blob: c244bf39cd5b4e0e610bedbce1e3261bff0c2729 (
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
112
113
114
|
#!/usr/bin/guile \
-s
!#
(use-modules (ice-9 popen)
(logging logger)
(logging port-log)
(ice-9 ftw)
(ice-9 match)
(ice-9 and-let-star)
(oop goops)
(term ansi-color))
(define (expand-file f)
;; https://irreal.org/blog/?p=83
(cond ((absolute-file-name? f) f)
((string=? (substring f 0 2) "~/")
(let ((prefix (passwd:dir (getpwuid (geteuid)))))
(string-append prefix (substring f 1 (string-length f)))))
((char=? (string-ref f 0) #\~)
(let* ((user-end (string-index f #\/))
(user (substring f 1 user-end))
(prefix (passwd:dir (getpwnam user))))
(string-append prefix (substring f user-end (string-length f)))))
(else (string-append (getcwd) "/" f))))
(define (symlink? path)
(false-if-exception
(eq? 'symlink (stat:type (lstat path)))))
(define (clean-file full-dest dry-run)
(and-let* ((info (false-if-exception (lstat full-dest)))
(type (stat:type info))
(deleter (if (eq? type 'directory) rmdir delete-file))
(task (if dry-run "Would delete" "Deleting")))
(format #t "~a ~a: ~a~%" task type full-dest)
(unless dry-run (deleter full-dest))))
(define (rm-tree path dry-run)
(define (enter? a b c) #t)
(define (down name stat result) result)
(define (leaf name stat result)
(clean-file name dry-run)
result)
(define up leaf)
(define skip leaf)
;; Ignore unreadable files/directories but warn the user.
(define (error name stat errno result)
(format (current-error-port) "warning~a: ~a: ~a~%"
errno name (strerror errno))
result)
(file-system-fold enter? leaf down up skip error
(list 0)
path))
(define (config-links src target dry-run)
(let ((src-path (expand-file src))
(target-path (expand-file target)))
(unless (and (symlink? target-path) (equal? (readlink target-path) src-path))
(rm-tree target-path dry-run)
(symlink src-path target-path)
(format #t " Symlink: ~a -> ~a~%" src target))))
(define (symlink-tree file-name target-path)
"Tree recursively symlinks target-path->file-name. The goal is to
have few symlinks, yet if in the target space there are some files
then symlink the files not the dir"
(define src-len (string-length file-name))
(define (enter? name stat result)
(let* ((subdir (substring name src-len))
(target-subdir (string-append target-path subdir)))
(format #t "~a: ~a | ~a ~a~%" name subdir target-subdir (stat:type stat))
(false-if-exception (eq? 'directory (stat:type (lstat target-subdir))))))
(define (leaf name stat result)
(let* ((subfile (substring name src-len))
(target-subfile (string-append target-path subfile)))
(config-links name target-subfile #f))
(set-car! result (1+ (car result)))
result)
(define (down name stat result)
(cons 0 result))
(define (up name stat result)
(let* ((subdir (substring name src-len))
(target-subdir (string-append target-path subdir))
(target-subdir-file-count (length (scandir target-subdir
(lambda (x)
(not (member x (list "." ".."))))))))
(format #t " up on ~a ~a ~a ~a ~%" result name target-subdir target-subdir-file-count)
(when (= (car result) target-subdir-file-count)
;(format #t "~% Clear ~a because is identical to source" name)
(leaf name stat result)))
(list-set! result 1 (1+ (cadr result)))
(cdr result))
;; Likewise for skipped directories.
(define skip leaf)
;; Ignore unreadable files/directories but warn the user.
(define (error name stat errno result)
(format (current-error-port) "warning: ~a: ~a~%"
name (strerror errno))
result)
(file-system-fold enter? leaf down up skip error
(list 0)
file-name))
(symlink-tree "config" "/home/titan/.config")
|
