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
   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 (require 'cl))
  31
  32 ;;; Function aliases later to be redefined for XEmacs usage.
  33
  34 (defvar gnus-xemacs (string-match "XEmacs\\|Lucid" emacs-version)
  35   "Non-nil if running under XEmacs.")
  36
  37 (defvar gnus-mouse-2 [mouse-2])
  38 (defvar gnus-down-mouse-3 [down-mouse-3])
  39 (defvar gnus-down-mouse-2 [down-mouse-2])
  40 (defvar gnus-widget-button-keymap nil)
  41 (defvar gnus-mode-line-modified
  42   (if (or gnus-xemacs
  43           (< emacs-major-version 20))
  44       '("--**-" . "-----")
  45     '("**" "--")))
  46
  47 (eval-and-compile
  48   (autoload 'gnus-xmas-define "gnus-xmas")
  49   (autoload 'gnus-xmas-redefine "gnus-xmas")
  50   (autoload 'appt-select-lowest-window "appt"))
  51
  52 (or (fboundp 'mail-file-babyl-p)
  53     (fset 'mail-file-babyl-p 'rmail-file-p))
  54
  55 ;;; Mule functions.
  56
  57 (eval-and-compile
  58   (if (string-match "XEmacs\\|Lucid" emacs-version)
  59       nil
  60
  61     (defvar gnus-mouse-face-prop 'mouse-face
  62       "Property used for highlighting mouse regions."))
  63
  64   (cond
  65    ((string-match "XEmacs\\|Lucid" emacs-version)
  66     (gnus-xmas-define))
  67
  68    ((or (not (boundp 'emacs-minor-version))
  69         (and (< emacs-major-version 20)
  70              (< emacs-minor-version 30)))
  71     ;; Remove the `intangible' prop.
  72     (let ((props (and (boundp 'gnus-hidden-properties)
  73                       gnus-hidden-properties)))
  74       (while (and props (not (eq (car (cdr props)) 'intangible)))
  75         (setq props (cdr props)))
  76       (when props
  77         (setcdr props (cdr (cdr (cdr props))))))
  78     (unless (fboundp 'buffer-substring-no-properties)
  79       (defun buffer-substring-no-properties (beg end)
  80         (format "%s" (buffer-substring beg end)))))
  81
  82    ((boundp 'MULE)
  83     (provide 'gnusutil))))
  84
  85 (eval-and-compile
  86   (cond
  87    ((not window-system)
  88     (defun gnus-dummy-func (&rest args))
  89     (let ((funcs '(mouse-set-point set-face-foreground
  90                                    set-face-background x-popup-menu)))
  91       (while funcs
  92         (unless (fboundp (car funcs))
  93           (fset (car funcs) 'gnus-dummy-func))
  94         (setq funcs (cdr funcs)))))))
  95
  96 (eval-and-compile
  97   (let ((case-fold-search t))
  98     (cond
  99      ((string-match "windows-nt\\|os/2\\|emx\\|cygwin32"
 100                     (symbol-name system-type))
 101       (setq nnheader-file-name-translation-alist
 102             (append nnheader-file-name-translation-alist
 103                     (mapcar (lambda (c) (cons c ?_))
 104                             '(?: ?* ?\" ?< ?> ??))
 105                     '((?+ . ?-))))))))
 106
 107 (defvar gnus-tmp-unread)
 108 (defvar gnus-tmp-replied)
 109 (defvar gnus-tmp-score-char)
 110 (defvar gnus-tmp-indentation)
 111 (defvar gnus-tmp-opening-bracket)
 112 (defvar gnus-tmp-lines)
 113 (defvar gnus-tmp-name)
 114 (defvar gnus-tmp-closing-bracket)
 115 (defvar gnus-tmp-subject-or-nil)
 116
 117 (defun gnus-ems-redefine ()
 118   (cond
 119    ((string-match "XEmacs\\|Lucid" emacs-version)
 120     (gnus-xmas-redefine))
 121
 122    ((featurep 'mule)
 123     ;; Mule and new Emacs definitions
 124
 125     ;; [Note] Now there are three kinds of mule implementations,
 126     ;; original MULE, XEmacs/mule and beta version of Emacs including
 127     ;; some mule features.  Unfortunately these API are different.  In
 128     ;; particular, Emacs (including original MULE) and XEmacs are
 129     ;; quite different.
 130     ;; Predicates to check are following:
 131     ;; (boundp 'MULE) is t only if MULE (original; anything older than
 132     ;;                     Mule 2.3) is running.
 133     ;; (featurep 'mule) is t when every mule variants are running.
 134
 135     ;; These implementations may be able to share between original
 136     ;; MULE and beta version of new Emacs.  In addition, it is able to
 137     ;; detect XEmacs/mule by (featurep 'mule) and to check variable
 138     ;; `emacs-version'.  In this case, implementation for XEmacs/mule
 139     ;; may be able to share between XEmacs and XEmacs/mule.
 140
 141     (defvar gnus-summary-display-table nil
 142       "Display table used in summary mode buffers.")
 143     (fset 'gnus-summary-set-display-table (lambda ()))
 144
 145     (if (fboundp 'truncate-string-to-width)
 146         (fset 'gnus-truncate-string 'truncate-string-to-width)
 147       (fset 'gnus-truncate-string 'truncate-string))
 148
 149     (when (boundp 'gnus-check-before-posting)
 150       (setq gnus-check-before-posting
 151             (delq 'long-lines
 152                   (delq 'control-chars gnus-check-before-posting))))
 153     ))
 154   (when (featurep 'mule)
 155     (defun gnus-tilde-max-form (el max-width)
 156       "Return a form that limits EL to MAX-WIDTH."
 157       (let ((max (abs max-width)))
 158         (if (symbolp el)
 159             (if (< max-width 0)
 160                 `(let ((width (string-width ,el)))
 161                    (gnus-truncate-string ,el width (- width ,max)))
 162               `(gnus-truncate-string ,el ,max))
 163           (if (< max-width 0)
 164               `(let* ((val (eval ,el))
 165                       (width (string-width val)))
 166                  (gnus-truncate-string val width (- width ,max)))
 167             `(let ((val (eval ,el)))
 168                (gnus-truncate-string val ,max))))))
 169
 170     (defun gnus-tilde-cut-form (el cut-width)
 171       "Return a form that cuts CUT-WIDTH off of EL."
 172       (let ((cut (abs cut-width)))
 173         (if (symbolp el)
 174             (if (< cut-width 0)
 175                 `(gnus-truncate-string ,el (- (string-width ,el) ,cut))
 176               `(gnus-truncate-string ,el (string-width ,el) ,cut))
 177           (if (< cut-width 0)
 178               `(let ((val (eval ,el)))
 179                  (gnus-truncate-string val (- (string-width val) ,cut)))
 180             `(let ((val (eval ,el)))
 181                (gnus-truncate-string val (string-width val) ,cut))))))
 182     ))
 183
 184 (defun gnus-region-active-p ()
 185   "Say whether the region is active."
 186   (and (boundp 'transient-mark-mode)
 187        transient-mark-mode
 188        (boundp 'mark-active)
 189        mark-active))
 190
 191 (defun gnus-add-minor-mode (mode name map)
 192   (if (fboundp 'add-minor-mode)
 193       (add-minor-mode mode name map)
 194     (set (make-local-variable mode) t)
 195     (unless (assq mode minor-mode-alist)
 196       (push `(,mode ,name) minor-mode-alist))
 197     (unless (assq mode minor-mode-map-alist)
 198       (push (cons mode map)
 199             minor-mode-map-alist))))
 200
 201 (defun gnus-x-splash ()
 202   "Show a splash screen using a pixmap in the current buffer."
 203   (let ((dir (nnheader-find-etc-directory "gnus"))
 204         pixmap file height beg i)
 205     (save-excursion
 206       (switch-to-buffer (gnus-get-buffer-create gnus-group-buffer))
 207       (let ((buffer-read-only nil))
 208         (erase-buffer)
 209         (when (and dir
 210                    (file-exists-p (setq file (concat dir "x-splash"))))
 211           (with-temp-buffer
 212             (insert-file-contents-as-binary file)
 213             (goto-char (point-min))
 214             (ignore-errors
 215               (setq pixmap (read (current-buffer))))))
 216         (when pixmap
 217           (unless (facep 'gnus-splash)
 218             (make-face 'gnus-splash))
 219           (setq height (/ (car pixmap) (frame-char-height))
 220                 width (/ (cadr pixmap) (frame-char-width)))
 221           (set-face-foreground 'gnus-splash "Brown")
 222           (set-face-stipple 'gnus-splash pixmap)
 223           (insert-char ?\n (* (/ (window-height) 2 height) height))
 224           (setq i height)
 225           (while (> i 0)
 226             (insert-char ?  (* (/ (window-width) 2 width) width))
 227             (setq beg (point))
 228             (insert-char ?  width)
 229             (set-text-properties beg (point) '(face gnus-splash))
 230             (insert "\n")
 231             (decf i))
 232           (goto-char (point-min))
 233           (sit-for 0))))))
 234
 235 (defun-maybe assoc-ignore-case (key alist)
 236   "Like `assoc', but assumes KEY is a string and ignores case when comparing."
 237   (setq key (downcase key))
 238   (let (element)
 239     (while (and alist (not element))
 240       (if (equal key (downcase (car (car alist))))
 241           (setq element (car alist)))
 242       (setq alist (cdr alist)))
 243     element))
 244
 245 \f
 246 ;;; Language support staffs.
 247
 248 (defvar-maybe current-language-environment "English"
 249   "The language environment.")
 250
 251 (defvar-maybe language-info-alist nil
 252   "Alist of language environment definitions.")
 253
 254 (defun-maybe get-language-info (lang-env key)
 255   "Return information listed under KEY for language environment LANG-ENV."
 256   (if (symbolp lang-env)
 257       (setq lang-env (symbol-name lang-env)))
 258   (let ((lang-slot (assoc-ignore-case lang-env language-info-alist)))
 259     (if lang-slot
 260         (cdr (assq key (cdr lang-slot))))))
 261
 262 (defun-maybe set-language-info (lang-env key info)
 263   "Modify part of the definition of language environment LANG-ENV."
 264   (if (symbolp lang-env)
 265       (setq lang-env (symbol-name lang-env)))
 266   (let (lang-slot key-slot)
 267     (setq lang-slot (assoc lang-env language-info-alist))
 268     (if (null lang-slot)                ; If no slot for the language, add it.
 269         (setq lang-slot (list lang-env)
 270               language-info-alist (cons lang-slot language-info-alist)))
 271     (setq key-slot (assq key lang-slot))
 272     (if (null key-slot)                 ; If no slot for the key, add it.
 273         (progn
 274           (setq key-slot (list key))
 275           (setcdr lang-slot (cons key-slot (cdr lang-slot)))))
 276     (setcdr key-slot info)))
 277
 278 (provide 'gnus-ems)
 279
 280 ;; Local Variables:
 281 ;; byte-compile-warnings: '(redefine callargs)
 282 ;; End:
 283
 284 ;;; gnus-ems.el ends here