hans/git-cli
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

added several commands

Browse Source
This commit is contained in:
Hans Dijkema
2026-08-11 20:50:08 +02:00
parent 1c7d71ab07
commit c45f666f23
14 changed files with 403 additions and 2781 deletions
Download Patch File Download Diff File Expand all files Collapse all files
main.rkt
+290 -4
View File
@@ -5,6 +5,7 @@
setup/getinfo
racket/async-channel
racket/list
racket/file
racket/match
racket/path
racket/string
@@ -24,6 +25,8 @@
git-clean?
git-diff
git-add
git-restore
git-reset
git-config
git-config-get
git-config-set
@@ -42,6 +45,8 @@
git-tag
git-tag-delete
(struct-out git-log-entry)
(struct-out git-grep-entry)
git-grep
git-log
git-log-lines
git-remotes
@@ -59,10 +64,13 @@
git-credentials-set!
git-credentials-ref
git-credentials-configured?
git-credentials-remove!)
git-credentials-remove!
git-prompt
)
(struct git-status-entry (path code flags) #:transparent)
(struct git-log-entry (id summary time) #:transparent)
(struct git-grep-entry (path line-number line) #:transparent)
(define-runtime-path git-command-directory ".")
@@ -135,6 +143,16 @@
[(3) "sending"]
[else #f]))
(define (git-prompt . msg)
(let ((m (if (null? msg)
(begin
(display "Give (commit) message: ")
(flush-output)
(let ((line (read-line)))
line))
(car msg))))
m))
(define (make-progress-reporter label quiet #:bytes? [bytes? #t] #:phase? [phase? #f])
(define last-phase -1)
(define last-percent -10)
@@ -448,7 +466,7 @@
(define (git-path-string path)
(regexp-replace* #rx"\\\\" (path->string path) "/"))
(define (relative-pathspec workdir path)
(define (relative-pathspec workdir path [who 'git-add])
(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.
@@ -457,7 +475,7 @@
(define s (git-path-string rel))
(when (or (string=? s "..")
(string-prefix? s "../"))
(error 'git-add "path is outside the repository: ~a" path))
(error who "path is outside the repository: ~a" path))
s)
(define (index-accept _path _matched-pathspec _payload)
@@ -478,6 +496,145 @@
(git_index_write index)
(void))
(define (revision-string revision)
(cond
[(symbol? revision) (symbol->string revision)]
[(string? revision) revision]
[else
(raise-argument-error 'git "(or/c symbol? string?)" revision)]))
(define (resolve-reset-target repo revision [allow-unborn-head? #f])
(define revision-name (revision-string revision))
(cond
[(and allow-unborn-head?
(string=? revision-name "HEAD")
(not (head-commit repo)))
#f]
[else
(with-handlers ([exn:fail?
(lambda (_)
(error 'git-reset "cannot resolve revision: ~a" revision-name))])
(git_revparse_single repo (format "~a^{commit}" revision-name)))]))
(define (make-pathspecs repo paths who)
(define workdir (string->path (git_repository_workdir repo)))
(make-git_strarray
(for/list ([path (in-list paths)])
(relative-pathspec workdir path who))))
(define (make-path-checkout-options repo paths)
(define options (make-safe-checkout-options))
;; `git restore` is explicitly destructive for the selected worktree paths.
;; Do not let checkout update the index when restoring only the worktree.
(set-git_checkout_opts-checkout_strategy!
options
'(GIT_CHECKOUT_FORCE GIT_CHECKOUT_DONT_UPDATE_INDEX))
(set-git_checkout_opts-paths! options (make-pathspecs repo paths 'git-restore))
options)
(define (split-at-double-dash args)
(let loop ([before null] [rest args])
(cond
[(null? rest) (values (reverse before) #f)]
[(equal? (car rest) "--") (values (reverse before) (cdr rest))]
[(eq? (car rest) '--) (values (reverse before) (cdr rest))]
[else (loop (cons (car rest) before) (cdr rest))])))
(define (git-reset . args)
(define repo (open-repository))
(define-values (before paths) (split-at-double-dash args))
(cond
[paths
(when (null? paths)
(error 'git-reset "expected at least one path after --"))
(define revision
(match before
['() 'HEAD]
[(list rev) rev]
[_ (error 'git-reset "invalid path reset arguments: ~e" args)]))
(define target (resolve-reset-target repo revision #t))
(git_reset_default repo target (make-pathspecs repo paths 'git-reset))
(void)]
[else
(define-values (mode revision)
(match args
['() (values 'GIT_RESET_MIXED 'HEAD)]
[(list '--soft) (values 'GIT_RESET_SOFT 'HEAD)]
[(list '--mixed) (values 'GIT_RESET_MIXED 'HEAD)]
[(list '--hard) (values 'GIT_RESET_HARD 'HEAD)]
[(list '--soft rev) (values 'GIT_RESET_SOFT rev)]
[(list '--mixed rev) (values 'GIT_RESET_MIXED rev)]
[(list '--hard rev) (values 'GIT_RESET_HARD rev)]
[(list rev) (values 'GIT_RESET_MIXED rev)]
[_ (error 'git-reset "invalid arguments: ~e" args)]))
(define target (resolve-reset-target repo revision))
(git_reset repo target mode (make-safe-checkout-options))
(void)]))
(define (parse-restore-arguments args)
(let loop ([rest args]
[staged? #f]
[worktree? #f]
[worktree-explicit? #f]
[source #f]
[paths null])
(cond
[(null? rest)
(define actual-worktree?
(if worktree-explicit? worktree? (not staged?)))
(values staged? actual-worktree? source (reverse paths))]
[(eq? (car rest) '--staged)
(loop (cdr rest) #t worktree? worktree-explicit? source paths)]
[(eq? (car rest) '--worktree)
(loop (cdr rest) staged? #t #t source paths)]
[(eq? (car rest) '--source)
(unless (pair? (cdr rest))
(error 'git-restore "--source requires a revision"))
(loop (cddr rest) staged? worktree? worktree-explicit?
(cadr rest) paths)]
[(or (eq? (car rest) '--) (equal? (car rest) "--"))
(values staged?
(if worktree-explicit? worktree? (not staged?))
source
(append (reverse paths) (cdr rest)))]
[(and (symbol? (car rest))
(string-prefix? (symbol->string (car rest)) "-"))
(error 'git-restore "unsupported option: ~a" (car rest))]
[else
(loop (cdr rest) staged? worktree? worktree-explicit?
source (cons (car rest) paths))])))
(define (git-restore . args)
(define-values (staged? worktree? source paths)
(parse-restore-arguments args))
(when (null? paths)
(error 'git-restore "expected at least one path"))
(unless (or staged? worktree?)
(error 'git-restore "nothing to restore"))
(define repo (open-repository))
(define source-revision (or source 'HEAD))
(when staged?
;; With an unborn HEAD, a staged restore removes matching new entries from
;; the index, which is exactly the useful `git restore --staged` behavior.
(define target (resolve-reset-target repo source-revision #t))
(git_reset_default repo target (make-pathspecs repo paths 'git-restore)))
(when worktree?
(define options (make-path-checkout-options repo paths))
(cond
[(or staged? (not source))
;; After a staged restore, or with no explicit source, the index is the
;; source for the worktree restore.
(git_checkout_index repo (git_repository_index repo) options)]
[else
(define object
(with-handlers ([exn:fail?
(lambda (_)
(error 'git-restore "cannot resolve source: ~a" source))])
(git_revparse_single repo (revision-string source))))
(git_checkout_tree repo object options)]))
(void))
(define (git-config-get key)
(define repo (open-repository))
(define config (git_repository_config repo))
@@ -712,6 +869,105 @@
(git_tag_delete (open-repository) name)
(void))
(define (grep-flag? x flag)
(and (symbol? x) (eq? x flag)))
(define (parse-grep-arguments args)
(let loop ([rest args] [ignore-case? #f] [invert? #f]
[show-line-numbers? #f] [files-only? #f] [count? #f])
(cond
[(null? rest)
(error 'git-grep "expected a pattern")]
[(grep-flag? (car rest) '-i)
(loop (cdr rest) #t invert? show-line-numbers? files-only? count?)]
[(grep-flag? (car rest) '-v)
(loop (cdr rest) ignore-case? #t show-line-numbers? files-only? count?)]
[(grep-flag? (car rest) '-n)
(loop (cdr rest) ignore-case? invert? #t files-only? count?)]
[(grep-flag? (car rest) '-l)
(loop (cdr rest) ignore-case? invert? show-line-numbers? #t count?)]
[(grep-flag? (car rest) '-c)
(loop (cdr rest) ignore-case? invert? show-line-numbers? files-only? #t)]
[(and (symbol? (car rest))
(string-prefix? (symbol->string (car rest)) "-"))
(error 'git-grep "unsupported option: ~a" (car rest))]
[else
(define pattern (car rest))
(define tail (cdr rest))
(when (> (length tail) 1)
(error 'git-grep "expected at most one revision after the pattern"))
(values ignore-case? invert? show-line-numbers? files-only? count?
pattern (and (pair? tail) (car tail)))])))
(define (grep-regexp pattern ignore-case?)
(define source
(cond
[(regexp? pattern) (object-name pattern)]
[(byte-regexp? pattern)
(bytes->string/utf-8 (object-name pattern))]
[(string? pattern) pattern]
[else (raise-argument-error 'git-grep "(or/c string? regexp?)" pattern)]))
(pregexp (if ignore-case? (format "(?i:~a)" source) source)))
(define (binary-bytes? bs)
(for/or ([b (in-bytes bs)]) (zero? b)))
(define (grep-bytes path bs rx invert?)
(cond
[(binary-bytes? bs) null]
[else
(define text (bytes->string/utf-8 bs #\uFFFD))
(for/list ([line (in-list (string-split text "\n" #:trim? #f))]
[number (in-naturals 1)]
#:when (if invert?
(not (regexp-match? rx line))
(regexp-match? rx line)))
(git-grep-entry path number line))]))
(define (working-tree-grep repo rx invert?)
(define index (git_repository_index repo))
(define workdir (git_repository_workdir repo))
(append*
(for/list ([i (in-range (git_index_entrycount index))])
(define entry (git_index_get_byindex index i))
(define path (git_index_entry-path entry))
(define full (build-path workdir path))
(if (file-exists? full)
(grep-bytes path (file->bytes full) rx invert?)
null))))
(define (revision-grep repo revision rx invert?)
(define object
(with-handlers ([exn:fail?
(lambda (_)
(error 'git-grep "cannot resolve revision: ~a" revision))])
(git_revparse_single repo (format "~a^{tree}" revision))))
(define tree (git_tree_lookup repo (git_object_id object)))
(define results null)
(git_tree_walk
tree 'GIT_TREEWALK_PRE
(lambda (root entry _payload)
(when (eq? (git_tree_entry_type entry) 'GIT_OBJECT_BLOB)
(define path (string-append root (git_tree_entry_name entry)))
(define blob (git_blob_lookup repo (git_tree_entry_id entry)))
(set! results
(append (grep-bytes path (git_blob_rawcontent blob) rx invert?)
results)))
0)
#"")
(reverse results))
(define (git-grep . args)
(define-values (ignore-case? invert? _show-line-numbers? _files-only? _count?
pattern revision)
(parse-grep-arguments args))
(define rx (grep-regexp pattern ignore-case?))
(define repo (open-repository))
(if revision
(revision-grep repo revision rx invert?)
(working-tree-grep repo rx invert?)))
(define (git-log [max-count 20])
(unless (exact-nonnegative-integer? max-count)
(raise-argument-error 'git-log "exact-nonnegative-integer?" max-count))
@@ -919,6 +1175,8 @@
(if (and (= (length args) 1) (eq? (car args) '-A))
(apply git-add (map git-status-entry-path (git 'status)))
(apply git-add args))]
[(restore) (apply git-restore args)]
[(reset) (apply git-reset args)]
[(config) (apply git-config args)]
[(commit) (apply git-commit args)]
[(branch-current)
@@ -940,6 +1198,7 @@
(match args
[(list '-d name) (git-tag-delete name)]
[_ (apply git-tag args)])]
[(grep) (apply git-grep args)]
[(log) (apply git-log args)]
[(remote)
(match args
@@ -1007,8 +1266,35 @@
[(void? result) (void)]
[else (displayln result out)]))
(define (display-grep-result args result [out (current-output-port)])
(define files-only? (member '-l args))
(define count? (member '-c args))
(define line-numbers? (member '-n args))
(cond
[files-only?
(for ([path (in-list (remove-duplicates (map git-grep-entry-path result)))])
(displayln path out))]
[count?
(define counts (make-hash))
(for ([entry (in-list result)])
(hash-update! counts (git-grep-entry-path entry) add1 0))
(for ([path (in-list (sort (hash-keys counts) string<?))])
(fprintf out "~a:~a\n" path (hash-ref counts path)))]
[else
(for ([entry (in-list result)])
(if line-numbers?
(fprintf out "~a:~a:~a\n"
(git-grep-entry-path entry)
(git-grep-entry-line-number entry)
(git-grep-entry-line entry))
(fprintf out "~a:~a\n"
(git-grep-entry-path entry)
(git-grep-entry-line entry))))]))
(define (dgit command #:quiet [quiet #f] . args)
(define result
(keyword-apply git '(#:quiet) (list quiet) (cons command args)))
(display-git-result command result)
(if (eq? command 'grep)
(display-grep-result args result)
(display-git-result command result))
result)