source: cl-darcs/trunk/prefs.lisp

;;; Copyright (C) 2006 Magnus Henoch
;;;
;;; 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 2 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, write to the Free Software
;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA

(in-package :darcs)

(defun has-prefs-dir (repo)
  "Return true if REPO has a _darcs/prefs subdirectory."
  ;; This is currently only used for checking whether we should write
  ;; preferences, so it doesn't matter that this implementation
  ;; doesn't work for HTTP.
  (fad:directory-exists-p (upath-subdir repo '("_darcs" "prefs"))))

(defun read-prefs (upath)
  "Read all preferences from repository at UPATH.
Return an alist with strings."
  (let (alist)
    (loop for line in (get-preflist upath "prefs")
       do (let ((pos (position #\Space line)))
            (when pos
              (let ((name (subseq line 0 pos))
                    (value (subseq line (1+ pos))))
                (push (cons name value) alist)))))
    alist))

(defun get-pref (upath prefname)
  "Get value of PREFNAME from repository at UPATH.
Return nil if no value was found."
  (cdr (assoc prefname (read-prefs upath) :test #'string=)))

(defun set-pref (repopath prefname value)
  "Set value of PREFNAME to VALUE in REPOPATH."
  (let* ((prefs (read-prefs repopath))
         (entry (assoc prefname prefs :test #'string=)))
    (if entry
        (setf (cdr entry) value)
        (push (cons prefname value) prefs))
    (set-preflist repopath "prefs"
                  (mapcar (lambda (p) (format nil "~A ~A" (car p) (cdr p))) prefs))))

(defun get-preflist (upath filename)
  "Get list of lines in preference file named by FILENAME in repository UPATH."
  (let ((stream (ignore-errors
                  (open-upath 
                   (upath-subdir upath '("_darcs" "prefs") filename)))))
    (when stream
      (with-open-stream (in stream)
        (flet ((unimportantp (line)
                 (or (zerop (length line))
                     (char= (elt line 0) #\#)
                     (eql (search "v v v v v v v" line) 0)
                     (eql (search "*************" line) 0)
                     (eql (search "^ ^ ^ ^ ^ ^ ^" line) 0))))
          (loop for line = (read-line in nil)
             while line 
             unless (unimportantp line) collect line))))))

(defun set-preflist (upath filename preflist)
  "Set preferences in FILENAME in repo UPATH to PREFLIST."
  (with-open-file (out (upath-subdir upath '("_darcs" "prefs") filename)
                       :direction :output
                       :if-exists :supersede
                       :if-does-not-exist :create)
    (dolist (pref preflist)
      (write-line pref out))))

(defun add-to-preflist (upath filename pref)
  "Add PREF to preferences in FILENAME in repo UPATH.
Do nothing if it's already there."
  (let ((prefs (get-preflist upath filename)))
    (unless (member pref prefs :test #'string=)
      (with-open-file (out (upath-subdir upath '("_darcs" "prefs") filename)
                           :direction :output
                           :if-exists :append
                           :if-does-not-exist :create)
        (write-line pref out)))))

(defun write-default-prefs (repopath)
  (default-boring repopath)
  (default-binaries repopath)
  (set-preflist repopath "motd" ()))

(defun default-boring (repopath)
  (set-preflist repopath "boring"
                '("# Boring file regexps:"
                  "\\.hi$" 
                  "\\.o$" "\\.o\\.cmd$" 
                  "# *.ko files aren't boring by default because they might" 
                  "# be Korean translations rather than kernel modules." 
                  "# \\.ko$" 
                  "\\.ko\\.cmd$" "\\.mod\\.c$" 
                  "(^|/)\\.tmp_versions($|/)" "(^|/)CVS($|/)" "(^|/)RCS($|/)" "~$" 
                  "#(^|/)\\.[^/]" "(^|/)_darcs($|/)" 
                  "\\.bak$" "\\.BAK$" "\\.orig$" "(^|/)vssver\\.scc$" 
                  "\\.swp$" "(^|/)MT($|/)" 
                  "(^|/)\\{arch\\}($|/)" "(^|/).arch-ids($|/)" 
                  "(^|/)," "\\.class$" "\\.prof$" "(^|/)\\.DS_Store$" 
                  "(^|/)BitKeeper($|/)" "(^|/)ChangeSet($|/)" 
                  "(^|/)\\.svn($|/)" "\\.py[co]$" "\\#" "\\.cvsignore$" 
                  "(^|/)Thumbs\\.db$" 
                  "(^|/)autom4te\\.cache($|/)")))

(defun default-binaries (repopath)
  (set-preflist
   repopath "binaries"
   (cons "# Binary file regexps:" 
         (mapcan (lambda (ext)
                   (list (format nil "\\.~A$" ext)
                         (format nil "\\.~A$" (string-upcase ext))))
                 '("png" "gz" "pdf" "jpg" "jpeg" "gif" "tif" 
                   "tiff" "pnm" "pbm" "pgm" "ppm" "bmp" "mng" 
                   "tar" "bz2" "z" "zip" "jar" "so" "a" 
                   "tgz" "mpg" "mpeg" "iso" "exe" "doc")))))

(defun set-default-repo (repopath repostring)
  (set-preflist repopath "defaultrepo" (list repostring))
  (add-to-preflist repopath "repos" repostring))