git.chise.org Git - elisp/gnus.git-/blob - lisp/gnus-ems.el

   1 ;;; gnus-ems.el --- functions for making Semi-gnus work under different Emacsen
   2 ;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003
   3 ;;        Free Software Foundation, Inc.
   4
   5 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
   6 ;;         Tatsuya Ichikawa <t-ichi@niagara.shiojiri.ne.jp>
   7 ;; Keywords: 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., 59 Temple Place - Suite 330,
  24 ;; Boston, MA 02111-1307, USA.
  25
  26 ;;; Commentary:
  27
  28 ;;; Code:
  29
  30 (eval-when-compile
  31   (require 'cl)
  32   (require 'ring))
  33
  34 ;;; Function aliases later to be redefined for XEmacs usage.
  35
  36 (defvar gnus-mouse-2 [mouse-2])
  37 (defvar gnus-down-mouse-3 [down-mouse-3])
  38 (defvar gnus-down-mouse-2 [down-mouse-2])
  39 (defvar gnus-widget-button-keymap nil)
  40 (defvar gnus-mode-line-modified
  41   (if (or (featurep 'xemacs)
  42           (< emacs-major-version 20))
  43       '("--**-" . "-----")
  44     '("**" "--")))
  45
  46 (eval-and-compile
  47   (autoload 'gnus-xmas-define "gnus-xmas")
  48   (autoload 'gnus-xmas-redefine "gnus-xmas")
  49   (autoload 'appt-select-lowest-window "appt")
  50   (autoload 'gnus-get-buffer-create "gnus")
  51   (autoload 'nnheader-find-etc-directory "nnheader"))
  52
  53 (if (or (featurep 'xemacs)
  54         (>= emacs-major-version 21))
  55     (autoload 'smiley-region "smiley")
  56   (autoload 'smiley-region "smiley-mule"))
  57
  58 ;; Fixme: shouldn't require message
  59 (autoload 'message-text-with-property "message")
  60
  61 (defun gnus-kill-all-overlays ()
  62   "Delete all overlays in the current buffer."
  63   (let* ((overlayss (overlay-lists))
  64          (buffer-read-only nil)
  65          (overlays (delq nil (nconc (car overlayss) (cdr overlayss)))))
  66     (while overlays
  67       (delete-overlay (pop overlays)))))
  68
  69 ;;; Mule functions.
  70
  71 (eval-and-compile
  72   (defalias 'gnus-char-width
  73     (if (fboundp 'char-width)
  74         'char-width
  75       (lambda (ch) 1)))) ;; A simple hack.
  76
  77 (eval-and-compile
  78   (if (featurep 'xemacs)
  79       (gnus-xmas-define)
  80     (defvar gnus-mouse-face-prop 'mouse-face
  81       "Property used for highlighting mouse regions.")))
  82
  83 (eval-when-compile
  84   (defvar gnus-tmp-unread)
  85   (defvar gnus-tmp-replied)
  86   (defvar gnus-tmp-score-char)
  87   (defvar gnus-tmp-indentation)
  88   (defvar gnus-tmp-opening-bracket)
  89   (defvar gnus-tmp-lines)
  90   (defvar gnus-tmp-name)
  91   (defvar gnus-tmp-closing-bracket)
  92   (defvar gnus-tmp-subject-or-nil)
  93   (defvar gnus-check-before-posting)
  94   (defvar gnus-mouse-face)
  95   (defvar gnus-group-buffer))
  96
  97 (defun gnus-ems-redefine ()
  98   (cond
  99    ((featurep 'xemacs)
 100     (gnus-xmas-redefine))
 101
 102    ((featurep 'mule)
 103     ;; Mule and new Emacs definitions
 104
 105     ;; [Note] Now there are three kinds of mule implementations,
 106     ;; original MULE, XEmacs/mule and Emacs 20+ including
 107     ;; MULE features.  Unfortunately these APIs are different.  In
 108     ;; particular, Emacs (including original Mule) and XEmacs are
 109     ;; quite different.  However, this version of Gnus doesn't support
 110     ;; anything other than XEmacs 20+ and Emacs 20.3+.
 111
 112     ;; Predicates to check are following:
 113     ;; (boundp 'MULE) is t only if Mule (original; anything older than
 114     ;;                     Mule 2.3) is running.
 115     ;; (featurep 'mule) is t when other mule variants are running.
 116
 117     ;; It is possible to detect XEmacs/mule by (featurep 'mule) and
 118     ;; (featurep 'xemacs).  In this case, the implementation for
 119     ;; XEmacs/mule may be shareable between XEmacs and XEmacs/mule.
 120
 121     (defvar gnus-summary-display-table nil
 122       "Display table used in summary mode buffers.")
 123
 124     (defalias 'gnus-summary-set-display-table (lambda ()))
 125
 126     (if (fboundp 'truncate-string-to-width)
 127         (fset 'gnus-truncate-string 'truncate-string-to-width)
 128       (fset 'gnus-truncate-string 'truncate-string))
 129
 130     (when (boundp 'gnus-check-before-posting)
 131       (setq gnus-check-before-posting
 132             (delq 'long-lines
 133                   (delq 'control-chars gnus-check-before-posting))))
 134     ))
 135   (when (featurep 'mule)
 136     (defun gnus-tilde-max-form (el max-width)
 137       "Return a form that limits EL to MAX-WIDTH."
 138       (let ((max (abs max-width)))
 139         (if (symbolp el)
 140             (if (< max-width 0)
 141                 `(let ((width (string-width ,el)))
 142                    (gnus-truncate-string ,el width (- width ,max)))
 143               `(gnus-truncate-string ,el ,max))
 144           (if (< max-width 0)
 145               `(let* ((val (eval ,el))
 146                       (width (string-width val)))
 147                  (gnus-truncate-string val width (- width ,max)))
 148             `(let ((val (eval ,el)))
 149                (gnus-truncate-string val ,max))))))
 150
 151     (defun gnus-tilde-cut-form (el cut-width)
 152       "Return a form that cuts CUT-WIDTH off of EL."
 153       (let ((cut (abs cut-width)))
 154         (if (symbolp el)
 155             (if (< cut-width 0)
 156                 `(gnus-truncate-string ,el (- (string-width ,el) ,cut))
 157               `(gnus-truncate-string ,el (string-width ,el) ,cut))
 158           (if (< cut-width 0)
 159               `(let ((val (eval ,el)))
 160                  (gnus-truncate-string val (- (string-width val) ,cut)))
 161             `(let ((val (eval ,el)))
 162                (gnus-truncate-string val (string-width val) ,cut))))))
 163     ))
 164
 165 (defun gnus-region-active-p ()
 166   "Say whether the region is active."
 167   (and (boundp 'transient-mark-mode)
 168        transient-mark-mode
 169        (boundp 'mark-active)
 170        mark-active))
 171
 172 (defun gnus-mark-active-p ()
 173   "Non-nil means the mark and region are currently active in this buffer."
 174   mark-active) ; aliased to region-exists-p in XEmacs.
 175
 176 (if (fboundp 'add-minor-mode)
 177     (defalias 'gnus-add-minor-mode 'add-minor-mode)
 178   (defun gnus-add-minor-mode (mode name map &rest rest)
 179     (set (make-local-variable mode) t)
 180     (unless (assq mode minor-mode-alist)
 181       (push `(,mode ,name) minor-mode-alist))
 182     (unless (assq mode minor-mode-map-alist)
 183       (push (cons mode map)
 184             minor-mode-map-alist))))
 185
 186 (defun gnus-x-splash ()
 187   "Show a splash screen using a pixmap in the current buffer."
 188   (let ((dir (nnheader-find-etc-directory "gnus"))
 189         pixmap file height beg i)
 190     (save-excursion
 191       (switch-to-buffer (gnus-get-buffer-create gnus-group-buffer))
 192       (let ((buffer-read-only nil)
 193             width height)
 194         (erase-buffer)
 195         (when (and dir
 196                    (file-exists-p (setq file
 197                                         (expand-file-name "x-splash" dir))))
 198           (let ((coding-system-for-read 'raw-text)
 199                 default-enable-multibyte-characters)
 200             (with-temp-buffer
 201               (insert-file-contents-as-binary file)
 202               (goto-char (point-min))
 203               (ignore-errors
 204                 (setq pixmap (read (current-buffer)))))))
 205         (when pixmap
 206           (make-face 'gnus-splash)
 207           (setq height (/ (car pixmap) (frame-char-height))
 208                 width (/ (cadr pixmap) (frame-char-width)))
 209           (set-face-foreground 'gnus-splash "Brown")
 210           (set-face-stipple 'gnus-splash pixmap)
 211           (insert-char ?\n (* (/ (window-height) 2 height) height))
 212           (setq i height)
 213           (while (> i 0)
 214             (insert-char ?\  (* (/ (window-width) 2 width) width))
 215             (setq beg (point))
 216             (insert-char ?\  width)
 217             (set-text-properties beg (point) '(face gnus-splash))
 218             (insert ?\n)
 219             (decf i))
 220           (goto-char (point-min))
 221           (sit-for 0))))))
 222
 223 ;;; Image functions.
 224
 225 (defun gnus-image-type-available-p (type)
 226   (and (fboundp 'image-type-available-p)
 227        (image-type-available-p type)))
 228
 229 (defun gnus-create-image (file &optional type data-p &rest props)
 230   (let ((face (plist-get props :face)))
 231     (when face
 232       (setq props (plist-put props :foreground (face-foreground face)))
 233       (setq props (plist-put props :background (face-background face))))
 234     (apply 'create-image file type data-p props)))
 235
 236 (defun gnus-put-image (glyph &optional string category)
 237   (let ((point (point)))
 238     (insert-image glyph (or string " "))
 239     (put-text-property point (point) 'gnus-image-category category)
 240     (unless string
 241       (put-text-property (1- (point)) (point)
 242                          'gnus-image-text-deletable t))
 243     glyph))
 244
 245 (defun gnus-remove-image (image &optional category)
 246   (dolist (position (message-text-with-property 'display))
 247     (when (and (equal (get-text-property position 'display) image)
 248                (equal (get-text-property position 'gnus-image-category)
 249                       category))
 250       (put-text-property position (1+ position) 'display nil)
 251       (when (get-text-property position 'gnus-image-text-deletable)
 252         (delete-region position (1+ position))))))
 253
 254 (defun-maybe assoc-ignore-case (key alist)
 255   "Like `assoc', but assumes KEY is a string and ignores case when comparing."
 256   (setq key (downcase key))
 257   (let (element)
 258     (while (and alist (not element))
 259       (if (equal key (downcase (car (car alist))))
 260           (setq element (car alist)))
 261       (setq alist (cdr alist)))
 262     element))
 263
 264 \f
 265 ;;; Language support staffs.
 266
 267 (defvar-maybe current-language-environment "English"
 268   "The language environment.")
 269
 270 (defvar-maybe language-info-alist nil
 271   "Alist of language environment definitions.")
 272
 273 (defun-maybe get-language-info (lang-env key)
 274   "Return information listed under KEY for language environment LANG-ENV."
 275   (if (symbolp lang-env)
 276       (setq lang-env (symbol-name lang-env)))
 277   (let ((lang-slot (assoc-ignore-case lang-env language-info-alist)))
 278     (if lang-slot
 279         (cdr (assq key (cdr lang-slot))))))
 280
 281 (defun-maybe set-language-info (lang-env key info)
 282   "Modify part of the definition of language environment LANG-ENV."
 283   (if (symbolp lang-env)
 284       (setq lang-env (symbol-name lang-env)))
 285   (let (lang-slot key-slot)
 286     (setq lang-slot (assoc lang-env language-info-alist))
 287     (if (null lang-slot)                ; If no slot for the language, add it.
 288         (setq lang-slot (list lang-env)
 289               language-info-alist (cons lang-slot language-info-alist)))
 290     (setq key-slot (assq key lang-slot))
 291     (if (null key-slot)                 ; If no slot for the key, add it.
 292         (progn
 293           (setq key-slot (list key))
 294           (setcdr lang-slot (cons key-slot (cdr lang-slot)))))
 295     (setcdr key-slot info)))
 296
 297 (provide 'gnus-ems)
 298
 299 ;;; gnus-ems.el ends here