(gnus-x-splash): Bind width, height.
[gnus] / 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 (featurep 'xemacs)
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 (autoload 'gnus-smiley-display "smiley-ems") ; override XEmacs version
53
54 ;;; Mule functions.
55
56 (defun gnus-mule-max-width-function (el max-width)
57   `(let* ((val (eval (, el)))
58           (valstr (if (numberp val)
59                       (int-to-string val) val)))
60      (if (> (length valstr) ,max-width)
61          (truncate-string-to-width valstr ,max-width)
62        valstr)))
63
64 (eval-and-compile
65   (if gnus-xemacs
66       (gnus-xmas-define)
67     (defvar gnus-mouse-face-prop 'mouse-face
68       "Property used for highlighting mouse regions.")))
69
70 (eval-and-compile
71   (let ((case-fold-search t))
72     (cond
73      ((string-match "windows-nt\\|os/2\\|emx\\|cygwin32"
74                     (symbol-name system-type))
75       (setq nnheader-file-name-translation-alist
76             (append nnheader-file-name-translation-alist
77                     (mapcar (lambda (c) (cons c ?_))
78                             '(?: ?* ?\" ?< ?> ??))
79                     '((?+ . ?-))))))))
80
81 (defvar gnus-tmp-unread)
82 (defvar gnus-tmp-replied)
83 (defvar gnus-tmp-score-char)
84 (defvar gnus-tmp-indentation)
85 (defvar gnus-tmp-opening-bracket)
86 (defvar gnus-tmp-lines)
87 (defvar gnus-tmp-name)
88 (defvar gnus-tmp-closing-bracket)
89 (defvar gnus-tmp-subject-or-nil)
90
91 (defun gnus-ems-redefine ()
92   (cond
93    (gnus-xemacs
94     (gnus-xmas-redefine))
95
96    ((featurep 'mule)
97     ;; Mule and new Emacs definitions
98
99     ;; [Note] Now there are three kinds of mule implementations,
100     ;; original MULE, XEmacs/mule and Emacs 20+ including
101     ;; MULE features.  Unfortunately these API are different.  In
102     ;; particular, Emacs (including original MULE) and XEmacs are
103     ;; quite different.  Howvere, this version of Gnus doesn't support
104     ;; anything other than XEmacs 20+ and Emacs 20.3+.
105
106     ;; Predicates to check are following:
107     ;; (boundp 'MULE) is t only if MULE (original; anything older than
108     ;;                     Mule 2.3) is running.
109     ;; (featurep 'mule) is t when every mule variants are running.
110
111     ;; It is possible to detect XEmacs/mule by (featurep 'mule) and
112     ;; checking `emacs-version'.  In this case, the implementation for
113     ;; XEmacs/mule may be shareable between XEmacs and XEmacs/mule.
114
115     (defvar gnus-summary-display-table nil
116       "Display table used in summary mode buffers.")
117     (defalias 'gnus-max-width-function 'gnus-mule-max-width-function)
118
119     (when (boundp 'gnus-check-before-posting)
120       (setq gnus-check-before-posting
121             (delq 'long-lines
122                   (delq 'control-chars gnus-check-before-posting))))
123
124     (defun gnus-summary-line-format-spec ()
125       (insert gnus-tmp-unread gnus-tmp-replied
126               gnus-tmp-score-char gnus-tmp-indentation)
127       (put-text-property
128        (point)
129        (progn
130          (insert
131           gnus-tmp-opening-bracket
132           (format "%4d: %-20s"
133                   gnus-tmp-lines
134                   (if (> (length gnus-tmp-name) 20)
135                       (truncate-string-to-width gnus-tmp-name 20)
136                     gnus-tmp-name))
137           gnus-tmp-closing-bracket)
138          (point))
139        gnus-mouse-face-prop gnus-mouse-face)
140       (insert " " gnus-tmp-subject-or-nil "\n")))))
141
142 (defun gnus-region-active-p ()
143   "Say whether the region is active."
144   (and (boundp 'transient-mark-mode)
145        transient-mark-mode
146        (boundp 'mark-active)
147        mark-active))
148
149 (if (fboundp 'add-minor-mode)
150     (defalias 'gnus-add-minor-mode 'add-minor-mode)
151   (defun gnus-add-minor-mode (mode name map &rest rest)
152     (set (make-local-variable mode) t)
153     (unless (assq mode minor-mode-alist)
154       (push `(,mode ,name) minor-mode-alist))
155     (unless (assq mode minor-mode-map-alist)
156       (push (cons mode map)
157             minor-mode-map-alist))))
158
159 (defun gnus-x-splash ()
160   "Show a splash screen using a pixmap in the current buffer."
161   (let ((dir (nnheader-find-etc-directory "gnus"))
162         pixmap file height beg i)
163     (save-excursion
164       (switch-to-buffer (gnus-get-buffer-create gnus-group-buffer))
165       (let ((buffer-read-only nil)
166             width height)
167         (erase-buffer)
168         (when (and dir
169                    (file-exists-p (setq file
170                                         (expand-file-name "x-splash" dir))))
171           (with-temp-buffer
172             (insert-file-contents file)
173             (goto-char (point-min))
174             (ignore-errors
175               (setq pixmap (read (current-buffer))))))
176         (when pixmap
177           (make-face 'gnus-splash)
178           (setq height (/ (car pixmap) (frame-char-height))
179                 width (/ (cadr pixmap) (frame-char-width)))
180           (set-face-foreground 'gnus-splash "Brown")
181           (set-face-stipple 'gnus-splash pixmap)
182           (insert-char ?\n (* (/ (window-height) 2 height) height))
183           (setq i height)
184           (while (> i 0)
185             (insert-char ?\  (* (/ (window-width) 2 width) width))
186             (setq beg (point))
187             (insert-char ?\  width)
188             (set-text-properties beg (point) '(face gnus-splash))
189             (insert ?\n)
190             (decf i))
191           (goto-char (point-min))
192           (sit-for 0))))))
193
194 (defvar gnus-article-xface-ring-internal nil
195   "Cache for face data.")
196
197 ;; Worth customizing?
198 (defvar gnus-article-xface-ring-size 6
199   "Length of the ring used for `gnus-article-xface-ring-internal'.")
200
201 (defvar gnus-article-compface-xbm
202   (eq 0 (string-match "#define" (shell-command-to-string "uncompface -X")))
203   "Non-nil means the compface program supports the -X option.
204 That produces XBM output.")
205
206 (defun gnus-article-display-xface (beg end)
207   "Display an XFace header from between BEG and END in the current article.
208 Requires support for images in your Emacs and the external programs
209 `uncompface', and `icontopbm'.  On a GNU/Linux system these
210 might be in packages with names like `compface' or `faces-xface' and
211 `netpbm' or `libgr-progs', for instance.  See also
212 `gnus-article-compface-xbm'.
213
214 This function is for Emacs 21+.  See `gnus-xmas-article-display-xface'
215 for XEmacs."
216   ;; It might be worth converting uncompface's output in Lisp.
217
218   (when (if (fboundp 'display-graphic-p)
219             (display-graphic-p))
220     (unless gnus-article-xface-ring-internal ; Only load ring when needed.
221       (setq gnus-article-xface-ring-internal
222             (make-ring gnus-article-xface-ring-size)))
223     (save-excursion
224       (let* ((cur (current-buffer))
225              (data (buffer-substring beg end))
226              (image (cdr-safe (assoc data (ring-elements
227                                            gnus-article-xface-ring-internal))))
228              default-enable-multibyte-characters)
229         (unless image
230           (with-temp-buffer
231             (insert data)
232             (and (eq 0 (apply #'call-process-region (point-min) (point-max)
233                               "uncompface"
234                               'delete '(t nil) nil
235                               (if gnus-article-compface-xbm
236                                   '("-X"))))
237                  (if gnus-article-compface-xbm
238                      t
239                    (goto-char (point-min))
240                    (progn (insert "/* Width=48, Height=48 */\n") t)
241                    (eq 0 (call-process-region (point-min) (point-max)
242                                               "icontopbm"
243                                               'delete '(t nil))))
244                  ;; Miles Bader says that faces don't look right as
245                  ;; light on dark.
246                  (if (eq 'dark (cdr-safe (assq 'background-mode
247                                                (frame-parameters))))
248                      (setq image (create-image (buffer-string)
249                                                (if gnus-article-compface-xbm
250                                                    'xbm
251                                                  'pbm)
252                                                t
253                                                :ascent 'center
254                                                :foreground "black"
255                                                :background "white"))
256                    (setq image (create-image (buffer-string)
257                                              (if gnus-article-compface-xbm
258                                                  'xbm
259                                                'pbm)
260                                              t
261                                              :ascent 'center)))))
262           (ring-insert gnus-article-xface-ring-internal (cons data image)))
263         (when image
264           (goto-char (point-min))
265           (re-search-forward "^From:" nil 'move)
266           (insert-image image))))))
267
268 (provide 'gnus-ems)
269
270 ;; Local Variables:
271 ;; byte-compile-warnings: '(redefine callargs)
272 ;; End:
273
274 ;;; gnus-ems.el ends here