cgit.sxemacs.org Git - gnus/blob - lisp/message-xmas.el

   1 ;;; message-xmas.el --- XEmacs extensions to message
   2 ;; Copyright (C) 1996 Free Software Foundation, Inc.
   3
   4 ;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
   5 ;; Keywords: mail, news
   6
   7 ;; This file is part of GNU Emacs.
   8
   9 ;; GNU Emacs is free software; you can redistribute it and/or modify
  10 ;; it under the terms of the GNU General Public License as published by
  11 ;; the Free Software Foundation; either version 2, or (at your option)
  12 ;; any later version.
  13
  14 ;; GNU Emacs is distributed in the hope that it will be useful,
  15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;; GNU General Public License for more details.
  18
  19 ;; You should have received a copy of the GNU General Public License
  20 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  21 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  22 ;; Boston, MA 02111-1307, USA.
  23
  24 ;;; Commentary:
  25
  26 ;;; Code:
  27
  28 (defvar message-xmas-glyph-directory nil
  29   "*Directory where Message logos and icons are located.
  30 If this variable is nil, Message will try to locate the directory
  31 automatically.")
  32
  33 (defvar message-use-toolbar 'default-toolbar
  34   "*If nil, do not use a toolbar.
  35 If it is non-nil, it must be a toolbar.  The five legal values are
  36 `default-toolbar', `top-toolbar', `bottom-toolbar',
  37 `right-toolbar', and `left-toolbar'.")
  38
  39 (defvar message-toolbar
  40   '([message-copy message-copy t "Copy message"]
  41     [message-delete message-delete t "Delete message"]
  42     [message-forward message-forward t "Forward message"]
  43     [message-get message-get t "Message get"]
  44     [message-help message-help  t "Message help"]
  45     [message-originate message-originate t "Originate"]
  46     [message-reply message-reply t "Reply"]
  47     [message-save message-save t "Save"]
  48     [message-spell message-spell t "Spell"])
  49   "The message buffer toolbar.")
  50
  51 (defun message-xmas-find-glyph-directory (&optional package)
  52   (setq package (or package "message"))
  53   (let ((path load-path)
  54         dir result)
  55     ;; We try to find the dir by looking at the load path,
  56     ;; stripping away the last component and adding "etc/".
  57     (while path
  58       (if (and (car path)
  59                (file-exists-p
  60                 (setq dir (concat
  61                            (file-name-directory
  62                             (directory-file-name (car path)))
  63                            "etc/" (or package "message") "/")))
  64                (file-directory-p dir))
  65           (setq result dir
  66                 path nil)
  67         (setq path (cdr path))))
  68     result))
  69
  70 (defun message-xmas-setup-toolbar (bar &optional force package)
  71   (let ((dir (message-xmas-find-glyph-directory package))
  72         icon up down disabled name)
  73     (unless package
  74       (setq message-xmas-glyph-directory dir))
  75     (when dir
  76       (if (and (not force)
  77                (boundp (aref (car bar) 0)))
  78           dir
  79         (while bar
  80           (setq icon (aref (car bar) 0)
  81                 name (symbol-name icon)
  82                 bar (cdr bar))
  83           (setq up (concat dir name "-up.xpm"))
  84           (setq down (concat dir name "-down.xpm"))
  85           (setq disabled (concat dir name "-disabled.xpm"))
  86           (if (not (file-exists-p up))
  87               (set icon nil)
  88             (set icon (toolbar-make-button-list
  89                        up (and (file-exists-p down) down)
  90                        (and (file-exists-p disabled) disabled)))))
  91         dir))))
  92
  93 (defun message-setup-toolbar ()
  94   (and message-use-toolbar
  95        (message-xmas-setup-toolbar message-toolbar)
  96        (set-specifier (symbol-value message-use-toolbar)
  97                       (cons (current-buffer) message-toolbar))))
  98
  99 (provide 'message-xmas)
 100
 101 ;;; message-xmas.el ends here