cgit.sxemacs.org Git - gnus/blob - lisp/messagexmas.el

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