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