Kde: Add Utilities: kwinid and kraisewindow
[emacsstuff.git] / lib / misc-local.el
1 ;; Miscellaneous local functions
2 ;;
3 ;; $Id: misc-local.el,v 1.20 2003/08/04 13:27:17 admin Exp $
4
5 ;;; Change-Log:
6
7 ;; $Log: misc-local.el,v $
8 ;; Revision 1.20  2003/08/04 13:27:17  admin
9 ;; Import der neuen Version
10 ;;
11 ;; Revision 1.19  2000/02/08 20:27:36  bund
12 ;; Besseres *scratch*-Buffer handling in kill-most-buffers
13 ;; setf in put-hashq/put-hash
14 ;;
15 ;; Revision 1.18  2000/02/04 13:16:45  bund
16 ;; *scratch*-Buffer verwaltung in kill-most-buffers verbessert
17 ;;
18 ;; Revision 1.17  2000/02/03 09:10:53  bund
19 ;; put-hash
20 ;;
21 ;; Revision 1.16  2000/02/01 11:21:18  bund
22 ;; Added emi-split-string
23 ;; Added put-hashq
24 ;;
25 ;; Revision 1.15  2000/01/26 15:26:58  bund
26 ;; better prefix-arg handling in kill-most-buffers
27 ;;
28 ;; Revision 1.14  2000/01/12 14:38:42  bund
29 ;; Neue funktion: kill-most-buffers
30 ;;
31 ;; Revision 1.13  1999/06/03 15:46:17  bund
32 ;; Added template-document-name function
33 ;;
34 ;; Revision 1.12  1999/02/02 12:48:45  bund
35 ;; Neue implementiereung von date-time-fielname-string et. al.
36 ;;
37 ;; Revision 1.11  1998/10/10 09:35:20  admin
38 ;; BUGFIX: fixed hook dependencies
39 ;;
40 ;; Revision 1.10  1998/10/07 14:33:28  bund
41 ;; Implemented window-size-change-functions hook for dedicated windows
42 ;;
43 ;; Revision 1.9  1998/10/07 13:44:46  bund
44 ;; Implemeted open-dedicated-window and it's friends
45 ;;
46 ;; Revision 1.8  1998/06/17 15:58:30  bund
47 ;; added query-filename-and-check
48 ;;
49 ;; Revision 1.7  1998/06/05 16:22:45  bund
50 ;; added load-add-hook-or-run
51 ;;
52 ;; Revision 1.7  1998/05/17 15:51:38  bund
53 ;; moved adabas-convert-char-byte to dataface.el
54 ;;
55 ;; Revision 1.6  1998/04/23 17:09:52  bund
56 ;; implemented hsxstring conversion functions
57 ;;
58 ;; Revision 1.5  1998/04/16 11:52:48  bund
59 ;; fixed (args-out-of-range) bug in string-replace
60 ;;
61 ;; Revision 1.4  1998/04/14 09:42:45  bund
62 ;; Implemented grep-list and grep-map-list[*]
63 ;;
64 ;; Revision 1.3  1998/03/31 12:47:28  bund
65 ;; misc changes
66 ;;
67 ;; Revision 1.2  1998/03/30 08:39:34  bund
68 ;; Added emi-mapcar*
69 ;;
70
71 ;;; Variables:
72
73 (defvar kill-most-buffers-nokill-list 
74   '("*desktop*" " *Adabas*"))
75
76 ;;; Code:
77
78 (require 'cl)
79
80 (defun emi-mapcar* (f &rest args)
81   "Apply FUNCTION to successive cars of all ARGS.
82 Return the list of results."
83   (if (not (memq 'nil args))
84       (cons (apply f (mapcar 'car args))
85             (apply 'emi-mapcar* f
86                    (mapcar 'cdr args)))))
87
88 (defun string-noempty (str)
89   "Return STR if (length STR) > 0, nil otherwise"
90   (if (> (length str) 0)
91       str
92     nil))
93
94 (defun date-time-filename-string (date &optional num)
95   "Return the string YYYYMMDDHHMMSS[nn] for the date DATE.
96  Append nn if NUM is non-nil."
97   (concat (format "%04d%02d%02d%02d%02d%02d" 
98                   (nth 5 date) (nth 4 date) (nth 3 date)
99                   (nth 2 date) (nth 1 date) (nth 0 date))
100           (if num (format "%02d" num) "")))
101
102 (defun date-time-string (date)
103   "Return DD.MM.YYYY HH:MM for the date DATE."
104   (format "%2d.%02d.%04d %2d:%02d"
105           (nth 3 date) (nth 4 date) (nth 5 date)
106           (nth 2 date) (nth 1 date)))
107
108 (defun current-date-time-filename-string (&optional num)
109   "Return the string YYYYMMDDHHMMSS[nn] for the current date-and-time.
110 If called interactively insert string at POINT"
111   (interactive)
112   (if (interactive-p)
113       (insert (date-time-filename-string (decode-time (current-time))))
114     (date-time-filename-string (decode-time (current-time)))))
115
116 (defun current-date-time-string ()
117   "Return the string DD.MM.YYYY HH:MM for the current date-and-time."
118   (interactive)
119   (if (interactive-p)
120       (insert (date-time-string (decode-time (current-time))))
121     (date-time-string (decode-time (current-time)))))
122
123 (defun template-document-name (template)
124   (if (string-match "\\.tmpl$" template)
125       (substring template 0 (match-beginning 0))
126     template))
127
128 (defun template-document-extension (template)
129   "Return the extension of TEMPLATE without the trailing .tmpl.
130 That is, if TEMPLATE is 'filename.ext.tmpl', return '.ext'. If
131 TEMPLATE does not have the '.tmpl' extension or the '.ext' part is
132 mising, return nil"
133   (if (string-match "\\.tmpl$" template)
134       (progn
135         (setq template (replace-match "" t t template))
136         (if (string-match "^.*\\." template)
137             (replace-match "" t t template)
138           nil))
139     nil))
140
141 (defun read-file-name-with-default (prompt default &optional existing)
142   "Read file name from user prompting with PROMPT. The user
143 will get DEFAULT provided as default choice"
144   (let (dir name)
145     (save-match-data
146       (if (string-match "^.*/" default)
147           (progn
148             (setq dir (match-string 0 default)
149                   name (substring default (match-end 0))))
150         (setq dir ""
151               name default)))
152     (read-file-name prompt
153                     dir
154                     default
155                     existing
156                     name)))
157
158 (defun string-replace (from to string &optional n start fixedcase literal subexp)
159   "Replate first N occurences, all if T, one if NIL of FROM in STRING
160 with TO. Returns the new string. FIXEDCASE, LITERAL and SUBEXP have
161 the same meaning as in replace-match."
162   (if (not (or (numberp n) n))
163       (setq n 1))
164   (while (and (if (numberp n) (> n 0) t)
165               (or (not start) (< start (length string)))
166               (string-match from string start))
167     (setq start (- (match-end 0) (length string))
168           string (replace-match to fixedcase literal string subexp)
169           start (+ start (length string)))
170     (if (numberp n)
171         (setq n (1- n))))
172   string)
173
174 (defun emi-split-string (string separator &optional N)
175   "Split STRING at SEPARATOR (a regex). Return list of strings. If N
176 is given, split at most that many times. The last string return will
177 contain the remaining string."
178   (let ((start 0)
179         strings)
180     (while (and (or (not N) (> N 0))
181                 (string-match separator string start))
182       (setq strings (cons (substring string start (match-beginning 0))
183                           strings)
184             start (match-end 0)
185             N (if N (- N 1))))
186     (nreverse (cons (substring string start) strings))))
187
188 (defun grep-list (func list)
189   "Create a new list from LIST keeping only elements, for which 
190 FUNC returns non-nil."
191   (if list
192       (if (funcall func (car list))
193           (cons (car list)
194                 (grep-list func (cdr list)))
195         (grep-list func (cdr list)))))
196
197 (defun grep-map-list (func list)
198   "Apply FUNC to all elements of LIST and build a new list from the
199 return values of FUNC (like mapcar) excluding all nil elements."
200   (if list
201       (let ((elem (funcall func (car list))))
202         (if elem
203             (cons elem 
204                   (grep-map-list func (cdr list)))
205           (grep-map-list func (cdr list))))))
206
207 (defun grep-map-list* (func &rest args)
208   "grep-map-list* is to grep-map-list, what emi-mapcar* is to mapcar."
209   (if (not (memq nil args))
210       (let ((elem (apply func (mapcar 'car args))))
211         (if elem
212             (cons elem
213                   (apply 'grep-map-list* func (mapcar 'cdr args)))
214           (apply 'grep-map-list* func (mapcar 'cdr args))))))
215
216 (defun hex-to-nibble (d)
217   (if (and (not (string< d "0"))
218            (or (string< d "9")
219                (string= d "9")))
220       (- (string-to-char d) ?0)
221     (+ (- (string-to-char (upcase d)) ?A) 10)))
222
223 (defun hex-to-byte (string)
224   (+ (if (> (length string) 0) (* (hex-to-nibble (substring string 0 1)) 16) 0)
225      (if (> (length string) 1) (hex-to-nibble (substring string 1 2)) 0)))
226
227 (defun nibble-to-hex (n)
228   (if (< n 10)
229       (char-to-string (+ ?0 n))
230     (char-to-string (+ ?A (- n 10)))))
231
232 (defun byte-to-hex (n)
233   (concat (nibble-to-hex (% (/ n 16) 16))
234           (nibble-to-hex (% n 16))))
235
236 (defun string-to-hexstring (value)
237   (let ((v ""))
238     (while (> (length value) 0)
239       (setq v (concat v (byte-to-hex (string-to-char value)))
240             value (substring value 1)))
241     v))
242
243 (defun hexstring-to-string (value)
244   (let ((v ""))
245     (while (> (length value) 1)
246       (setq v (concat v (char-to-string (hex-to-byte value)))
247             value (substring value 2)))
248     v))
249
250 (defun load-hook-add-or-run (feature hook-symbol hook)
251   "If FEATURE is present, immediately execute HOOK, otherwise add it to
252 HOOK-SYMBOL (preferably a load hook symbol)"
253   (if (featurep feature)
254       (funcall hook)
255     (add-hook hook-symbol hook)))
256
257 (defun query-filename-and-check (prompt &optional directory default initial)
258   "Query the user for the name of a new file. If FILENAME allready exists, 
259 query wether to overwrite it and delete the file in the affirmative case.
260 Returns the filename entered. If the user terminates the request, a quit
261 condition is generated."
262   (let* ((filename (read-file-name prompt directory default nil initial))
263          (filebuffer (find-buffer-visiting filename))
264          (fileexists (file-readable-p filename)))
265     (if (not (if (or filebuffer fileexists)
266                  (yes-or-no-p (concat "Overwrite " filename "? "))
267                t))
268         (setq quit-flag t)
269       (if fileexists (delete-file filename))
270       (if filebuffer (kill-buffer filebuffer)))
271     filename))
272
273 (defvar assign-window-buffer-window nil)
274 (defvar assign-window-buffer-buffers nil)
275 (put 'assign-window-buffer-window 'permanent-local t)
276 (put 'assign-window-buffer-buffers 'permanent-local t)
277 (make-variable-buffer-local 'assign-window-buffer-window)
278 (make-variable-buffer-local 'assign-window-buffer-buffers)
279 (put 'kill-buffer-hook 'permanent-local t)
280 (defvar assign-window-windows nil)
281 (defvar assign-window-hook-running nil)
282
283 (defun assign-window-to-buffer (buffer window &optional window-conf other-buffers)
284   "Assigns WINDOW to be fixed on displaying BUFFER. If BUFFER is
285 killed, the WINDOW is killed to. If WINDOW-CONF is given, instead of
286 killing the buffer, the WINDOW-CONFiguration is restored. If
287 OTHER-BUFFERS is given, theese buffers are killed together with
288 BUFFER, if BUFFER is killed."
289   (select-window window)
290   (switch-to-buffer buffer)
291   (setq buffer (get-buffer buffer))
292   (make-local-hook 'kill-buffer-hook)
293   (setq assign-window-buffer-window (cons window window-conf)
294         assign-window-buffer-buffers 
295         (delq buffer (mapcar (function
296                               (lambda (buffer)
297                                 (get-buffer buffer)))
298                              other-buffers)))
299   (add-hook 'kill-buffer-hook 'assign-window-to-buffer-hook t t)
300   (setq assign-window-windows (cons (cons window buffer) assign-window-windows))
301   (set-window-dedicated-p window t))
302
303 ;;;FIXME: There's an emacs bug: If the dedicated window is the
304 ;;;       right/top one of a split, killing the dedicated window will
305 ;;;       result in the combined window having the dedicated flag
306 ;;;       set. Workaround ???
307 (defun assign-window-change-hook (frame)
308   (let ((p assign-window-windows)
309         (assign-window-hook-running t)
310         last)
311     (while p
312       (if (not (window-live-p (car (car p))))
313           (progn
314             (if (buffer-live-p (cdr (car p)))
315                 (kill-buffer (cdr (car p))))
316             (if last
317                 (setcdr last (cdr p))
318               (setq assign-window-windows (cdr p)))
319             (setq p (cdr p)))
320         (setq last p
321               p (cdr p))))))
322
323 (if (not (memq 'assign-window-change-hook window-size-change-functions))
324     (setq window-size-change-functions 
325           (cons 'assign-window-change-hook window-size-change-functions)))
326
327 (defun assign-window-to-buffer-hook ()
328   (if (and (boundp 'assign-window-buffer-window)
329            (boundp 'assign-window-buffer-buffers))
330       (let ((window assign-window-buffer-window)
331             (buffers assign-window-buffer-buffers)
332             (old-assign-window-hook-running (and (boundp 'assign-window-hook-running)
333                                                  assign-window-hook-running))
334             (assign-window-hook-running t))
335         (setq assign-window-windows 
336               (delete-if (function
337                           (lambda (x) (eq (cdr x) (current-buffer))))
338                          assign-window-windows))
339         (if (window-live-p (car window))
340             (set-window-dedicated-p (car window) nil))
341         (if (cdr window)
342             (if (not old-assign-window-hook-running)
343                 (set-window-configuration (cdr window)))
344           (if (window-live-p (car window)) 
345               (delete-window (car window))))
346         (if buffers
347             (mapcar (function (lambda (buffer)
348                                 (if (buffer-live-p buffer) (kill-buffer buffer))))
349                     buffers)))))
350
351 (defun save-split-window (&optional size horizontal)
352   "Split the current window vertically, horizontally if HORIZONTAL is
353 non-nil, if the size of the current frame permits.
354
355 size is passed to split-window-[horizontally|vertically] but adjusted
356 using window-min-width or window-min-height respectively.
357
358 The selected window will be the old one, i.e. the left/top one. The
359 return value will be the new window, or nil if the window was not
360 split."
361   (if (if horizontal
362           (> (window-width) (+ (* 2 window-min-width) 2))
363         (> (window-height) (+ (* 2 window-min-height) 1)))
364       (progn
365         (if size
366             (if (< size 0)
367                 (if horizontal
368                     (setq size (- (max window-min-width (- size))))
369                   (setq size (- (max window-min-height (- size)))))
370               (if horizontal
371                   (setq size (max window-min-width size))
372                 (setq size (max window-min-height size)))))
373         (if horizontal
374             (split-window-horizontally size)
375           (split-window-vertically size)))))
376
377 (defun open-dedicated-window (buffer &optional size horizontal)
378   "Open a new window visiting BUFFER. This new window will be assign
379 to BUFFER using assign-window-to-buffer. If SIZE is given, it gives
380 the size of the new window to open. By default the current window is
381 split vertically. If HORIZONTAL is non-nil, the window is split
382 horizontally. 
383
384 If SIZE is positive, the left/top window after splitting will be the
385 new window, if SIZE is negative, the right/bottom window will be
386 used. if SIZE is not nil and not a number, the right/bottom window
387 will be used, but no explicit SIZE is requested.
388
389 The selected buffer and window will be the newly opened window with
390 it's bufer. The return value will be the window showing the buffer
391 active before calling this function. If the window could not be split,
392 because the frame is to small, BUFFER will be the selected buffer in
393 the current window and the return value is nil."
394   (let ((size (and (numberp size) size))
395         (which (if (numberp size) (< size 0) size))
396         (wc (current-window-configuration))
397         this other)
398     (if (setq other (save-split-window size horizontal))
399         (if which
400             (progn
401               (setq this other
402                     other (selected-window))
403               (select-window this))
404           (setq this (selected-window))))
405     (assign-window-to-buffer buffer (selected-window) wc)
406     other))
407
408 (defun kill-most-buffers (arg)
409   "Kill all Buffers exept those in kill-most-buffers-nokill-list.
410
411 If called with a negative prefix- argument, the current buffer will
412 not be killed. If called with a positive prefix argument only
413 non-displayed buffers are killed.
414
415 Additionally will make all windows in all frames schow the `*scratch*'
416 buffer."
417   (interactive "P")
418   (loop for buffer being the buffers
419         if (not (or (and arg
420                          (if (> (prefix-numeric-value arg) 0)
421                              (get-buffer-window buffer t)
422                            (eq buffer (current-buffer))))
423                     (member (buffer-name buffer)
424                             kill-most-buffers-nokill-list)))
425           do (kill-buffer buffer))
426   (if (get-buffer "*scratch*")
427       (kill-buffer "*scratch*"))
428   (get-buffer-create "*scratch*")
429   (if (not (and arg (> (prefix-numeric-value arg) 0)))
430       (loop for window being the windows
431             if (not (and arg (eq window (selected-window))))
432               do (set-window-buffer window "*scratch*"))))
433
434 (defmacro put-hashq (element hash)
435   "Place ELEMENT into HASH."
436   (let ((x (make-symbol "x"))
437         (y (make-symbol "y")))
438     `(let* ((,x ,element)
439             (,y (assq (car ,x) ,hash)))
440        (if ,y
441            (progn (setcdr ,y (cdr ,x)) ,y)
442          (progn (setf ,hash (cons ,x ,hash)) ,x)))))
443
444 (defmacro put-hash (element hash)
445   "Place ELEMENT into HASH."
446   (let ((x (make-symbol "x"))
447         (y (make-symbol "y")))
448     `(let* ((,x ,element)
449             (,y (assoc (car ,x) ,hash)))
450        (if ,y
451            (progn (setcdr ,y (cdr ,x)) ,y)
452          (progn (setf ,hash (cons ,x ,hash)) ,x)))))
453
454 (provide 'misc-local)