Add config management commands

This procedure writes a configuration alist to a format understood by
git.

gitto/Makefile

@@ -3,7 +3,8 @@ SITEDIR = $(shell pkg-config guile-2.0 --variable=sitedir \
 	--define-variable=prefix=$(DESTDIR))
 COMPDIR = $(DESTDIR)/lib/guile/2.0/site-ccache
 
-objects = git.scm git.go main.scm main.go path.scm path.go
+objects = config.scm config.go git.scm git.go main.scm main.go path.scm \
+	path.go
 install-objects = $(addprefix install-,$(objects))
 uninstall-objects = $(addprefix uninstall-,$(objects))
 

gitto/config.scm

@@ -0,0 +1,86 @@
+;; -*- coding: utf-8; -*-
+;; gitto -- Keep track of your git repositories
+;; Copyright (C) 2012 Tom Willemsen <tom at ryuslash dot org>
+
+;; This file is part of gitto.
+
+;; gitto is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; gitto is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with gitto.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gitto config)
+  #:use-module (ice-9 format)
+  #:use-module (ice-9 rdelim)
+  #:export (global-config
+
+            merge-config
+            read-config
+            write-config))
+
+(define global-config '())
+
+(define (merge-config repo-name x y)
+  (let ((lst (if x (list-copy x) '())))
+    (for-each
+     (lambda (s)
+       (let ((b-sec (assoc (car s) lst)))
+        (set! lst (assoc-set!
+                   lst (car s) (merge-settings
+                                repo-name (if b-sec (cdr b-sec) #f) (cdr s))))))
+     y)
+    lst))
+
+(define (merge-settings repo-name x y)
+  (let ((lst (if x (list-copy x) '())))
+    (for-each (lambda (v)
+                (set! lst (assoc-set!
+                           lst (car v) (format #f (cdr v) repo-name))))
+              y)
+    lst))
+
+(define (parse-setting line)
+  (let ((idx (string-index line #\=)))
+    (list (cons (string-trim-both (substring line 0 idx))
+                (string-trim-both (substring line (1+ idx)))))))
+
+(define (read-config repo-location)
+  (let ((port (open-input-file
+               (string-append repo-location "/.git/config")))
+        (config '())
+        (current-section #f)
+        (assign-pos #f))
+    (do ((line (read-line port) (read-line port)))
+        ((eof-object? line))
+      (cond ((string= line "[" 0 1)
+             (let ((section (cons (string-trim-both
+                                   line (char-set #\[ #\])) '())))
+               (set! config (append config (list section)))
+               (set! current-section section)))
+            ((string-contains line "=")
+             (set-cdr! current-section
+                       (append (cdr current-section)
+                               (parse-setting line))))))
+    (close-port port)
+    config))
+
+(define* (write-config config #:optional (file #f))
+  (let ((thunk (lambda () (for-each write-section config))))
+    (if file
+        (with-output-to-file file thunk)
+        (thunk))))
+
+(define (write-section section)
+  (format #t "[~a]~%" (car section))
+  (for-each write-setting (cdr section)))
+
+(define (write-setting setting)
+  (format #t "~8t~a = ~a~%" (car setting) (cdr setting)))

gitto/main.scm

@@ -18,6 +18,7 @@
 ;; along with gitto.  If not, see <http://www.gnu.org/licenses/>.
 
 (define-module (gitto main)
+  #:use-module (gitto config)
   #:use-module (gitto git)
   #:use-module (gitto path)
   #:use-module (ice-9 format)
@@ -134,14 +135,38 @@ gitto [options]
                 repositories))
   (save-repositories-list))
 
+(define (show-global-config)
+  (write-config global-config))
+
+(define (show-config)
+  (for-each (lambda (repo)
+              (display (string-upcase (repo-name repo)))
+              (newline)
+              (write-config (read-config (repo-location repo)))
+              (newline)
+              (newline))
+            repositories))
+
+(define (update-config)
+  (for-each (lambda (repo)
+              (write-config
+               (merge-config (repo-name repo)
+                             (read-config (repo-location repo))
+                             global-config)
+               (string-append (repo-location repo) "/.git/config")))
+            repositories))
+
 (define option-spec
-  `((version      (single-char #\v))
-    (help         (single-char #\h))
-    (register     (single-char #\r) (value #t) (predicate ,git-dir?))
-    (remove       (single-char #\R) (value #t) (predicate ,known?))
-    (repositories (single-char #\l))
-    (purge        (single-char #\p))
-    (check        (single-char #\c) (value #t))))
+  `((version       (single-char #\v))
+    (help          (single-char #\h))
+    (register      (single-char #\r) (value #t) (predicate ,git-dir?))
+    (remove        (single-char #\R) (value #t) (predicate ,known?))
+    (repositories  (single-char #\l))
+    (purge         (single-char #\p))
+    (check         (single-char #\c) (value #t))
+    (config        (single-char #\C))
+    (global-config)
+    (update-config)))
 
 (define (main args)
   "Parse the command line options and run the appropriate functions."
@@ -153,6 +178,9 @@ gitto [options]
          (list?                (option-ref options 'repositories #f))
          (purge?               (option-ref options 'purge #f))
          (check?               (option-ref options 'check #f))
+         (config?              (option-ref options 'config #f))
+         (global-config?       (option-ref options 'global-config #f))
+         (update-config?       (option-ref options 'update-config #f))
          (cfg (config-file "rc.scm")))
     (when (file-exists? cfg)
       (save-module-excursion
@@ -167,6 +195,9 @@ gitto [options]
           (list?                   (list-repository-locations))
           (purge?                  (purge))
           (check?               => repository-registered?)
+          (config?                 (show-config))
+          (global-config?          (show-global-config))
+          (update-config?          (update-config))
           (#t                      (list-repositories)))))
 
 (define repositories-file (data-file "repos.scm"))