Sync up with Pterodactyl Gnus v0.83.
[elisp/gnus.git-] / lisp / gnus-ems.el
1 ;;; gnus-ems.el --- functions for making Semi-gnus work under different Emacsen
2 ;; Copyright (C) 1995,96,97,98,99 Free Software Foundation, Inc.
3
4 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
5 ;;         Tatsuya Ichikawa <t-ichi@niagara.shiojiri.ne.jp>
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 (defvar gnus-xemacs (string-match "XEmacs\\|Lucid" emacs-version)
34   "Non-nil if running under XEmacs.")
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 gnus-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 (or (fboundp 'mail-file-babyl-p)
52     (fset 'mail-file-babyl-p 'rmail-file-p))
53
54 ;;; Mule functions.
55
56 (defun gnus-mule-cite-add-face (number prefix face)
57   ;; At line NUMBER, ignore PREFIX and add FACE to the rest of the line.
58   (when face
59     (let ((inhibit-point-motion-hooks t)
60           from to)
61       (goto-line number)
62       (unless (eobp)            ; Sometimes things become confused (broken).
63         (forward-char (chars-in-string prefix))
64         (skip-chars-forward " \t")
65         (setq from (point))
66         (end-of-line 1)
67         (skip-chars-backward " \t")
68         (setq to (point))
69         (when (< from to)
70           (push (setq overlay (gnus-make-overlay from to))
71                 gnus-cite-overlay-list)
72           (gnus-overlay-put (gnus-make-overlay from to) 'face face))))))
73
74 (defvar gnus-mule-bitmap-image-file nil)
75 (defun gnus-mule-group-startup-message (&optional x y)
76   "Insert startup message in current buffer."
77   ;; Insert the message.
78   (erase-buffer)
79   (insert
80    (if (featurep 'bitmap)
81      (format "              %s
82
83 "
84              "" (if (and (stringp gnus-mule-bitmap-image-file)
85                          (file-exists-p gnus-mule-bitmap-image-file))
86                     (insert-file gnus-mule-bitmap-image-file)))
87      (format "              %s
88           _    ___ _             _
89           _ ___ __ ___  __    _ ___
90           __   _     ___    __  ___
91               _           ___     _
92              _  _ __             _
93              ___   __            _
94                    __           _
95                     _      _   _
96                    _      _    _
97                       _  _    _
98                   __  ___
99                  _   _ _     _
100                 _   _
101               _    _
102              _    _
103             _
104           __
105
106 "
107              "")))
108   ;; And then hack it.
109   (gnus-indent-rigidly (point-min) (point-max)
110                        (/ (max (- (window-width) (or x 46)) 0) 2))
111   (goto-char (point-min))
112   (forward-line 1)
113   (let* ((pheight (count-lines (point-min) (point-max)))
114          (wheight (window-height))
115          (rest (- wheight pheight)))
116     (insert (make-string (max 0 (* 2 (/ rest 3))) ?\n)))
117   ;; Fontify some.
118   (put-text-property (point-min) (point-max) 'face 'gnus-splash-face)
119   (goto-char (point-min))
120   (setq mode-line-buffer-identification (concat " " gnus-version))
121   (setq gnus-simple-splash t)
122   (set-buffer-modified-p t))
123
124 (eval-and-compile
125   (if (string-match "XEmacs\\|Lucid" emacs-version)
126       nil
127
128     (defvar gnus-mouse-face-prop 'mouse-face
129       "Property used for highlighting mouse regions."))
130
131   (cond
132    ((string-match "XEmacs\\|Lucid" emacs-version)
133     (gnus-xmas-define))
134
135    ((or (not (boundp 'emacs-minor-version))
136         (and (< emacs-major-version 20)
137              (< emacs-minor-version 30)))
138     ;; Remove the `intangible' prop.
139     (let ((props (and (boundp 'gnus-hidden-properties)
140                       gnus-hidden-properties)))
141       (while (and props (not (eq (car (cdr props)) 'intangible)))
142         (setq props (cdr props)))
143       (when props
144         (setcdr props (cdr (cdr (cdr props))))))
145     (unless (fboundp 'buffer-substring-no-properties)
146       (defun buffer-substring-no-properties (beg end)
147         (format "%s" (buffer-substring beg end)))))
148
149    ((boundp 'MULE)
150     (provide 'gnusutil))))
151
152 (eval-and-compile
153   (cond
154    ((not window-system)
155     (defun gnus-dummy-func (&rest args))
156     (let ((funcs '(mouse-set-point set-face-foreground
157                                    set-face-background x-popup-menu)))
158       (while funcs
159         (unless (fboundp (car funcs))
160           (fset (car funcs) 'gnus-dummy-func))
161         (setq funcs (cdr funcs)))))))
162
163 (eval-and-compile
164   (let ((case-fold-search t))
165     (cond
166      ((string-match "windows-nt\\|os/2\\|emx" (symbol-name system-type))
167       (setq nnheader-file-name-translation-alist
168             (append nnheader-file-name-translation-alist
169                     '((?: . ?_)
170                       (?+ . ?-))))))))
171
172 (defvar gnus-tmp-unread)
173 (defvar gnus-tmp-replied)
174 (defvar gnus-tmp-score-char)
175 (defvar gnus-tmp-indentation)
176 (defvar gnus-tmp-opening-bracket)
177 (defvar gnus-tmp-lines)
178 (defvar gnus-tmp-name)
179 (defvar gnus-tmp-closing-bracket)
180 (defvar gnus-tmp-subject-or-nil)
181
182 (defun gnus-ems-redefine ()
183   (cond
184    ((string-match "XEmacs\\|Lucid" emacs-version)
185     (gnus-xmas-redefine))
186
187    ((featurep 'mule)
188     ;; Mule and new Emacs definitions
189
190     ;; [Note] Now there are three kinds of mule implementations,
191     ;; original MULE, XEmacs/mule and beta version of Emacs including
192     ;; some mule features. Unfortunately these API are different. In
193     ;; particular, Emacs (including original MULE) and XEmacs are
194     ;; quite different.
195     ;; Predicates to check are following:
196     ;; (boundp 'MULE) is t only if MULE (original; anything older than
197     ;;                     Mule 2.3) is running.
198     ;; (featurep 'mule) is t when every mule variants are running.
199
200     ;; These implementations may be able to share between original
201     ;; MULE and beta version of new Emacs. In addition, it is able to
202     ;; detect XEmacs/mule by (featurep 'mule) and to check variable
203     ;; `emacs-version'. In this case, implementation for XEmacs/mule
204     ;; may be able to share between XEmacs and XEmacs/mule.
205
206     (defvar gnus-summary-display-table nil
207       "Display table used in summary mode buffers.")
208     (fset 'gnus-summary-set-display-table (lambda ()))
209
210     (if (fboundp 'truncate-string-to-width)
211         (fset 'gnus-truncate-string 'truncate-string-to-width)
212       (fset 'gnus-truncate-string 'truncate-string))
213
214     (defun gnus-tilde-max-form (el max-width)
215       "Return a form that limits EL to MAX-WIDTH."
216       (let ((max (abs max-width)))
217         (if (symbolp el)
218             `(if (> (string-width ,el) ,max)
219                  ,(if (< max-width 0)
220                       `(gnus-truncate-string
221                         ,el (string-width ,el)
222                         (- (string-width ,el) ,max))
223                     `(gnus-truncate-string ,el ,max))
224                ,el)
225           `(let ((val (eval ,el)))
226              (if (> (string-width val) ,max)
227                  ,(if (< max-width 0)
228                       `(gnus-truncate-string
229                         val (string-width val)
230                         (- (string-width val) ,max))
231                     `(gnus-truncate-string val ,max))
232                val)))))
233
234     (defun gnus-tilde-cut-form (el cut-width)
235       "Return a form that cuts CUT-WIDTH off of EL."
236       (let ((cut (abs cut-width)))
237         (if (symbolp el)
238             `(if (> (string-width ,el) ,cut)
239                  ,(if (< cut-width 0)
240                       `(gnus-truncate-string
241                         ,el (- (string-width ,el) ,cut))
242                     `(gnus-truncate-string
243                       ,el (- (string-width ,el) ,cut) ,cut))
244                ,el)
245           `(let ((val (eval ,el)))
246              (if (> (string-width val) ,cut)
247                  ,(if (< cut-width 0)
248                       `(gnus-truncate-string
249                         val (- (string-width val) ,cut))
250                     `(gnus-truncate-string
251                       val (- (string-width val) ,cut) ,cut))
252                val)))))
253
254     (when window-system
255       (require 'path-util)
256       (if (module-installed-p 'bitmap)
257           (fset 'gnus-group-startup-message 'gnus-mule-group-startup-message)
258         ))
259
260     (when (boundp 'gnus-check-before-posting)
261       (setq gnus-check-before-posting
262             (delq 'long-lines
263                   (delq 'control-chars gnus-check-before-posting))))
264
265     (when (fboundp 'chars-in-string)
266       (fset 'gnus-cite-add-face 'gnus-mule-cite-add-face))
267
268     )))
269
270 (defun gnus-region-active-p ()
271   "Say whether the region is active."
272   (and (boundp 'transient-mark-mode)
273        transient-mark-mode
274        (boundp 'mark-active)
275        mark-active))
276
277 (defun gnus-add-minor-mode (mode name map)
278   (if (fboundp 'add-minor-mode)
279       (add-minor-mode mode name map)
280     (set (make-local-variable mode) t)
281     (unless (assq mode minor-mode-alist)
282       (push `(,mode ,name) minor-mode-alist))
283     (unless (assq mode minor-mode-map-alist)
284       (push (cons mode map)
285             minor-mode-map-alist))))
286
287 (defun gnus-x-splash ()
288   "Show a splash screen using a pixmap in the current buffer."
289   (let ((dir (nnheader-find-etc-directory "gnus"))
290         pixmap file height beg i)
291     (save-excursion
292       (switch-to-buffer (gnus-get-buffer-create gnus-group-buffer))
293       (let ((buffer-read-only nil))
294         (erase-buffer)
295         (when (and dir
296                    (file-exists-p (setq file (concat dir "x-splash"))))
297           (with-temp-file nil
298             (insert-file-contents file)
299             (goto-char (point-min))
300             (ignore-errors
301               (setq pixmap (read (current-buffer))))))
302         (when pixmap
303           (unless (facep 'gnus-splash)
304             (make-face 'gnus-splash))
305           (setq height (/ (car pixmap) (frame-char-height))
306                 width (/ (cadr pixmap) (frame-char-width)))
307           (set-face-foreground 'gnus-splash "ForestGreen")
308           (set-face-stipple 'gnus-splash pixmap)
309           (insert-char ?\n (* (/ (window-height) 2 height) height))
310           (setq i height)
311           (while (> i 0)
312             (insert-char ?  (* (/ (window-width) 2 width) width))
313             (setq beg (point))
314             (insert-char ?  width)
315             (set-text-properties beg (point) '(face gnus-splash))
316             (insert "\n")
317             (decf i))
318           (goto-char (point-min))
319           (sit-for 0))))))
320
321 (if (fboundp 'split-string)
322     (fset 'gnus-split-string 'split-string)
323   (defun gnus-split-string (string pattern)
324     "Return a list of substrings of STRING which are separated by PATTERN."
325     (let (parts (start 0))
326       (while (string-match pattern string start)
327         (setq parts (cons (substring string start (match-beginning 0)) parts)
328               start (match-end 0)))
329       (nreverse (cons (substring string start) parts)))))
330
331 (provide 'gnus-ems)
332
333 ;; Local Variables:
334 ;; byte-compile-warnings: '(redefine callargs)
335 ;; End:
336
337 ;;; gnus-ems.el ends here