*** empty log message ***
[emacs.git] / lisp / pcvs-util.el
blob06a07583482213bc7fb4a8c4a9e136bb3642cba3
1 ;;; pcvs-util.el --- Utitlity functions for pcl-cvs
3 ;; Copyright (C) 1998-2000 Free Software Foundation, Inc.
5 ;; Author: Stefan Monnier <monnier@cs.yale.edu>
6 ;; Keywords: pcl-cvs
7 ;; Version: $Name: $
8 ;; Revision: $Id: pcvs-util.el,v 1.1 2000/08/05 19:33:53 gerd Exp gerd $
10 ;; This file is part of GNU Emacs.
12 ;; GNU Emacs is free software; you can redistribute it and/or modify
13 ;; it under the terms of the GNU General Public License as published by
14 ;; the Free Software Foundation; either version 2, or (at your option)
15 ;; any later version.
17 ;; GNU Emacs is distributed in the hope that it will be useful,
18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
20 ;; GNU General Public License for more details.
22 ;; You should have received a copy of the GNU General Public License
23 ;; along with GNU Emacs; see the file COPYING. If not, write to the
24 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
25 ;; Boston, MA 02111-1307, USA.
27 ;;; Commentary:
30 ;;; Code:
32 (eval-when-compile (require 'cl))
34 ;;;;
35 ;;;; list processing
36 ;;;l
38 (defsubst cvs-car (x) (if (consp x) (car x) x))
39 (defalias 'cvs-cdr 'cdr-safe)
40 (defsubst cvs-append (&rest xs)
41 (apply 'append (mapcar (lambda (x) (if (listp x) x (list x))) xs)))
43 (defsubst cvs-every (-cvs-every-f -cvs-every-l)
44 (while (consp -cvs-every-l)
45 (unless (funcall -cvs-every-f (pop -cvs-every-l))
46 (setq -cvs-every-l t)))
47 (not -cvs-every-l))
49 (defun cvs-union (xs ys)
50 (let ((zs ys))
51 (dolist (x xs zs)
52 (unless (member x ys) (push x zs)))))
55 (defun cvs-map (-cvs-map-f &rest -cvs-map-ls)
56 (unless (cvs-every 'null -cvs-map-ls)
57 (cons (apply -cvs-map-f (mapcar 'car -cvs-map-ls))
58 (apply 'cvs-map -cvs-map-f (mapcar 'cdr -cvs-map-ls)))))
60 (defun cvs-first (l &optional n)
61 (if (null n) (car l)
62 (when l
63 (let* ((nl (list (pop l)))
64 (ret nl))
65 (while (and l (> n 1))
66 (setcdr nl (list (pop l)))
67 (setq nl (cdr nl))
68 (decf n))
69 ret))))
71 (defun cvs-partition (p l)
72 "Partition a list L into two lists based on predicate P.
73 The function returns a `cons' cell where the `car' contains
74 elements of L for which P is true while the `cdr' contains
75 the other elements. The ordering among elements is maintained."
76 (let (car cdr)
77 (dolist (x l)
78 (if (funcall p x) (push x car) (push x cdr)))
79 (cons (nreverse car) (nreverse cdr))))
81 ;;;;
82 ;;;; frame, window, buffer handling
83 ;;;;
85 (defun cvs-pop-to-buffer-same-frame (buf)
86 "Pop to BUF like `pop-to-buffer' but staying on the same frame.
87 If `pop-to-buffer' would have opened a new frame, this function would
88 try to split the a new window instead."
89 (let ((pop-up-windows (or pop-up-windows pop-up-frames))
90 (pop-up-frames nil))
91 (or (let ((buf (get-buffer-window buf))) (and buf (select-window buf)))
92 (and pop-up-windows
93 (ignore-errors (select-window (split-window-vertically)))
94 (switch-to-buffer buf))
95 (pop-to-buffer (current-buffer)))))
97 (defun cvs-bury-buffer (buf &optional mainbuf)
98 "Hide the buffer BUF that was temporarily popped up.
99 BUF is assumed to be a temporary buffer used from the buffer MAINBUF."
100 (interactive (list (current-buffer)))
101 (save-current-buffer
102 (let ((win (if (eq buf (window-buffer (selected-window))) (selected-window)
103 (get-buffer-window buf t))))
104 (when win
105 (if (window-dedicated-p win)
106 (condition-case ()
107 (delete-window win)
108 (error (iconify-frame (window-frame win))))
109 (if (and mainbuf (get-buffer-window mainbuf))
110 (delete-window win)))))
111 (with-current-buffer buf
112 (bury-buffer (unless (and (eq buf (window-buffer (selected-window)))
113 (not (window-dedicated-p (selected-window))))
114 buf)))
115 (when mainbuf
116 (let ((mainwin (or (get-buffer-window mainbuf)
117 (get-buffer-window mainbuf 'visible))))
118 (when mainwin (select-window mainwin))))))
120 (defun cvs-get-buffer-create (name &optional noreuse)
121 "Create a buffer NAME unless such a buffer already exists.
122 If the NAME looks like an absolute file name, the buffer will be created
123 with `create-file-buffer' and will probably get another name than NAME.
124 In such a case, the search for another buffer with the same name doesn't
125 use the buffer name but the buffer's `list-buffers-directory' variable.
126 If NOREUSE is non-nil, always return a new buffer."
127 (or (and (not (file-name-absolute-p name)) (get-buffer-create name))
128 (unless noreuse
129 (dolist (buf (buffer-list))
130 (with-current-buffer buf
131 (when (equal name list-buffers-directory)
132 (return buf)))))
133 (with-current-buffer (create-file-buffer name)
134 (set (make-local-variable 'list-buffers-directory) name)
135 (current-buffer))))
137 ;;;;
138 ;;;; string processing
139 ;;;;
141 (defun cvs-file-to-string (file &optional oneline args)
142 "Read the content of FILE and return it as a string.
143 If ONELINE is t, only the first line (no \\n) will be returned.
144 If ARGS is non-nil, the file will be executed with ARGS as its
145 arguments. If ARGS is not a list, no argument will be passed."
146 (with-temp-buffer
147 (condition-case nil
148 (progn
149 (if args
150 (apply 'call-process
151 file nil t nil (when (listp args) args))
152 (insert-file-contents file))
153 (buffer-substring (point-min)
154 (if oneline
155 (progn (goto-char (point-min)) (end-of-line) (point))
156 (point-max))))
157 (file-error nil))))
159 (defun cvs-string-prefix-p (str1 str2)
160 "Tell whether STR1 is a prefix of STR2."
161 (let ((length1 (length str1)))
162 (and (>= (length str2) length1)
163 (string= str1 (substring str2 0 length1)))))
165 ;; (string->strings (strings->string X)) == X
166 (defun cvs-strings->string (strings &optional separator)
167 "Concatenate the STRINGS, adding the SEPARATOR (default \" \").
168 This tries to quote the strings to avoid ambiguity such that
169 (cvs-string->strings (cvs-strings->string strs)) == strs
170 Only some SEPARATOR will work properly."
171 (let ((sep (or separator " ")))
172 (mapconcat
173 (lambda (str)
174 (if (string-match "[\\\"]" str)
175 (concat "\"" (replace-regexp-in-string "[\\\"]" "\\\\\\&" str) "\"")
176 str))
177 strings sep)))
179 ;; (string->strings (strings->string X)) == X
180 (defun cvs-string->strings (string &optional separator)
181 "Split the STRING into a list of strings.
182 It understands elisp style quoting within STRING such that
183 (cvs-string->strings (cvs-strings->string strs)) == strs
184 The SEPARATOR regexp defaults to \"\\s-+\"."
185 (let ((sep (or separator "\\s-+"))
186 (i (string-match "[\"]" string)))
187 (if (null i) (split-string string sep) ; no quoting: easy
188 (append (unless (eq i 0) (split-string (substring string 0 i) sep))
189 (let ((rfs (read-from-string string i)))
190 (cons (car rfs)
191 (cvs-string->strings (substring string (cdr rfs)) sep)))))))
193 ;;;;
194 ;;;; file names
195 ;;;;
197 (defsubst cvs-expand-dir-name (d)
198 (file-name-as-directory (expand-file-name d)))
200 ;;;;
201 ;;;; (interactive <foo>) support function
202 ;;;;
204 (defstruct (cvs-qtypedesc
205 (:constructor nil) (:copier nil)
206 (:constructor cvs-qtypedesc-create
207 (str2obj obj2str &optional complete hist-sym require)))
208 str2obj
209 obj2str
210 hist-sym
211 complete
212 require)
215 (defconst cvs-qtypedesc-string1 (cvs-qtypedesc-create 'identity 'identity t))
216 (defconst cvs-qtypedesc-string (cvs-qtypedesc-create 'identity 'identity))
217 (defconst cvs-qtypedesc-strings
218 (cvs-qtypedesc-create 'cvs-string->strings 'cvs-strings->string nil))
220 (defun cvs-query-read (default prompt qtypedesc &optional hist-sym)
221 (let* ((qtypedesc (or qtypedesc cvs-qtypedesc-strings))
222 (hist-sym (or hist-sym (cvs-qtypedesc-hist-sym qtypedesc)))
223 (complete (cvs-qtypedesc-complete qtypedesc))
224 (completions (and (functionp complete) (funcall complete)))
225 (initval (funcall (cvs-qtypedesc-obj2str qtypedesc) default)))
226 (funcall (cvs-qtypedesc-str2obj qtypedesc)
227 (cond
228 ((null complete) (read-string prompt initval hist-sym))
229 ((functionp complete)
230 (completing-read prompt completions
231 nil (cvs-qtypedesc-require qtypedesc)
232 initval hist-sym))
233 (t initval)))))
235 ;;;;
236 ;;;; Flags handling
237 ;;;;
239 (defstruct (cvs-flags
240 (:constructor nil)
241 (:constructor -cvs-flags-make
242 (desc defaults &optional qtypedesc hist-sym)))
243 defaults persist desc qtypedesc hist-sym)
245 (defmacro cvs-flags-define (sym defaults
246 &optional desc qtypedesc hist-sym docstring)
247 `(defconst ,sym
248 (let ((bound (boundp ',sym)))
249 (if (and bound (cvs-flags-p ,sym)) ,sym
250 (let ((defaults ,defaults))
251 (-cvs-flags-make ,desc
252 (if bound (cons ,sym (cdr defaults)) defaults)
253 ,qtypedesc ,hist-sym))))
254 ,docstring))
256 (defun cvs-flags-query (sym &optional desc arg)
257 "Query flags based on SYM.
258 Optional argument DESC will be used for the prompt
259 If ARG (or a prefix argument) is nil, just use the 0th default.
260 If it is a non-negative integer, use the corresponding default.
261 If it is a negative integer query for a new value of the corresponding
262 default and return that new value.
263 If it is \\[universal-argument], just query and return a value without
264 altering the defaults.
265 If it is \\[universal-argument] \\[universal-argument], behave just
266 as if a negative zero was provided."
267 (let* ((flags (symbol-value sym))
268 (desc (or desc (cvs-flags-desc flags)))
269 (qtypedesc (cvs-flags-qtypedesc flags))
270 (hist-sym (cvs-flags-hist-sym flags))
271 (arg (if (eq arg 'noquery) 0 (or arg current-prefix-arg 0)))
272 (numarg (prefix-numeric-value arg))
273 (defaults (cvs-flags-defaults flags))
274 (permstr (if (< numarg 0) (format " (%sth default)" (- numarg)))))
275 ;; special case for universal-argument
276 (when (consp arg)
277 (setq permstr (if (> numarg 4) " (permanent)" ""))
278 (setq numarg 0))
280 ;; sanity check
281 (unless (< (abs numarg) (length defaults))
282 (error "There is no %sth default." (abs numarg)))
284 (if permstr
285 (let* ((prompt (format "%s%s: " desc permstr))
286 (fs (cvs-query-read (nth (- numarg) (cvs-flags-defaults flags))
287 prompt qtypedesc hist-sym)))
288 (when (not (equal permstr ""))
289 (setf (nth (- numarg) (cvs-flags-defaults flags)) fs))
291 (nth numarg defaults))))
293 (defsubst cvs-flags-set (sym index value)
294 "Set SYM's INDEX'th setting to VALUE."
295 (setf (nth index (cvs-flags-defaults (symbol-value sym))) value))
297 ;;;;
298 ;;;; Prefix keys
299 ;;;;
301 (defconst cvs-prefix-number 10)
303 (defsubst cvs-prefix-sym (sym) (intern (concat (symbol-name sym) "-cps")))
305 (defmacro cvs-prefix-define (sym docstring desc defaults
306 &optional qtypedesc hist-sym)
307 (let ((cps (cvs-prefix-sym sym)))
308 `(progn
309 (defvar ,sym nil ,(cons (or docstring "") "
310 See `cvs-prefix-set' for further description of the behavior."))
311 (defconst ,cps
312 (let ((defaults ,defaults))
313 ;; sanity ensurance
314 (unless (>= (length defaults) cvs-prefix-number)
315 (setq defaults (append defaults
316 (make-list (1- cvs-prefix-number)
317 (nth 0 defaults)))))
318 (-cvs-flags-make ,desc defaults ,qtypedesc ,hist-sym))))))
320 (defun cvs-prefix-make-local (sym)
321 (let ((cps (cvs-prefix-sym sym)))
322 (make-local-variable sym)
323 (set (make-local-variable cps) (copy-cvs-flags (symbol-value cps)))))
325 (defun cvs-prefix-set (sym arg)
326 ;; we could distinguish between numeric and non-numeric prefix args instead of
327 ;; relying on that magic `4'.
328 "Set the cvs-prefix contained in SYM.
329 If ARG is between 0 and 9, it selects the corresponding default.
330 If ARG is negative (or \\[universal-argument] which corresponds to negative 0),
331 it queries the user and sets the -ARG'th default.
332 If ARG is greater than 9 (or \\[universal-argument] \\[universal-argument]),
333 the (ARG mod 10)'th prefix is made persistent.
334 If ARG is NIL toggle the PREFIX's value between its 0th default and NIL
335 and reset the persistence."
336 (let* ((prefix (symbol-value (cvs-prefix-sym sym)))
337 (numarg (if (integerp arg) arg 0))
338 (defs (cvs-flags-defaults prefix)))
340 ;; set persistence if requested
341 (when (> (prefix-numeric-value arg) 9)
342 (setf (cvs-flags-persist prefix) t)
343 (setq numarg (mod numarg 10)))
345 ;; set the value
346 (set sym
347 (cond
348 ((null arg)
349 (setf (cvs-flags-persist prefix) nil)
350 (unless (symbol-value sym) (nth 0 (cvs-flags-defaults prefix))))
352 ((or (consp arg) (< numarg 0))
353 (setf (nth (- numarg) (cvs-flags-defaults prefix))
354 (cvs-query-read (nth (- numarg) (cvs-flags-defaults prefix))
355 (format "%s: " (cvs-flags-desc prefix))
356 (cvs-flags-qtypedesc prefix)
357 (cvs-flags-hist-sym prefix))))
358 (t (nth numarg (cvs-flags-defaults prefix)))))
359 (force-mode-line-update)))
361 (defun cvs-prefix-get (sym &optional read-only)
362 "Return the current value of the prefix SYM.
363 and reset it unless READ-ONLY is non-nil."
364 (prog1 (symbol-value sym)
365 (unless (or read-only
366 (cvs-flags-persist (symbol-value (cvs-prefix-sym sym))))
367 (set sym nil)
368 (force-mode-line-update))))
370 (provide 'pcvs-util)
372 ;;; pcl-cvs-util.el ends here