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

   1 ;;; messagexmas.el --- XEmacs extensions to message
   2
   3 ;; Copyright (C) 1996-2012 Free Software Foundation, Inc.
   4
   5 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
   6 ;; Keywords: mail, news
   7
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs is free software; you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation; either version 3, or (at your option)
  13 ;; any later version.
  14
  15 ;; GNU Emacs is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  22
  23 ;;; Commentary:
  24
  25 ;;; Code:
  26
  27 (eval-when-compile (require 'cl))
  28 (require 'nnheader)
  29
  30 (defvar message-xmas-dont-activate-region t
  31   "If t, don't activate region after yanking.")
  32
  33 (defvar message-xmas-glyph-directory nil
  34   "*Directory where Message logos and icons are located.
  35 If this variable is nil, Message will try to locate the directory
  36 automatically.")
  37
  38 (defvar message-use-toolbar (if (featurep 'toolbar) 'default)
  39   "*Position to display the toolbar.  Nil means do not use a toolbar.
  40 If it is non-nil, it should be one of the symbols `default', `top',
  41 `bottom', `right', and `left'.  `default' means to use the default
  42 toolbar, the rest mean to display the toolbar on the place which those
  43 names show.")
  44
  45 (defvar message-toolbar-thickness
  46   (if (featurep 'toolbar)
  47       (cons (specifier-instance default-toolbar-height)
  48             (specifier-instance default-toolbar-width)))
  49   "*Cons of the height and the width specifying the thickness of a toolbar.
  50 The height is used for the toolbar displayed on the top or the bottom,
  51 the width is used for the toolbar displayed on the right or the left.")
  52
  53 (defvar message-toolbar
  54   '([message-spell ispell-message t "Spell"]
  55     [message-help (Info-goto-node "(Message)Top") t "Message help"])
  56   "The message buffer toolbar.")
  57
  58 (defun message-xmas-find-glyph-directory (&optional package)
  59   (setq package (or package "message"))
  60   (let ((dir (symbol-value
  61               (intern-soft (concat package "-xmas-glyph-directory")))))
  62     (if (and (stringp dir) (file-directory-p dir))
  63         dir
  64       (nnheader-find-etc-directory package))))
  65
  66 (defun message-xmas-setup-toolbar (bar &optional force package)
  67   (let ((dir (or (message-xmas-find-glyph-directory package)
  68                  (message-xmas-find-glyph-directory "gnus")))
  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       (while bar
  75         (setq icon (aref (car bar) 0)
  76               name (symbol-name icon)
  77               bar (cdr bar))
  78         (when (or force
  79                   (not (boundp icon)))
  80           (setq up (concat dir name "-up." xpm))
  81           (setq down (concat dir name "-down." xpm))
  82           (setq disabled (concat dir name "-disabled." xpm))
  83           (if (not (file-exists-p up))
  84               (setq bar nil
  85                     dir 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   (when (featurep 'toolbar)
  93     (if (and message-use-toolbar
  94              (message-xmas-setup-toolbar message-toolbar))
  95         (let ((bar (or (intern-soft (format "%s-toolbar" message-use-toolbar))
  96                        'default-toolbar))
  97               (height (car message-toolbar-thickness))
  98               (width (cdr message-toolbar-thickness))
  99               (cur (current-buffer))
 100               bars)
 101           (set-specifier (symbol-value bar) message-toolbar cur)
 102           (set-specifier default-toolbar-height height cur)
 103           (set-specifier default-toolbar-width width cur)
 104           (set-specifier top-toolbar-height height cur)
 105           (set-specifier bottom-toolbar-height height cur)
 106           (set-specifier right-toolbar-width width cur)
 107           (set-specifier left-toolbar-width width cur)
 108           (if (eq bar 'default-toolbar)
 109               (progn
 110                 (remove-specifier default-toolbar-visible-p cur)
 111                 (remove-specifier top-toolbar cur)
 112                 (remove-specifier top-toolbar-visible-p cur)
 113                 (remove-specifier bottom-toolbar cur)
 114                 (remove-specifier bottom-toolbar-visible-p cur)
 115                 (remove-specifier right-toolbar cur)
 116                 (remove-specifier right-toolbar-visible-p cur)
 117                 (remove-specifier left-toolbar cur)
 118                 (remove-specifier left-toolbar-visible-p cur))
 119             (set-specifier (symbol-value (intern (format "%s-visible-p" bar)))
 120                            t cur)
 121             (setq bars (delq bar (list 'default-toolbar
 122                                        'bottom-toolbar 'top-toolbar
 123                                        'right-toolbar 'left-toolbar)))
 124             (while bars
 125               (set-specifier (symbol-value (intern (format "%s-visible-p"
 126                                                            (pop bars))))
 127                              nil cur))))
 128       (let ((cur (current-buffer)))
 129         (set-specifier default-toolbar-visible-p nil cur)
 130         (set-specifier top-toolbar-visible-p nil cur)
 131         (set-specifier bottom-toolbar-visible-p nil cur)
 132         (set-specifier right-toolbar-visible-p nil cur)
 133         (set-specifier left-toolbar-visible-p nil cur)))))
 134
 135 (defun message-xmas-exchange-point-and-mark ()
 136   "Exchange point and mark, but allow for XEmacs's optional argument."
 137   (exchange-point-and-mark message-xmas-dont-activate-region))
 138
 139 (defun message-xmas-maybe-fontify ()
 140   (when (featurep 'font-lock)
 141     (font-lock-set-defaults)))
 142
 143 (defun message-xmas-make-caesar-translation-table (n)
 144   "Create a rot table with offset N."
 145   (let ((i -1)
 146         (table (make-string 256 0))
 147         (a (mm-char-int ?a))
 148         (A (mm-char-int ?A)))
 149     (while (< (incf i) 256)
 150       (aset table i i))
 151     (concat
 152      (substring table 0 A)
 153      (substring table (+ A n) (+ A n (- 26 n)))
 154      (substring table A (+ A n))
 155      (substring table (+ A 26) a)
 156      (substring table (+ a n) (+ a n (- 26 n)))
 157      (substring table a (+ a n))
 158      (substring table (+ a 26) 255))))
 159
 160 (defun message-xmas-make-date (&optional now)
 161   "Make a valid data header.
 162 If NOW, use that time instead."
 163   (let ((zone (car (current-time-zone)))
 164         sign)
 165     (if (>= zone 0)
 166         (setq sign "+")
 167       (setq sign "-"
 168             zone (- zone)))
 169     (format "%s %s%02d%02d"
 170             (format-time-string "%a, %d %b %Y %T" now)
 171             sign
 172             (/ zone 3600)
 173             (/ (% zone 3600) 60))))
 174
 175 (add-hook 'message-mode-hook 'message-xmas-maybe-fontify)
 176
 177 (defun message-xmas-redefine ()
 178   "Redefine message functions for XEmacs."
 179   (defalias 'message-exchange-point-and-mark
 180     'message-xmas-exchange-point-and-mark)
 181   (defalias 'message-mark-active-p
 182     'region-exists-p)
 183   (defalias 'message-make-caesar-translation-table
 184     'message-xmas-make-caesar-translation-table)
 185   (defalias 'message-make-overlay 'make-extent)
 186   (defalias 'message-delete-overlay 'delete-extent)
 187   (defalias 'message-overlay-put 'set-extent-property)
 188   (defalias 'message-make-date 'message-xmas-make-date))
 189
 190 (message-xmas-redefine)
 191
 192 (provide 'messagexmas)
 193
 194 ;;; messagexmas.el ends here