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