Mercurial > emacs
annotate lisp/gnus/gnus-ems.el @ 84969:6e58c1c8c0fc
(Fgpm_mouse_start): Don't signal an error if already activated on this tty.
(Fgpm_mouse_stop): Only deactivate if it was activated on this tty.
author | Stefan Monnier <monnier@iro.umontreal.ca> |
---|---|
date | Fri, 28 Sep 2007 20:07:54 +0000 |
parents | 28c0174177f4 |
children | f4c90d55f00f a3c27999decb 424b655804ca |
rev | line source |
---|---|
17493 | 1 ;;; gnus-ems.el --- functions for making Gnus work under different Emacsen |
64754
fafd692d1e40
Update years in copyright notice; nfc.
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
64085
diff
changeset
|
2 |
fafd692d1e40
Update years in copyright notice; nfc.
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
64085
diff
changeset
|
3 ;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, |
75347 | 4 ;; 2004, 2005, 2006, 2007 Free Software Foundation, Inc. |
17493 | 5 |
24357
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
20118
diff
changeset
|
6 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> |
17493 | 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 | |
78224
24202b793a08
Switch license to GPLv3 or later.
Glenn Morris <rgm@gnu.org>
parents:
78013
diff
changeset
|
13 ;; the Free Software Foundation; either version 3, or (at your option) |
17493 | 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 | |
64085 | 23 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, |
24 ;; Boston, MA 02110-1301, USA. | |
17493 | 25 |
26 ;;; Commentary: | |
27 | |
28 ;;; Code: | |
29 | |
33814 | 30 (eval-when-compile |
31 (require 'cl) | |
32 (require 'ring)) | |
17493 | 33 |
34 ;;; Function aliases later to be redefined for XEmacs usage. | |
35 | |
36 (defvar gnus-mouse-2 [mouse-2]) | |
31716
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24357
diff
changeset
|
37 (defvar gnus-down-mouse-3 [down-mouse-3]) |
17493 | 38 (defvar gnus-down-mouse-2 [down-mouse-2]) |
31716
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24357
diff
changeset
|
39 (defvar gnus-widget-button-keymap nil) |
19969
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
17493
diff
changeset
|
40 (defvar gnus-mode-line-modified |
32920
5b203c66fa7b
2000-10-08 08:57:13 ShengHuo ZHU <zsh@cs.rochester.edu>
Dave Love <fx@gnu.org>
parents:
32139
diff
changeset
|
41 (if (or (featurep 'xemacs) |
19969
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
17493
diff
changeset
|
42 (< emacs-major-version 20)) |
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
17493
diff
changeset
|
43 '("--**-" . "-----") |
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
17493
diff
changeset
|
44 '("**" "--"))) |
17493 | 45 |
46 (eval-and-compile | |
47 (autoload 'gnus-xmas-define "gnus-xmas") | |
48 (autoload 'gnus-xmas-redefine "gnus-xmas") | |
56927
55fd4f77387a
Revision: miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-523
Miles Bader <miles@gnu.org>
parents:
52401
diff
changeset
|
49 (autoload 'appt-select-lowest-window "appt") |
55fd4f77387a
Revision: miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-523
Miles Bader <miles@gnu.org>
parents:
52401
diff
changeset
|
50 (autoload 'gnus-get-buffer-create "gnus") |
55fd4f77387a
Revision: miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-523
Miles Bader <miles@gnu.org>
parents:
52401
diff
changeset
|
51 (autoload 'nnheader-find-etc-directory "nnheader")) |
17493 | 52 |
56927
55fd4f77387a
Revision: miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-523
Miles Bader <miles@gnu.org>
parents:
52401
diff
changeset
|
53 (autoload 'smiley-region "smiley") |
55fd4f77387a
Revision: miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-523
Miles Bader <miles@gnu.org>
parents:
52401
diff
changeset
|
54 ;; Fixme: shouldn't require message |
55fd4f77387a
Revision: miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-523
Miles Bader <miles@gnu.org>
parents:
52401
diff
changeset
|
55 (autoload 'message-text-with-property "message") |
32920
5b203c66fa7b
2000-10-08 08:57:13 ShengHuo ZHU <zsh@cs.rochester.edu>
Dave Love <fx@gnu.org>
parents:
32139
diff
changeset
|
56 |
5b203c66fa7b
2000-10-08 08:57:13 ShengHuo ZHU <zsh@cs.rochester.edu>
Dave Love <fx@gnu.org>
parents:
32139
diff
changeset
|
57 (defun gnus-kill-all-overlays () |
5b203c66fa7b
2000-10-08 08:57:13 ShengHuo ZHU <zsh@cs.rochester.edu>
Dave Love <fx@gnu.org>
parents:
32139
diff
changeset
|
58 "Delete all overlays in the current buffer." |
5b203c66fa7b
2000-10-08 08:57:13 ShengHuo ZHU <zsh@cs.rochester.edu>
Dave Love <fx@gnu.org>
parents:
32139
diff
changeset
|
59 (let* ((overlayss (overlay-lists)) |
5b203c66fa7b
2000-10-08 08:57:13 ShengHuo ZHU <zsh@cs.rochester.edu>
Dave Love <fx@gnu.org>
parents:
32139
diff
changeset
|
60 (buffer-read-only nil) |
5b203c66fa7b
2000-10-08 08:57:13 ShengHuo ZHU <zsh@cs.rochester.edu>
Dave Love <fx@gnu.org>
parents:
32139
diff
changeset
|
61 (overlays (delq nil (nconc (car overlayss) (cdr overlayss))))) |
5b203c66fa7b
2000-10-08 08:57:13 ShengHuo ZHU <zsh@cs.rochester.edu>
Dave Love <fx@gnu.org>
parents:
32139
diff
changeset
|
62 (while overlays |
5b203c66fa7b
2000-10-08 08:57:13 ShengHuo ZHU <zsh@cs.rochester.edu>
Dave Love <fx@gnu.org>
parents:
32139
diff
changeset
|
63 (delete-overlay (pop overlays))))) |
31780
d2b5643aab16
(gnus-smiley-display): Autoload from smiley-ems.
Dave Love <fx@gnu.org>
parents:
31767
diff
changeset
|
64 |
17493 | 65 ;;; Mule functions. |
66 | |
67 (defun gnus-mule-max-width-function (el max-width) | |
31716
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24357
diff
changeset
|
68 `(let* ((val (eval (, el))) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24357
diff
changeset
|
69 (valstr (if (numberp val) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24357
diff
changeset
|
70 (int-to-string val) val))) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24357
diff
changeset
|
71 (if (> (length valstr) ,max-width) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24357
diff
changeset
|
72 (truncate-string-to-width valstr ,max-width) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24357
diff
changeset
|
73 valstr))) |
24357
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
20118
diff
changeset
|
74 |
17493 | 75 (eval-and-compile |
56927
55fd4f77387a
Revision: miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-523
Miles Bader <miles@gnu.org>
parents:
52401
diff
changeset
|
76 (defalias 'gnus-char-width |
55fd4f77387a
Revision: miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-523
Miles Bader <miles@gnu.org>
parents:
52401
diff
changeset
|
77 (if (fboundp 'char-width) |
55fd4f77387a
Revision: miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-523
Miles Bader <miles@gnu.org>
parents:
52401
diff
changeset
|
78 'char-width |
55fd4f77387a
Revision: miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-523
Miles Bader <miles@gnu.org>
parents:
52401
diff
changeset
|
79 (lambda (ch) 1)))) ;; A simple hack. |
55fd4f77387a
Revision: miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-523
Miles Bader <miles@gnu.org>
parents:
52401
diff
changeset
|
80 |
55fd4f77387a
Revision: miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-523
Miles Bader <miles@gnu.org>
parents:
52401
diff
changeset
|
81 (eval-and-compile |
32920
5b203c66fa7b
2000-10-08 08:57:13 ShengHuo ZHU <zsh@cs.rochester.edu>
Dave Love <fx@gnu.org>
parents:
32139
diff
changeset
|
82 (if (featurep 'xemacs) |
31716
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24357
diff
changeset
|
83 (gnus-xmas-define) |
17493 | 84 (defvar gnus-mouse-face-prop 'mouse-face |
31716
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24357
diff
changeset
|
85 "Property used for highlighting mouse regions."))) |
17493 | 86 |
56927
55fd4f77387a
Revision: miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-523
Miles Bader <miles@gnu.org>
parents:
52401
diff
changeset
|
87 (eval-when-compile |
55fd4f77387a
Revision: miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-523
Miles Bader <miles@gnu.org>
parents:
52401
diff
changeset
|
88 (defvar gnus-tmp-unread) |
55fd4f77387a
Revision: miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-523
Miles Bader <miles@gnu.org>
parents:
52401
diff
changeset
|
89 (defvar gnus-tmp-replied) |
55fd4f77387a
Revision: miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-523
Miles Bader <miles@gnu.org>
parents:
52401
diff
changeset
|
90 (defvar gnus-tmp-score-char) |
55fd4f77387a
Revision: miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-523
Miles Bader <miles@gnu.org>
parents:
52401
diff
changeset
|
91 (defvar gnus-tmp-indentation) |
55fd4f77387a
Revision: miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-523
Miles Bader <miles@gnu.org>
parents:
52401
diff
changeset
|
92 (defvar gnus-tmp-opening-bracket) |
55fd4f77387a
Revision: miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-523
Miles Bader <miles@gnu.org>
parents:
52401
diff
changeset
|
93 (defvar gnus-tmp-lines) |
55fd4f77387a
Revision: miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-523
Miles Bader <miles@gnu.org>
parents:
52401
diff
changeset
|
94 (defvar gnus-tmp-name) |
55fd4f77387a
Revision: miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-523
Miles Bader <miles@gnu.org>
parents:
52401
diff
changeset
|
95 (defvar gnus-tmp-closing-bracket) |
55fd4f77387a
Revision: miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-523
Miles Bader <miles@gnu.org>
parents:
52401
diff
changeset
|
96 (defvar gnus-tmp-subject-or-nil) |
55fd4f77387a
Revision: miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-523
Miles Bader <miles@gnu.org>
parents:
52401
diff
changeset
|
97 (defvar gnus-check-before-posting) |
55fd4f77387a
Revision: miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-523
Miles Bader <miles@gnu.org>
parents:
52401
diff
changeset
|
98 (defvar gnus-mouse-face) |
55fd4f77387a
Revision: miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-523
Miles Bader <miles@gnu.org>
parents:
52401
diff
changeset
|
99 (defvar gnus-group-buffer)) |
17493 | 100 |
101 (defun gnus-ems-redefine () | |
102 (cond | |
32939
c8119677d63e
Use (featurep 'xemacs) instead of the `gnus-xemacs' variable, as the
Miles Bader <miles@gnu.org>
parents:
32920
diff
changeset
|
103 ((featurep 'xemacs) |
17493 | 104 (gnus-xmas-redefine)) |
105 | |
106 ((featurep 'mule) | |
107 ;; Mule and new Emacs definitions | |
108 | |
109 ;; [Note] Now there are three kinds of mule implementations, | |
31716
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24357
diff
changeset
|
110 ;; original MULE, XEmacs/mule and Emacs 20+ including |
56927
55fd4f77387a
Revision: miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-523
Miles Bader <miles@gnu.org>
parents:
52401
diff
changeset
|
111 ;; MULE features. Unfortunately these APIs are different. In |
55fd4f77387a
Revision: miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-523
Miles Bader <miles@gnu.org>
parents:
52401
diff
changeset
|
112 ;; particular, Emacs (including original Mule) and XEmacs are |
44532
b94ae378e07c
(gnus-ems-redefine): Fix typo in comment.
Juanma Barranquero <lekktu@gmail.com>
parents:
39483
diff
changeset
|
113 ;; quite different. However, this version of Gnus doesn't support |
31716
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24357
diff
changeset
|
114 ;; anything other than XEmacs 20+ and Emacs 20.3+. |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24357
diff
changeset
|
115 |
17493 | 116 ;; Predicates to check are following: |
56927
55fd4f77387a
Revision: miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-523
Miles Bader <miles@gnu.org>
parents:
52401
diff
changeset
|
117 ;; (boundp 'MULE) is t only if Mule (original; anything older than |
17493 | 118 ;; Mule 2.3) is running. |
56927
55fd4f77387a
Revision: miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-523
Miles Bader <miles@gnu.org>
parents:
52401
diff
changeset
|
119 ;; (featurep 'mule) is t when other mule variants are running. |
17493 | 120 |
31716
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24357
diff
changeset
|
121 ;; It is possible to detect XEmacs/mule by (featurep 'mule) and |
56927
55fd4f77387a
Revision: miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-523
Miles Bader <miles@gnu.org>
parents:
52401
diff
changeset
|
122 ;; (featurep 'xemacs). In this case, the implementation for |
31716
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24357
diff
changeset
|
123 ;; XEmacs/mule may be shareable between XEmacs and XEmacs/mule. |
17493 | 124 |
125 (defvar gnus-summary-display-table nil | |
126 "Display table used in summary mode buffers.") | |
31716
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24357
diff
changeset
|
127 (defalias 'gnus-max-width-function 'gnus-mule-max-width-function) |
17493 | 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) | |
31716
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24357
diff
changeset
|
145 (truncate-string-to-width gnus-tmp-name 20) |
17493 | 146 gnus-tmp-name)) |
147 gnus-tmp-closing-bracket) | |
148 (point)) | |
149 gnus-mouse-face-prop gnus-mouse-face) | |
31716
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24357
diff
changeset
|
150 (insert " " gnus-tmp-subject-or-nil "\n"))))) |
17493 | 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 | |
56927
55fd4f77387a
Revision: miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-523
Miles Bader <miles@gnu.org>
parents:
52401
diff
changeset
|
159 (defun gnus-mark-active-p () |
55fd4f77387a
Revision: miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-523
Miles Bader <miles@gnu.org>
parents:
52401
diff
changeset
|
160 "Non-nil means the mark and region are currently active in this buffer." |
55fd4f77387a
Revision: miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-523
Miles Bader <miles@gnu.org>
parents:
52401
diff
changeset
|
161 mark-active) ; aliased to region-exists-p in XEmacs. |
55fd4f77387a
Revision: miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-523
Miles Bader <miles@gnu.org>
parents:
52401
diff
changeset
|
162 |
31716
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24357
diff
changeset
|
163 (if (fboundp 'add-minor-mode) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24357
diff
changeset
|
164 (defalias 'gnus-add-minor-mode 'add-minor-mode) |
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24357
diff
changeset
|
165 (defun gnus-add-minor-mode (mode name map &rest rest) |
24357
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
20118
diff
changeset
|
166 (set (make-local-variable mode) t) |
19969
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
17493
diff
changeset
|
167 (unless (assq mode minor-mode-alist) |
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
17493
diff
changeset
|
168 (push `(,mode ,name) minor-mode-alist)) |
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
17493
diff
changeset
|
169 (unless (assq mode minor-mode-map-alist) |
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
17493
diff
changeset
|
170 (push (cons mode map) |
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
17493
diff
changeset
|
171 minor-mode-map-alist)))) |
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
17493
diff
changeset
|
172 |
24357
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
20118
diff
changeset
|
173 (defun gnus-x-splash () |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
20118
diff
changeset
|
174 "Show a splash screen using a pixmap in the current buffer." |
78006 | 175 (interactive) |
176 (unless window-system | |
177 (error "`gnus-x-splash' requires running on the window system")) | |
178 (switch-to-buffer (gnus-get-buffer-create (if (or (gnus-alive-p) | |
179 (interactive-p)) | |
180 "*gnus-x-splash*" | |
181 gnus-group-buffer))) | |
78546 | 182 (let ((inhibit-read-only t) |
78006 | 183 (file (nnheader-find-etc-directory "images/gnus/x-splash" t)) |
184 pixmap fcw fch width height fringes sbars left yoffset top ls) | |
185 (erase-buffer) | |
78013 | 186 (sit-for 0) ;; Necessary for measuring the window size correctly. |
78006 | 187 (when (and file |
188 (ignore-errors | |
189 (let ((coding-system-for-read 'raw-text) | |
190 default-enable-multibyte-characters) | |
191 (with-temp-buffer | |
192 (insert-file-contents file) | |
193 (goto-char (point-min)) | |
194 (setq pixmap (read (current-buffer))))))) | |
195 (setq fcw (float (frame-char-width)) | |
196 fch (float (frame-char-height)) | |
197 width (/ (car pixmap) fcw) | |
198 height (/ (cadr pixmap) fch) | |
199 fringes (if (fboundp 'window-fringes) | |
200 (eval '(window-fringes)) | |
201 '(10 11 nil)) | |
202 sbars (frame-parameter nil 'vertical-scroll-bars)) | |
203 (cond ((eq sbars 'right) | |
204 (setq sbars | |
205 (cons 0 (/ (or (frame-parameter nil 'scroll-bar-width) 14) | |
206 fcw)))) | |
207 (sbars | |
208 (setq sbars | |
209 (cons (/ (or (frame-parameter nil 'scroll-bar-width) 14) | |
210 fcw) | |
211 0)))) | |
212 (setq left (- (* (round (/ (1- (/ (+ (window-width) | |
213 (car sbars) (cdr sbars) | |
214 (/ (+ (or (car fringes) 0) | |
215 (or (cadr fringes) 0)) | |
216 fcw)) | |
217 width)) | |
218 2)) | |
219 width) | |
220 (car sbars) | |
221 (/ (or (car fringes) 0) fcw)) | |
222 yoffset (cadr (window-edges)) | |
223 top (max 0 (- (* (max (if (and tool-bar-mode | |
224 (not (featurep 'gtk)) | |
225 (eq (frame-first-window) | |
226 (selected-window))) | |
227 1 0) | |
228 (round (/ (1- (/ (+ (1- (window-height)) | |
229 (* 2 yoffset)) | |
230 height)) | |
231 2))) | |
232 height) | |
233 yoffset)) | |
234 ls (/ (or line-spacing 0) fch) | |
235 height (max 0 (- height ls))) | |
236 (cond ((>= (- top ls) 1) | |
237 (insert | |
238 (propertize | |
239 " " | |
240 'display `(space :width 0 :ascent 100)) | |
241 "\n" | |
242 (propertize | |
243 " " | |
244 'display `(space :width 0 :height ,(- top ls 1) :ascent 100)) | |
245 "\n")) | |
246 ((> (- top ls) 0) | |
247 (insert | |
248 (propertize | |
249 " " | |
250 'display `(space :width 0 :height ,(- top ls) :ascent 100)) | |
251 "\n"))) | |
252 (if (and (> width 0) (> left 0)) | |
253 (insert (propertize | |
254 " " | |
255 'display `(space :width ,left :height ,height :ascent 0))) | |
256 (setq width (+ width left))) | |
257 (when (> width 0) | |
258 (insert (propertize | |
259 " " | |
260 'display `(space :width ,width :height ,height :ascent 0) | |
261 'face `(gnus-splash :stipple ,pixmap)))) | |
262 (goto-char (if (<= (- top ls) 0) (1- (point)) (point-min))) | |
263 (redraw-frame (selected-frame)) | |
264 (sit-for 0)))) | |
24357
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
20118
diff
changeset
|
265 |
56927
55fd4f77387a
Revision: miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-523
Miles Bader <miles@gnu.org>
parents:
52401
diff
changeset
|
266 ;;; Image functions. |
31716
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24357
diff
changeset
|
267 |
56927
55fd4f77387a
Revision: miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-523
Miles Bader <miles@gnu.org>
parents:
52401
diff
changeset
|
268 (defun gnus-image-type-available-p (type) |
55fd4f77387a
Revision: miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-523
Miles Bader <miles@gnu.org>
parents:
52401
diff
changeset
|
269 (and (fboundp 'image-type-available-p) |
74984 | 270 (image-type-available-p type) |
271 (if (fboundp 'display-images-p) | |
272 (display-images-p) | |
273 t))) | |
32139
6d8322cfbf71
Don't turn off compiler warnings in local vars.
Dave Love <fx@gnu.org>
parents:
31802
diff
changeset
|
274 |
56927
55fd4f77387a
Revision: miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-523
Miles Bader <miles@gnu.org>
parents:
52401
diff
changeset
|
275 (defun gnus-create-image (file &optional type data-p &rest props) |
55fd4f77387a
Revision: miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-523
Miles Bader <miles@gnu.org>
parents:
52401
diff
changeset
|
276 (let ((face (plist-get props :face))) |
55fd4f77387a
Revision: miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-523
Miles Bader <miles@gnu.org>
parents:
52401
diff
changeset
|
277 (when face |
55fd4f77387a
Revision: miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-523
Miles Bader <miles@gnu.org>
parents:
52401
diff
changeset
|
278 (setq props (plist-put props :foreground (face-foreground face))) |
55fd4f77387a
Revision: miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-523
Miles Bader <miles@gnu.org>
parents:
52401
diff
changeset
|
279 (setq props (plist-put props :background (face-background face)))) |
55fd4f77387a
Revision: miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-523
Miles Bader <miles@gnu.org>
parents:
52401
diff
changeset
|
280 (apply 'create-image file type data-p props))) |
31716
9968f55ad26e
Update to emacs-21-branch of the Gnus CVS repository.
Gerd Moellmann <gerd@gnu.org>
parents:
24357
diff
changeset
|
281 |
56927
55fd4f77387a
Revision: miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-523
Miles Bader <miles@gnu.org>
parents:
52401
diff
changeset
|
282 (defun gnus-put-image (glyph &optional string category) |
55fd4f77387a
Revision: miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-523
Miles Bader <miles@gnu.org>
parents:
52401
diff
changeset
|
283 (let ((point (point))) |
55fd4f77387a
Revision: miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-523
Miles Bader <miles@gnu.org>
parents:
52401
diff
changeset
|
284 (insert-image glyph (or string " ")) |
55fd4f77387a
Revision: miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-523
Miles Bader <miles@gnu.org>
parents:
52401
diff
changeset
|
285 (put-text-property point (point) 'gnus-image-category category) |
55fd4f77387a
Revision: miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-523
Miles Bader <miles@gnu.org>
parents:
52401
diff
changeset
|
286 (unless string |
55fd4f77387a
Revision: miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-523
Miles Bader <miles@gnu.org>
parents:
52401
diff
changeset
|
287 (put-text-property (1- (point)) (point) |
55fd4f77387a
Revision: miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-523
Miles Bader <miles@gnu.org>
parents:
52401
diff
changeset
|
288 'gnus-image-text-deletable t)) |
55fd4f77387a
Revision: miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-523
Miles Bader <miles@gnu.org>
parents:
52401
diff
changeset
|
289 glyph)) |
55fd4f77387a
Revision: miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-523
Miles Bader <miles@gnu.org>
parents:
52401
diff
changeset
|
290 |
55fd4f77387a
Revision: miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-523
Miles Bader <miles@gnu.org>
parents:
52401
diff
changeset
|
291 (defun gnus-remove-image (image &optional category) |
55fd4f77387a
Revision: miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-523
Miles Bader <miles@gnu.org>
parents:
52401
diff
changeset
|
292 (dolist (position (message-text-with-property 'display)) |
55fd4f77387a
Revision: miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-523
Miles Bader <miles@gnu.org>
parents:
52401
diff
changeset
|
293 (when (and (equal (get-text-property position 'display) image) |
55fd4f77387a
Revision: miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-523
Miles Bader <miles@gnu.org>
parents:
52401
diff
changeset
|
294 (equal (get-text-property position 'gnus-image-category) |
55fd4f77387a
Revision: miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-523
Miles Bader <miles@gnu.org>
parents:
52401
diff
changeset
|
295 category)) |
55fd4f77387a
Revision: miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-523
Miles Bader <miles@gnu.org>
parents:
52401
diff
changeset
|
296 (put-text-property position (1+ position) 'display nil) |
55fd4f77387a
Revision: miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-523
Miles Bader <miles@gnu.org>
parents:
52401
diff
changeset
|
297 (when (get-text-property position 'gnus-image-text-deletable) |
55fd4f77387a
Revision: miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-523
Miles Bader <miles@gnu.org>
parents:
52401
diff
changeset
|
298 (delete-region position (1+ position)))))) |
24357
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
20118
diff
changeset
|
299 |
17493 | 300 (provide 'gnus-ems) |
301 | |
52401 | 302 ;;; arch-tag: e7360b45-14b5-4171-aa39-69a44aed3cdb |
17493 | 303 ;;; gnus-ems.el ends here |