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   '(
  41     [message-reply message-reply t "Reply"]
  42     [message-get message-get t "Message get"]
  43     [message-originate message-originate t "Originate"]
  44     [message-save message-save t "Save"]
  45     [message-copy message-copy t "Copy message"]
  46     [message-delete message-delete t "Delete message"]
  47     [message-forward message-forward t "Forward message"]
  48     [message-spell message-spell t "Spell"]
  49     [message-help message-help  t "Message help"]
  50     )
  51   "The message buffer toolbar.")
  52
  53 (defun message-xmas-find-glyph-directory (&optional package)
  54   (setq package (or package "message"))
  55   (let ((path load-path)
  56         dir result)
  57     ;; We try to find the dir by looking at the load path,
  58     ;; stripping away the last component and adding "etc/".
  59     (while path
  60       (if (and (car path)
  61                (file-exists-p
  62                 (setq dir (concat
  63                            (file-name-directory
  64                             (directory-file-name (car path)))
  65                            "etc/" (or package "message") "/")))
  66                (file-directory-p dir))
  67           (setq result dir
  68                 path nil)
  69         (setq path (cdr path))))
  70     result))
  71
  72 (defun message-xmas-setup-toolbar (bar &optional force package)
  73   (let ((dir (message-xmas-find-glyph-directory package))
  74         icon up down disabled name)
  75     (unless package
  76       (setq message-xmas-glyph-directory dir))
  77     (when dir
  78       (if (and (not force)
  79                (boundp (aref (car bar) 0)))
  80           dir
  81         (while bar
  82           (setq icon (aref (car bar) 0)
  83                 name (symbol-name icon)
  84                 bar (cdr bar))
  85           (setq up (concat dir name "-up.xpm"))
  86           (setq down (concat dir name "-down.xpm"))
  87           (setq disabled (concat dir name "-disabled.xpm"))
  88           (if (not (file-exists-p up))
  89               (set icon nil)
  90             (set icon (toolbar-make-button-list
  91                        up (and (file-exists-p down) down)
  92                        (and (file-exists-p disabled) disabled)))))
  93         dir))))
  94
  95 (defun message-setup-toolbar ()
  96   (and message-use-toolbar
  97        (message-xmas-setup-toolbar message-toolbar)
  98        (set-specifier (symbol-value message-use-toolbar)
  99                       (cons (current-buffer) message-toolbar))))
 100
 101 (provide 'message-xmas)
 102
 103 ;;; message-xmas.el ends here