1 ;;; messagexmas.el --- XEmacs extensions to message
3 ;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2003, 2004
4 ;; Free Software Foundation, Inc.
6 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
7 ;; Keywords: mail, news
9 ;; This file is part of GNU Emacs.
11 ;; GNU Emacs is free software; you can redistribute it and/or modify
12 ;; it under the terms of the GNU General Public License as published by
13 ;; the Free Software Foundation; either version 2, or (at your option)
16 ;; GNU Emacs is distributed in the hope that it will be useful,
17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19 ;; GNU General Public License for more details.
21 ;; You should have received a copy of the GNU General Public License
22 ;; along with GNU Emacs; see the file COPYING. If not, write to the
23 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
24 ;; Boston, MA 02110-1301, USA.
30 (eval-when-compile (require 'cl))
33 (defvar message-xmas-dont-activate-region t
34 "If t, don't activate region after yanking.")
36 (defvar message-xmas-glyph-directory nil
37 "*Directory where Message logos and icons are located.
38 If this variable is nil, Message will try to locate the directory
41 (defvar message-use-toolbar
42 (if (and (featurep 'toolbar)
43 (specifier-instance default-toolbar-visible-p))
45 "*Position to display the toolbar. Nil means do not use a toolbar.
46 If it is non-nil, it should be one of the symbols `default', `top',
47 `bottom', `right', and `left'. `default' means to use the default
48 toolbar, the rest mean to display the toolbar on the place which those
51 (defvar message-toolbar-thickness
52 (if (featurep 'toolbar)
53 (cons (specifier-instance default-toolbar-height)
54 (specifier-instance default-toolbar-width)))
55 "*Cons of the height and the width specifying the thickness of a toolbar.
56 The height is used for the toolbar displayed on the top or the bottom,
57 the width is used for the toolbar displayed on the right or the left.")
59 (defvar message-toolbar
60 '([message-spell ispell-message t "Spell"]
61 [message-help (Info-goto-node "(Message)Top") t "Message help"])
62 "The message buffer toolbar.")
64 (defun message-xmas-find-glyph-directory (&optional package)
65 (setq package (or package "message"))
66 (let ((dir (symbol-value
67 (intern-soft (concat package "-xmas-glyph-directory")))))
68 (if (and (stringp dir) (file-directory-p dir))
70 (nnheader-find-etc-directory package))))
72 (defun message-xmas-setup-toolbar (bar &optional force package)
73 (let ((dir (or (message-xmas-find-glyph-directory package)
74 (message-xmas-find-glyph-directory "gnus")))
75 (xpm (if (featurep 'xpm) "xpm" "xbm"))
76 icon up down disabled name)
78 (setq message-xmas-glyph-directory dir))
81 (setq icon (aref (car bar) 0)
82 name (symbol-name icon)
86 (setq up (concat dir name "-up." xpm))
87 (setq down (concat dir name "-down." xpm))
88 (setq disabled (concat dir name "-disabled." xpm))
89 (if (not (file-exists-p up))
92 (set icon (toolbar-make-button-list
93 up (and (file-exists-p down) down)
94 (and (file-exists-p disabled) disabled)))))))
97 (defun message-setup-toolbar ()
98 (when (featurep 'toolbar)
99 (if (and message-use-toolbar
100 (message-xmas-setup-toolbar message-toolbar))
101 (let* ((bar (or (intern-soft (format "%s-toolbar" message-use-toolbar))
103 (bars (delq bar (list 'top-toolbar 'bottom-toolbar
104 'right-toolbar 'left-toolbar)))
107 (remove-specifier (symbol-value (pop bars)) (current-buffer)))
108 (unless (eq bar 'default-toolbar)
109 (set-specifier default-toolbar nil (current-buffer)))
110 (set-specifier (symbol-value bar) message-toolbar (current-buffer))
111 (when (setq hw (cdr (assq message-use-toolbar
112 '((default . default-toolbar-height)
113 (top . top-toolbar-height)
114 (bottom . bottom-toolbar-height)))))
115 (set-specifier (symbol-value hw) (car message-toolbar-thickness)
117 (when (setq hw (cdr (assq message-use-toolbar
118 '((default . default-toolbar-width)
119 (right . right-toolbar-width)
120 (left . left-toolbar-width)))))
121 (set-specifier (symbol-value hw) (cdr message-toolbar-thickness)
123 (set-specifier default-toolbar nil (current-buffer))
124 (remove-specifier top-toolbar (current-buffer))
125 (remove-specifier bottom-toolbar (current-buffer))
126 (remove-specifier right-toolbar (current-buffer))
127 (remove-specifier left-toolbar (current-buffer)))
128 (set-specifier default-toolbar-visible-p t (current-buffer))
129 (set-specifier top-toolbar-visible-p t (current-buffer))
130 (set-specifier bottom-toolbar-visible-p t (current-buffer))
131 (set-specifier right-toolbar-visible-p t (current-buffer))
132 (set-specifier left-toolbar-visible-p t (current-buffer))))
134 (defun message-xmas-exchange-point-and-mark ()
135 "Exchange point and mark, but allow for XEmacs' optional argument."
136 (exchange-point-and-mark message-xmas-dont-activate-region))
138 (defun message-xmas-maybe-fontify ()
139 (when (featurep 'font-lock)
140 (font-lock-set-defaults)))
142 (defun message-xmas-make-caesar-translation-table (n)
143 "Create a rot table with offset N."
145 (table (make-string 256 0))
148 (while (< (incf i) 256)
151 (substring table 0 A)
152 (substring table (+ A n) (+ A n (- 26 n)))
153 (substring table A (+ A n))
154 (substring table (+ A 26) a)
155 (substring table (+ a n) (+ a n (- 26 n)))
156 (substring table a (+ a n))
157 (substring table (+ a 26) 255))))
159 (defun message-xmas-make-date (&optional now)
160 "Make a valid data header.
161 If NOW, use that time instead."
162 (let ((zone (car (current-time-zone)))
168 (format "%s %s%02d%02d"
169 (format-time-string "%a, %d %b %Y %T" now)
172 (/ (% zone 3600) 60))))
174 (add-hook 'message-mode-hook 'message-xmas-maybe-fontify)
176 (defun message-xmas-redefine ()
177 "Redefine message functions for XEmacs."
178 (defalias 'message-exchange-point-and-mark
179 'message-xmas-exchange-point-and-mark)
180 (defalias 'message-mark-active-p
182 (defalias 'message-make-caesar-translation-table
183 'message-xmas-make-caesar-translation-table)
184 (defalias 'message-make-overlay 'make-extent)
185 (defalias 'message-delete-overlay 'delete-extent)
186 (defalias 'message-overlay-put 'set-extent-property)
187 (defalias 'message-make-date 'message-xmas-make-date))
189 (message-xmas-redefine)
191 (provide 'messagexmas)
193 ;;; messagexmas.el ends here