From 00e3289bc5ff11fb4d992748321934644b373663 Mon Sep 17 00:00:00 2001 From: Reiner Steib Date: Fri, 20 Jan 2006 20:52:52 +0000 Subject: [PATCH] New file. (gmm-verbose, gmm-message, gmm-error): From gnus-utils.el. (gmm-lazy): New widget copied from `nnmail.el'. (gmm-tool-bar-from-list): New function for creating customizable tool bars. gmm-utils.el (gmm-widget-p): New function. --- lisp/ChangeLog | 12 +++ lisp/gmm-utils.el | 195 ++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 207 insertions(+) create mode 100644 lisp/gmm-utils.el diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 416f9512b..c0632b009 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,15 @@ +2006-01-20 Reiner Steib + + * gmm-utils.el: New file. + (gmm-verbose, gmm-message, gmm-error): From gnus-utils.el. + (gmm-lazy): New widget copied from `nnmail.el'. + (gmm-tool-bar-from-list): New function for creating customizable + tool bars. + +2006-01-20 Per Abrahamsen + + * gmm-utils.el (gmm-widget-p): New function. + 2006-01-20 Reiner Steib * mml.el (mml-attach-file): Describe `description' in doc string. diff --git a/lisp/gmm-utils.el b/lisp/gmm-utils.el new file mode 100644 index 000000000..8c15075d5 --- /dev/null +++ b/lisp/gmm-utils.el @@ -0,0 +1,195 @@ +;;; gmm-utils.el --- Utility functions for Gnus, Message and MML + +;; Copyright (C) 2006 Free Software Foundation, Inc. + +;; Author: Reiner Steib +;; Keywords: news + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; Commentary: + +;; This library provides self-contained utility functions. The functions are +;; used in Gnus, Message and MML, but within this library there are no +;; dependencies on Gnus, Message, or MML or Gnus. + +;;; Code: + +(defgroup gmm nil + "Utility functions for Gnus, Message and MML" + :group 'lisp) + +;; Helper functions from `gnus-utils.el': gmm-verbose, gmm-message, gmm-error + +(defcustom gmm-verbose 7 + "Integer that says how verbose gmm should be. +The higher the number, the more messages will flash to say what +it done. At zero, it will be totally mute; at five, it will +display most important messages; and at ten, it will keep on +jabbering all the time." + :type 'integer) + +;;;###autoload +(defun gmm-message (level &rest args) + "If LEVEL is lower than `gmm-verbose' print ARGS using `message'. + +Guideline for numbers: +1 - error messages, 3 - non-serious error messages, 5 - messages for things +that take a long time, 7 - not very important messages on stuff, 9 - messages +inside loops." + (if (<= level gmm-verbose) + (apply 'message args) + ;; We have to do this format thingy here even if the result isn't + ;; shown - the return value has to be the same as the return value + ;; from `message'. + (apply 'format args))) + +;;;###autoload +(defun gmm-error (level &rest args) + "Beep an error if LEVEL is equal to or less than `gmm-verbose'." + (when (<= (floor level) gmm-verbose) + (apply 'message args) + (ding) + (let (duration) + (when (and (floatp level) + (not (zerop (setq duration (* 10 (- level (floor level))))))) + (sit-for duration)))) + nil) + +;;;###autoload +(defun gmm-widget-p (symbol) + "Non-nil iff SYMBOL is a widget." + (get symbol 'widget-type)) + +;; Copy of the `nnmail-lazy' code from `nnmail.el': +(define-widget 'gmm-lazy 'default + "Base widget for recursive datastructures. + +This is copy of the `lazy' widget in Emacs 22.1 provided for compatibility." + :format "%{%t%}: %v" + :convert-widget 'widget-value-convert-widget + :value-create (lambda (widget) + (let ((value (widget-get widget :value)) + (type (widget-get widget :type))) + (widget-put widget :children + (list (widget-create-child-value + widget (widget-convert type) value))))) + :value-delete 'widget-children-value-delete + :value-get (lambda (widget) + (widget-value (car (widget-get widget :children)))) + :value-inline (lambda (widget) + (widget-apply (car (widget-get widget :children)) + :value-inline)) + :default-get (lambda (widget) + (widget-default-get + (widget-convert (widget-get widget :type)))) + :match (lambda (widget value) + (widget-apply (widget-convert (widget-get widget :type)) + :match value)) + :validate (lambda (widget) + (widget-apply (car (widget-get widget :children)) :validate))) + +;; Note: The format of `gmm-tool-bar-item' may change if some future Emacs +;; version will provide customizable tool bar buttons using a different +;; interface. + +;;;###autoload +(define-widget 'gmm-tool-bar-item (if (gmm-widget-p 'lazy) 'lazy 'gmm-lazy) + "Tool bar list item." + :tag "Tool bar item" + :type '(list (function :tag "Menu Command") + (string :tag "Icon file") + (choice (const :tag "Default map" nil) + ;; Note: Usually we need non-nil attributes if map is + ;; t. + (const :tag "No menu" t) + (sexp :tag "Other map")) + (plist :inline t :tag "Properties"))) + +(defvar tool-bar-map) + +;;;###autoload +(defun gmm-tool-bar-from-list (icon-list zap-list default-map) + "Make a tool bar from ICON-LIST. + +Withing each entry of ICON-LIST, the first element is a menu +command, the second element is an icon file name and the third +element is a test function. You can use \\[describe-key] + to find out the name of a menu command. The forth +and all following elements are passed a the PROPS argument to the +function `tool-bar-local-item'. + +If ZAP-LIST is a list, remove those item from the default +`tool-bar-map'. If it is t, start with a new sparse map. + +DEFAULT-MAP specifies the default key map for ICON-LIST." + (let (;; For Emacs 21, we must let-bind `tool-bar-map'. In Emacs 22, we + ;; could use some other local variable. + (tool-bar-map (if (eq zap-list t) + (make-sparse-keymap) + (copy-keymap tool-bar-map)))) + (when (listp zap-list) + ;; Zap some items which aren't relevant for this mode and take up space. + (dolist (key zap-list) + (define-key tool-bar-map (vector key) nil))) + (mapc (lambda (el) + (let ((command (car el)) + (icon (nth 1 el)) + (fmap (or (nth 2 el) default-map)) + (props (cdr (cdr (cdr el)))) ) + (if props (gmm-message 9 "props=`%s'" props)) + ;; command may stem from different from-maps: + (cond ((eq command 'ignore) + ;; FIXME: How to get no tool tip at all? + (if (fboundp 'tool-bar-local-item) + (apply 'tool-bar-local-item icon nil nil + tool-bar-map props) + ;; (tool-bar-local-item ICON DEF KEY MAP &rest PROPS) + ;; (tool-bar-add-item ICON DEF KEY &rest PROPS) + (apply 'tool-bar-add-item icon nil nil props))) + ((equal fmap t) ;; Not a menu command + (if (fboundp 'tool-bar-local-item) + (apply 'tool-bar-local-item + icon command + (intern icon) ;; reuse icon or fmap here? + tool-bar-map props) + ;; Emacs 21 compatibility: + (apply 'tool-bar-add-item + icon command + (intern icon) + props))) + (t ;; A menu command + (if (fboundp 'tool-bar-local-item-from-menu) + (apply 'tool-bar-local-item-from-menu + ;; (apply 'tool-bar-local-item icon def key + ;; tool-bar-map props) + command icon tool-bar-map (symbol-value fmap) + props) + ;; Emacs 21 compatibility: + (apply 'tool-bar-add-item-from-menu + command icon (symbol-value fmap) + props)))) + t)) + (if (symbolp icon-list) + (eval icon-list) + icon-list)) + tool-bar-map)) + +(provide 'gmm-utils) + +;;; gmm-utils.el ends here -- 2.25.1