| 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 read-prefs (upath) |
|---|
| 20 | "Read all preferences from repository at UPATH. |
|---|
| 21 | Return an alist with strings." |
|---|
| 22 | (let (alist) |
|---|
| 23 | (loop for line in (get-preflist upath "prefs") |
|---|
| 24 | do (let ((pos (position #\Space line))) |
|---|
| 25 | (when pos |
|---|
| 26 | (let ((name (subseq line 0 pos)) |
|---|
| 27 | (value (subseq line (1+ pos)))) |
|---|
| 28 | (push (cons name value) alist))))) |
|---|
| 29 | alist)) |
|---|
| 30 | |
|---|
| 31 | (defun get-pref (upath prefname) |
|---|
| 32 | "Get value of PREFNAME from repository at UPATH. |
|---|
| 33 | Return nil if no value was found." |
|---|
| 34 | (cdr (assoc prefname (read-prefs upath) :test #'string=))) |
|---|
| 35 | |
|---|
| 36 | (defun set-pref (repopath prefname value) |
|---|
| 37 | "Set value of PREFNAME to VALUE in REPOPATH." |
|---|
| 38 | (let* ((prefs (read-prefs repopath)) |
|---|
| 39 | (entry (assoc prefname prefs :test #'string=))) |
|---|
| 40 | (if entry |
|---|
| 41 | (setf (cdr entry) value) |
|---|
| 42 | (push (cons prefname value) prefs)) |
|---|
| 43 | (set-preflist repopath "prefs" |
|---|
| 44 | (mapcar (lambda (p) (format nil "~A ~A" (car p) (cdr p))) prefs)))) |
|---|
| 45 | |
|---|
| 46 | (defun get-preflist (upath filename) |
|---|
| 47 | "Get list of lines in preference file named by FILENAME in repository UPATH." |
|---|
| 48 | (let ((stream (ignore-errors |
|---|
| 49 | (open-upath |
|---|
| 50 | (upath-subdir upath '("_darcs" "prefs") filename))))) |
|---|
| 51 | (when stream |
|---|
| 52 | (with-open-stream (in stream) |
|---|
| 53 | (flet ((unimportantp (line) |
|---|
| 54 | (or (zerop (length line)) |
|---|
| 55 | (char= (elt line 0) #\#) |
|---|
| 56 | (eql (search "v v v v v v v" line) 0) |
|---|
| 57 | (eql (search "*************" line) 0) |
|---|
| 58 | (eql (search "^ ^ ^ ^ ^ ^ ^" line) 0)))) |
|---|
| 59 | (loop for line = (read-line in nil) |
|---|
| 60 | while line |
|---|
| 61 | unless (unimportantp line) collect line)))))) |
|---|
| 62 | |
|---|
| 63 | (defun set-preflist (upath filename preflist) |
|---|
| 64 | "Set preferences in FILENAME in repo UPATH to PREFLIST." |
|---|
| 65 | (with-open-file (out (upath-subdir upath '("_darcs" "prefs") filename) |
|---|
| 66 | :direction :output |
|---|
| 67 | :if-exists :supersede |
|---|
| 68 | :if-does-not-exist :create) |
|---|
| 69 | (dolist (pref preflist) |
|---|
| 70 | (write-line pref out)))) |
|---|
| 71 | |
|---|
| 72 | (defun add-to-preflist (upath filename pref) |
|---|
| 73 | "Add PREF to preferences in FILENAME in repo UPATH. |
|---|
| 74 | Do nothing if it's already there." |
|---|
| 75 | (let ((prefs (get-preflist upath filename))) |
|---|
| 76 | (unless (member pref prefs :test #'string=) |
|---|
| 77 | (with-open-file (out (upath-subdir upath '("_darcs" "prefs") filename) |
|---|
| 78 | :direction :output |
|---|
| 79 | :if-exists :append |
|---|
| 80 | :if-does-not-exist :create) |
|---|
| 81 | (write-line pref out))))) |
|---|
| 82 | |
|---|
| 83 | (defun write-default-prefs (repopath) |
|---|
| 84 | (default-boring repopath) |
|---|
| 85 | (default-binaries repopath) |
|---|
| 86 | (set-preflist repopath "motd" ())) |
|---|
| 87 | |
|---|
| 88 | (defun default-boring (repopath) |
|---|
| 89 | (set-preflist repopath "boring" |
|---|
| 90 | '("# Boring file regexps:" |
|---|
| 91 | "\\.hi$" |
|---|
| 92 | "\\.o$" "\\.o\\.cmd$" |
|---|
| 93 | "# *.ko files aren't boring by default because they might" |
|---|
| 94 | "# be Korean translations rather than kernel modules." |
|---|
| 95 | "# \\.ko$" |
|---|
| 96 | "\\.ko\\.cmd$" "\\.mod\\.c$" |
|---|
| 97 | "(^|/)\\.tmp_versions($|/)" "(^|/)CVS($|/)" "(^|/)RCS($|/)" "~$" |
|---|
| 98 | "#(^|/)\\.[^/]" "(^|/)_darcs($|/)" |
|---|
| 99 | "\\.bak$" "\\.BAK$" "\\.orig$" "(^|/)vssver\\.scc$" |
|---|
| 100 | "\\.swp$" "(^|/)MT($|/)" |
|---|
| 101 | "(^|/)\\{arch\\}($|/)" "(^|/).arch-ids($|/)" |
|---|
| 102 | "(^|/)," "\\.class$" "\\.prof$" "(^|/)\\.DS_Store$" |
|---|
| 103 | "(^|/)BitKeeper($|/)" "(^|/)ChangeSet($|/)" |
|---|
| 104 | "(^|/)\\.svn($|/)" "\\.py[co]$" "\\#" "\\.cvsignore$" |
|---|
| 105 | "(^|/)Thumbs\\.db$" |
|---|
| 106 | "(^|/)autom4te\\.cache($|/)"))) |
|---|
| 107 | |
|---|
| 108 | (defun default-binaries (repopath) |
|---|
| 109 | (set-preflist |
|---|
| 110 | repopath "binaries" |
|---|
| 111 | (cons "# Binary file regexps:" |
|---|
| 112 | (mapcan (lambda (ext) |
|---|
| 113 | (list (format nil "\\.~A$" ext) |
|---|
| 114 | (format nil "\\.~A$" (string-upcase ext)))) |
|---|
| 115 | '("png" "gz" "pdf" "jpg" "jpeg" "gif" "tif" |
|---|
| 116 | "tiff" "pnm" "pbm" "pgm" "ppm" "bmp" "mng" |
|---|
| 117 | "tar" "bz2" "z" "zip" "jar" "so" "a" |
|---|
| 118 | "tgz" "mpg" "mpeg" "iso" "exe" "doc"))))) |
|---|
| 119 | |
|---|
| 120 | (defun set-default-repo (repopath repostring) |
|---|
| 121 | (set-preflist repopath "defaultrepo" (list repostring)) |
|---|
| 122 | (add-to-preflist repopath "repos" repostring)) |
|---|
