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

   1 ;;; messagexmas.el --- XEmacs extensions to message
   2
   3 ;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2003, 2004
   4 ;;      Free Software Foundation, Inc.
   5
   6 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
   7 ;; Keywords: mail, news
   8
   9 ;; This file is part of GNU Emacs.
  10
  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)
  14 ;; any later version.
  15
  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.
  20
  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.
  25
  26 ;;; Commentary:
  27
  28 ;;; Code:
  29
  30 (eval-when-compile (require 'cl))
  31 (require 'nnheader)
  32
  33 (defvar message-xmas-dont-activate-region t
  34   "If t, don't activate region after yanking.")
  35
  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
  39 automatically.")
  40
  41 (defvar message-use-toolbar (if (featurep 'toolbar) 'default)
  42   "*Position to display the toolbar.  Nil means do not use a toolbar.
  43 If it is non-nil, it should be one of the symbols `default', `top',
  44 `bottom', `right', and `left'.  `default' means to use the default
  45 toolbar, the rest mean to display the toolbar on the place which those
  46 names show.")
  47
  48 (defvar message-toolbar-thickness
  49   (if (featurep 'toolbar)
  50       (cons (specifier-instance default-toolbar-height)
  51             (specifier-instance default-toolbar-width)))
  52   "*Cons of the height and the width specifying the thickness of a toolbar.
  53 The height is used for the toolbar displayed on the top or the bottom,
  54 the width is used for the toolbar displayed on the right or the left.")
  55
  56 (defvar message-toolbar
  57   '([message-spell ispell-message t "Spell"]
  58     [message-help (Info-goto-node "(Message)Top") t "Message help"])
  59   "The message buffer toolbar.")
  60
  61 (defun message-xmas-find-glyph-directory (&optional package)
  62   (setq package (or package "message"))
  63   (let ((dir (symbol-value
  64               (intern-soft (concat package "-xmas-glyph-directory")))))
  65     (if (and (stringp dir) (file-directory-p dir))
  66         dir
  67       (nnheader-find-etc-directory package))))
  68
  69 (defun message-xmas-setup-toolbar (bar &optional force package)
  70   (let ((dir (or (message-xmas-find-glyph-directory package)
  71                  (message-xmas-find-glyph-directory "gnus")))
  72         (xpm (if (featurep 'xpm) "xpm" "xbm"))
  73         icon up down disabled name)
  74     (unless package
  75       (setq message-xmas-glyph-directory dir))
  76     (when dir
  77       (while bar
  78         (setq icon (aref (car bar) 0)
  79               name (symbol-name icon)
  80               bar (cdr bar))
  81         (when (or force
  82                   (not (boundp icon)))
  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               (setq bar nil
  88                     dir nil)
  89             (set icon (toolbar-make-button-list
  90                        up (and (file-exists-p down) down)
  91                        (and (file-exists-p disabled) disabled)))))))
  92     dir))
  93
  94 (defun message-setup-toolbar ()
  95   (when (featurep 'toolbar)
  96     (if (and message-use-toolbar
  97              (message-xmas-setup-toolbar message-toolbar))
  98         (let* ((bar (or (intern-soft (format "%s-toolbar" message-use-toolbar))
  99                         'default-toolbar))
 100                (bars (delq bar (list 'top-toolbar 'bottom-toolbar
 101                                      'right-toolbar 'left-toolbar)))
 102                hw)
 103           (while bars
 104             (remove-specifier (symbol-value (pop bars)) (current-buffer)))
 105           (unless (eq bar 'default-toolbar)
 106             (set-specifier default-toolbar nil (current-buffer)))
 107           (set-specifier (symbol-value bar) message-toolbar (current-buffer))
 108           (when (setq hw (cdr (assq message-use-toolbar
 109                                     '((default . default-toolbar-height)
 110                                       (top . top-toolbar-height)
 111                                       (bottom . bottom-toolbar-height)))))
 112             (set-specifier (symbol-value hw) (car message-toolbar-thickness)
 113                            (current-buffer)))
 114           (when (setq hw (cdr (assq message-use-toolbar
 115                                     '((default . default-toolbar-width)
 116                                       (right . right-toolbar-width)
 117                                       (left . left-toolbar-width)))))
 118             (set-specifier (symbol-value hw) (cdr message-toolbar-thickness)
 119                            (current-buffer))))
 120       (set-specifier default-toolbar nil (current-buffer))
 121       (remove-specifier top-toolbar (current-buffer))
 122       (remove-specifier bottom-toolbar (current-buffer))
 123       (remove-specifier right-toolbar (current-buffer))
 124       (remove-specifier left-toolbar (current-buffer)))
 125     (set-specifier default-toolbar-visible-p t (current-buffer))
 126     (set-specifier top-toolbar-visible-p t (current-buffer))
 127     (set-specifier bottom-toolbar-visible-p t (current-buffer))
 128     (set-specifier right-toolbar-visible-p t (current-buffer))
 129     (set-specifier left-toolbar-visible-p t (current-buffer))))
 130
 131 (defun message-xmas-exchange-point-and-mark ()
 132   "Exchange point and mark, but allow for XEmacs' optional argument."
 133   (exchange-point-and-mark message-xmas-dont-activate-region))
 134
 135 (defun message-xmas-maybe-fontify ()
 136   (when (featurep 'font-lock)
 137     (font-lock-set-defaults)))
 138
 139 (defun message-xmas-make-caesar-translation-table (n)
 140   "Create a rot table with offset N."
 141   (let ((i -1)
 142         (table (make-string 256 0))
 143         (a (mm-char-int ?a))
 144         (A (mm-char-int ?A)))
 145     (while (< (incf i) 256)
 146       (aset table i i))
 147     (concat
 148      (substring table 0 A)
 149      (substring table (+ A n) (+ A n (- 26 n)))
 150      (substring table A (+ A n))
 151      (substring table (+ A 26) a)
 152      (substring table (+ a n) (+ a n (- 26 n)))
 153      (substring table a (+ a n))
 154      (substring table (+ a 26) 255))))
 155
 156 (defun message-xmas-make-date (&optional now)
 157   "Make a valid data header.
 158 If NOW, use that time instead."
 159   (let ((zone (car (current-time-zone)))
 160         sign)
 161     (if (>= zone 0)
 162         (setq sign "+")
 163       (setq sign "-"
 164             zone (- zone)))
 165     (format "%s %s%02d%02d"
 166             (format-time-string "%a, %d %b %Y %T" now)
 167             sign
 168             (/ zone 3600)
 169             (/ (% zone 3600) 60))))
 170
 171 (add-hook 'message-mode-hook 'message-xmas-maybe-fontify)
 172
 173 (defun message-xmas-redefine ()
 174   "Redefine message functions for XEmacs."
 175   (defalias 'message-exchange-point-and-mark
 176     'message-xmas-exchange-point-and-mark)
 177   (defalias 'message-mark-active-p
 178     'region-exists-p)
 179   (defalias 'message-make-caesar-translation-table
 180     'message-xmas-make-caesar-translation-table)
 181   (defalias 'message-make-overlay 'make-extent)
 182   (defalias 'message-delete-overlay 'delete-extent)
 183   (defalias 'message-overlay-put 'set-extent-property)
 184   (defalias 'message-make-date 'message-xmas-make-date))
 185
 186 (message-xmas-redefine)
 187
 188 (provide 'messagexmas)
 189
 190 ;;; arch-tag: 0ece0484-8757-4641-b2d4-17147dd5c5b5
 191 ;;; messagexmas.el ends here