cgit.sxemacs.org Git - gnus/blob - lisp/gnus-ems.el

   1 ;;; gnus-ems.el --- functions for making 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 ;; Keywords: news
   7
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs is free software; you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation; either version 2, or (at your option)
  13 ;; any later version.
  14
  15 ;; GNU Emacs is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23 ;; Boston, MA 02111-1307, USA.
  24
  25 ;;; Commentary:
  26
  27 ;;; Code:
  28
  29 (eval-when-compile (require 'cl))
  30
  31 ;;; Function aliases later to be redefined for XEmacs usage.
  32
  33 (eval-and-compile
  34   (defvar gnus-xemacs (string-match "XEmacs" emacs-version)
  35     "Non-nil if running under XEmacs."))
  36
  37 (defvar gnus-mouse-2 [mouse-2])
  38 (defvar gnus-down-mouse-3 [down-mouse-3])
  39 (defvar gnus-down-mouse-2 [down-mouse-2])
  40 (defvar gnus-widget-button-keymap nil)
  41 (defvar gnus-mode-line-modified
  42   (if (or gnus-xemacs
  43           (< emacs-major-version 20))
  44       '("--**-" . "-----")
  45     '("**" "--")))
  46
  47 (eval-and-compile
  48   (autoload 'gnus-xmas-define "gnus-xmas")
  49   (autoload 'gnus-xmas-redefine "gnus-xmas")
  50   (autoload 'appt-select-lowest-window "appt"))
  51
  52 ;;; Mule functions.
  53
  54 (defun gnus-mule-max-width-function (el max-width)
  55   `(let* ((val (eval (, el)))
  56           (valstr (if (numberp val)
  57                       (int-to-string val) val)))
  58      (if (> (length valstr) ,max-width)
  59          (truncate-string-to-width valstr ,max-width)
  60        valstr)))
  61
  62 (eval-and-compile
  63   (if gnus-xemacs
  64       (gnus-xmas-define)
  65     (defvar gnus-mouse-face-prop 'mouse-face
  66       "Property used for highlighting mouse regions.")))
  67
  68 (eval-and-compile
  69   (cond
  70    ((not window-system)
  71     (defun gnus-dummy-func (&rest args))
  72     (let ((funcs '(mouse-set-point set-face-foreground
  73                                    set-face-background x-popup-menu)))
  74       (while funcs
  75         (unless (fboundp (car funcs))
  76           (defalias (car funcs) 'gnus-dummy-func))
  77         (setq funcs (cdr funcs)))))))
  78
  79 (eval-and-compile
  80   (let ((case-fold-search t))
  81     (cond
  82      ((string-match "windows-nt\\|os/2\\|emx\\|cygwin32"
  83                     (symbol-name system-type))
  84       (setq nnheader-file-name-translation-alist
  85             (append nnheader-file-name-translation-alist
  86                     (mapcar (lambda (c) (cons c ?_))
  87                             '(?: ?* ?\" ?< ?> ??))
  88                     '((?+ . ?-))))))))
  89
  90 (defvar gnus-tmp-unread)
  91 (defvar gnus-tmp-replied)
  92 (defvar gnus-tmp-score-char)
  93 (defvar gnus-tmp-indentation)
  94 (defvar gnus-tmp-opening-bracket)
  95 (defvar gnus-tmp-lines)
  96 (defvar gnus-tmp-name)
  97 (defvar gnus-tmp-closing-bracket)
  98 (defvar gnus-tmp-subject-or-nil)
  99
 100 (defun gnus-ems-redefine ()
 101   (cond
 102    (gnus-xemacs
 103     (gnus-xmas-redefine))
 104
 105    ((featurep 'mule)
 106     ;; Mule and new Emacs definitions
 107
 108     ;; [Note] Now there are three kinds of mule implementations,
 109     ;; original MULE, XEmacs/mule and Emacs 20+ including
 110     ;; MULE features.  Unfortunately these API are different.  In
 111     ;; particular, Emacs (including original MULE) and XEmacs are
 112     ;; quite different.  Howvere, this version of Gnus doesn't support
 113     ;; anything other than XEmacs 20+ and Emacs 20.3+.
 114
 115     ;; Predicates to check are following:
 116     ;; (boundp 'MULE) is t only if MULE (original; anything older than
 117     ;;                     Mule 2.3) is running.
 118     ;; (featurep 'mule) is t when every mule variants are running.
 119
 120     ;; It is possible to detect XEmacs/mule by (featurep 'mule) and
 121     ;; checking `emacs-version'.  In this case, the implementation for
 122     ;; XEmacs/mule may be shareable between XEmacs and XEmacs/mule.
 123
 124     (defvar gnus-summary-display-table nil
 125       "Display table used in summary mode buffers.")
 126     (defalias 'gnus-max-width-function 'gnus-mule-max-width-function)
 127     (defalias 'gnus-summary-set-display-table (lambda ()))
 128
 129     (when (boundp 'gnus-check-before-posting)
 130       (setq gnus-check-before-posting
 131             (delq 'long-lines
 132                   (delq 'control-chars gnus-check-before-posting))))
 133
 134     (defun gnus-summary-line-format-spec ()
 135       (insert gnus-tmp-unread gnus-tmp-replied
 136               gnus-tmp-score-char gnus-tmp-indentation)
 137       (put-text-property
 138        (point)
 139        (progn
 140          (insert
 141           gnus-tmp-opening-bracket
 142           (format "%4d: %-20s"
 143                   gnus-tmp-lines
 144                   (if (> (length gnus-tmp-name) 20)
 145                       (truncate-string-to-width gnus-tmp-name 20)
 146                     gnus-tmp-name))
 147           gnus-tmp-closing-bracket)
 148          (point))
 149        gnus-mouse-face-prop gnus-mouse-face)
 150       (insert " " gnus-tmp-subject-or-nil "\n")))))
 151
 152 (defun gnus-region-active-p ()
 153   "Say whether the region is active."
 154   (and (boundp 'transient-mark-mode)
 155        transient-mark-mode
 156        (boundp 'mark-active)
 157        mark-active))
 158
 159 (defun gnus-add-minor-mode (mode name map)
 160   (if (fboundp 'add-minor-mode)
 161       (add-minor-mode mode name map)
 162     (set (make-local-variable mode) t)
 163     (unless (assq mode minor-mode-alist)
 164       (push `(,mode ,name) minor-mode-alist))
 165     (unless (assq mode minor-mode-map-alist)
 166       (push (cons mode map)
 167             minor-mode-map-alist))))
 168
 169 (defun gnus-x-splash ()
 170   "Show a splash screen using a pixmap in the current buffer."
 171   (let ((dir (nnheader-find-etc-directory "gnus"))
 172         pixmap file height beg i)
 173     (save-excursion
 174       (switch-to-buffer (gnus-get-buffer-create gnus-group-buffer))
 175       (let ((buffer-read-only nil))
 176         (erase-buffer)
 177         (when (and dir
 178                    (file-exists-p (setq file (concat dir "x-splash"))))
 179           (with-temp-buffer
 180             (insert-file-contents file)
 181             (goto-char (point-min))
 182             (ignore-errors
 183               (setq pixmap (read (current-buffer))))))
 184         (when pixmap
 185           (unless (facep 'gnus-splash)
 186             (make-face 'gnus-splash))
 187           (setq height (/ (car pixmap) (frame-char-height))
 188                 width (/ (cadr pixmap) (frame-char-width)))
 189           (set-face-foreground 'gnus-splash "Brown")
 190           (set-face-stipple 'gnus-splash pixmap)
 191           (insert-char ?\n (* (/ (window-height) 2 height) height))
 192           (setq i height)
 193           (while (> i 0)
 194             (insert-char ?  (* (/ (window-width) 2 width) width))
 195             (setq beg (point))
 196             (insert-char ?  width)
 197             (set-text-properties beg (point) '(face gnus-splash))
 198             (insert "\n")
 199             (decf i))
 200           (goto-char (point-min))
 201           (sit-for 0))))))
 202
 203 (defun gnus-article-display-xface (beg end)
 204   "Display an XFace header from between BEG and END in the current article.
 205 This requires support for XPM or XBM images in your Emacs and the
 206 external programs `uncompface', `icontopbm' and either `ppmtoxpm' (for
 207 XPM support) or `ppmtoxbm' (for XBM support).  On a GNU/Linux system
 208 these might be in packages with names like `compface' or `faces-xface'
 209 and `netpbm' or `libgr-progs', for instance.
 210
 211 This function is for Emacs 21+.  See `gnus-xmas-article-display-xface'
 212 for XEmacs."
 213   (save-excursion
 214     (let ((cur (current-buffer))
 215           image type)
 216       (when (and (fboundp 'image-type-available-p)
 217                  (cond ((image-type-available-p 'xpm) (setq type 'xpm))
 218                        ((image-type-available-p 'xbm) (setq type 'xbm))))
 219         (with-temp-buffer
 220           (insert-buffer-substring cur beg end)
 221           (call-process-region (point-min) (point-max) "uncompface"
 222                                'delete '(t nil))
 223           (goto-char (point-min))
 224           (insert "/* Width=48, Height=48 */\n")
 225           (and (eq 0 (call-process-region (point-min) (point-max) "icontopbm"
 226                                           'delete '(t nil)))
 227                (eq 0 (call-process-region (point-min) (point-max)
 228                                           (if (eq type 'xpm)
 229                                               "ppmtoxpm"
 230                                             "pbmtoxbm")
 231                                           'delete '(t nil)))
 232                (setq image (create-image (buffer-string) type t))))
 233         (when image
 234           (goto-char (point-min))
 235           (re-search-forward "^From:" nil 'move)
 236             (insert-image image " "))))))
 237
 238 (provide 'gnus-ems)
 239
 240 ;; Local Variables:
 241 ;; byte-compile-warnings: '(redefine callargs)
 242 ;; End:
 243
 244 ;;; gnus-ems.el ends here