1 | ;;; Copyright (C) 2006 Magnus Henoch |
---|
2 | ;;; |
---|
3 | ;;; This program is free software; you can redistribute it and/or |
---|
4 | ;;; modify it under the terms of the GNU General Public License as |
---|
5 | ;;; published by the Free Software Foundation; either version 2 of the |
---|
6 | ;;; License, or (at your option) any later version. |
---|
7 | ;;; |
---|
8 | ;;; This program is distributed in the hope that it will be useful, |
---|
9 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
---|
10 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
---|
11 | ;;; General Public License for more details. |
---|
12 | ;;; |
---|
13 | ;;; You should have received a copy of the GNU General Public License |
---|
14 | ;;; along with this program; if not, write to the Free Software |
---|
15 | ;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA |
---|
16 | |
---|
17 | (in-package :darcs) |
---|
18 | |
---|
19 | (defun has-prefs-dir (repo) |
---|
20 | "Return true if REPO has a _darcs/prefs subdirectory." |
---|
21 | ;; This is currently only used for checking whether we should write |
---|
22 | ;; preferences, so it doesn't matter that this implementation |
---|
23 | ;; doesn't work for HTTP. |
---|
24 | (fad:directory-exists-p (upath-subdir repo '("_darcs" "prefs")))) |
---|
25 | |
---|
26 | (defun read-prefs (upath) |
---|
27 | "Read all preferences from repository at UPATH. |
---|
28 | Return an alist with strings." |
---|
29 | (let (alist) |
---|
30 | (loop for line in (get-preflist upath "prefs") |
---|
31 | do (let ((pos (position #\Space line))) |
---|
32 | (when pos |
---|
33 | (let ((name (subseq line 0 pos)) |
---|
34 | (value (subseq line (1+ pos)))) |
---|
35 | (push (cons name value) alist))))) |
---|
36 | alist)) |
---|
37 | |
---|
38 | (defun get-pref (upath prefname) |
---|
39 | "Get value of PREFNAME from repository at UPATH. |
---|
40 | Return nil if no value was found." |
---|
41 | (cdr (assoc prefname (read-prefs upath) :test #'string=))) |
---|
42 | |
---|
43 | (defun set-pref (repopath prefname value) |
---|
44 | "Set value of PREFNAME to VALUE in REPOPATH." |
---|
45 | (let* ((prefs (read-prefs repopath)) |
---|
46 | (entry (assoc prefname prefs :test #'string=))) |
---|
47 | (if entry |
---|
48 | (setf (cdr entry) value) |
---|
49 | (push (cons prefname value) prefs)) |
---|
50 | (set-preflist repopath "prefs" |
---|
51 | (mapcar (lambda (p) (format nil "~A ~A" (car p) (cdr p))) prefs)))) |
---|
52 | |
---|
53 | (defun get-preflist (upath filename) |
---|
54 | "Get list of lines in preference file named by FILENAME in repository UPATH." |
---|
55 | (let ((stream (ignore-errors |
---|
56 | (open-upath |
---|
57 | (upath-subdir upath '("_darcs" "prefs") filename))))) |
---|
58 | (when stream |
---|
59 | (with-open-stream (in stream) |
---|
60 | (flet ((unimportantp (line) |
---|
61 | (or (zerop (length line)) |
---|
62 | (char= (elt line 0) #\#) |
---|
63 | (eql (search "v v v v v v v" line) 0) |
---|
64 | (eql (search "*************" line) 0) |
---|
65 | (eql (search "^ ^ ^ ^ ^ ^ ^" line) 0)))) |
---|
66 | (loop for line = (read-line in nil) |
---|
67 | while line |
---|
68 | unless (unimportantp line) collect line)))))) |
---|
69 | |
---|
70 | (defun set-preflist (upath filename preflist) |
---|
71 | "Set preferences in FILENAME in repo UPATH to PREFLIST." |
---|
72 | (with-open-file (out (upath-subdir upath '("_darcs" "prefs") filename) |
---|
73 | :direction :output |
---|
74 | :if-exists :supersede |
---|
75 | :if-does-not-exist :create) |
---|
76 | (dolist (pref preflist) |
---|
77 | (write-line pref out)))) |
---|
78 | |
---|
79 | (defun add-to-preflist (upath filename pref) |
---|
80 | "Add PREF to preferences in FILENAME in repo UPATH. |
---|
81 | Do nothing if it's already there." |
---|
82 | (let ((prefs (get-preflist upath filename))) |
---|
83 | (unless (member pref prefs :test #'string=) |
---|
84 | (with-open-file (out (upath-subdir upath '("_darcs" "prefs") filename) |
---|
85 | :direction :output |
---|
86 | :if-exists :append |
---|
87 | :if-does-not-exist :create) |
---|
88 | (write-line pref out))))) |
---|
89 | |
---|
90 | (defun write-default-prefs (repopath) |
---|
91 | (default-boring repopath) |
---|
92 | (default-binaries repopath) |
---|
93 | (set-preflist repopath "motd" ())) |
---|
94 | |
---|
95 | (defun default-boring (repopath) |
---|
96 | (set-preflist repopath "boring" |
---|
97 | '("# Boring file regexps:" |
---|
98 | "\\.hi$" |
---|
99 | "\\.o$" "\\.o\\.cmd$" |
---|
100 | "# *.ko files aren't boring by default because they might" |
---|
101 | "# be Korean translations rather than kernel modules." |
---|
102 | "# \\.ko$" |
---|
103 | "\\.ko\\.cmd$" "\\.mod\\.c$" |
---|
104 | "(^|/)\\.tmp_versions($|/)" "(^|/)CVS($|/)" "(^|/)RCS($|/)" "~$" |
---|
105 | "#(^|/)\\.[^/]" "(^|/)_darcs($|/)" |
---|
106 | "\\.bak$" "\\.BAK$" "\\.orig$" "(^|/)vssver\\.scc$" |
---|
107 | "\\.swp$" "(^|/)MT($|/)" |
---|
108 | "(^|/)\\{arch\\}($|/)" "(^|/).arch-ids($|/)" |
---|
109 | "(^|/)," "\\.class$" "\\.prof$" "(^|/)\\.DS_Store$" |
---|
110 | "(^|/)BitKeeper($|/)" "(^|/)ChangeSet($|/)" |
---|
111 | "(^|/)\\.svn($|/)" "\\.py[co]$" "\\#" "\\.cvsignore$" |
---|
112 | "(^|/)Thumbs\\.db$" |
---|
113 | "(^|/)autom4te\\.cache($|/)"))) |
---|
114 | |
---|
115 | (defun default-binaries (repopath) |
---|
116 | (set-preflist |
---|
117 | repopath "binaries" |
---|
118 | (cons "# Binary file regexps:" |
---|
119 | (mapcan (lambda (ext) |
---|
120 | (list (format nil "\\.~A$" ext) |
---|
121 | (format nil "\\.~A$" (string-upcase ext)))) |
---|
122 | '("png" "gz" "pdf" "jpg" "jpeg" "gif" "tif" |
---|
123 | "tiff" "pnm" "pbm" "pgm" "ppm" "bmp" "mng" |
---|
124 | "tar" "bz2" "z" "zip" "jar" "so" "a" |
---|
125 | "tgz" "mpg" "mpeg" "iso" "exe" "doc"))))) |
---|
126 | |
---|
127 | (defun set-default-repo (repopath repostring) |
---|
128 | (set-preflist repopath "defaultrepo" (list repostring)) |
---|
129 | (add-to-preflist repopath "repos" repostring)) |
---|