*** empty log message ***
[emacs.git] / lisp / pcvs-util.el
blob3945d7ba67c627ad78350a0d08443fb1b12a2bd8
1 ;;; pcvs-util.el --- utility functions for PCL-CVS -*- byte-compile-dynamic: t -*-
3 ;; Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 ;; 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007 Free Software Foundation, Inc.
6 ;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
7 ;; Keywords: pcl-cvs
9 ;; This file is part of GNU Emacs.
11 ;; GNU Emacs is free software; you can redistribute it and/or modify
12 ;; it under the terms of the GNU General Public License as published by
13 ;; the Free Software Foundation; either version 2, or (at your option)
14 ;; any later version.
16 ;; GNU Emacs is distributed in the hope that it will be useful,
17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19 ;; GNU General Public License for more details.
21 ;; You should have received a copy of the GNU General Public License
22 ;; along with GNU Emacs; see the file COPYING. If not, write to the
23 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
24 ;; Boston, MA 02110-1301, USA.
26 ;;; Commentary:
29 ;;; Code:
31 (eval-when-compile (require 'cl))
33 ;;;;
34 ;;;; list processing
35 ;;;;
37 (defsubst cvs-car (x) (if (consp x) (car x) x))
38 (defalias 'cvs-cdr 'cdr-safe)
39 (defsubst cvs-append (&rest xs)
40 (apply 'append (mapcar (lambda (x) (if (listp x) x (list x))) xs)))
42 (defsubst cvs-every (-cvs-every-f -cvs-every-l)
43 (while (consp -cvs-every-l)
44 (unless (funcall -cvs-every-f (pop -cvs-every-l))
45 (setq -cvs-every-l t)))
46 (not -cvs-every-l))
48 (defun cvs-union (xs ys)
49 (let ((zs ys))
50 (dolist (x xs zs)
51 (unless (member x ys) (push x zs)))))
53 (defun cvs-map (-cvs-map-f &rest -cvs-map-ls)
54 (unless (cvs-every 'null -cvs-map-ls)
55 (cons (apply -cvs-map-f (mapcar 'car -cvs-map-ls))
56 (apply 'cvs-map -cvs-map-f (mapcar 'cdr -cvs-map-ls)))))
58 (defun cvs-first (l &optional n)
59 (if (null n) (car l)
60 (when l
61 (let* ((nl (list (pop l)))
62 (ret nl))
63 (while (and l (> n 1))
64 (setcdr nl (list (pop l)))
65 (setq nl (cdr nl))
66 (decf n))
67 ret))))
69 (defun cvs-partition (p l)
70 "Partition a list L into two lists based on predicate P.
71 The function returns a `cons' cell where the `car' contains
72 elements of L for which P is true while the `cdr' contains
73 the other elements. The ordering among elements is maintained."
74 (let (car cdr)
75 (dolist (x l)
76 (if (funcall p x) (push x car) (push x cdr)))
77 (cons (nreverse car) (nreverse cdr))))
79 ;;;
80 ;;; frame, window, buffer handling
81 ;;;
83 (defun cvs-pop-to-buffer-same-frame (buf)
84 "Pop to BUF like `pop-to-buffer' but staying on the same frame.
85 If `pop-to-buffer' would have opened a new frame, this function would
86 try to split a new window instead."
87 (let ((pop-up-windows (or pop-up-windows pop-up-frames))
88 (pop-up-frames nil))
89 (or (let ((buf (get-buffer-window buf))) (and buf (select-window buf)))
90 (and pop-up-windows
91 (ignore-errors (select-window (split-window-vertically)))
92 (switch-to-buffer buf))
93 (pop-to-buffer (current-buffer)))))
95 (defun cvs-bury-buffer (buf &optional mainbuf)
96 "Hide the buffer BUF that was temporarily popped up.
97 BUF is assumed to be a temporary buffer used from the buffer MAINBUF."
98 (interactive (list (current-buffer)))
99 (save-current-buffer
100 (let ((win (if (eq buf (window-buffer (selected-window))) (selected-window)
101 (get-buffer-window buf t))))
102 (when win
103 (if (window-dedicated-p win)
104 (condition-case ()
105 (delete-window win)
106 (error (iconify-frame (window-frame win))))
107 ;;; (if (and mainbuf (get-buffer-window mainbuf))
108 ;;; ;; FIXME: if the buffer popped into a pre-existing window,
109 ;;; ;; we don't want to delete that window.
110 ;;; t ;;(delete-window win)
111 ;;; )
113 (with-current-buffer buf
114 (bury-buffer (unless (and (eq buf (window-buffer (selected-window)))
115 (not (window-dedicated-p (selected-window))))
116 buf)))
117 (when mainbuf
118 (let ((mainwin (or (get-buffer-window mainbuf)
119 (get-buffer-window mainbuf 'visible))))
120 (when mainwin (select-window mainwin))))))
122 (defun cvs-get-buffer-create (name &optional noreuse)
123 "Create a buffer NAME unless such a buffer already exists.
124 If the NAME looks like an absolute file name, the buffer will be created
125 with `create-file-buffer' and will probably get another name than NAME.
126 In such a case, the search for another buffer with the same name doesn't
127 use the buffer name but the buffer's `list-buffers-directory' variable.
128 If NOREUSE is non-nil, always return a new buffer."
129 (or (and (not (file-name-absolute-p name))
130 (if noreuse (generate-new-buffer name)
131 (get-buffer-create name)))
132 (unless noreuse
133 (dolist (buf (buffer-list))
134 (with-current-buffer buf
135 (when (equal name list-buffers-directory)
136 (return buf)))))
137 (with-current-buffer (create-file-buffer name)
138 (set (make-local-variable 'list-buffers-directory) name)
139 (current-buffer))))
141 ;;;;
142 ;;;; string processing
143 ;;;;
145 (defun cvs-insert-strings (strings)
146 "Insert a list of STRINGS into the current buffer.
147 Uses columns to keep the listing readable but compact."
148 (when (consp strings)
149 (let* ((length (apply 'max (mapcar 'length strings)))
150 (wwidth (1- (window-width)))
151 (columns (min
152 ;; At least 2 columns; at least 2 spaces between columns.
153 (max 2 (/ wwidth (+ 2 length)))
154 ;; Don't allocate more columns than we can fill.
155 ;; Windows can't show less than 3 lines anyway.
156 (max 1 (/ (length strings) 2))))
157 (colwidth (/ wwidth columns)))
158 ;; Use tab-width rather than indent-to.
159 (setq tab-width colwidth)
160 ;; The insertion should be "sensible" no matter what choices were made.
161 (dolist (str strings)
162 (unless (bolp)
163 (insert " \t")
164 (when (< wwidth (+ (max colwidth (length str)) (current-column)))
165 (delete-char -2) (insert "\n")))
166 (insert str)))))
169 (defun cvs-file-to-string (file &optional oneline args)
170 "Read the content of FILE and return it as a string.
171 If ONELINE is t, only the first line (no \\n) will be returned.
172 If ARGS is non-nil, the file will be executed with ARGS as its
173 arguments. If ARGS is not a list, no argument will be passed."
174 (condition-case nil
175 (with-temp-buffer
176 (if args
177 (apply 'call-process
178 file nil t nil (when (listp args) args))
179 (insert-file-contents file))
180 (goto-char (point-min))
181 (buffer-substring (point)
182 (if oneline (line-end-position) (point-max))))
183 (file-error nil)))
185 (defun cvs-string-prefix-p (str1 str2)
186 "Tell whether STR1 is a prefix of STR2."
187 (eq t (compare-strings str2 nil (length str1) str1 nil nil)))
189 ;; (string->strings (strings->string X)) == X
190 (defun cvs-strings->string (strings &optional separator)
191 "Concatenate the STRINGS, adding the SEPARATOR (default \" \").
192 This tries to quote the strings to avoid ambiguity such that
193 (cvs-string->strings (cvs-strings->string strs)) == strs
194 Only some SEPARATORs will work properly."
195 (let ((sep (or separator " ")))
196 (mapconcat
197 (lambda (str)
198 (if (string-match "[\\\"]" str)
199 (concat "\"" (replace-regexp-in-string "[\\\"]" "\\\\\\&" str) "\"")
200 str))
201 strings sep)))
203 ;; (string->strings (strings->string X)) == X
204 (defun cvs-string->strings (string &optional separator)
205 "Split the STRING into a list of strings.
206 It understands elisp style quoting within STRING such that
207 (cvs-string->strings (cvs-strings->string strs)) == strs
208 The SEPARATOR regexp defaults to \"\\s-+\"."
209 (let ((sep (or separator "\\s-+"))
210 (i (string-match "[\"]" string)))
211 (if (null i) (split-string string sep t) ; no quoting: easy
212 (append (unless (eq i 0) (split-string (substring string 0 i) sep t))
213 (let ((rfs (read-from-string string i)))
214 (cons (car rfs)
215 (cvs-string->strings (substring string (cdr rfs))
216 sep)))))))
218 ;;;;
219 ;;;; file names
220 ;;;;
222 (defsubst cvs-expand-dir-name (d)
223 (file-name-as-directory (expand-file-name d)))
225 ;;;;
226 ;;;; (interactive <foo>) support function
227 ;;;;
229 (defstruct (cvs-qtypedesc
230 (:constructor nil) (:copier nil)
231 (:constructor cvs-qtypedesc-create
232 (str2obj obj2str &optional complete hist-sym require)))
233 str2obj
234 obj2str
235 hist-sym
236 complete
237 require)
240 (defconst cvs-qtypedesc-string1 (cvs-qtypedesc-create 'identity 'identity t))
241 (defconst cvs-qtypedesc-string (cvs-qtypedesc-create 'identity 'identity))
242 (defconst cvs-qtypedesc-strings
243 (cvs-qtypedesc-create 'cvs-string->strings 'cvs-strings->string nil))
245 (defun cvs-query-read (default prompt qtypedesc &optional hist-sym)
246 (let* ((qtypedesc (or qtypedesc cvs-qtypedesc-strings))
247 (hist-sym (or hist-sym (cvs-qtypedesc-hist-sym qtypedesc)))
248 (complete (cvs-qtypedesc-complete qtypedesc))
249 (completions (and (functionp complete) (funcall complete)))
250 (initval (funcall (cvs-qtypedesc-obj2str qtypedesc) default)))
251 (funcall (cvs-qtypedesc-str2obj qtypedesc)
252 (cond
253 ((null complete) (read-string prompt initval hist-sym))
254 ((functionp complete)
255 (completing-read prompt completions
256 nil (cvs-qtypedesc-require qtypedesc)
257 initval hist-sym))
258 (t initval)))))
260 ;;;;
261 ;;;; Flags handling
262 ;;;;
264 (defstruct (cvs-flags
265 (:constructor nil)
266 (:constructor -cvs-flags-make
267 (desc defaults &optional qtypedesc hist-sym)))
268 defaults persist desc qtypedesc hist-sym)
270 (defmacro cvs-flags-define (sym defaults
271 &optional desc qtypedesc hist-sym docstring)
272 `(defconst ,sym
273 (let ((bound (boundp ',sym)))
274 (if (and bound (cvs-flags-p ,sym)) ,sym
275 (let ((defaults ,defaults))
276 (-cvs-flags-make ,desc
277 (if bound (cons ,sym (cdr defaults)) defaults)
278 ,qtypedesc ,hist-sym))))
279 ,docstring))
281 (defun cvs-flags-query (sym &optional desc arg)
282 "Query flags based on SYM.
283 Optional argument DESC will be used for the prompt.
284 If ARG (or a prefix argument) is nil, just use the 0th default.
285 If it is a non-negative integer, use the corresponding default.
286 If it is a negative integer query for a new value of the corresponding
287 default and return that new value.
288 If it is \\[universal-argument], just query and return a value without
289 altering the defaults.
290 If it is \\[universal-argument] \\[universal-argument], behave just
291 as if a negative zero was provided."
292 (let* ((flags (symbol-value sym))
293 (desc (or desc (cvs-flags-desc flags)))
294 (qtypedesc (cvs-flags-qtypedesc flags))
295 (hist-sym (cvs-flags-hist-sym flags))
296 (arg (if (eq arg 'noquery) 0 (or arg current-prefix-arg 0)))
297 (numarg (prefix-numeric-value arg))
298 (defaults (cvs-flags-defaults flags))
299 (permstr (if (< numarg 0) (format " (%sth default)" (- numarg)))))
300 ;; special case for universal-argument
301 (when (consp arg)
302 (setq permstr (if (> numarg 4) " (permanent)" ""))
303 (setq numarg 0))
305 ;; sanity check
306 (unless (< (abs numarg) (length defaults))
307 (error "There is no %sth default" (abs numarg)))
309 (if permstr
310 (let* ((prompt (format "%s%s: " desc permstr))
311 (fs (cvs-query-read (nth (- numarg) (cvs-flags-defaults flags))
312 prompt qtypedesc hist-sym)))
313 (when (not (equal permstr ""))
314 (setf (nth (- numarg) (cvs-flags-defaults flags)) fs))
316 (nth numarg defaults))))
318 (defsubst cvs-flags-set (sym index value)
319 "Set SYM's INDEX'th setting to VALUE."
320 (setf (nth index (cvs-flags-defaults (symbol-value sym))) value))
322 ;;;;
323 ;;;; Prefix keys
324 ;;;;
326 (defconst cvs-prefix-number 10)
328 (defsubst cvs-prefix-sym (sym) (intern (concat (symbol-name sym) "-cps")))
330 (defmacro cvs-prefix-define (sym docstring desc defaults
331 &optional qtypedesc hist-sym)
332 (let ((cps (cvs-prefix-sym sym)))
333 `(progn
334 (defvar ,sym nil ,(concat (or docstring "") "
335 See `cvs-prefix-set' for further description of the behavior."))
336 (defvar ,cps
337 (let ((defaults ,defaults))
338 ;; sanity ensurance
339 (unless (>= (length defaults) cvs-prefix-number)
340 (setq defaults (append defaults
341 (make-list (1- cvs-prefix-number)
342 (nth 0 defaults)))))
343 (-cvs-flags-make ,desc defaults ,qtypedesc ,hist-sym))))))
345 (defun cvs-prefix-make-local (sym)
346 (let ((cps (cvs-prefix-sym sym)))
347 (make-local-variable sym)
348 (set (make-local-variable cps) (copy-cvs-flags (symbol-value cps)))))
350 (defun cvs-prefix-set (sym arg)
351 ;; we could distinguish between numeric and non-numeric prefix args instead of
352 ;; relying on that magic `4'.
353 "Set the cvs-prefix contained in SYM.
354 If ARG is between 0 and 9, it selects the corresponding default.
355 If ARG is negative (or \\[universal-argument] which corresponds to negative 0),
356 it queries the user and sets the -ARG'th default.
357 If ARG is greater than 9 (or \\[universal-argument] \\[universal-argument]),
358 the (ARG mod 10)'th prefix is made persistent.
359 If ARG is nil toggle the PREFIX's value between its 0th default and nil
360 and reset the persistence."
361 (let* ((prefix (symbol-value (cvs-prefix-sym sym)))
362 (numarg (if (integerp arg) arg 0))
363 ;; (defs (cvs-flags-defaults prefix))
366 ;; set persistence if requested
367 (when (> (prefix-numeric-value arg) 9)
368 (setf (cvs-flags-persist prefix) t)
369 (setq numarg (mod numarg 10)))
371 ;; set the value
372 (set sym
373 (cond
374 ((null arg)
375 (setf (cvs-flags-persist prefix) nil)
376 (unless (symbol-value sym) (nth 0 (cvs-flags-defaults prefix))))
378 ((or (consp arg) (< numarg 0))
379 (setf (nth (- numarg) (cvs-flags-defaults prefix))
380 (cvs-query-read (nth (- numarg) (cvs-flags-defaults prefix))
381 (format "%s: " (cvs-flags-desc prefix))
382 (cvs-flags-qtypedesc prefix)
383 (cvs-flags-hist-sym prefix))))
384 (t (nth numarg (cvs-flags-defaults prefix)))))
385 (force-mode-line-update)))
387 (defun cvs-prefix-get (sym &optional read-only)
388 "Return the current value of the prefix SYM.
389 And reset it unless READ-ONLY is non-nil."
390 (prog1 (symbol-value sym)
391 (unless (or read-only
392 (cvs-flags-persist (symbol-value (cvs-prefix-sym sym))))
393 (set sym nil)
394 (force-mode-line-update))))
396 (provide 'pcvs-util)
398 ;; arch-tag: 3b2588bb-2ae3-4f1f-bf5b-dea91b1f8a59
399 ;;; pcvs-util.el ends here