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