config functionality extended
This commit is contained in:
@@ -143,46 +143,79 @@
|
||||
; result : Arguments accepted by git config.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (git-config-args args info)
|
||||
(if (null? args)
|
||||
(error 'git-config "Expected get or set!")
|
||||
(let ((action (car args))
|
||||
(rest (cdr args)))
|
||||
(cond
|
||||
((eq? action 'get)
|
||||
(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)
|
||||
'(--list))
|
||||
((null? (cddr rest))
|
||||
(hash-set! info 'config-operation 'get-all)
|
||||
(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)
|
||||
(list '--get (car rest)))
|
||||
(else
|
||||
(error 'git-config "Too many arguments for config get"))))
|
||||
(define (scope? x)
|
||||
(member x '(--global --local --system)))
|
||||
|
||||
((eq? action 'set!)
|
||||
(cond
|
||||
((= (length rest) 2)
|
||||
(hash-set! info 'config-operation 'set)
|
||||
rest)
|
||||
((and (= (length rest) 3)
|
||||
(member (car rest) '(--global --local --system)))
|
||||
(hash-set! info 'config-operation 'set)
|
||||
rest)
|
||||
(else
|
||||
(error 'git-config
|
||||
"Expected config set! [--global|--local|--system] key value"))))
|
||||
(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!"))))))))
|
||||
|
||||
(else
|
||||
(error 'git-config "Expected get or set!"))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Process the result of the Racket-oriented git config interface.
|
||||
|
||||
Reference in New Issue
Block a user