blob: 25534541411ff6449c5560676a870408a4675d3d (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
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)))
|
