Commit | Line | Data |
---|---|---|
23f87bed | 1 | ;;; gnus-spec.el --- format spec functions for Gnus |
e84b4b86 | 2 | |
73b0cd50 | 3 | ;; Copyright (C) 1996-2011 Free Software Foundation, Inc. |
eec82323 | 4 | |
6748645f | 5 | ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> |
eec82323 LMI |
6 | ;; Keywords: news |
7 | ||
8 | ;; This file is part of GNU Emacs. | |
9 | ||
5e809f55 | 10 | ;; GNU Emacs is free software: you can redistribute it and/or modify |
eec82323 | 11 | ;; it under the terms of the GNU General Public License as published by |
5e809f55 GM |
12 | ;; the Free Software Foundation, either version 3 of the License, or |
13 | ;; (at your option) any later version. | |
eec82323 LMI |
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 | |
5e809f55 | 17 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
eec82323 LMI |
18 | ;; GNU General Public License for more details. |
19 | ||
20 | ;; You should have received a copy of the GNU General Public License | |
5e809f55 | 21 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. |
eec82323 LMI |
22 | |
23 | ;;; Commentary: | |
24 | ||
25 | ;;; Code: | |
26 | ||
f0b7f5a8 | 27 | ;; For Emacs <22.2 and XEmacs. |
2d1974c9 GM |
28 | (eval-and-compile |
29 | (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) | |
5ab7173c | 30 | (eval-when-compile (require 'cl)) |
139bbb9c | 31 | (defvar gnus-newsrc-file-version) |
5ab7173c | 32 | |
eec82323 LMI |
33 | (require 'gnus) |
34 | ||
23f87bed MB |
35 | (defcustom gnus-use-correct-string-widths (featurep 'xemacs) |
36 | "*If non-nil, use correct functions for dealing with wide characters." | |
bf247b6e | 37 | :version "22.1" |
23f87bed MB |
38 | :group 'gnus-format |
39 | :type 'boolean) | |
40 | ||
41 | (defcustom gnus-make-format-preserve-properties (featurep 'xemacs) | |
42 | "*If non-nil, use a replacement `format' function which preserves | |
0985c8f6 | 43 | text properties. This is only needed on XEmacs, as Emacs does this anyway." |
bf247b6e | 44 | :version "22.1" |
23f87bed MB |
45 | :group 'gnus-format |
46 | :type 'boolean) | |
47 | ||
eec82323 LMI |
48 | ;;; Internal variables. |
49 | ||
50 | (defvar gnus-summary-mark-positions nil) | |
51 | (defvar gnus-group-mark-positions nil) | |
52 | (defvar gnus-group-indentation "") | |
53 | ||
54 | ;; Format specs. The chunks below are the machine-generated forms | |
99d99081 | 55 | ;; that are to be evalled as the result of the default format strings. |
eec82323 LMI |
56 | ;; We write them in here to get them byte-compiled. That way the |
57 | ;; default actions will be quite fast, while still retaining the full | |
58 | ;; flexibility of the user-defined format specs. | |
59 | ||
60 | ;; First we have lots of dummy defvars to let the compiler know these | |
61 | ;; are really dynamic variables. | |
62 | ||
63 | (defvar gnus-tmp-unread) | |
64 | (defvar gnus-tmp-replied) | |
65 | (defvar gnus-tmp-score-char) | |
66 | (defvar gnus-tmp-indentation) | |
67 | (defvar gnus-tmp-opening-bracket) | |
68 | (defvar gnus-tmp-lines) | |
69 | (defvar gnus-tmp-name) | |
70 | (defvar gnus-tmp-closing-bracket) | |
71 | (defvar gnus-tmp-subject-or-nil) | |
72 | (defvar gnus-tmp-subject) | |
73 | (defvar gnus-tmp-marked) | |
74 | (defvar gnus-tmp-marked-mark) | |
75 | (defvar gnus-tmp-subscribed) | |
76 | (defvar gnus-tmp-process-marked) | |
77 | (defvar gnus-tmp-number-of-unread) | |
78 | (defvar gnus-tmp-group-name) | |
79 | (defvar gnus-tmp-group) | |
80 | (defvar gnus-tmp-article-number) | |
81 | (defvar gnus-tmp-unread-and-unselected) | |
82 | (defvar gnus-tmp-news-method) | |
83 | (defvar gnus-tmp-news-server) | |
84 | (defvar gnus-tmp-article-number) | |
85 | (defvar gnus-mouse-face) | |
86 | (defvar gnus-mouse-face-prop) | |
23f87bed MB |
87 | (defvar gnus-tmp-header) |
88 | (defvar gnus-tmp-from) | |
eec82323 | 89 | |
2d1974c9 GM |
90 | (declare-function gnus-summary-from-or-to-or-newsgroups "gnus-sum" |
91 | (header gnus-tmp-from)) | |
92 | ||
c7b98a1c | 93 | (defmacro gnus-lrm-string-p (string) |
e21bac42 G |
94 | (if (fboundp 'bidi-string-mark-left-to-right) |
95 | ;; LRM, RLM, PDF characters as integers to avoid breaking Emacs | |
96 | ;; 23. | |
97 | `(memq (aref ,string (1- (length ,string))) '(8206 8207 8236)) | |
c7b98a1c G |
98 | nil)) |
99 | ||
100 | (defvar gnus-lrm-string (if (ignore-errors (string 8206)) | |
101 | (propertize (string 8206) 'invisible t) | |
102 | "")) | |
103 | ||
eec82323 LMI |
104 | (defun gnus-summary-line-format-spec () |
105 | (insert gnus-tmp-unread gnus-tmp-replied | |
106 | gnus-tmp-score-char gnus-tmp-indentation) | |
107 | (gnus-put-text-property | |
108 | (point) | |
109 | (progn | |
110 | (insert | |
23f87bed MB |
111 | (format "%c%4s: %-23s%c" gnus-tmp-opening-bracket gnus-tmp-lines |
112 | (let ((val | |
113 | (inline | |
114 | (gnus-summary-from-or-to-or-newsgroups | |
115 | gnus-tmp-header gnus-tmp-from)))) | |
116 | (if (> (length val) 23) | |
c7b98a1c G |
117 | (if (gnus-lrm-string-p val) |
118 | (concat (substring val 0 23) gnus-lrm-string) | |
119 | (substring val 0 23)) | |
23f87bed MB |
120 | val)) |
121 | gnus-tmp-closing-bracket)) | |
eec82323 LMI |
122 | (point)) |
123 | gnus-mouse-face-prop gnus-mouse-face) | |
124 | (insert " " gnus-tmp-subject-or-nil "\n")) | |
125 | ||
126 | (defvar gnus-summary-line-format-spec | |
127 | (gnus-byte-code 'gnus-summary-line-format-spec)) | |
128 | ||
129 | (defun gnus-summary-dummy-line-format-spec () | |
130 | (insert "* ") | |
131 | (gnus-put-text-property | |
132 | (point) | |
133 | (progn | |
134 | (insert ": :") | |
135 | (point)) | |
136 | gnus-mouse-face-prop gnus-mouse-face) | |
137 | (insert " " gnus-tmp-subject "\n")) | |
138 | ||
139 | (defvar gnus-summary-dummy-line-format-spec | |
140 | (gnus-byte-code 'gnus-summary-dummy-line-format-spec)) | |
141 | ||
142 | (defun gnus-group-line-format-spec () | |
143 | (insert gnus-tmp-marked-mark gnus-tmp-subscribed | |
144 | gnus-tmp-process-marked | |
145 | gnus-group-indentation | |
146 | (format "%5s: " gnus-tmp-number-of-unread)) | |
147 | (gnus-put-text-property | |
148 | (point) | |
149 | (progn | |
150 | (insert gnus-tmp-group "\n") | |
151 | (1- (point))) | |
152 | gnus-mouse-face-prop gnus-mouse-face)) | |
153 | (defvar gnus-group-line-format-spec | |
154 | (gnus-byte-code 'gnus-group-line-format-spec)) | |
155 | ||
156 | (defvar gnus-format-specs | |
157 | `((version . ,emacs-version) | |
23f87bed | 158 | (gnus-version . ,(gnus-continuum-version)) |
01c52d31 | 159 | (group "%M\%S\%p\%P\%5y: %(%g%)\n" ,gnus-group-line-format-spec) |
eec82323 LMI |
160 | (summary-dummy "* %(: :%) %S\n" |
161 | ,gnus-summary-dummy-line-format-spec) | |
23f87bed | 162 | (summary "%U%R%z%I%(%[%4L: %-23,23f%]%) %s\n" |
eec82323 LMI |
163 | ,gnus-summary-line-format-spec)) |
164 | "Alist of format specs.") | |
165 | ||
23f87bed MB |
166 | (defvar gnus-default-format-specs gnus-format-specs) |
167 | ||
eec82323 LMI |
168 | (defvar gnus-article-mode-line-format-spec nil) |
169 | (defvar gnus-summary-mode-line-format-spec nil) | |
170 | (defvar gnus-group-mode-line-format-spec nil) | |
171 | ||
23f87bed | 172 | ;;; Phew. All that gruft is over with, fortunately. |
eec82323 LMI |
173 | |
174 | ;;;###autoload | |
175 | (defun gnus-update-format (var) | |
176 | "Update the format specification near point." | |
177 | (interactive | |
178 | (list | |
179 | (save-excursion | |
180 | (eval-defun nil) | |
181 | ;; Find the end of the current word. | |
182 | (re-search-forward "[ \t\n]" nil t) | |
183 | ;; Search backward. | |
184 | (when (re-search-backward "\\(gnus-[-a-z]+-line-format\\)" nil t) | |
185 | (match-string 1))))) | |
186 | (let* ((type (intern (progn (string-match "gnus-\\([-a-z]+\\)-line" var) | |
187 | (match-string 1 var)))) | |
188 | (entry (assq type gnus-format-specs)) | |
189 | value spec) | |
190 | (when entry | |
191 | (setq gnus-format-specs (delq entry gnus-format-specs))) | |
192 | (set | |
193 | (intern (format "%s-spec" var)) | |
194 | (gnus-parse-format (setq value (symbol-value (intern var))) | |
195 | (symbol-value (intern (format "%s-alist" var))) | |
196 | (not (string-match "mode" var)))) | |
197 | (setq spec (symbol-value (intern (format "%s-spec" var)))) | |
198 | (push (list type value spec) gnus-format-specs) | |
199 | ||
200 | (pop-to-buffer "*Gnus Format*") | |
201 | (erase-buffer) | |
202 | (lisp-interaction-mode) | |
23f87bed | 203 | (insert (gnus-pp-to-string spec)))) |
eec82323 LMI |
204 | |
205 | (defun gnus-update-format-specifications (&optional force &rest types) | |
5153a47a MB |
206 | "Update all (necessary) format specifications. |
207 | Return a list of updated types." | |
eec82323 LMI |
208 | ;; Make the indentation array. |
209 | ;; See whether all the stored info needs to be flushed. | |
210 | (when (or force | |
23f87bed MB |
211 | (not gnus-newsrc-file-version) |
212 | (not (equal (gnus-continuum-version) | |
213 | (gnus-continuum-version gnus-newsrc-file-version))) | |
eec82323 LMI |
214 | (not (equal emacs-version |
215 | (cdr (assq 'version gnus-format-specs))))) | |
216 | (setq gnus-format-specs nil)) | |
01c52d31 MB |
217 | ;; Flush the group format spec cache if there's the grouplens stuff |
218 | ;; or it doesn't support decoded group names. | |
91472578 | 219 | (when (memq 'group types) |
01c52d31 MB |
220 | (let* ((spec (assq 'group gnus-format-specs)) |
221 | (sspec (gnus-prin1-to-string (nth 2 spec)))) | |
222 | (when (or (string-match " gnus-tmp-grouplens[ )]" sspec) | |
223 | (not (string-match " gnus-tmp-decoded-group[ )]" sspec))) | |
91472578 | 224 | (setq gnus-format-specs (delq spec gnus-format-specs))))) |
eec82323 LMI |
225 | |
226 | ;; Go through all the formats and see whether they need updating. | |
5153a47a | 227 | (let (new-format entry type val updated) |
eec82323 | 228 | (while (setq type (pop types)) |
23f87bed MB |
229 | ;; Jump to the proper buffer to find out the value of the |
230 | ;; variable, if possible. (It may be buffer-local.) | |
eec82323 | 231 | (save-excursion |
5153a47a | 232 | (let ((buffer (intern (format "gnus-%s-buffer" type)))) |
eec82323 LMI |
233 | (when (and (boundp buffer) |
234 | (setq val (symbol-value buffer)) | |
6748645f LMI |
235 | (gnus-buffer-exists-p val)) |
236 | (set-buffer val)) | |
eec82323 LMI |
237 | (setq new-format (symbol-value |
238 | (intern (format "gnus-%s-line-format" type))))) | |
239 | (setq entry (cdr (assq type gnus-format-specs))) | |
240 | (if (and (car entry) | |
241 | (equal (car entry) new-format)) | |
242 | ;; Use the old format. | |
243 | (set (intern (format "gnus-%s-line-format-spec" type)) | |
244 | (cadr entry)) | |
245 | ;; This is a new format. | |
246 | (setq val | |
247 | (if (not (stringp new-format)) | |
248 | ;; This is a function call or something. | |
249 | new-format | |
250 | ;; This is a "real" format. | |
251 | (gnus-parse-format | |
252 | new-format | |
253 | (symbol-value | |
16409b0b | 254 | (intern (format "gnus-%s-line-format-alist" type))) |
eec82323 LMI |
255 | (not (string-match "mode$" (symbol-name type)))))) |
256 | ;; Enter the new format spec into the list. | |
257 | (if entry | |
258 | (progn | |
259 | (setcar (cdr entry) val) | |
260 | (setcar entry new-format)) | |
261 | (push (list type new-format val) gnus-format-specs)) | |
5153a47a MB |
262 | (set (intern (format "gnus-%s-line-format-spec" type)) val) |
263 | (push type updated)))) | |
eec82323 | 264 | |
5153a47a MB |
265 | (unless (assq 'version gnus-format-specs) |
266 | (push (cons 'version emacs-version) gnus-format-specs)) | |
267 | updated)) | |
eec82323 | 268 | |
052bd38a LMI |
269 | (defcustom gnus-mouse-face-0 'highlight |
270 | "The \"%(hello%)\" face." | |
271 | :group 'gnus-format | |
272 | :type 'face) | |
273 | ||
274 | (defcustom gnus-mouse-face-1 'highlight | |
275 | "The \"%1(hello%)\" face." | |
276 | :group 'gnus-format | |
277 | :type 'face) | |
278 | ||
279 | (defcustom gnus-mouse-face-2 'highlight | |
280 | "The \"%2(hello%)\" face." | |
281 | :group 'gnus-format | |
282 | :type 'face) | |
283 | ||
284 | (defcustom gnus-mouse-face-3 'highlight | |
285 | "The \"%3(hello%)\" face." | |
286 | :group 'gnus-format | |
287 | :type 'face) | |
288 | ||
289 | (defcustom gnus-mouse-face-4 'highlight | |
290 | "The \"%4(hello%)\" face." | |
291 | :group 'gnus-format | |
292 | :type 'face) | |
eec82323 LMI |
293 | |
294 | (defun gnus-mouse-face-function (form type) | |
295 | `(gnus-put-text-property | |
296 | (point) (progn ,@form (point)) | |
297 | gnus-mouse-face-prop | |
298 | ,(if (equal type 0) | |
299 | 'gnus-mouse-face | |
300 | `(quote ,(symbol-value (intern (format "gnus-mouse-face-%d" type))))))) | |
301 | ||
052bd38a LMI |
302 | (defcustom gnus-face-0 'bold |
303 | "The \"%{hello%}\" face." | |
304 | :group 'gnus-format | |
305 | :type 'face) | |
306 | ||
307 | (defcustom gnus-face-1 'italic | |
308 | "The \"%1{hello%}\" face." | |
309 | :group 'gnus-format | |
310 | :type 'face) | |
311 | ||
312 | (defcustom gnus-face-2 'bold-italic | |
313 | "The \"%2{hello%}\" face." | |
314 | :group 'gnus-format | |
315 | :type 'face) | |
316 | ||
317 | (defcustom gnus-face-3 'bold | |
318 | "The \"%3{hello%}\" face." | |
319 | :group 'gnus-format | |
320 | :type 'face) | |
321 | ||
322 | (defcustom gnus-face-4 'bold | |
323 | "The \"%4{hello%}\" face." | |
324 | :group 'gnus-format | |
325 | :type 'face) | |
eec82323 LMI |
326 | |
327 | (defun gnus-face-face-function (form type) | |
6748645f | 328 | `(gnus-add-text-properties |
eec82323 | 329 | (point) (progn ,@form (point)) |
6748645f | 330 | '(gnus-face t face ,(symbol-value (intern (format "gnus-face-%d" type)))))) |
eec82323 | 331 | |
16409b0b GM |
332 | (defun gnus-balloon-face-function (form type) |
333 | `(gnus-put-text-property | |
334 | (point) (progn ,@form (point)) | |
23f87bed MB |
335 | ,(if (fboundp 'balloon-help-mode) |
336 | ''balloon-help | |
337 | ''help-echo) | |
16409b0b GM |
338 | ,(intern (format "gnus-balloon-face-%d" type)))) |
339 | ||
23f87bed MB |
340 | (defun gnus-spec-tab (column) |
341 | (if (> column 0) | |
aa0a8561 | 342 | `(insert-char ? (max (- ,column (current-column)) 0)) |
23f87bed | 343 | (let ((column (abs column))) |
aa0a8561 MB |
344 | `(if (> (current-column) ,column) |
345 | (let ((end (point))) | |
346 | (if (= (move-to-column ,column) ,column) | |
347 | (delete-region (point) end) | |
348 | (delete-region (1- (point)) end) | |
349 | (insert " "))) | |
350 | (insert-char ? (max (- ,column (current-column)) 0)))))) | |
23f87bed MB |
351 | |
352 | (defun gnus-correct-length (string) | |
353 | "Return the correct width of STRING." | |
01c52d31 | 354 | (apply #'+ (mapcar #'char-width string))) |
23f87bed MB |
355 | |
356 | (defun gnus-correct-substring (string start &optional end) | |
357 | (let ((wstart 0) | |
358 | (wend 0) | |
359 | (wseek 0) | |
360 | (seek 0) | |
361 | (length (length string)) | |
362 | (string (concat string "\0"))) | |
363 | ;; Find the start position. | |
364 | (while (and (< seek length) | |
365 | (< wseek start)) | |
01c52d31 | 366 | (incf wseek (char-width (aref string seek))) |
23f87bed MB |
367 | (incf seek)) |
368 | (setq wstart seek) | |
369 | ;; Find the end position. | |
370 | (while (and (<= seek length) | |
371 | (or (not end) | |
372 | (<= wseek end))) | |
01c52d31 | 373 | (incf wseek (char-width (aref string seek))) |
23f87bed MB |
374 | (incf seek)) |
375 | (setq wend seek) | |
376 | (substring string wstart (1- wend)))) | |
377 | ||
378 | (defun gnus-string-width-function () | |
379 | (cond | |
380 | (gnus-use-correct-string-widths | |
381 | 'gnus-correct-length) | |
382 | ((fboundp 'string-width) | |
383 | 'string-width) | |
384 | (t | |
385 | 'length))) | |
386 | ||
387 | (defun gnus-substring-function () | |
388 | (cond | |
389 | (gnus-use-correct-string-widths | |
390 | 'gnus-correct-substring) | |
391 | ((fboundp 'string-width) | |
392 | 'gnus-correct-substring) | |
393 | (t | |
394 | 'substring))) | |
395 | ||
eec82323 LMI |
396 | (defun gnus-tilde-max-form (el max-width) |
397 | "Return a form that limits EL to MAX-WIDTH." | |
23f87bed MB |
398 | (let ((max (abs max-width)) |
399 | (length-fun (gnus-string-width-function)) | |
400 | (substring-fun (gnus-substring-function))) | |
eec82323 | 401 | (if (symbolp el) |
23f87bed | 402 | `(if (> (,length-fun ,el) ,max) |
eec82323 | 403 | ,(if (< max-width 0) |
23f87bed | 404 | `(,substring-fun ,el (- (,length-fun ,el) ,max)) |
c7b98a1c G |
405 | `(if (gnus-lrm-string-p ,el) |
406 | (concat (,substring-fun ,el 0 ,max) ,gnus-lrm-string) | |
407 | (,substring-fun ,el 0 ,max))) | |
eec82323 LMI |
408 | ,el) |
409 | `(let ((val (eval ,el))) | |
23f87bed | 410 | (if (> (,length-fun val) ,max) |
eec82323 | 411 | ,(if (< max-width 0) |
23f87bed | 412 | `(,substring-fun val (- (,length-fun val) ,max)) |
c7b98a1c G |
413 | `(if (gnus-lrm-string-p val) |
414 | (concat (,substring-fun val 0 ,max) ,gnus-lrm-string) | |
415 | (,substring-fun val 0 ,max))) | |
eec82323 LMI |
416 | val))))) |
417 | ||
418 | (defun gnus-tilde-cut-form (el cut-width) | |
419 | "Return a form that cuts CUT-WIDTH off of EL." | |
23f87bed MB |
420 | (let ((cut (abs cut-width)) |
421 | (length-fun (gnus-string-width-function)) | |
422 | (substring-fun (gnus-substring-function))) | |
eec82323 | 423 | (if (symbolp el) |
23f87bed | 424 | `(if (> (,length-fun ,el) ,cut) |
eec82323 | 425 | ,(if (< cut-width 0) |
23f87bed MB |
426 | `(,substring-fun ,el 0 (- (,length-fun ,el) ,cut)) |
427 | `(,substring-fun ,el ,cut)) | |
eec82323 LMI |
428 | ,el) |
429 | `(let ((val (eval ,el))) | |
23f87bed | 430 | (if (> (,length-fun val) ,cut) |
eec82323 | 431 | ,(if (< cut-width 0) |
23f87bed MB |
432 | `(,substring-fun val 0 (- (,length-fun val) ,cut)) |
433 | `(,substring-fun val ,cut)) | |
eec82323 LMI |
434 | val))))) |
435 | ||
436 | (defun gnus-tilde-ignore-form (el ignore-value) | |
437 | "Return a form that is blank when EL is IGNORE-VALUE." | |
438 | (if (symbolp el) | |
439 | `(if (equal ,el ,ignore-value) | |
440 | "" ,el) | |
441 | `(let ((val (eval ,el))) | |
442 | (if (equal val ,ignore-value) | |
443 | "" val)))) | |
444 | ||
23f87bed MB |
445 | (defun gnus-pad-form (el pad-width) |
446 | "Return a form that pads EL to PAD-WIDTH accounting for multi-column | |
447 | characters correctly. This is because `format' may pad to columns or to | |
448 | characters when given a pad value." | |
449 | (let ((pad (abs pad-width)) | |
450 | (side (< 0 pad-width)) | |
451 | (length-fun (gnus-string-width-function))) | |
452 | (if (symbolp el) | |
453 | `(let ((need (- ,pad (,length-fun ,el)))) | |
454 | (if (> need 0) | |
455 | (concat ,(when side '(make-string need ?\ )) | |
456 | ,el | |
457 | ,(when (not side) '(make-string need ?\ ))) | |
458 | ,el)) | |
459 | `(let* ((val (eval ,el)) | |
460 | (need (- ,pad (,length-fun val)))) | |
461 | (if (> need 0) | |
462 | (concat ,(when side '(make-string need ?\ )) | |
463 | val | |
464 | ,(when (not side) '(make-string need ?\ ))) | |
465 | val))))) | |
466 | ||
eec82323 LMI |
467 | (defun gnus-parse-format (format spec-alist &optional insert) |
468 | ;; This function parses the FORMAT string with the help of the | |
469 | ;; SPEC-ALIST and returns a list that can be eval'ed to return the | |
470 | ;; string. If the FORMAT string contains the specifiers %( and %) | |
471 | ;; the text between them will have the mouse-face text property. | |
16409b0b GM |
472 | ;; If the FORMAT string contains the specifiers %[ and %], the text between |
473 | ;; them will have the balloon-help text property. | |
23f87bed MB |
474 | (let ((case-fold-search nil)) |
475 | (if (string-match | |
476 |