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