| 1 | ;;; gmm-utils.el --- Utility functions for Gnus, Message and MML |
| 2 | |
| 3 | ;; Copyright (C) 2006-2012 Free Software Foundation, Inc. |
| 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 3 of the License, or |
| 13 | ;; (at your option) 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. If not, see <http://www.gnu.org/licenses/>. |
| 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 |
| 27 | ;; dependencies on Gnus, Message, or MML. |
| 28 | |
| 29 | ;;; Code: |
| 30 | |
| 31 | (defgroup gmm nil |
| 32 | "Utility functions for Gnus, Message and MML." |
| 33 | :prefix "gmm-" |
| 34 | :version "22.1" ;; Gnus 5.10.9 |
| 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 |
| 42 | it did. At zero, it will be totally mute; at five, it will |
| 43 | display most important messages; and at ten, it will keep on |
| 44 | jabbering all the time." |
| 45 | :type 'integer |
| 46 | :group 'gmm) |
| 47 | |
| 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 | |
| 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: |
| 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." |
| 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) |
| 93 | "Non-nil if SYMBOL is a widget." |
| 94 | (get symbol 'widget-type)) |
| 95 | |
| 96 | (autoload 'widget-create-child-value "wid-edit") |
| 97 | (autoload 'widget-convert "wid-edit") |
| 98 | (autoload 'widget-default-get "wid-edit") |
| 99 | |
| 100 | ;; Copy of the `nnmail-lazy' code from `nnmail.el': |
| 101 | (define-widget 'gmm-lazy 'default |
| 102 | "Base widget for recursive datastructures. |
| 103 | |
| 104 | This is a copy of the `lazy' widget in Emacs 22.1 provided for compatibility." |
| 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 | ;; |
| 143 | ;; Combinations of mouse-[23] plus shift and/or control might be overkill. |
| 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) |
| 220 | "Preferred tool bar style." |
| 221 | :type '(choice (const :tag "GNOME style" gnome) |
| 222 | (const :tag "Retro look" retro)) |
| 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 |
| 235 | and all following elements are passed as the PROPS argument to the |
| 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 |
| 270 | (apply 'tool-bar-local-item |
| 271 | icon command |
| 272 | (intern icon) ;; reuse icon or fmap here? |
| 273 | tool-bar-map props)) |
| 274 | (t ;; A menu command |
| 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))) |
| 280 | t)) |
| 281 | (if (symbolp icon-list) |
| 282 | (eval icon-list) |
| 283 | icon-list)) |
| 284 | tool-bar-map)) |
| 285 | |
| 286 | (defmacro defun-gmm (name function arg-list &rest body) |
| 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 | |
| 295 | (defun-gmm gmm-image-search-load-path |
| 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 | |
| 301 | ;; Cf. `mh-image-load-path-for-library' in `mh-compat.el'. |
| 302 | |
| 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. |
| 306 | |
| 307 | It searches for IMAGE in `image-load-path' (excluding |
| 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 |
| 315 | value of `load-path'. If PATH is given, it is used instead of |
| 316 | `load-path'. |
| 317 | |
| 318 | If NO-ERROR is non-nil and a suitable path can't be found, don't |
| 319 | signal an error. Instead, return a list of directories as before, |
| 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 | |
| 355 | ;; If `image-directory-load-path' isn't Emacs's image directory, |
| 356 | ;; it's probably a user preference, so use it. Then use a |
| 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))))) |
| 386 | ;; Use Emacs's image directory. |
| 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. |
| 400 | If mode is nil, use `major-mode' of the current buffer." |
| 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 | |
| 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." |
| 414 | (if (and mustbenew (featurep 'xemacs)) |
| 415 | (if (file-exists-p filename) |
| 416 | (signal 'file-already-exists (list "File exists" filename)) |
| 417 | (write-region start end filename append visit lockname)) |
| 418 | (write-region start end filename append visit lockname mustbenew))) |
| 419 | |
| 420 | (provide 'gmm-utils) |
| 421 | |
| 422 | ;;; gmm-utils.el ends here |