diff --git a/README.md b/README.md index ee52a60..c234b19 100644 --- a/README.md +++ b/README.md @@ -30,6 +30,8 @@ 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` 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-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` / diff --git a/info.rkt b/info.rkt index 097bebf..f142c0b 100644 --- a/info.rkt +++ b/info.rkt @@ -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.3.23") +(define version "0.3.29") (define pkg-authors '("Hans Dijkema")) (define license 'MIT) diff --git a/main.rkt b/main.rkt index 2141d14..583bd78 100644 --- a/main.rkt +++ b/main.rkt @@ -11,9 +11,8 @@ net/sendurl ) -; test - -(provide git +(provide gt + git git-add git-status git-commit @@ -26,6 +25,7 @@ git-log git-grep git-branch + git-remote git-clone git-rev-list git-diff @@ -54,6 +54,11 @@ ;; 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. @@ -380,11 +385,119 @@ ; 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) + (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. diff --git a/scribblings/git-cli.scrbl b/scribblings/git-cli.scrbl index e456e9d..67f280a 100644 --- a/scribblings/git-cli.scrbl +++ b/scribblings/git-cli.scrbl @@ -19,7 +19,7 @@ read credentials or other answers from the terminal. 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['config], @racket['branch], @racket['switch], @racket['clone], +@racket['config], @racket['branch], @racket['remote], @racket['switch], @racket['clone], @racket['tag], @racket['log], @racket['rev-list], @racket['diff], @racket['show], @racket['grep], @racket['help], @racket['version], and @@ -134,12 +134,76 @@ appear directly after @racket['config] or directly after @racket['get] / @racket['set!]. A successful write returns @racket[#t]. } -@defproc[(git-branch [argument any/c] ...) boolean?]{ +@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=} 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-switch [argument any/c] ...) boolean?]{ Runs @tt{git switch} with the supplied arguments.