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