Mercurial > emacs
comparison lisp/pcvs-util.el @ 28088:b442dfc3cef0
*** empty log message ***
author | Stefan Monnier <monnier@iro.umontreal.ca> |
---|---|
date | Sat, 11 Mar 2000 03:51:31 +0000 |
parents | |
children | ff69c2cd80c1 |
comparison
equal
deleted
inserted
replaced
28087:9ca294cf76c7 | 28088:b442dfc3cef0 |
---|---|
1 ;;; pcvs-util.el --- Utitlity functions for pcl-cvs | |
2 | |
3 ;; Copyright (C) 1998-2000 Free Software Foundation, Inc. | |
4 | |
5 ;; Author: Stefan Monnier <monnier@cs.yale.edu> | |
6 ;; Keywords: pcl-cvs | |
7 ;; Version: $Name: $ | |
8 ;; Revision: $Id: pcl-cvs-util.el,v 1.26 2000/03/05 21:32:21 monnier Exp $ | |
9 | |
10 ;; This file is part of GNU Emacs. | |
11 | |
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. | |
16 | |
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. | |
21 | |
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. | |
26 | |
27 ;;; Commentary: | |
28 | |
29 | |
30 ;;; Code: | |
31 | |
32 (eval-when-compile (require 'cl)) | |
33 | |
34 ;;;; | |
35 ;;;; list processing | |
36 ;;;l | |
37 | |
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))) | |
42 | |
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)) | |
48 | |
49 (defun cvs-union (xs ys) | |
50 (let ((zs ys)) | |
51 (dolist (x xs zs) | |
52 (unless (member x ys) (push x zs))))) | |
53 | |
54 | |
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))))) | |
59 | |
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)))) | |
70 | |
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)))) | |
80 | |
81 ;;;; | |
82 ;;;; frame, window, buffer handling | |
83 ;;;; | |
84 | |
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))))) | |
96 | |
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)))))) | |
119 | |
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)))) | |
136 | |
137 ;;;; | |
138 ;;;; string processing | |
139 ;;;; | |
140 | |
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)))) | |
158 | |
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))))) | |
164 | |
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-regexps-in-string "[\\\"]" "\\\\\\&" str) "\"") | |
176 str)) | |
177 strings sep))) | |
178 | |
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))))))) | |
192 | |
193 | |
194 (defun cvs-string-fill (str n &optional filling truncate) | |
195 "Add FILLING (defaults to the space char) to STR to reach size N. | |
196 If STR is longer than N, truncate if TRUNCATE is set, else don't do anything." | |
197 (let ((l (length str))) | |
198 (if (> l n) | |
199 (if truncate (substring str 0 n) str) | |
200 (concat str (make-string (- n l) (or filling ? )))))) | |
201 | |
202 ;;;; | |
203 ;;;; file names | |
204 ;;;; | |
205 | |
206 (defsubst cvs-expand-dir-name (d) | |
207 (file-name-as-directory (expand-file-name d))) | |
208 | |
209 ;;;; | |
210 ;;;; (interactive <foo>) support function | |
211 ;;;; | |
212 | |
213 (defstruct (cvs-qtypedesc | |
214 (:constructor nil) (:copier nil) | |
215 (:constructor cvs-qtypedesc-create | |
216 (str2obj obj2str &optional complete hist-sym require))) | |
217 str2obj | |
218 obj2str | |
219 hist-sym | |
220 complete | |
221 require) | |
222 | |
223 | |
224 (defconst cvs-qtypedesc-string1 (cvs-qtypedesc-create 'identity 'identity t)) | |
225 (defconst cvs-qtypedesc-string (cvs-qtypedesc-create 'identity 'identity)) | |
226 (defconst cvs-qtypedesc-strings | |
227 (cvs-qtypedesc-create 'cvs-string->strings 'cvs-strings->string nil)) | |
228 | |
229 (defun cvs-query-read (default prompt qtypedesc &optional hist-sym) | |
230 (let* ((qtypedesc (or qtypedesc cvs-qtypedesc-strings)) | |
231 (hist-sym (or hist-sym (cvs-qtypedesc-hist-sym qtypedesc))) | |
232 (complete (cvs-qtypedesc-complete qtypedesc)) | |
233 (completions (and (functionp complete) (funcall complete))) | |
234 (initval (funcall (cvs-qtypedesc-obj2str qtypedesc) default))) | |
235 (funcall (cvs-qtypedesc-str2obj qtypedesc) | |
236 (cond | |
237 ((null complete) (read-string prompt initval hist-sym)) | |
238 ((functionp complete) | |
239 (completing-read prompt completions | |
240 nil (cvs-qtypedesc-require qtypedesc) | |
241 initval hist-sym)) | |
242 (t initval))))) | |
243 | |
244 ;;;; | |
245 ;;;; Flags handling | |
246 ;;;; | |
247 | |
248 (defstruct (cvs-flags | |
249 (:constructor nil) | |
250 (:constructor -cvs-flags-make | |
251 (desc defaults &optional qtypedesc hist-sym))) | |
252 defaults persist desc qtypedesc hist-sym) | |
253 | |
254 (defmacro cvs-flags-define (sym defaults | |
255 &optional desc qtypedesc hist-sym docstring) | |
256 `(defconst ,sym | |
257 (let ((bound (boundp ',sym))) | |
258 (if (and bound (cvs-flags-p ,sym)) ,sym | |
259 (let ((defaults ,defaults)) | |
260 (-cvs-flags-make ,desc | |
261 (if bound (cons ,sym (cdr defaults)) defaults) | |
262 ,qtypedesc ,hist-sym)))) | |
263 ,docstring)) | |
264 | |
265 (defun cvs-flags-query (sym &optional desc arg) | |
266 "Query flags based on SYM. | |
267 Optional argument DESC will be used for the prompt | |
268 If ARG (or a prefix argument) is nil, just use the 0th default. | |
269 If it is a non-negative integer, use the corresponding default. | |
270 If it is a negative integer query for a new value of the corresponding | |
271 default and return that new value. | |
272 If it is \\[universal-argument], just query and return a value without | |
273 altering the defaults. | |
274 If it is \\[universal-argument] \\[universal-argument], behave just | |
275 as if a negative zero was provided." | |
276 (let* ((flags (symbol-value sym)) | |
277 (desc (or desc (cvs-flags-desc flags))) | |
278 (qtypedesc (cvs-flags-qtypedesc flags)) | |
279 (hist-sym (cvs-flags-hist-sym flags)) | |
280 (arg (if (eq arg 'noquery) 0 (or arg current-prefix-arg 0))) | |
281 (numarg (prefix-numeric-value arg)) | |
282 (defaults (cvs-flags-defaults flags)) | |
283 (permstr (if (< numarg 0) (format " (%sth default)" (- numarg))))) | |
284 ;; special case for universal-argument | |
285 (when (consp arg) | |
286 (setq permstr (if (> numarg 4) " (permanent)" "")) | |
287 (setq numarg 0)) | |
288 | |
289 ;; sanity check | |
290 (unless (< (abs numarg) (length defaults)) | |
291 (error "There is no %sth default." (abs numarg))) | |
292 | |
293 (if permstr | |
294 (let* ((prompt (format "%s%s: " desc permstr)) | |
295 (fs (cvs-query-read (nth (- numarg) (cvs-flags-defaults flags)) | |
296 prompt qtypedesc hist-sym))) | |
297 (when (not (equal permstr "")) | |
298 (setf (nth (- numarg) (cvs-flags-defaults flags)) fs)) | |
299 fs) | |
300 (nth numarg defaults)))) | |
301 | |
302 (defsubst cvs-flags-set (sym index value) | |
303 "Set SYM's INDEX'th setting to VALUE." | |
304 (setf (nth index (cvs-flags-defaults (symbol-value sym))) value)) | |
305 | |
306 ;;;; | |
307 ;;;; Prefix keys | |
308 ;;;; | |
309 | |
310 (defconst cvs-prefix-number 10) | |
311 | |
312 (defsubst cvs-prefix-sym (sym) (intern (concat (symbol-name sym) "-cps"))) | |
313 | |
314 (defmacro cvs-prefix-define (sym docstring desc defaults | |
315 &optional qtypedesc hist-sym) | |
316 (let ((cps (cvs-prefix-sym sym))) | |
317 `(progn | |
318 (defvar ,sym nil ,(cons (or docstring "") " | |
319 See `cvs-prefix-set' for further description of the behavior.")) | |
320 (defconst ,cps | |
321 (let ((defaults ,defaults)) | |
322 ;; sanity ensurance | |
323 (unless (>= (length defaults) cvs-prefix-number) | |
324 (setq defaults (append defaults | |
325 (make-list (1- cvs-prefix-number) | |
326 (first defaults))))) | |
327 (-cvs-flags-make ,desc defaults ,qtypedesc ,hist-sym)))))) | |
328 | |
329 (defun cvs-prefix-make-local (sym) | |
330 (let ((cps (cvs-prefix-sym sym))) | |
331 (make-local-variable sym) | |
332 (set (make-local-variable cps) (copy-cvs-flags (symbol-value cps))))) | |
333 | |
334 (defun cvs-prefix-set (sym arg) | |
335 ;; we could distinguish between numeric and non-numeric prefix args instead of | |
336 ;; relying on that magic `4'. | |
337 "Set the cvs-prefix contained in SYM. | |
338 If ARG is between 0 and 9, it selects the corresponding default. | |
339 If ARG is negative (or \\[universal-argument] which corresponds to negative 0), | |
340 it queries the user and sets the -ARG'th default. | |
341 If ARG is greater than 9 (or \\[universal-argument] \\[universal-argument]), | |
342 the (ARG mod 10)'th prefix is made persistent. | |
343 If ARG is NIL toggle the PREFIX's value between its 0th default and NIL | |
344 and reset the persistence." | |
345 (let* ((prefix (symbol-value (cvs-prefix-sym sym))) | |
346 (numarg (if (integerp arg) arg 0)) | |
347 (defs (cvs-flags-defaults prefix))) | |
348 | |
349 ;; set persistence if requested | |
350 (when (> (prefix-numeric-value arg) 9) | |
351 (setf (cvs-flags-persist prefix) t) | |
352 (setq numarg (mod numarg 10))) | |
353 | |
354 ;; set the value | |
355 (set sym | |
356 (cond | |
357 ((null arg) | |
358 (setf (cvs-flags-persist prefix) nil) | |
359 (unless (symbol-value sym) (first (cvs-flags-defaults prefix)))) | |
360 | |
361 ((or (consp arg) (< numarg 0)) | |
362 (setf (nth (- numarg) (cvs-flags-defaults prefix)) | |
363 (cvs-query-read (nth (- numarg) (cvs-flags-defaults prefix)) | |
364 (format "%s: " (cvs-flags-desc prefix)) | |
365 (cvs-flags-qtypedesc prefix) | |
366 (cvs-flags-hist-sym prefix)))) | |
367 (t (nth numarg (cvs-flags-defaults prefix))))) | |
368 (force-mode-line-update))) | |
369 | |
370 (defun cvs-prefix-get (sym &optional read-only) | |
371 "Return the current value of the prefix SYM. | |
372 and reset it unless READ-ONLY is non-nil." | |
373 (prog1 (symbol-value sym) | |
374 (unless (or read-only | |
375 (cvs-flags-persist (symbol-value (cvs-prefix-sym sym)))) | |
376 (set sym nil) | |
377 (force-mode-line-update)))) | |
378 | |
379 (provide 'pcvs-util) | |
380 | |
381 ;;; pcl-cvs-util.el ends here |