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