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