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 (eval-and-compile
  35   (defvar gnus-xemacs (featurep 'xemacs)
  36     "Non-nil if running under XEmacs."))
  37
  38 (defvar gnus-mouse-2 [mouse-2])
  39 (defvar gnus-down-mouse-3 [down-mouse-3])
  40 (defvar gnus-down-mouse-2 [down-mouse-2])
  41 (defvar gnus-widget-button-keymap nil)
  42 (defvar gnus-mode-line-modified
  43   (if (or gnus-xemacs
  44           (< emacs-major-version 20))
  45       '("--**-" . "-----")
  46     '("**" "--")))
  47
  48 (eval-and-compile
  49   (autoload 'gnus-xmas-define "gnus-xmas")
  50   (autoload 'gnus-xmas-redefine "gnus-xmas")
  51   (autoload 'appt-select-lowest-window "appt"))
  52
  53 (or (fboundp 'mail-file-babyl-p)
  54     (fset 'mail-file-babyl-p 'rmail-file-p))
  55
  56 (when (and (not (featurep 'xemacs)) (>= emacs-major-version 21))
  57   (autoload 'gnus-smiley-display "smiley-ems")) ; override XEmacs version
  58
  59 ;;; Mule functions.
  60
  61 (eval-and-compile
  62   (if gnus-xemacs
  63       (gnus-xmas-define)
  64     (defvar gnus-mouse-face-prop 'mouse-face
  65       "Property used for highlighting mouse regions.")))
  66
  67 (eval-and-compile
  68   (let ((case-fold-search t))
  69     (cond
  70      ((string-match "windows-nt\\|os/2\\|emx\\|cygwin32"
  71                     (symbol-name system-type))
  72       (setq nnheader-file-name-translation-alist
  73             (append nnheader-file-name-translation-alist
  74                     (mapcar (lambda (c) (cons c ?_))
  75                             '(?: ?* ?\" ?< ?> ??))
  76                     '((?+ . ?-))))))))
  77
  78 (defvar gnus-tmp-unread)
  79 (defvar gnus-tmp-replied)
  80 (defvar gnus-tmp-score-char)
  81 (defvar gnus-tmp-indentation)
  82 (defvar gnus-tmp-opening-bracket)
  83 (defvar gnus-tmp-lines)
  84 (defvar gnus-tmp-name)
  85 (defvar gnus-tmp-closing-bracket)
  86 (defvar gnus-tmp-subject-or-nil)
  87
  88 (defun gnus-ems-redefine ()
  89   (cond
  90    (gnus-xemacs
  91     (gnus-xmas-redefine))
  92
  93    ((featurep 'mule)
  94     ;; Mule and new Emacs definitions
  95
  96     ;; [Note] Now there are three kinds of mule implementations,
  97     ;; original MULE, XEmacs/mule and Emacs 20+ including
  98     ;; MULE features.  Unfortunately these API are different.  In
  99     ;; particular, Emacs (including original MULE) and XEmacs are
 100     ;; quite different.  However, this version of Gnus doesn't support
 101     ;; anything other than XEmacs 20+ and Emacs 20.3+.
 102
 103     ;; Predicates to check are following:
 104     ;; (boundp 'MULE) is t only if MULE (original; anything older than
 105     ;;                     Mule 2.3) is running.
 106     ;; (featurep 'mule) is t when every mule variants are running.
 107
 108     ;; It is possible to detect XEmacs/mule by (featurep 'mule) and
 109     ;; checking `emacs-version'.  In this case, the implementation for
 110     ;; XEmacs/mule may be shareable between XEmacs and XEmacs/mule.
 111
 112     (defvar gnus-summary-display-table nil
 113       "Display table used in summary mode buffers.")
 114
 115     (defalias 'gnus-summary-set-display-table (lambda ()))
 116
 117     (if (fboundp 'truncate-string-to-width)
 118         (fset 'gnus-truncate-string 'truncate-string-to-width)
 119       (fset 'gnus-truncate-string 'truncate-string))
 120
 121     (when (boundp 'gnus-check-before-posting)
 122       (setq gnus-check-before-posting
 123             (delq 'long-lines
 124                   (delq 'control-chars gnus-check-before-posting))))
 125     ))
 126   (when (featurep 'mule)
 127     (defun gnus-tilde-max-form (el max-width)
 128       "Return a form that limits EL to MAX-WIDTH."
 129       (let ((max (abs max-width)))
 130         (if (symbolp el)
 131             (if (< max-width 0)
 132                 `(let ((width (string-width ,el)))
 133                    (gnus-truncate-string ,el width (- width ,max)))
 134               `(gnus-truncate-string ,el ,max))
 135           (if (< max-width 0)
 136               `(let* ((val (eval ,el))
 137                       (width (string-width val)))
 138                  (gnus-truncate-string val width (- width ,max)))
 139             `(let ((val (eval ,el)))
 140                (gnus-truncate-string val ,max))))))
 141
 142     (defun gnus-tilde-cut-form (el cut-width)
 143       "Return a form that cuts CUT-WIDTH off of EL."
 144       (let ((cut (abs cut-width)))
 145         (if (symbolp el)
 146             (if (< cut-width 0)
 147                 `(gnus-truncate-string ,el (- (string-width ,el) ,cut))
 148               `(gnus-truncate-string ,el (string-width ,el) ,cut))
 149           (if (< cut-width 0)
 150               `(let ((val (eval ,el)))
 151                  (gnus-truncate-string val (- (string-width val) ,cut)))
 152             `(let ((val (eval ,el)))
 153                (gnus-truncate-string val (string-width val) ,cut))))))
 154     ))
 155
 156 (defun gnus-region-active-p ()
 157   "Say whether the region is active."
 158   (and (boundp 'transient-mark-mode)
 159        transient-mark-mode
 160        (boundp 'mark-active)
 161        mark-active))
 162
 163 (if (fboundp 'add-minor-mode)
 164     (defalias 'gnus-add-minor-mode 'add-minor-mode)
 165   (defun gnus-add-minor-mode (mode name map &rest rest)
 166     (set (make-local-variable mode) t)
 167     (unless (assq mode minor-mode-alist)
 168       (push `(,mode ,name) minor-mode-alist))
 169     (unless (assq mode minor-mode-map-alist)
 170       (push (cons mode map)
 171             minor-mode-map-alist))))
 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           (with-temp-buffer
 186             (insert-file-contents-as-binary file)
 187             (goto-char (point-min))
 188             (ignore-errors
 189               (setq pixmap (read (current-buffer))))))
 190         (when pixmap
 191           (make-face 'gnus-splash)
 192           (setq height (/ (car pixmap) (frame-char-height))
 193                 width (/ (cadr pixmap) (frame-char-width)))
 194           (set-face-foreground 'gnus-splash "Brown")
 195           (set-face-stipple 'gnus-splash pixmap)
 196           (insert-char ?\n (* (/ (window-height) 2 height) height))
 197           (setq i height)
 198           (while (> i 0)
 199             (insert-char ?\  (* (/ (window-width) 2 width) width))
 200             (setq beg (point))
 201             (insert-char ?\  width)
 202             (set-text-properties beg (point) '(face gnus-splash))
 203             (insert ?\n)
 204             (decf i))
 205           (goto-char (point-min))
 206           (sit-for 0))))))
 207
 208 (defvar gnus-article-xface-ring-internal nil
 209   "Cache for face data.")
 210
 211 ;; Worth customizing?
 212 (defvar gnus-article-xface-ring-size 6
 213   "Length of the ring used for `gnus-article-xface-ring-internal'.")
 214
 215 (defvar gnus-article-compface-xbm
 216   (when (and (not (featurep 'xemacs)) (>= emacs-major-version 21))
 217     (eq 0 (string-match "#define" (shell-command-to-string "uncompface -X"))))
 218   "Non-nil means the compface program supports the -X option.
 219 That produces XBM output.")
 220
 221 (defun gnus-article-display-xface (beg end)
 222   "Display an XFace header from between BEG and END in the current article.
 223 Requires support for images in your Emacs and the external programs
 224 `uncompface', and `icontopbm'.  On a GNU/Linux system these
 225 might be in packages with names like `compface' or `faces-xface' and
 226 `netpbm' or `libgr-progs', for instance.  See also
 227 `gnus-article-compface-xbm'.
 228
 229 This function is for Emacs 21+.  See `gnus-xmas-article-display-xface'
 230 for XEmacs."
 231   ;; It might be worth converting uncompface's output in Lisp.
 232
 233   (when (if (fboundp 'display-graphic-p)
 234             (display-graphic-p))
 235     (unless gnus-article-xface-ring-internal ; Only load ring when needed.
 236       (setq gnus-article-xface-ring-internal
 237             (make-ring gnus-article-xface-ring-size)))
 238     (save-excursion
 239       (let* ((cur (current-buffer))
 240              (data (buffer-substring beg end))
 241              (image (cdr-safe (assoc data (ring-elements
 242                                            gnus-article-xface-ring-internal))))
 243              default-enable-multibyte-characters)
 244         (unless image
 245           (with-temp-buffer
 246             (insert data)
 247             (and (eq 0 (apply #'call-process-region (point-min) (point-max)
 248                               "uncompface"
 249                               'delete '(t nil) nil
 250                               (if gnus-article-compface-xbm
 251                                   '("-X"))))
 252                  (if gnus-article-compface-xbm
 253                      t
 254                    (goto-char (point-min))
 255                    (progn (insert "/* Width=48, Height=48 */\n") t)
 256                    (eq 0 (call-process-region (point-min) (point-max)
 257                                               "icontopbm"
 258                                               'delete '(t nil))))
 259                  ;; Miles Bader says that faces don't look right as
 260                  ;; light on dark.
 261                  (if (eq 'dark (cdr-safe (assq 'background-mode
 262                                                (frame-parameters))))
 263                      (setq image (create-image (buffer-string)
 264                                                (if gnus-article-compface-xbm
 265                                                    'xbm
 266                                                  'pbm)
 267                                                t
 268                                                :ascent 'center
 269                                                :foreground "black"
 270                                                :background "white"))
 271                    (setq image (create-image (buffer-string)
 272                                              (if gnus-article-compface-xbm
 273                                                  'xbm
 274                                                'pbm)
 275                                              t
 276                                              :ascent 'center)))))
 277           (ring-insert gnus-article-xface-ring-internal (cons data image)))
 278         (when image
 279           (goto-char (point-min))
 280           (re-search-forward "^From:" nil 'move)
 281           (insert-image image))))))
 282
 283 (defun-maybe assoc-ignore-case (key alist)
 284   "Like `assoc', but assumes KEY is a string and ignores case when comparing."
 285   (setq key (downcase key))
 286   (let (element)
 287     (while (and alist (not element))
 288       (if (equal key (downcase (car (car alist))))
 289           (setq element (car alist)))
 290       (setq alist (cdr alist)))
 291     element))
 292
 293 \f
 294 ;;; Language support staffs.
 295
 296 (defvar-maybe current-language-environment "English"
 297   "The language environment.")
 298
 299 (defvar-maybe language-info-alist nil
 300   "Alist of language environment definitions.")
 301
 302 (defun-maybe get-language-info (lang-env key)
 303   "Return information listed under KEY for language environment LANG-ENV."
 304   (if (symbolp lang-env)
 305       (setq lang-env (symbol-name lang-env)))
 306   (let ((lang-slot (assoc-ignore-case lang-env language-info-alist)))
 307     (if lang-slot
 308         (cdr (assq key (cdr lang-slot))))))
 309
 310 (defun-maybe set-language-info (lang-env key info)
 311   "Modify part of the definition of language environment LANG-ENV."
 312   (if (symbolp lang-env)
 313       (setq lang-env (symbol-name lang-env)))
 314   (let (lang-slot key-slot)
 315     (setq lang-slot (assoc lang-env language-info-alist))
 316     (if (null lang-slot)                ; If no slot for the language, add it.
 317         (setq lang-slot (list lang-env)
 318               language-info-alist (cons lang-slot language-info-alist)))
 319     (setq key-slot (assq key lang-slot))
 320     (if (null key-slot)                 ; If no slot for the key, add it.
 321         (progn
 322           (setq key-slot (list key))
 323           (setcdr lang-slot (cons key-slot (cdr lang-slot)))))
 324     (setcdr key-slot info)))
 325
 326 (provide 'gnus-ems)
 327
 328 ;; Local Variables:
 329 ;; byte-compile-warnings: '(redefine callargs)
 330 ;; End:
 331
 332 ;;; gnus-ems.el ends here