Add new autotools based installation scripts.

1 files changed, 111 insertions, 0 deletions

diff --git a/dotfiles.scm b/dotfiles.scm
new file mode 100644
index 0000000..2553454
--- /dev/null
+++ b/dotfiles.scm
@@ -0,0 +1,111 @@
+;;; Copyright © 2015 David Thompson <davet@gnu.org>
+;;;
+;;; This program 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.
+;;;
+;;; This program 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 this program.  If not, see
+;;; <http://www.gnu.org/licenses/>.
+
+(define-module (dotfiles)
+  #:use-module (ice-9 ftw)
+  #:use-module (ice-9 i18n)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 regex)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-11)
+  #:use-module (srfi srfi-26)
+  #:export (install-dotfiles))
+
+(define (recursive-scandir dir)
+  "Return a list of all the file names in DIR, recursively."
+  (define (components file)
+    (string-split file #\/))
+
+  (define suffix
+    (let ((prefix-length (length (components dir))))
+      (lambda (file)
+        (string-join (drop (components file) prefix-length) "/"))))
+
+  (define enter? (const #t))
+
+  ;; Ignore the backup files that Emacs makes.
+  (define ignore?
+    (let ((patterns (map make-regexp '("~$" "^\\.#" "^#"))))
+      (lambda (file)
+	(let ((base (basename file)))
+	  (any (cut regexp-exec <> base) patterns)))))
+
+  (define (leaf name stat result)
+    (if (ignore? name)
+	result
+	(cons (suffix name) result)))
+
+  ;; No-op
+  (define (down name stat result) result)
+  (define (up name stat result) result)
+  (define (skip name stat result) result)
+  (define (error name stat errno result) result)
+
+  (let-values (((files discard)
+                (file-system-fold enter? leaf down up skip error '() dir)))
+    (sort files string-locale<?)))
+
+(define (mkdir-p dir)
+  "Create directory DIR and all its ancestors."
+  (define absolute?
+    (string-prefix? "/" dir))
+
+  (define not-slash
+    (char-set-complement (char-set #\/)))
+
+  (let loop ((components (string-tokenize dir not-slash))
+             (root       (if absolute?
+                             ""
+                             ".")))
+    (match components
+      ((head tail ...)
+       (let ((path (string-append root "/" head)))
+         (catch 'system-error
+           (lambda ()
+             (mkdir path)
+             (loop tail path))
+           (lambda args
+             (if (= EEXIST (system-error-errno args))
+                 (loop tail path)
+                 (apply throw args))))))
+      (() #t))))
+
+(define (symlink? file)
+  "Return #t if FILE is a symbolic link."
+  (eq? (stat:type (lstat file)) 'symlink))
+
+(define (already-linked? src-file dest-file)
+  "Return #t if SRC-FILE is a symbolic link to DEST-FILE."
+  (and (symlink? dest-file)
+       (string=? (readlink dest-file) src-file)))
+
+(define (install-dotfiles src-dir dest-dir)
+  "Symlink the dotfiles in SRC-DIR to DEST-DIR."
+  
+  (define (install-dotfile file)
+    (let ((src-file (string-append src-dir "/" file))
+	  (dest-file (string-append dest-dir "/" file)))
+      (cond
+       ((not (file-exists? dest-file))
+	(format #t "~a → ~a~%" file dest-file)
+	(mkdir-p (dirname dest-file))
+	(symlink src-file dest-file))
+       ((already-linked? src-file dest-file)
+	(format #t "~a already installed~%" file))
+       (else
+	(error "destination file already exists: " dest-file)))))
+
+  (for-each install-dotfile (recursive-scandir src-dir)))