Mercurial > hg > xemacs-beta

comparison lisp/gnus/gnus-ems.el @ 16:0293115a14e9 r19-15b91

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-15b91
author cvs
date Mon, 13 Aug 2007 08:49:20 +0200
parents ac2d302a0011
children 8fc7fe29b841
comparison
equal deleted inserted replaced
15:ad457d5f7d04 16:0293115a14e9
1 ;;; gnus-ems.el --- functions for making Gnus work under different Emacsen 1 ;;; gnus-ems.el --- functions for making Gnus work under different Emacsen
2 ;; Copyright (C) 1995,96 Free Software Foundation, Inc. 2 ;; Copyright (C) 1995,96,97 Free Software Foundation, Inc.
3 3
4 ;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no> 4 ;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
5 ;; Keywords: news 5 ;; Keywords: news
6 6
7 ;; This file is part of GNU Emacs. 7 ;; This file is part of GNU Emacs.
25 25
26 ;;; Code: 26 ;;; Code:
27 27
28 (eval-when-compile (require 'cl)) 28 (eval-when-compile (require 'cl))
29 29
30 ;;; Function aliases later to be redefined for XEmacs usage.
31
32 (defvar gnus-xemacs (string-match "XEmacs\\|Lucid" emacs-version)
33 "Non-nil if running under XEmacs.")
34
30 (defvar gnus-mouse-2 [mouse-2]) 35 (defvar gnus-mouse-2 [mouse-2])
31 36 (defvar gnus-down-mouse-2 [down-mouse-2])
32 (defalias 'gnus-make-overlay 'make-overlay)
33 (defalias 'gnus-overlay-put 'overlay-put)
34 (defalias 'gnus-move-overlay 'move-overlay)
35 (defalias 'gnus-overlay-end 'overlay-end)
36 (defalias 'gnus-extent-detached-p 'ignore)
37 (defalias 'gnus-extent-start-open 'ignore)
38 (defalias 'gnus-set-text-properties 'set-text-properties)
39 (defalias 'gnus-group-remove-excess-properties 'ignore)
40 (defalias 'gnus-topic-remove-excess-properties 'ignore)
41 (defalias 'gnus-appt-select-lowest-window 'appt-select-lowest-window)
42 (defalias 'gnus-mail-strip-quoted-names 'mail-strip-quoted-names)
43 (defalias 'gnus-make-local-hook 'make-local-hook)
44 (defalias 'gnus-add-hook 'add-hook)
45 (defalias 'gnus-character-to-event 'identity)
46 (defalias 'gnus-add-text-properties 'add-text-properties)
47 (defalias 'gnus-put-text-property 'put-text-property)
48 (defalias 'gnus-mode-line-buffer-identification 'identity)
49
50 37
51 (eval-and-compile 38 (eval-and-compile
52 (autoload 'gnus-xmas-define "gnus-xmas") 39 (autoload 'gnus-xmas-define "gnus-xmas")
53 (autoload 'gnus-xmas-redefine "gnus-xmas") 40 (autoload 'gnus-xmas-redefine "gnus-xmas")
54 (autoload 'appt-select-lowest-window "appt.el")) 41 (autoload 'appt-select-lowest-window "appt.el"))
58 45
59 ;;; Mule functions. 46 ;;; Mule functions.
60 47
61 (defun gnus-mule-cite-add-face (number prefix face) 48 (defun gnus-mule-cite-add-face (number prefix face)
62 ;; At line NUMBER, ignore PREFIX and add FACE to the rest of the line. 49 ;; At line NUMBER, ignore PREFIX and add FACE to the rest of the line.
63 (if face 50 (when face
64 (let ((inhibit-point-motion-hooks t) 51 (let ((inhibit-point-motion-hooks t)
65 from to) 52 from to)
66 (goto-line number) 53 (goto-line number)
67 (if (boundp 'MULE) 54 (if (boundp 'MULE)
68 (forward-char (chars-in-string prefix)) 55 (forward-char (chars-in-string prefix))
69 (forward-char (length prefix))) 56 (forward-char (length prefix)))
70 (skip-chars-forward " \t") 57 (skip-chars-forward " \t")
71 (setq from (point)) 58 (setq from (point))
72 (end-of-line 1) 59 (end-of-line 1)
73 (skip-chars-backward " \t") 60 (skip-chars-backward " \t")
74 (setq to (point)) 61 (setq to (point))
75 (if (< from to) 62 (when (< from to)
76 (gnus-overlay-put (gnus-make-overlay from to) 'face face))))) 63 (gnus-overlay-put (gnus-make-overlay from to) 'face face)))))
77 64
78 (defun gnus-mule-max-width-function (el max-width) 65 (defun gnus-mule-max-width-function (el max-width)
79 (` (let* ((val (eval (, el))) 66 (` (let* ((val (eval (, el)))
80 (valstr (if (numberp val) 67 (valstr (if (numberp val)
81 (int-to-string val) val))) 68 (int-to-string val) val)))
82 (if (> (length valstr) (, max-width)) 69 (if (> (length valstr) (, max-width))
83 (truncate-string valstr (, max-width)) 70 (truncate-string valstr (, max-width))
84 valstr)))) 71 valstr))))
85 72
86 (eval-and-compile 73 (eval-and-compile
87 (if (string-match "XEmacs\\|Lucid" emacs-version) 74 (if gnus-xemacs
88 () 75 nil
89 76
90 (defvar gnus-mouse-face-prop 'mouse-face 77 (defvar gnus-mouse-face-prop 'mouse-face
91 "Property used for highlighting mouse regions.") 78 "Property used for highlighting mouse regions.")
92 79
93 (defvar gnus-article-x-face-command 80 (defvar gnus-article-x-face-command
94 "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | xv -quit -" 81 "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | xv -quit -"
95 "String or function to be executed to display an X-Face header. 82 "String or function to be executed to display an X-Face header.
96 If it is a string, the command will be executed in a sub-shell 83 If it is a string, the command will be executed in a sub-shell
97 asynchronously. The compressed face will be piped to this command.") 84 asynchronously. The compressed face will be piped to this command."))
98
99 ;; Added by Per Abrahamsen <amanda@iesd.auc.dk>.
100 (defvar gnus-display-type
101 (condition-case nil
102 (let ((display-resource (x-get-resource ".displayType" "DisplayType")))
103 (cond (display-resource (intern (downcase display-resource)))
104 ((x-display-color-p) 'color)
105 ((x-display-grayscale-p) 'grayscale)
106 (t 'mono)))
107 (error 'mono))
108 "A symbol indicating the display Emacs is running under.
109 The symbol should be one of `color', `grayscale' or `mono'. If Emacs
110 guesses this display attribute wrongly, either set this variable in
111 your `~/.emacs' or set the resource `Emacs.displayType' in your
112 `~/.Xdefaults'. See also `gnus-background-mode'.
113
114 This is a meta-variable that will affect what default values other
115 variables get. You would normally not change this variable, but
116 pounce directly on the real variables themselves.")
117
118 (defvar gnus-background-mode
119 (condition-case nil
120 (let ((bg-resource (x-get-resource ".backgroundMode"
121 "BackgroundMode"))
122 (params (frame-parameters)))
123 (cond (bg-resource (intern (downcase bg-resource)))
124 ((and (cdr (assq 'background-color params))
125 (< (apply '+ (x-color-values
126 (cdr (assq 'background-color params))))
127 (* (apply '+ (x-color-values "white")) .6)))
128 'dark)
129 (t 'light)))
130 (error 'light))
131 "A symbol indicating the Emacs background brightness.
132 The symbol should be one of `light' or `dark'.
133 If Emacs guesses this frame attribute wrongly, either set this variable in
134 your `~/.emacs' or set the resource `Emacs.backgroundMode' in your
135 `~/.Xdefaults'.
136 See also `gnus-display-type'.
137
138 This is a meta-variable that will affect what default values other
139 variables get. You would normally not change this variable, but
140 pounce directly on the real variables themselves."))
141 85
142 (cond 86 (cond
143 ((string-match "XEmacs\\|Lucid" emacs-version) 87 ((string-match "XEmacs\\|Lucid" emacs-version)
144 (gnus-xmas-define)) 88 (gnus-xmas-define))
145 89
146 ((or (not (boundp 'emacs-minor-version)) 90 ((or (not (boundp 'emacs-minor-version))
147 (< emacs-minor-version 30)) 91 (< emacs-minor-version 30))
148 ;; Remove the `intangible' prop. 92 ;; Remove the `intangible' prop.
149 (let ((props (and (boundp 'gnus-hidden-properties) 93 (let ((props (and (boundp 'gnus-hidden-properties)
150 gnus-hidden-properties))) 94 gnus-hidden-properties)))
151 (while (and props (not (eq (car (cdr props)) 'intangible))) 95 (while (and props (not (eq (car (cdr props)) 'intangible)))
152 (setq props (cdr props))) 96 (setq props (cdr props)))
153 (and props (setcdr props (cdr (cdr (cdr props)))))) 97 (when props
154 (or (fboundp 'buffer-substring-no-properties) 98 (setcdr props (cdr (cdr (cdr props))))))
155 (defun buffer-substring-no-properties (beg end) 99 (unless (fboundp 'buffer-substring-no-properties)
156 (format "%s" (buffer-substring beg end))))) 100 (defun buffer-substring-no-properties (beg end)
101 (format "%s" (buffer-substring beg end)))))
157 102
158 ((boundp 'MULE) 103 ((boundp 'MULE)
159 (provide 'gnusutil)))) 104 (provide 'gnusutil))))
160 105
161 (eval-and-compile 106 (eval-and-compile
163 ((not window-system) 108 ((not window-system)
164 (defun gnus-dummy-func (&rest args)) 109 (defun gnus-dummy-func (&rest args))
165 (let ((funcs '(mouse-set-point set-face-foreground 110 (let ((funcs '(mouse-set-point set-face-foreground
166 set-face-background x-popup-menu))) 111 set-face-background x-popup-menu)))
167 (while funcs 112 (while funcs
168 (or (fboundp (car funcs)) 113 (unless (fboundp (car funcs))
169 (fset (car funcs) 'gnus-dummy-func)) 114 (fset (car funcs) 'gnus-dummy-func))
170 (setq funcs (cdr funcs)))))) 115 (setq funcs (cdr funcs))))))
171 (or (fboundp 'file-regular-p) 116 (unless (fboundp 'file-regular-p)
172 (defun file-regular-p (file) 117 (defun file-regular-p (file)
173 (and (not (file-directory-p file)) 118 (and (not (file-directory-p file))
174 (not (file-symlink-p file)) 119 (not (file-symlink-p file))
175 (file-exists-p file)))) 120 (file-exists-p file))))
176 (or (fboundp 'face-list) 121 (unless (fboundp 'face-list)
177 (defun face-list (&rest args)))) 122 (defun face-list (&rest args))))
178 123
179 (eval-and-compile 124 (eval-and-compile
180 (let ((case-fold-search t)) 125 (let ((case-fold-search t))
181 (cond 126 (cond
182 ((string-match "windows-nt\\|os/2\\|emx" (format "%s" system-type)) 127 ((string-match "windows-nt\\|os/2\\|emx" (format "%s" system-type))
198 (defun gnus-ems-redefine () 143 (defun gnus-ems-redefine ()
199 (cond 144 (cond
200 ((string-match "XEmacs\\|Lucid" emacs-version) 145 ((string-match "XEmacs\\|Lucid" emacs-version)
201 (gnus-xmas-redefine)) 146 (gnus-xmas-redefine))
202 147
203 ((boundp 'MULE) 148 ((featurep 'mule)
204 ;; Mule definitions 149 ;; Mule and new Emacs definitions
150
151 ;; [Note] Now there are three kinds of mule implementations,
152 ;; original MULE, XEmacs/mule and beta version of Emacs including
153 ;; some mule features. Unfortunately these API are different. In
154 ;; particular, Emacs (including original MULE) and XEmacs are
155 ;; quite different.
156 ;; Predicates to check are following:
157 ;; (boundp 'MULE) is t only if MULE (original; anything older than
158 ;; Mule 2.3) is running.
159 ;; (featurep 'mule) is t when every mule variants are running.
160
161 ;; These implementations may be able to share between original
162 ;; MULE and beta version of new Emacs. In addition, it is able to
163 ;; detect XEmacs/mule by (featurep 'mule) and to check variable
164 ;; `emacs-version'. In this case, implementation for XEmacs/mule
165 ;; may be able to share between XEmacs and XEmacs/mule.
166
205 (defalias 'gnus-truncate-string 'truncate-string) 167 (defalias 'gnus-truncate-string 'truncate-string)
206 168
207 (fset 'gnus-summary-make-display-table (lambda () nil)) 169 (defvar gnus-summary-display-table nil
170 "Display table used in summary mode buffers.")
208 (fset 'gnus-cite-add-face 'gnus-mule-cite-add-face) 171 (fset 'gnus-cite-add-face 'gnus-mule-cite-add-face)
209 (fset 'gnus-max-width-function 'gnus-mule-max-width-function) 172 (fset 'gnus-max-width-function 'gnus-mule-max-width-function)
210 173
211 (if (boundp 'gnus-check-before-posting) 174 (when (boundp 'gnus-check-before-posting)
212 (setq gnus-check-before-posting 175 (setq gnus-check-before-posting
213 (delq 'long-lines 176 (delq 'long-lines
214 (delq 'control-chars gnus-check-before-posting)))) 177 (delq 'control-chars gnus-check-before-posting))))
215 178
216 (defun gnus-summary-line-format-spec () 179 (defun gnus-summary-line-format-spec ()
217 (insert gnus-tmp-unread gnus-tmp-replied 180 (insert gnus-tmp-unread gnus-tmp-replied
218 gnus-tmp-score-char gnus-tmp-indentation) 181 gnus-tmp-score-char gnus-tmp-indentation)
219 (put-text-property 182 (put-text-property
221 (progn 184 (progn
222 (insert 185 (insert
223 gnus-tmp-opening-bracket 186 gnus-tmp-opening-bracket
224 (format "%4d: %-20s" 187 (format "%4d: %-20s"
225 gnus-tmp-lines 188 gnus-tmp-lines
226 (if (> (length gnus-tmp-name) 20) 189 (if (> (length gnus-tmp-name) 20)
227 (truncate-string gnus-tmp-name 20) 190 (truncate-string gnus-tmp-name 20)
228 gnus-tmp-name)) 191 gnus-tmp-name))
229 gnus-tmp-closing-bracket) 192 gnus-tmp-closing-bracket)
230 (point)) 193 (point))
231 gnus-mouse-face-prop gnus-mouse-face) 194 gnus-mouse-face-prop gnus-mouse-face)
232 (insert " " gnus-tmp-subject-or-nil "\n")) 195 (insert " " gnus-tmp-subject-or-nil "\n"))