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
   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
  51 (if (or (featurep 'xemacs)
  52         (>= emacs-major-version 21))
  53     (autoload 'smiley-region "smiley")
  54   (autoload 'smiley-region "smiley-mule"))
  55
  56 (defun gnus-kill-all-overlays ()
  57   "Delete all overlays in the current buffer."
  58   (let* ((overlayss (overlay-lists))
  59          (buffer-read-only nil)
  60          (overlays (delq nil (nconc (car overlayss) (cdr overlayss)))))
  61     (while overlays
  62       (delete-overlay (pop overlays)))))
  63
  64 ;;; Mule functions.
  65
  66 (eval-and-compile
  67   (defalias 'gnus-char-width
  68     (if (fboundp 'char-width)
  69         'char-width
  70       (lambda (ch) 1)))) ;; A simple hack.
  71
  72 (eval-and-compile
  73   (if (featurep 'xemacs)
  74       (gnus-xmas-define)
  75     (defvar gnus-mouse-face-prop 'mouse-face
  76       "Property used for highlighting mouse regions.")))
  77
  78 (eval-and-compile
  79   (let ((case-fold-search t))
  80     (cond
  81      ((string-match "windows-nt\\|os/2\\|emx\\|cygwin32"
  82                     (symbol-name system-type))
  83       (setq nnheader-file-name-translation-alist
  84             (append nnheader-file-name-translation-alist
  85                     (mapcar (lambda (c) (cons c ?_))
  86                             '(?: ?* ?\" ?< ?> ??))
  87                     (if (string-match "windows-nt\\|cygwin32"
  88                                       (symbol-name system-type))
  89                         nil
  90                       '((?+ . ?-)))))))))
  91
  92 (defvar gnus-tmp-unread)
  93 (defvar gnus-tmp-replied)
  94 (defvar gnus-tmp-score-char)
  95 (defvar gnus-tmp-indentation)
  96 (defvar gnus-tmp-opening-bracket)
  97 (defvar gnus-tmp-lines)
  98 (defvar gnus-tmp-name)
  99 (defvar gnus-tmp-closing-bracket)
 100 (defvar gnus-tmp-subject-or-nil)
 101 (defvar gnus-check-before-posting)
 102
 103 (defun gnus-ems-redefine ()
 104   (cond
 105    ((featurep 'xemacs)
 106     (gnus-xmas-redefine))
 107
 108    ((featurep 'mule)
 109     ;; Mule and new Emacs definitions
 110
 111     ;; [Note] Now there are three kinds of mule implementations,
 112     ;; original MULE, XEmacs/mule and Emacs 20+ including
 113     ;; MULE features.  Unfortunately these API are different.  In
 114     ;; particular, Emacs (including original MULE) and XEmacs are
 115     ;; quite different.  However, this version of Gnus doesn't support
 116     ;; anything other than XEmacs 20+ and Emacs 20.3+.
 117
 118     ;; Predicates to check are following:
 119     ;; (boundp 'MULE) is t only if MULE (original; anything older than
 120     ;;                     Mule 2.3) is running.
 121     ;; (featurep 'mule) is t when every mule variants are running.
 122
 123     ;; It is possible to detect XEmacs/mule by (featurep 'mule) and
 124     ;; checking `emacs-version'.  In this case, the implementation for
 125     ;; XEmacs/mule may be shareable between XEmacs and XEmacs/mule.
 126
 127     (defvar gnus-summary-display-table nil
 128       "Display table used in summary mode buffers.")
 129
 130     (defalias 'gnus-summary-set-display-table (lambda ()))
 131
 132     (if (fboundp 'truncate-string-to-width)
 133         (fset 'gnus-truncate-string 'truncate-string-to-width)
 134       (fset 'gnus-truncate-string 'truncate-string))
 135
 136     (when (boundp 'gnus-check-before-posting)
 137       (setq gnus-check-before-posting
 138             (delq 'long-lines
 139                   (delq 'control-chars gnus-check-before-posting))))
 140     ))
 141   (when (featurep 'mule)
 142     (defun gnus-tilde-max-form (el max-width)
 143       "Return a form that limits EL to MAX-WIDTH."
 144       (let ((max (abs max-width)))
 145         (if (symbolp el)
 146             (if (< max-width 0)
 147                 `(let ((width (string-width ,el)))
 148                    (gnus-truncate-string ,el width (- width ,max)))
 149               `(gnus-truncate-string ,el ,max))
 150           (if (< max-width 0)
 151               `(let* ((val (eval ,el))
 152                       (width (string-width val)))
 153                  (gnus-truncate-string val width (- width ,max)))
 154             `(let ((val (eval ,el)))
 155                (gnus-truncate-string val ,max))))))
 156
 157     (defun gnus-tilde-cut-form (el cut-width)
 158       "Return a form that cuts CUT-WIDTH off of EL."
 159       (let ((cut (abs cut-width)))
 160         (if (symbolp el)
 161             (if (< cut-width 0)
 162                 `(gnus-truncate-string ,el (- (string-width ,el) ,cut))
 163               `(gnus-truncate-string ,el (string-width ,el) ,cut))
 164           (if (< cut-width 0)
 165               `(let ((val (eval ,el)))
 166                  (gnus-truncate-string val (- (string-width val) ,cut)))
 167             `(let ((val (eval ,el)))
 168                (gnus-truncate-string val (string-width val) ,cut))))))
 169     ))
 170
 171 (defun gnus-region-active-p ()
 172   "Say whether the region is active."
 173   (and (boundp 'transient-mark-mode)
 174        transient-mark-mode
 175        (boundp 'mark-active)
 176        mark-active))
 177
 178 (if (fboundp 'add-minor-mode)
 179     (defalias 'gnus-add-minor-mode 'add-minor-mode)
 180   (defun gnus-add-minor-mode (mode name map &rest rest)
 181     (set (make-local-variable mode) t)
 182     (unless (assq mode minor-mode-alist)
 183       (push `(,mode ,name) minor-mode-alist))
 184     (unless (assq mode minor-mode-map-alist)
 185       (push (cons mode map)
 186             minor-mode-map-alist))))
 187
 188 (defun gnus-x-splash ()
 189   "Show a splash screen using a pixmap in the current buffer."
 190   (let ((dir (nnheader-find-etc-directory "gnus"))
 191         pixmap file height beg i)
 192     (save-excursion
 193       (switch-to-buffer (gnus-get-buffer-create gnus-group-buffer))
 194       (let ((buffer-read-only nil)
 195             width height)
 196         (erase-buffer)
 197         (when (and dir
 198                    (file-exists-p (setq file
 199                                         (expand-file-name "x-splash" dir))))
 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)
 237   (insert-image glyph (or string " "))
 238   (unless string
 239     (put-text-property (1- (point)) (point)
 240                        'gnus-image-text-deletable t))
 241   glyph)
 242
 243 (defun gnus-remove-image (image)
 244   (dolist (position (message-text-with-property 'display))
 245     (when (equal (get-text-property position 'display) image)
 246       (put-text-property position (1+ position) 'display nil)
 247       (when (get-text-property position 'gnus-image-text-deletable)
 248         (delete-region position (1+ position))))))
 249
 250 (defun-maybe assoc-ignore-case (key alist)
 251   "Like `assoc', but assumes KEY is a string and ignores case when comparing."
 252   (setq key (downcase key))
 253   (let (element)
 254     (while (and alist (not element))
 255       (if (equal key (downcase (car (car alist))))
 256           (setq element (car alist)))
 257       (setq alist (cdr alist)))
 258     element))
 259
 260 \f
 261 ;;; Language support staffs.
 262
 263 (defvar-maybe current-language-environment "English"
 264   "The language environment.")
 265
 266 (defvar-maybe language-info-alist nil
 267   "Alist of language environment definitions.")
 268
 269 (defun-maybe get-language-info (lang-env key)
 270   "Return information listed under KEY for language environment LANG-ENV."
 271   (if (symbolp lang-env)
 272       (setq lang-env (symbol-name lang-env)))
 273   (let ((lang-slot (assoc-ignore-case lang-env language-info-alist)))
 274     (if lang-slot
 275         (cdr (assq key (cdr lang-slot))))))
 276
 277 (defun-maybe set-language-info (lang-env key info)
 278   "Modify part of the definition of language environment LANG-ENV."
 279   (if (symbolp lang-env)
 280       (setq lang-env (symbol-name lang-env)))
 281   (let (lang-slot key-slot)
 282     (setq lang-slot (assoc lang-env language-info-alist))
 283     (if (null lang-slot)                ; If no slot for the language, add it.
 284         (setq lang-slot (list lang-env)
 285               language-info-alist (cons lang-slot language-info-alist)))
 286     (setq key-slot (assq key lang-slot))
 287     (if (null key-slot)                 ; If no slot for the key, add it.
 288         (progn
 289           (setq key-slot (list key))
 290           (setcdr lang-slot (cons key-slot (cdr lang-slot)))))
 291     (setcdr key-slot info)))
 292
 293 (provide 'gnus-ems)
 294
 295 ;;; gnus-ems.el ends here