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)