Mercurial > hg > xemacs-beta

comparison lisp/gnus/gnus-ems.el @ 70:131b0175ea99 r20-0b30

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-0b30
author cvs
date Mon, 13 Aug 2007 09:02:59 +0200
parents ec9a17fef872
children 0d2f883870bc
comparison
equal deleted inserted replaced
69:804d1389bcd6 70:131b0175ea99
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,97 Free Software Foundation, Inc. 2 ;; Copyright (C) 1995,96 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
35 (defvar gnus-mouse-2 [mouse-2]) 30 (defvar gnus-mouse-2 [mouse-2])
36 (defvar gnus-down-mouse-2 [down-mouse-2]) 31
37 32 (defalias 'gnus-make-overlay 'make-overlay)
38 (eval-and-compile 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
51 (eval-and-compile
39 (autoload 'gnus-xmas-define "gnus-xmas") 52 (autoload 'gnus-xmas-define "gnus-xmas")
40 (autoload 'gnus-xmas-redefine "gnus-xmas") 53 (autoload 'gnus-xmas-redefine "gnus-xmas")
41 (autoload 'appt-select-lowest-window "appt.el")) 54 (autoload 'appt-select-lowest-window "appt.el"))
42 55
43 (or (fboundp 'mail-file-babyl-p) 56 (or (fboundp 'mail-file-babyl-p)
45 58
46 ;;; Mule functions. 59 ;;; Mule functions.
47 60
48 (defun gnus-mule-cite-add-face (number prefix face) 61 (defun gnus-mule-cite-add-face (number prefix face)
49 ;; At line NUMBER, ignore PREFIX and add FACE to the rest of the line. 62 ;; At line NUMBER, ignore PREFIX and add FACE to the rest of the line.
50 (when face 63 (if face
51 (let ((inhibit-point-motion-hooks t) 64 (let ((inhibit-point-motion-hooks t)
52 from to) 65 from to)
53 (goto-line number) 66 (goto-line number)
54 (if (boundp 'MULE) 67 (if (boundp 'MULE)
55 (forward-char (chars-in-string prefix)) 68 (forward-char (chars-in-string prefix))
56 (forward-char (length prefix))) 69 (forward-char (length prefix)))
57 (skip-chars-forward " \t") 70 (skip-chars-forward " \t")
58 (setq from (point)) 71 (setq from (point))
59 (end-of-line 1) 72 (end-of-line 1)
60 (skip-chars-backward " \t") 73 (skip-chars-backward " \t")
61 (setq to (point)) 74 (setq to (point))
62 (when (< from to) 75 (if (< from to)
63 (gnus-overlay-put (gnus-make-overlay from to) 'face face))))) 76 (gnus-overlay-put (gnus-make-overlay from to) 'face face)))))
64 77
65 (defun gnus-mule-max-width-function (el max-width) 78 (defun gnus-mule-max-width-function (el max-width)
66 (` (let* ((val (eval (, el))) 79 (` (let* ((val (eval (, el)))
67 (valstr (if (numberp val) 80 (valstr (if (numberp val)
68 (int-to-string val) val))) 81 (int-to-string val) val)))
70 (truncate-string valstr (, max-width)) 83 (truncate-string valstr (, max-width))
71 valstr)))) 84 valstr))))
72 85
73 (eval-and-compile 86 (eval-and-compile
74 (if (string-match "XEmacs\\|Lucid" emacs-version) 87 (if (string-match "XEmacs\\|Lucid" emacs-version)
75 nil 88 ()
76 89
77 (defvar gnus-mouse-face-prop 'mouse-face 90 (defvar gnus-mouse-face-prop 'mouse-face
78 "Property used for highlighting mouse regions.") 91 "Property used for highlighting mouse regions.")
79 92
80 (defvar gnus-article-x-face-command 93 (defvar gnus-article-x-face-command
81 "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | xv -quit -" 94 "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | xv -quit -"
82 "String or function to be executed to display an X-Face header. 95 "String or function to be executed to display an X-Face header.
83 If it is a string, the command will be executed in a sub-shell 96 If it is a string, the command will be executed in a sub-shell
84 asynchronously. The compressed face will be piped to this command.")) 97 asynchronously. The compressed face will be piped to this command.")
85 98
86 (cond 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
142 (cond
87 ((string-match "XEmacs\\|Lucid" emacs-version) 143 ((string-match "XEmacs\\|Lucid" emacs-version)
88 (gnus-xmas-define)) 144 (gnus-xmas-define))
89 145
90 ((or (not (boundp 'emacs-minor-version)) 146 ((or (not (boundp 'emacs-minor-version))
91 (< emacs-minor-version 30)) 147 (< emacs-minor-version 30))
92 ;; Remove the `intangible' prop. 148 ;; Remove the `intangible' prop.
93 (let ((props (and (boundp 'gnus-hidden-properties) 149 (let ((props (and (boundp 'gnus-hidden-properties)
94 gnus-hidden-properties))) 150 gnus-hidden-properties)))
95 (while (and props (not (eq (car (cdr props)) 'intangible))) 151 (while (and props (not (eq (car (cdr props)) 'intangible)))
96 (setq props (cdr props))) 152 (setq props (cdr props)))
97 (when props 153 (and props (setcdr props (cdr (cdr (cdr props))))))
98 (setcdr props (cdr (cdr (cdr props)))))) 154 (or (fboundp 'buffer-substring-no-properties)
99 (unless (fboundp 'buffer-substring-no-properties) 155 (defun buffer-substring-no-properties (beg end)
100 (defun buffer-substring-no-properties (beg end) 156 (format "%s" (buffer-substring beg end)))))
101 (format "%s" (buffer-substring beg end))))) 157
102
103 ((boundp 'MULE) 158 ((boundp 'MULE)
104 (provide 'gnusutil)))) 159 (provide 'gnusutil))))
105 160
106 (eval-and-compile 161 (eval-and-compile
107 (cond 162 (cond
108 ((not window-system) 163 ((not window-system)
109 (defun gnus-dummy-func (&rest args)) 164 (defun gnus-dummy-func (&rest args))
110 (let ((funcs '(mouse-set-point set-face-foreground 165 (let ((funcs '(mouse-set-point set-face-foreground
111 set-face-background x-popup-menu))) 166 set-face-background x-popup-menu)))
112 (while funcs 167 (while funcs
113 (unless (fboundp (car funcs)) 168 (or (fboundp (car funcs))
114 (fset (car funcs) 'gnus-dummy-func)) 169 (fset (car funcs) 'gnus-dummy-func))
115 (setq funcs (cdr funcs)))))) 170 (setq funcs (cdr funcs))))))
116 (unless (fboundp 'file-regular-p) 171 (or (fboundp 'file-regular-p)
117 (defun file-regular-p (file) 172 (defun file-regular-p (file)
118 (and (not (file-directory-p file)) 173 (and (not (file-directory-p file))
119 (not (file-symlink-p file)) 174 (not (file-symlink-p file))
120 (file-exists-p file)))) 175 (file-exists-p file))))
121 (unless (fboundp 'face-list) 176 (or (fboundp 'face-list)
122 (defun face-list (&rest args)))) 177 (defun face-list (&rest args))))
123 178
124 (eval-and-compile 179 (eval-and-compile
125 (let ((case-fold-search t)) 180 (let ((case-fold-search t))
126 (cond 181 (cond
127 ((string-match "windows-nt\\|os/2\\|emx" (format "%s" system-type)) 182 ((string-match "windows-nt\\|os/2\\|emx" (format "%s" system-type))
139 (defvar gnus-tmp-name) 194 (defvar gnus-tmp-name)
140 (defvar gnus-tmp-closing-bracket) 195 (defvar gnus-tmp-closing-bracket)
141 (defvar gnus-tmp-subject-or-nil) 196 (defvar gnus-tmp-subject-or-nil)
142 197
143 (defun gnus-ems-redefine () 198 (defun gnus-ems-redefine ()
144 (cond 199 (cond
145 ((string-match "XEmacs\\|Lucid" emacs-version) 200 ((string-match "XEmacs\\|Lucid" emacs-version)
146 (gnus-xmas-redefine)) 201 (gnus-xmas-redefine))
147 202
148 ((featurep 'mule) 203 ((boundp 'MULE)
149 ;; Mule and new Emacs definitions 204 ;; Mule 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
167 (defalias 'gnus-truncate-string 'truncate-string) 205 (defalias 'gnus-truncate-string 'truncate-string)
168 206
169 (defvar gnus-summary-display-table nil 207 (fset 'gnus-summary-make-display-table (lambda () nil))
170 "Display table used in summary mode buffers.")
171 (fset 'gnus-cite-add-face 'gnus-mule-cite-add-face) 208 (fset 'gnus-cite-add-face 'gnus-mule-cite-add-face)
172 (fset 'gnus-max-width-function 'gnus-mule-max-width-function) 209 (fset 'gnus-max-width-function 'gnus-mule-max-width-function)
173 210
174 (when (boundp 'gnus-check-before-posting) 211 (if (boundp 'gnus-check-before-posting)
175 (setq gnus-check-before-posting 212 (setq gnus-check-before-posting
176 (delq 'long-lines 213 (delq 'long-lines
177 (delq 'control-chars gnus-check-before-posting)))) 214 (delq 'control-chars gnus-check-before-posting))))
178 215
179 (defun gnus-summary-line-format-spec () 216 (defun gnus-summary-line-format-spec ()
180 (insert gnus-tmp-unread gnus-tmp-replied 217 (insert gnus-tmp-unread gnus-tmp-replied
181 gnus-tmp-score-char gnus-tmp-indentation) 218 gnus-tmp-score-char gnus-tmp-indentation)
182 (put-text-property 219 (put-text-property
183 (point) 220 (point)
184 (progn 221 (progn
185 (insert 222 (insert
186 gnus-tmp-opening-bracket 223 gnus-tmp-opening-bracket
187 (format "%4d: %-20s" 224 (format "%4d: %-20s"
188 gnus-tmp-lines 225 gnus-tmp-lines
189 (if (> (length gnus-tmp-name) 20) 226 (if (> (length gnus-tmp-name) 20)
190 (truncate-string gnus-tmp-name 20) 227 (truncate-string gnus-tmp-name 20)
191 gnus-tmp-name)) 228 gnus-tmp-name))
192 gnus-tmp-closing-bracket) 229 gnus-tmp-closing-bracket)
193 (point)) 230 (point))
194 gnus-mouse-face-prop gnus-mouse-face) 231 gnus-mouse-face-prop gnus-mouse-face)
195 (insert " " gnus-tmp-subject-or-nil "\n")) 232 (insert " " gnus-tmp-subject-or-nil "\n"))
196 ))) 233 )))
197 234
198 (defun gnus-region-active-p ()
199 "Say whether the region is active."
200 (and (boundp 'transient-mark-mode)
201 transient-mark-mode
202 (boundp 'mark-active)
203 mark-active))
204 235
205 (provide 'gnus-ems) 236 (provide 'gnus-ems)
206 237
207 ;; Local Variables: 238 ;; Local Variables:
208 ;; byte-compile-warnings: '(redefine callargs) 239 ;; byte-compile-warnings: '(redefine callargs)