Commit | Line | Data |
---|---|---|
18c06a99 RS |
1 | ;;; gmm-utils.el --- Utility functions for Gnus, Message and MML |
2 | ||
44e97401 | 3 | ;; Copyright (C) 2006-2012 Free Software Foundation, Inc. |
18c06a99 RS |
4 | |
5 | ;; Author: Reiner Steib <reiner.steib@gmx.de> | |
6 | ;; Keywords: news | |
7 | ||
8 | ;; This file is part of GNU Emacs. | |
9 | ||
5e809f55 | 10 | ;; GNU Emacs is free software: you can redistribute it and/or modify |
18c06a99 | 11 | ;; it under the terms of the GNU General Public License as published by |
5e809f55 GM |
12 | ;; the Free Software Foundation, either version 3 of the License, or |
13 | ;; (at your option) any later version. | |
18c06a99 RS |
14 | |
15 | ;; GNU Emacs is distributed in the hope that it will be useful, | |
16 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
5e809f55 | 17 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
18c06a99 RS |
18 | ;; GNU General Public License for more details. |
19 | ||
20 | ;; You should have received a copy of the GNU General Public License | |
5e809f55 | 21 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. |
18c06a99 RS |
22 | |
23 | ;;; Commentary: | |
24 | ||
25 | ;; This library provides self-contained utility functions. The functions are | |
26 | ;; used in Gnus, Message and MML, but within this library there are no | |
8aed9ac5 | 27 | ;; dependencies on Gnus, Message, or MML. |
18c06a99 RS |
28 | |
29 | ;;; Code: | |
30 | ||
18c06a99 | 31 | (defgroup gmm nil |
bed8ad40 | 32 | "Utility functions for Gnus, Message and MML." |
18c06a99 | 33 | :prefix "gmm-" |
67099291 | 34 | :version "22.1" ;; Gnus 5.10.9 |
18c06a99 RS |
35 | :group 'lisp) |
36 | ||
37 | ;; Helper functions from `gnus-utils.el': gmm-verbose, gmm-message, gmm-error | |
38 | ||
39 | (defcustom gmm-verbose 7 | |
40 | "Integer that says how verbose gmm should be. | |
41 | The higher the number, the more messages will flash to say what | |
bed8ad40 | 42 | it did. At zero, it will be totally mute; at five, it will |
18c06a99 RS |
43 | display most important messages; and at ten, it will keep on |
44 | jabbering all the time." | |
45 | :type 'integer | |
46 | :group 'gmm) | |
47 | ||
01c52d31 MB |
48 | ;;;###autoload |
49 | (defun gmm-regexp-concat (regexp) | |
50 | "Potentially concat a list of regexps into a single one. | |
51 | The concatenation is done with logical ORs." | |
52 | (cond ((null regexp) | |
53 | nil) | |
54 | ((stringp regexp) | |
55 | regexp) | |
56 | ((listp regexp) | |
57 | (mapconcat (lambda (elt) (concat "\\(" elt "\\)")) | |
58 | regexp | |
59 | "\\|")))) | |
60 | ||
18c06a99 RS |
61 | ;;;###autoload |
62 | (defun gmm-message (level &rest args) | |
63 | "If LEVEL is lower than `gmm-verbose' print ARGS using `message'. | |
64 | ||
65 | Guideline for numbers: | |
bed8ad40 JB |
66 | 1 - error messages |
67 | 3 - non-serious error messages | |
68 | 5 - messages for things that take a long time | |
69 | 7 - not very important messages on stuff | |
70 | 9 - messages inside loops." | |
18c06a99 RS |
71 | (if (<= level gmm-verbose) |
72 | (apply 'message args) | |
73 | ;; We have to do this format thingy here even if the result isn't | |
74 | ;; shown - the return value has to be the same as the return value | |
75 | ;; from `message'. | |
76 | (apply 'format args))) | |
77 | ||
78 | ;;;###autoload | |
79 | (defun gmm-error (level &rest args) | |
80 | "Beep an error if LEVEL is equal to or less than `gmm-verbose'. | |
81 | ARGS are passed to `message'." | |
82 | (when (<= (floor level) gmm-verbose) | |
83 | (apply 'message args) | |
84 | (ding) | |
85 | (let (duration) | |
86 | (when (and (floatp level) | |
87 | (not (zerop (setq duration (* 10 (- level (floor level))))))) | |
88 | (sit-for duration)))) | |
89 | nil) | |
90 | ||
91 | ;;;###autoload | |
92 | (defun gmm-widget-p (symbol) | |
e7f767c2 | 93 | "Non-nil if SYMBOL is a widget." |
18c06a99 RS |
94 | (get symbol 'widget-type)) |
95 | ||
aa8f8277 GM |
96 | (autoload 'widget-create-child-value "wid-edit") |
97 | (autoload 'widget-convert "wid-edit") | |
98 | (autoload 'widget-default-get "wid-edit") | |
99 | ||
18c06a99 RS |
100 | ;; Copy of the `nnmail-lazy' code from `nnmail.el': |
101 | (define-widget 'gmm-lazy 'default | |
102 | "Base widget for recursive datastructures. | |
103 | ||
bed8ad40 | 104 | This is a copy of the `lazy' widget in Emacs 22.1 provided for compatibility." |
18c06a99 RS |
105 | :format "%{%t%}: %v" |
106 | :convert-widget 'widget-value-convert-widget | |
107 | :value-create (lambda (widget) | |
108 | (let ((value (widget-get widget :value)) | |
109 | (type (widget-get widget :type))) | |
110 | (widget-put widget :children | |
111 | (list (widget-create-child-value | |
112 | widget (widget-convert type) value))))) | |
113 | :value-delete 'widget-children-value-delete | |
114 | :value-get (lambda (widget) | |
115 | (widget-value (car (widget-get widget :children)))) | |
116 | :value-inline (lambda (widget) | |
117 | (widget-apply (car (widget-get widget :children)) | |
118 | :value-inline)) | |
119 | :default-get (lambda (widget) | |
120 | (widget-default-get | |
121 | (widget-convert (widget-get widget :type)))) | |
122 | :match (lambda (widget value) | |
123 | (widget-apply (widget-convert (widget-get widget :type)) | |
124 | :match value)) | |
125 | :validate (lambda (widget) | |
126 | (widget-apply (car (widget-get widget :children)) :validate))) | |
127 | ||
128 | ;; Note: The format of `gmm-tool-bar-item' may change if some future Emacs | |
129 | ;; version will provide customizable tool bar buttons using a different | |
130 | ;; interface. | |
131 | ||
132 | ;; TODO: Extend API so that the "Command" entry can be a function or a plist. | |
133 | ;; In case of a list it should have the format... | |
134 | ;; | |
135 | ;; (:none command-without-modifier | |
136 | ;; :shift command-with-shift-pressed | |
137 | ;; :control command-with-ctrl-pressed | |
138 | ;; :control-shift command-with-control-and-shift-pressed | |
139 | ;; ;; mouse-2 and mouse-3 can't be used in Emacs yet. | |
140 | ;; :mouse-2 command-on-mouse-2-press | |
141 | ;; :mouse-3 command-on-mouse-3-press) ;; typically a menu of related commands | |
142 | ;; | |
da6062e6 | 143 | ;; Combinations of mouse-[23] plus shift and/or control might be overkill. |
18c06a99 RS |
144 | ;; |
145 | ;; Then use (plist-get rs-command :none), (plist-get rs-command :shift) | |
146 | ||
147 | (define-widget 'gmm-tool-bar-item (if (gmm-widget-p 'lazy) 'lazy 'gmm-lazy) | |
148 | "Tool bar list item." | |
149 | :tag "Tool bar item" | |
150 | :type '(choice | |
151 | (list :tag "Command and Icon" | |
152 | (function :tag "Command") | |
153 | (string :tag "Icon file") | |
154 | (choice | |
155 | (const :tag "Default map" nil) | |
156 | ;; Note: Usually we need non-nil attributes if map is t. | |
157 | (const :tag "No menu" t) | |
158 | (sexp :tag "Other map")) | |
159 | (plist :inline t :tag "Properties")) | |
160 | (list :tag "Separator" | |
161 | (const :tag "No command" gmm-ignore) | |
162 | (string :tag "Icon file") | |
163 | (const :tag "No map") | |
164 | (plist :inline t :tag "Properties")))) | |
165 | ||
166 | (define-widget 'gmm-tool-bar-zap-list (if (gmm-widget-p 'lazy) 'lazy 'gmm-lazy) | |
167 | "Tool bar zap list." | |
168 | :tag "Tool bar zap list" | |
169 | :type '(choice (const :tag "Zap all" t) | |
170 | (const :tag "Keep all" nil) | |
171 | (list | |
172 | ;; :value | |
173 | ;; Work around (bug in customize?), see | |
174 | ;; <news:v9is48jrj1.fsf@marauder.physik.uni-ulm.de> | |
175 | ;; (new-file open-file dired kill-buffer write-file | |
176 | ;; print-buffer customize help) | |
177 | (set :inline t | |
178 | (const new-file) | |
179 | (const open-file) | |
180 | (const dired) | |
181 | (const kill-buffer) | |
182 | (const save-buffer) | |
183 | (const write-file) | |
184 | (const undo) | |
185 | (const cut) | |
186 | (const copy) | |
187 | (const paste) | |
188 | (const search-forward) | |
189 | (const print-buffer) | |
190 | (const customize) | |
191 | (const help)) | |
192 | (repeat :inline t | |
193 | :tag "Other" | |
194 | (symbol :tag "Icon item"))))) | |
195 | ||
196 | ;; (defun gmm-color-cells (&optional display) | |
197 | ;; "Return the number of color cells supported by DISPLAY. | |
198 | ;; Compatibility function." | |
199 | ;; ;; `display-color-cells' doesn't return more than 256 even if color depth is | |
200 | ;; ;; > 8 in Emacs 21. | |
201 | ;; ;; | |
202 | ;; ;; Feel free to add proper XEmacs support. | |
203 | ;; (let* ((cells (and (fboundp 'display-color-cells) | |
204 | ;; (display-color-cells display))) | |
205 | ;; (plane (and (fboundp 'x-display-planes) | |
206 | ;; (ash 1 (x-display-planes)))) | |
207 | ;; (none -1)) | |
208 | ;; (max (if (integerp cells) cells none) | |
209 | ;; (if (integerp plane) plane none)))) | |
210 | ||
211 | (defcustom gmm-tool-bar-style | |
212 | (if (and (boundp 'tool-bar-mode) | |
213 | tool-bar-mode | |
214 | (and (fboundp 'display-visual-class) | |
215 | (not (memq (display-visual-class) | |
216 | (list 'static-gray 'gray-scale | |
217 | 'static-color 'pseudo-color))))) | |
218 | 'gnome | |
219 | 'retro) | |
e4920bc9 | 220 | "Preferred tool bar style." |
ba361211 MB |
221 | :type '(choice (const :tag "GNOME style" gnome) |
222 | (const :tag "Retro look" retro)) | |
18c06a99 RS |
223 | :group 'gmm) |
224 | ||
225 | (defvar tool-bar-map) | |
226 | ||
227 | ;;;###autoload | |
228 | (defun gmm-tool-bar-from-list (icon-list zap-list default-map) | |
229 | "Make a tool bar from ICON-LIST. | |
230 | ||
231 | Within each entry of ICON-LIST, the first element is a menu | |
232 | command, the second element is an icon file name and the third | |
233 | element is a test function. You can use \\[describe-key] | |
234 | <menu-entry> to find out the name of a menu command. The fourth | |
8aed9ac5 | 235 | and all following elements are passed as the PROPS argument to the |
18c06a99 RS |
236 | function `tool-bar-local-item'. |
237 | ||
238 | If ZAP-LIST is a list, remove those item from the default | |
239 | `tool-bar-map'. If it is t, start with a new sparse map. You | |
240 | can use \\[describe-key] <icon> to find out the name of an icon | |
241 | item. When \\[describe-key] <icon> shows \"<tool-bar> <new-file> | |
242 | runs the command find-file\", then use `new-file' in ZAP-LIST. | |
243 | ||
244 | DEFAULT-MAP specifies the default key map for ICON-LIST." | |
245 | (let (;; For Emacs 21, we must let-bind `tool-bar-map'. In Emacs 22, we | |
246 | ;; could use some other local variable. | |
247 | (tool-bar-map (if (eq zap-list t) | |
248 | (make-sparse-keymap) | |
249 | (copy-keymap tool-bar-map)))) | |
250 | (when (listp zap-list) | |
251 | ;; Zap some items which aren't relevant for this mode and take up space. | |
252 | (dolist (key zap-list) | |
253 | (define-key tool-bar-map (vector key) nil))) | |
254 | (mapc (lambda (el) | |
255 | (let ((command (car el)) | |
256 | (icon (nth 1 el)) | |
257 | (fmap (or (nth 2 el) default-map)) | |
258 | (props (cdr (cdr (cdr el)))) ) | |
259 | ;; command may stem from different from-maps: | |
260 | (cond ((eq command 'gmm-ignore) | |
261 | ;; The dummy `gmm-ignore', see `gmm-tool-bar-item' | |
262 | ;; widget. Suppress tooltip by adding `:enable nil'. | |
263 | (if (fboundp 'tool-bar-local-item) | |
264 | (apply 'tool-bar-local-item icon nil nil | |
265 | tool-bar-map :enable nil props) | |
266 | ;; (tool-bar-local-item ICON DEF KEY MAP &rest PROPS) | |
267 | ;; (tool-bar-add-item ICON DEF KEY &rest PROPS) | |
268 | (apply 'tool-bar-add-item icon nil nil :enable nil props))) | |
269 | ((equal fmap t) ;; Not a menu command | |
5843126b KY |
270 | (apply 'tool-bar-local-item |
271 | icon command | |
272 | (intern icon) ;; reuse icon or fmap here? | |
273 | tool-bar-map props)) | |
18c06a99 | 274 | (t ;; A menu command |
5843126b KY |
275 | (apply 'tool-bar-local-item-from-menu |
276 | ;; (apply 'tool-bar-local-item icon def key | |
277 | ;; tool-bar-map props) | |
278 | command icon tool-bar-map (symbol-value fmap) | |
279 | props))) | |
18c06a99 RS |
280 | t)) |
281 | (if (symbolp icon-list) | |
282 | (eval icon-list) | |
283 | icon-list)) | |
284 | tool-bar-map)) | |
285 | ||
d7ba2a01 | 286 | (defmacro defun-gmm (name function arg-list &rest body) |
18c06a99 RS |
287 | "Create function NAME. |
288 | If FUNCTION exists, then NAME becomes an alias for FUNCTION. | |
289 | Otherwise, create function NAME with ARG-LIST and BODY." | |
290 | (let ((defined-p (fboundp function))) | |
291 | (if defined-p | |
292 | `(defalias ',name ',function) | |
293 | `(defun ,name ,arg-list ,@body)))) | |
294 | ||
d7ba2a01 | 295 | (defun-gmm gmm-image-search-load-path |
18c06a99 RS |
296 | image-search-load-path (file &optional path) |
297 | "Emacs 21 and XEmacs don't have `image-search-load-path'. | |
298 | This function returns nil on those systems." | |
299 | nil) | |
300 | ||
d7ba2a01 | 301 | ;; Cf. `mh-image-load-path-for-library' in `mh-compat.el'. |
18c06a99 | 302 | |
d7ba2a01 RS |
303 | (defun-gmm gmm-image-load-path-for-library |
304 | image-load-path-for-library (library image &optional path no-error) | |
305 | "Return a suitable search path for images used by LIBRARY. | |
18c06a99 | 306 | |
d7ba2a01 | 307 | It searches for IMAGE in `image-load-path' (excluding |
18c06a99 RS |
308 | \"`data-directory'/images\") and `load-path', followed by a path |
309 | suitable for LIBRARY, which includes \"../../etc/images\" and | |
310 | \"../etc/images\" relative to the library file itself, and then | |
311 | in \"`data-directory'/images\". | |
312 | ||
313 | Then this function returns a list of directories which contains | |
314 | first the directory in which IMAGE was found, followed by the | |
bed8ad40 | 315 | value of `load-path'. If PATH is given, it is used instead of |
18c06a99 RS |
316 | `load-path'. |
317 | ||
318 | If NO-ERROR is non-nil and a suitable path can't be found, don't | |
bed8ad40 | 319 | signal an error. Instead, return a list of directories as before, |
18c06a99 RS |
320 | except that nil appears in place of the image directory. |
321 | ||
322 | Here is an example that uses a common idiom to provide | |
323 | compatibility with versions of Emacs that lack the variable | |
324 | `image-load-path': | |
325 | ||
326 | ;; Shush compiler. | |
327 | (defvar image-load-path) | |
328 | ||
329 | (let* ((load-path (image-load-path-for-library \"mh-e\" \"mh-logo.xpm\")) | |
330 | (image-load-path (cons (car load-path) | |
331 | (when (boundp 'image-load-path) | |
332 | image-load-path)))) | |
333 | (mh-tool-bar-folder-buttons-init))" | |
334 | (unless library (error "No library specified")) | |
335 | (unless image (error "No image specified")) | |
336 | (let (image-directory image-directory-load-path) | |
337 | ;; Check for images in image-load-path or load-path. | |
338 | (let ((img image) | |
339 | (dir (or | |
340 | ;; Images in image-load-path. | |
341 | (gmm-image-search-load-path image) ;; "gmm-" prefix! | |
342 | ;; Images in load-path. | |
343 | (locate-library image))) | |
344 | parent) | |
345 | ;; Since the image might be in a nested directory (for | |
346 | ;; example, mail/attach.pbm), adjust `image-directory' | |
347 | ;; accordingly. | |
348 | (when dir | |
349 | (setq dir (file-name-directory dir)) | |
350 | (while (setq parent (file-name-directory img)) | |
351 | (setq img (directory-file-name parent) | |
352 | dir (expand-file-name "../" dir)))) | |
353 | (setq image-directory-load-path dir)) | |
354 | ||
44e97401 | 355 | ;; If `image-directory-load-path' isn't Emacs's image directory, |
bed8ad40 | 356 | ;; it's probably a user preference, so use it. Then use a |
18c06a99 RS |
357 | ;; relative setting if possible; otherwise, use |
358 | ;; `image-directory-load-path'. | |
359 | (cond | |
360 | ;; User-modified image-load-path? | |
361 | ((and image-directory-load-path | |
362 | (not (equal image-directory-load-path | |
363 | (file-name-as-directory | |
364 | (expand-file-name "images" data-directory))))) | |
365 | (setq image-directory image-directory-load-path)) | |
366 | ;; Try relative setting. | |
367 | ((let (library-name d1ei d2ei) | |
368 | ;; First, find library in the load-path. | |
369 | (setq library-name (locate-library library)) | |
370 | (if (not library-name) | |
371 | (error "Cannot find library %s in load-path" library)) | |
372 | ;; And then set image-directory relative to that. | |
373 | (setq | |
374 | ;; Go down 2 levels. | |
375 | d2ei (file-name-as-directory | |
376 | (expand-file-name | |
377 | (concat (file-name-directory library-name) "../../etc/images"))) | |
378 | ;; Go down 1 level. | |
379 | d1ei (file-name-as-directory | |
380 | (expand-file-name | |
381 | (concat (file-name-directory library-name) "../etc/images")))) | |
382 | (setq image-directory | |
383 | ;; Set it to nil if image is not found. | |
384 | (cond ((file-exists-p (expand-file-name image d2ei)) d2ei) | |
385 | ((file-exists-p (expand-file-name image d1ei)) d1ei))))) | |
44e97401 | 386 | ;; Use Emacs's image directory. |
18c06a99 RS |
387 | (image-directory-load-path |
388 | (setq image-directory image-directory-load-path)) | |
389 | (no-error | |
390 | (message "Could not find image %s for library %s" image library)) | |
391 | (t | |
392 | (error "Could not find image %s for library %s" image library))) | |
393 | ||
394 | ;; Return an augmented `path' or `load-path'. | |
395 | (nconc (list image-directory) | |
396 | (delete image-directory (copy-sequence (or path load-path)))))) | |
397 | ||
398 | (defun gmm-customize-mode (&optional mode) | |
399 | "Customize customization group for MODE. | |
bed8ad40 | 400 | If mode is nil, use `major-mode' of the current buffer." |
18c06a99 RS |
401 | (interactive) |
402 | (customize-group | |
403 | (or mode | |
404 | (intern (let ((mode (symbol-name major-mode))) | |
405 | (string-match "^\\(.+\\)-mode$" mode) | |
406 | (match-string 1 mode)))))) | |
407 | ||
92edaeed MB |
408 | (defun gmm-write-region (start end filename &optional append visit |
409 | lockname mustbenew) | |
410 | "Compatibility function for `write-region'. | |
411 | ||
412 | In XEmacs, the seventh argument of `write-region' specifies the | |
413 | coding-system." | |
4ec3f7cf | 414 | (if (and mustbenew (featurep 'xemacs)) |
92edaeed | 415 | (if (file-exists-p filename) |
4ec3f7cf | 416 | (signal 'file-already-exists (list "File exists" filename)) |
92edaeed MB |
417 | (write-region start end filename append visit lockname)) |
418 | (write-region start end filename append visit lockname mustbenew))) | |
419 | ||
ad6fe94d | 420 | ;; `flet' and `labels' are obsolete since Emacs 24.3. |
066f0e09 KY |
421 | (defmacro gmm-flet (bindings &rest body) |
422 | "Make temporary overriding function definitions. | |
423 | This is an analogue of a dynamically scoped `let' that operates on | |
424 | the function cell of FUNCs rather than their value cell. | |
425 | ||
426 | \(fn ((FUNC ARGLIST BODY...) ...) FORM...)" | |
427 | (require 'cl) | |
428 | (if (fboundp 'cl-letf) | |
429 | `(cl-letf ,(mapcar (lambda (binding) | |
430 | `((symbol-function ',(car binding)) | |
431 | (lambda ,@(cdr binding)))) | |
432 | bindings) | |
433 | ,@body) | |
434 | `(flet ,bindings ,@body))) | |
435 | (put 'gmm-flet 'lisp-indent-function 1) | |
436 | ||
46a2cc44 KY |
437 | (defmacro gmm-labels (bindings &rest body) |
438 | "Make temporary function bindings. | |
f2484dff KY |
439 | The bindings can be recursive and the scoping is lexical, but capturing |
440 | them in closures will only work if `lexical-binding' is in use. But in | |
441 | Emacs 24.2 and older, the lexical scoping is handled via `lexical-let' | |
442 | rather than relying on `lexical-binding'. | |
46a2cc44 KY |
443 | |
444 | \(fn ((FUNC ARGLIST BODY...) ...) FORM...)" | |
68c2d59d KY |
445 | `(,(progn (require 'cl) (if (fboundp 'cl-labels) 'cl-labels 'labels)) |
446 | ,bindings ,@body)) | |
46a2cc44 KY |
447 | (put 'gmm-labels 'lisp-indent-function 1) |
448 | ||
18c06a99 RS |
449 | (provide 'gmm-utils) |
450 | ||
18c06a99 | 451 | ;;; gmm-utils.el ends here |