1;;; gmm-utils.el --- Utility functions for Gnus, Message and MML 2 3;; Copyright (C) 2006, 2007 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 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 29;; dependencies on Gnus, Message, or MML. 30 31;;; Code: 32 33(require 'wid-edit) 34 35(defgroup gmm nil 36 "Utility functions for Gnus, Message and MML" 37 :prefix "gmm-" 38 :version "22.1" ;; Gnus 5.10.9 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. 45The higher the number, the more messages will flash to say what 46it done. At zero, it will be totally mute; at five, it will 47display most important messages; and at ten, it will keep on 48jabbering 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 56Guideline for numbers: 571 - error messages, 3 - non-serious error messages, 5 - messages for things 58that take a long time, 7 - not very important messages on stuff, 9 - messages 59inside 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'. 70ARGS 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 89This 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." 206 :type '(choice (const :tag "GNOME style" gnome) 207 (const :tag "Retro look" retro)) 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 216Within each entry of ICON-LIST, the first element is a menu 217command, the second element is an icon file name and the third 218element is a test function. You can use \\[describe-key] 219<menu-entry> to find out the name of a menu command. The fourth 220and all following elements are passed as the PROPS argument to the 221function `tool-bar-local-item'. 222 223If 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 225can use \\[describe-key] <icon> to find out the name of an icon 226item. When \\[describe-key] <icon> shows \"<tool-bar> <new-file> 227runs the command find-file\", then use `new-file' in ZAP-LIST. 228 229DEFAULT-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 282(defmacro defun-gmm (name function arg-list &rest body) 283 "Create function NAME. 284If FUNCTION exists, then NAME becomes an alias for FUNCTION. 285Otherwise, 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 291(defun-gmm gmm-image-search-load-path 292 image-search-load-path (file &optional path) 293 "Emacs 21 and XEmacs don't have `image-search-load-path'. 294This function returns nil on those systems." 295 nil) 296 297;; Cf. `mh-image-load-path-for-library' in `mh-compat.el'. 298 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. 302 303It searches for IMAGE in `image-load-path' (excluding 304\"`data-directory'/images\") and `load-path', followed by a path 305suitable for LIBRARY, which includes \"../../etc/images\" and 306\"../etc/images\" relative to the library file itself, and then 307in \"`data-directory'/images\". 308 309Then this function returns a list of directories which contains 310first the directory in which IMAGE was found, followed by the 311value of `load-path'. If PATH is given, it is used instead of 312`load-path'. 313 314If NO-ERROR is non-nil and a suitable path can't be found, don't 315signal an error. Instead, return a list of directories as before, 316except that nil appears in place of the image directory. 317 318Here is an example that uses a common idiom to provide 319compatibility 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. 396If 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 404(defun gmm-write-region (start end filename &optional append visit 405 lockname mustbenew) 406 "Compatibility function for `write-region'. 407 408In XEmacs, the seventh argument of `write-region' specifies the 409coding-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 419(provide 'gmm-utils) 420 421;; arch-tag: e0b60920-2ce6-40c1-bfc0-cadbbe26b602 422;;; gmm-utils.el ends here 423