Commit | Line | Data |
---|---|---|
23f87bed | 1 | ;;; gnus-spec.el --- format spec functions for Gnus |
e84b4b86 | 2 | |
ba318903 | 3 | ;; Copyright (C) 1996-2014 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 | ||
5ab7173c | 27 | (eval-when-compile (require 'cl)) |
139bbb9c | 28 | (defvar gnus-newsrc-file-version) |
5ab7173c | 29 | |
eec82323 LMI |
30 | (require 'gnus) |
31 | ||
23f87bed MB |
32 | (defcustom gnus-use-correct-string-widths (featurep 'xemacs) |
33 | "*If non-nil, use correct functions for dealing with wide characters." | |
bf247b6e | 34 | :version "22.1" |
23f87bed MB |
35 | :group 'gnus-format |
36 | :type 'boolean) | |
37 | ||
38 | (defcustom gnus-make-format-preserve-properties (featurep 'xemacs) | |
39 | "*If non-nil, use a replacement `format' function which preserves | |
0985c8f6 | 40 | text properties. This is only needed on XEmacs, as Emacs does this anyway." |
bf247b6e | 41 | :version "22.1" |
23f87bed MB |
42 | :group 'gnus-format |
43 | :type 'boolean) | |
44 | ||
eec82323 LMI |
45 | ;;; Internal variables. |
46 | ||
47 | (defvar gnus-summary-mark-positions nil) | |
48 | (defvar gnus-group-mark-positions nil) | |
49 | (defvar gnus-group-indentation "") | |
50 | ||
51 | ;; Format specs. The chunks below are the machine-generated forms | |
99d99081 | 52 | ;; that are to be evalled as the result of the default format strings. |
eec82323 LMI |
53 | ;; We write them in here to get them byte-compiled. That way the |
54 | ;; default actions will be quite fast, while still retaining the full | |
55 | ;; flexibility of the user-defined format specs. | |
56 | ||
57 | ;; First we have lots of dummy defvars to let the compiler know these | |
58 | ;; are really dynamic variables. | |
59 | ||
60 | (defvar gnus-tmp-unread) | |
61 | (defvar gnus-tmp-replied) | |
62 | (defvar gnus-tmp-score-char) | |
63 | (defvar gnus-tmp-indentation) | |
64 | (defvar gnus-tmp-opening-bracket) | |
65 | (defvar gnus-tmp-lines) | |
66 | (defvar gnus-tmp-name) | |
67 | (defvar gnus-tmp-closing-bracket) | |
68 | (defvar gnus-tmp-subject-or-nil) | |
69 | (defvar gnus-tmp-subject) | |
70 | (defvar gnus-tmp-marked) | |
71 | (defvar gnus-tmp-marked-mark) | |
72 | (defvar gnus-tmp-subscribed) | |
73 | (defvar gnus-tmp-process-marked) | |
74 | (defvar gnus-tmp-number-of-unread) | |
75 | (defvar gnus-tmp-group-name) | |
76 | (defvar gnus-tmp-group) | |
77 | (defvar gnus-tmp-article-number) | |
78 | (defvar gnus-tmp-unread-and-unselected) | |
79 | (defvar gnus-tmp-news-method) | |
80 | (defvar gnus-tmp-news-server) | |
eec82323 LMI |
81 | (defvar gnus-mouse-face) |
82 | (defvar gnus-mouse-face-prop) | |
23f87bed MB |
83 | (defvar gnus-tmp-header) |
84 | (defvar gnus-tmp-from) | |
eec82323 | 85 | |
2d1974c9 GM |
86 | (declare-function gnus-summary-from-or-to-or-newsgroups "gnus-sum" |
87 | (header gnus-tmp-from)) | |
88 | ||
c7b98a1c | 89 | (defmacro gnus-lrm-string-p (string) |
e21bac42 G |
90 | (if (fboundp 'bidi-string-mark-left-to-right) |
91 | ;; LRM, RLM, PDF characters as integers to avoid breaking Emacs | |
92 | ;; 23. | |
93 | `(memq (aref ,string (1- (length ,string))) '(8206 8207 8236)) | |
c7b98a1c G |
94 | nil)) |
95 | ||
96 | (defvar gnus-lrm-string (if (ignore-errors (string 8206)) | |
97 | (propertize (string 8206) 'invisible t) | |
98 | "")) | |
99 | ||
89b163db G |
100 | (defvar gnus-summary-line-format-spec nil) |
101 | (defvar gnus-summary-dummy-line-format-spec nil) | |
102 | (defvar gnus-group-line-format-spec nil) | |
eec82323 LMI |
103 | |
104 | (defvar gnus-format-specs | |
105 | `((version . ,emacs-version) | |
89b163db | 106 | (gnus-version . ,(gnus-continuum-version))) |
eec82323 LMI |
107 | "Alist of format specs.") |
108 | ||
23f87bed MB |
109 | (defvar gnus-default-format-specs gnus-format-specs) |
110 | ||
eec82323 LMI |
111 | (defvar gnus-article-mode-line-format-spec nil) |
112 | (defvar gnus-summary-mode-line-format-spec nil) | |
113 | (defvar gnus-group-mode-line-format-spec nil) | |
114 | ||
23f87bed | 115 | ;;; Phew. All that gruft is over with, fortunately. |
eec82323 LMI |
116 | |
117 | ;;;###autoload | |
118 | (defun gnus-update-format (var) | |
119 | "Update the format specification near point." | |
120 | (interactive | |
121 | (list | |
122 | (save-excursion | |
123 | (eval-defun nil) | |
124 | ;; Find the end of the current word. | |
125 | (re-search-forward "[ \t\n]" nil t) | |
126 | ;; Search backward. | |
127 | (when (re-search-backward "\\(gnus-[-a-z]+-line-format\\)" nil t) | |
128 | (match-string 1))))) | |
129 | (let* ((type (intern (progn (string-match "gnus-\\([-a-z]+\\)-line" var) | |
130 | (match-string 1 var)))) | |
131 | (entry (assq type gnus-format-specs)) | |
132 | value spec) | |
133 | (when entry | |
134 | (setq gnus-format-specs (delq entry gnus-format-specs))) | |
135 | (set | |
136 | (intern (format "%s-spec" var)) | |
137 | (gnus-parse-format (setq value (symbol-value (intern var))) | |
138 | (symbol-value (intern (format "%s-alist" var))) | |
139 | (not (string-match "mode" var)))) | |
140 | (setq spec (symbol-value (intern (format "%s-spec" var)))) | |
141 | (push (list type value spec) gnus-format-specs) | |
142 | ||
143 | (pop-to-buffer "*Gnus Format*") | |
144 | (erase-buffer) | |
145 | (lisp-interaction-mode) | |
23f87bed | 146 | (insert (gnus-pp-to-string spec)))) |
eec82323 LMI |
147 | |
148 | (defun gnus-update-format-specifications (&optional force &rest types) | |
5153a47a MB |
149 | "Update all (necessary) format specifications. |
150 | Return a list of updated types." | |
eec82323 LMI |
151 | ;; Make the indentation array. |
152 | ;; See whether all the stored info needs to be flushed. | |
153 | (when (or force | |
23f87bed MB |
154 | (not gnus-newsrc-file-version) |
155 | (not (equal (gnus-continuum-version) | |
156 | (gnus-continuum-version gnus-newsrc-file-version))) | |
eec82323 LMI |
157 | (not (equal emacs-version |
158 | (cdr (assq 'version gnus-format-specs))))) | |
159 | (setq gnus-format-specs nil)) | |
eec82323 | 160 | ;; Go through all the formats and see whether they need updating. |
5153a47a | 161 | (let (new-format entry type val updated) |
eec82323 | 162 | (while (setq type (pop types)) |
23f87bed MB |
163 | ;; Jump to the proper buffer to find out the value of the |
164 | ;; variable, if possible. (It may be buffer-local.) | |
eec82323 | 165 | (save-excursion |
5153a47a | 166 | (let ((buffer (intern (format "gnus-%s-buffer" type)))) |
eec82323 LMI |
167 | (when (and (boundp buffer) |
168 | (setq val (symbol-value buffer)) | |
6748645f LMI |
169 | (gnus-buffer-exists-p val)) |
170 | (set-buffer val)) | |
eec82323 LMI |
171 | (setq new-format (symbol-value |
172 | (intern (format "gnus-%s-line-format" type))))) | |
173 | (setq entry (cdr (assq type gnus-format-specs))) | |
174 | (if (and (car entry) | |
175 | (equal (car entry) new-format)) | |
176 | ;; Use the old format. | |
177 | (set (intern (format "gnus-%s-line-format-spec" type)) | |
178 | (cadr entry)) | |
179 | ;; This is a new format. | |
180 | (setq val | |
181 | (if (not (stringp new-format)) | |
182 | ;; This is a function call or something. | |
183 | new-format | |
184 | ;; This is a "real" format. | |
185 | (gnus-parse-format | |
186 | new-format | |
187 | (symbol-value | |
16409b0b | 188 | (intern (format "gnus-%s-line-format-alist" type))) |
eec82323 LMI |
189 | (not (string-match "mode$" (symbol-name type)))))) |
190 | ;; Enter the new format spec into the list. | |
191 | (if entry | |
192 | (progn | |
193 | (setcar (cdr entry) val) | |
194 | (setcar entry new-format)) | |
195 | (push (list type new-format val) gnus-format-specs)) | |
5153a47a MB |
196 | (set (intern (format "gnus-%s-line-format-spec" type)) val) |
197 | (push type updated)))) | |
eec82323 | 198 | |
5153a47a MB |
199 | (unless (assq 'version gnus-format-specs) |
200 | (push (cons 'version emacs-version) gnus-format-specs)) | |
201 | updated)) | |
eec82323 | 202 | |
052bd38a LMI |
203 | (defcustom gnus-mouse-face-0 'highlight |
204 | "The \"%(hello%)\" face." | |
205 | :group 'gnus-format | |
206 | :type 'face) | |
207 | ||
208 | (defcustom gnus-mouse-face-1 'highlight | |
209 | "The \"%1(hello%)\" face." | |
210 | :group 'gnus-format | |
211 | :type 'face) | |
212 | ||
213 | (defcustom gnus-mouse-face-2 'highlight | |
214 | "The \"%2(hello%)\" face." | |
215 | :group 'gnus-format | |
216 | :type 'face) | |
217 | ||
218 | (defcustom gnus-mouse-face-3 'highlight | |
219 | "The \"%3(hello%)\" face." | |
220 | :group 'gnus-format | |
221 | :type 'face) | |
222 | ||
223 | (defcustom gnus-mouse-face-4 'highlight | |
224 | "The \"%4(hello%)\" face." | |
225 | :group 'gnus-format | |
226 | :type 'face) | |
eec82323 LMI |
227 | |
228 | (defun gnus-mouse-face-function (form type) | |
229 | `(gnus-put-text-property | |
230 | (point) (progn ,@form (point)) | |
231 | gnus-mouse-face-prop | |
232 | ,(if (equal type 0) | |
233 | 'gnus-mouse-face | |
234 | `(quote ,(symbol-value (intern (format "gnus-mouse-face-%d" type))))))) | |
235 | ||
052bd38a LMI |
236 | (defcustom gnus-face-0 'bold |
237 | "The \"%{hello%}\" face." | |
238 | :group 'gnus-format | |
239 | :type 'face) | |
240 | ||
241 | (defcustom gnus-face-1 'italic | |
242 | "The \"%1{hello%}\" face." | |
243 | :group 'gnus-format | |
244 | :type 'face) | |
245 | ||
246 | (defcustom gnus-face-2 'bold-italic | |
247 | "The \"%2{hello%}\" face." | |
248 | :group 'gnus-format | |
249 | :type 'face) | |
250 | ||
251 | (defcustom gnus-face-3 'bold | |
252 | "The \"%3{hello%}\" face." | |
253 | :group 'gnus-format | |
254 | :type 'face) | |
255 | ||
256 | (defcustom gnus-face-4 'bold | |
257 | "The \"%4{hello%}\" face." | |
258 | :group 'gnus-format | |
259 | :type 'face) | |
eec82323 LMI |
260 | |
261 | (defun gnus-face-face-function (form type) | |
6748645f | 262 | `(gnus-add-text-properties |
eec82323 | 263 | (point) (progn ,@form (point)) |
cc21c235 G |
264 | (cons 'face |
265 | (cons | |
266 | ;; Delay consing the value of the `face' property until | |
267 | ;; `gnus-add-text-properties' runs, since it will be modified | |
268 | ;; by `gnus-put-text-property-excluding-characters-with-faces'. | |
19693cc1 | 269 | (list ',(symbol-value (intern (format "gnus-face-%d" type))) 'default) |
cc21c235 G |
270 | ;; Redundant now, but still convenient. |
271 | '(gnus-face t))))) | |
eec82323 | 272 | |
16409b0b GM |
273 | (defun gnus-balloon-face-function (form type) |
274 | `(gnus-put-text-property | |
275 | (point) (progn ,@form (point)) | |
23f87bed MB |
276 | ,(if (fboundp 'balloon-help-mode) |
277 | ''balloon-help | |
278 | ''help-echo) | |
16409b0b GM |
279 | ,(intern (format "gnus-balloon-face-%d" type)))) |
280 | ||
23f87bed MB |
281 | (defun gnus-spec-tab (column) |
282 | (if (> column 0) | |
aa0a8561 | 283 | `(insert-char ? (max (- ,column (current-column)) 0)) |
23f87bed | 284 | (let ((column (abs column))) |
aa0a8561 MB |
285 | `(if (> (current-column) ,column) |
286 | (let ((end (point))) | |
287 | (if (= (move-to-column ,column) ,column) | |
288 | (delete-region (point) end) | |
289 | (delete-region (1- (point)) end) | |
290 | (insert " "))) | |
291 | (insert-char ? (max (- ,column (current-column)) 0)))))) | |
23f87bed MB |
292 | |
293 | (defun gnus-correct-length (string) | |
294 | "Return the correct width of STRING." | |
01c52d31 | 295 | (apply #'+ (mapcar #'char-width string))) |
23f87bed MB |
296 | |
297 | (defun gnus-correct-substring (string start &optional end) | |
298 | (let ((wstart 0) | |
299 | (wend 0) | |
300 | (wseek 0) | |
301 | (seek 0) | |
302 | (length (length string)) | |
303 | (string (concat string "\0"))) | |
304 | ;; Find the start position. | |
305 | (while (and (< seek length) | |
306 | (< wseek start)) | |
01c52d31 | 307 | (incf wseek (char-width (aref string seek))) |
23f87bed MB |
308 | (incf seek)) |
309 | (setq wstart seek) | |
310 | ;; Find the end position. | |
311 | (while (and (<= seek length) | |
312 | (or (not end) | |
313 | (<= wseek end))) | |
01c52d31 | 314 | (incf wseek (char-width (aref string seek))) |
23f87bed MB |
315 | (incf seek)) |
316 | (setq wend seek) | |
317 | (substring string wstart (1- wend)))) | |
318 | ||
319 | (defun gnus-string-width-function () | |
320 | (cond | |
321 | (gnus-use-correct-string-widths | |
322 | 'gnus-correct-length) | |
323 | ((fboundp 'string-width) | |
324 | 'string-width) | |
325 | (t | |
326 | 'length))) | |
327 | ||
328 | (defun gnus-substring-function () | |
329 | (cond | |
330 | (gnus-use-correct-string-widths | |
331 | 'gnus-correct-substring) | |
332 | ((fboundp 'string-width) | |
333 | 'gnus-correct-substring) | |
334 | (t | |
335 | 'substring))) | |
336 | ||
eec82323 LMI |
337 | (defun gnus-tilde-max-form (el max-width) |
338 | "Return a form that limits EL to MAX-WIDTH." | |
23f87bed MB |
339 | (let ((max (abs max-width)) |
340 | (length-fun (gnus-string-width-function)) | |
341 | (substring-fun (gnus-substring-function))) | |
eec82323 | 342 | (if (symbolp el) |
23f87bed | 343 | `(if (> (,length-fun ,el) ,max) |
eec82323 | 344 | ,(if (< max-width 0) |
23f87bed | 345 | `(,substring-fun ,el (- (,length-fun ,el) ,max)) |
c7b98a1c G |
346 | `(if (gnus-lrm-string-p ,el) |
347 | (concat (,substring-fun ,el 0 ,max) ,gnus-lrm-string) | |
348 | (,substring-fun ,el 0 ,max))) | |
eec82323 LMI |
349 | ,el) |
350 | `(let ((val (eval ,el))) | |
23f87bed | 351 | (if (> (,length-fun val) ,max) |
eec82323 | 352 | ,(if (< max-width 0) |
23f87bed | 353 | `(,substring-fun val (- (,length-fun val) ,max)) |
c7b98a1c G |
354 | `(if (gnus-lrm-string-p val) |
355 | (concat (,substring-fun val 0 ,max) ,gnus-lrm-string) | |
356 | (,substring-fun val 0 ,max))) | |
eec82323 LMI |
357 | val))))) |
358 | ||
359 | (defun gnus-tilde-cut-form (el cut-width) | |
360 | "Return a form that cuts CUT-WIDTH off of EL." | |
23f87bed MB |
361 | (let ((cut (abs cut-width)) |
362 | (length-fun (gnus-string-width-function)) | |
363 | (substring-fun (gnus-substring-function))) | |
eec82323 | 364 | (if (symbolp el) |
23f87bed | 365 | `(if (> (,length-fun ,el) ,cut) |
eec82323 | 366 | ,(if (< cut-width 0) |
23f87bed MB |
367 | `(,substring-fun ,el 0 (- (,length-fun ,el) ,cut)) |
368 | `(,substring-fun ,el ,cut)) | |
eec82323 LMI |
369 | ,el) |
370 | `(let ((val (eval ,el))) | |
23f87bed | 371 | (if (> (,length-fun val) ,cut) |
eec82323 | 372 | ,(if (< cut-width 0) |
23f87bed MB |
373 | `(,substring-fun val 0 (- (,length-fun val) ,cut)) |
374 | `(,substring-fun val ,cut)) | |
eec82323 LMI |
375 | val))))) |
376 | ||
377 | (defun gnus-tilde-ignore-form (el ignore-value) | |
378 | "Return a form that is blank when EL is IGNORE-VALUE." | |
379 | (if (symbolp el) | |
380 | `(if (equal ,el ,ignore-value) | |
381 | "" ,el) | |
382 | `(let ((val (eval ,el))) | |
383 | (if (equal val ,ignore-value) | |
384 | "" val)))) | |
385 | ||
23f87bed MB |
386 | (defun gnus-pad-form (el pad-width) |
387 | "Return a form that pads EL to PAD-WIDTH accounting for multi-column | |
388 | characters correctly. This is because `format' may pad to columns or to | |
389 | characters when given a pad value." | |
390 | (let ((pad (abs pad-width)) | |
391 | (side (< 0 pad-width)) | |
392 | (length-fun (gnus-string-width-function))) | |
393 | (if (symbolp el) | |
394 | `(let ((need (- ,pad (,length-fun ,el)))) | |
395 | (if (> need 0) | |
396 | (concat ,(when side '(make-string need ?\ )) | |
397 | ,el | |
398 | ,(when (not side) '(make-string need ?\ ))) | |
399 | ,el)) | |
400 | `(let* ((val (eval ,el)) | |
401 | (need (- ,pad (,length-fun val)))) | |
402 | (if (> need 0) | |
403 | (concat ,(when side '(make-string need ?\ )) | |
404 | val | |
405 | ,(when (not side) '(make-string need ?\ ))) | |
406 | val))))) | |
407 | ||
eec82323 LMI |
408 | (defun gnus-parse-format (format spec-alist &optional insert) |
409 | ;; This function parses the FORMAT string with the help of the | |
410 | ;; SPEC-ALIST and returns a list that can be eval'ed to return the | |
411 | ;; string. If the FORMAT string contains the specifiers %( and %) | |
412 | ;; the text between them will have the mouse-face text property. | |
16409b0b GM |
413 | ;; If the FORMAT string contains the specifiers %[ and %], the text between |
414 | ;; them will have the balloon-help text property. | |
23f87bed MB |
415 | (let ((case-fold-search nil)) |
416 | (if (string-match | |
c38e0c97 | 417 | "\\`\\(.*\\)%[0-9]?[{(«]\\(.*\\)%[0-9]?[»})]\\(.*\n?\\)\\'\\|%[-0-9]*=\\|%[-0-9]*\\*" |
23f87bed MB |
418 | format) |
419 | (gnus-parse-complex-format format spec-alist) | |
420 | ;; This is a simple format. | |
421 | (gnus-parse-simple-format format spec-alist insert)))) | |
eec82323 LMI |
422 | |
423 | (defun gnus-parse-complex-format (format spec-alist) | |
23f87bed MB |
424 | (let ((cursor-spec nil)) |
425 | (save-excursion | |
426 | (gnus-set-work-buffer) | |
427 | (insert format) | |
428 | (goto-char (point-min)) | |
429 | (while (re-search-forward "\"" nil t) | |
430 | (replace-match "\\\"" nil t)) | |
431 | (goto-char (point-min)) | |
432 | (insert "(\"") | |
433 | ;; Convert all font specs into font spec lists. | |
c38e0c97 | 434 | (while (re-search-forward "%\\([0-9]+\\)?\\([«»{}()]\\)" nil t) |
23f87bed MB |
435 | (let ((number (if (match-beginning 1) |
436 | (match-string 1) "0")) | |
437 | (delim (aref (match-string 2) 0))) | |
438 | (if (or (= delim ?\() | |
439 | (= delim ?\{) | |
d8a6e1af | 440 | (= delim 171)) ; « |
23f87bed MB |
441 | (replace-match (concat "\"(" |
442 | (cond ((= delim ?\() "mouse") | |
443 | ((= delim ?\{) "face") | |
444 | (t "balloon")) | |
445 | " " number " \"") | |
446 | t t) | |
447 | (replace-match "\")\"")))) | |
448 | (goto-char (point-max)) | |
449 | (insert "\")") | |
450 | ;; Convert point position commands. | |
451 | (goto-char (point-min)) | |
452 | (let ((case-fold-search nil)) | |
453 | (while (re-search-forward "%\\([-0-9]+\\)?\\*" nil t) | |
454 | (replace-match "\"(point)\"" t t) | |
455 | (setq cursor-spec t))) | |
456 | ;; Convert TAB commands. | |
457 | (goto-char (point-min)) | |
458 | (while (re-search-forward "%\\([-0-9]+\\)=" nil t) | |
459 | (replace-match (format "\"(tab %s)\"" (match-string 1)) t t)) | |
460 | ;; Convert the buffer into the spec. | |
461 | (goto-char (point-min)) | |
462 | (let ((form (read (current-buffer)))) | |
463 | (if cursor-spec | |
464 | `(let (gnus-position) | |
465 | ,@(gnus-complex-form-to-spec form spec-alist) | |
466 | (if gnus-position | |
467 | (gnus-put-text-property gnus-position (1+ gnus-position) | |
468 | 'gnus-position t))) | |
469 | `(progn | |
470 | ,@(gnus-complex-form-to-spec form spec-alist))))))) | |
eec82323 LMI |
471 | |
472 | (defun gnus-complex-form-to-spec (form spec-alist) | |
473 | (delq nil | |
474 | (mapcar | |
475 | (lambda (sform) | |
23f87bed MB |
476 | (cond |
477 | ((stringp sform) | |
478 | (gnus-parse-simple-format sform spec-alist t)) | |
479 | ((eq (car sform) 'point) | |
480 | '(setq gnus-position (point))) | |
481 | ((eq (car sform) 'tab) | |
482 | (gnus-spec-tab (cadr sform))) | |
483 | (t | |
eec82323 LMI |
484 | (funcall (intern (format "gnus-%s-face-function" (car sform))) |
485 | (gnus-complex-form-to-spec (cddr sform) spec-alist) | |
23f87bed | 486 | (nth 1 sform))))) |
eec82323 LMI |
487 | form))) |
488 | ||
23f87bed MB |
489 | |
490 | (defun gnus-xmas-format (fstring &rest args) | |
491 | "A version of `format' which preserves text properties. | |
492 | ||
493 | Required for XEmacs, where the built in `format' function strips all text | |
494 | properties from both the format string and any inserted strings. | |
495 | ||
496 | Only supports the format sequence %s, and %% for inserting | |
497 | literal % characters. A pad width and an optional - (to right pad) | |
498 | are supported for %s." | |
499 | (let ((re "%%\\|%\\(-\\)?\\([1-9][0-9]*\\)?s") | |
500 | (n (length args))) | |
501 | (with-temp-buffer | |
502 | (insert fstring) | |
503 | (goto-char (point-min)) | |
504 | (while (re-search-forward re nil t) | |
505 | (goto-char (match-end 0)) | |
506 | (cond | |
507 | ((string= (match-string 0) "%%") | |
508 | (delete-char -1)) | |
509 | (t | |
510 | (if (null args) | |
311273ab GM |
511 | (signal 'wrong-number-of-arguments |
512 | (list #'gnus-xmas-format n fstring))) | |
e9bd5782 | 513 | (let* ((minlen (string-to-number (or (match-string 2) ""))) |
23f87bed MB |
514 | (arg (car args)) |
515 | (str (if (stringp arg) arg (format "%s" arg))) | |
516 | (lpad (null (match-string 1))) | |
517 | (padlen (max 0 (- minlen (length str))))) | |
518 | (replace-match "") | |
519 | (if lpad (insert-char ?\ padlen)) | |
520 | (insert str) | |
521 | (unless lpad (insert-char ?\ padlen)) | |
522 | (setq args (cdr args)))))) | |
523 | (buffer-string)))) | |
524 | ||
eec82323 LMI |
525 | (defun gnus-parse-simple-format (format spec-alist &optional insert) |
526 | ;; This function parses the FORMAT string with the help of the | |
527 | ;; SPEC-ALIST and returns a list that can be eval'ed to return a | |
528 | ;; string. | |
529 | (let ((max-width 0) | |
530 | spec flist fstring elem result dontinsert user-defined | |
531 | type value pad-width spec-beg cut-width ignore-value | |
23f87bed | 532 | tilde-form tilde elem-type extended-spec) |
eec82323 LMI |
533 | (save-excursion |
534 | (gnus-set-work-buffer) | |
535 | (insert format) | |
536 | (goto-char (point-min)) | |
537 | (while (re-search-forward "%" nil t) | |
538 | (setq user-defined nil | |
539 | spec-beg nil | |
540 | pad-width nil | |
541 | max-width nil | |
542 | cut-width nil | |
543 | ignore-value nil | |
23f87bed MB |
544 | tilde-form nil |
545 | extended-spec nil) | |
eec82323 LMI |
546 | (setq spec-beg (1- (point))) |
547 | ||
548 | ;; Parse this spec fully. | |
549 | (while | |
550 | (cond | |
551 | ((looking-at "\\([-.0-9]+\\)\\(,[-0-9]+\\)?") | |
552 | (setq pad-width (string-to-number (match-string 1))) | |
553 | (when (match-beginning 2) | |
554 | (setq max-width (string-to-number (buffer-substring | |
555 | (1+ (match-beginning 2)) | |
556 | (match-end 2))))) | |
557 | (goto-char (match-end 0))) | |
558 | ((looking-at "~") | |
559 | (forward-char 1) | |
560 | (setq tilde (read (current-buffer)) | |
561 | type (car tilde) | |
562 | value (cadr tilde)) | |
563 | (cond | |
564 | ((memq type '(pad pad-left)) | |
565 | (setq pad-width value)) | |
566 | ((eq type 'pad-right) | |
567 | (setq pad-width (- value))) | |
568 | ((memq type '(max-right max)) | |
569 | (setq max-width value)) | |
570 | ((eq type 'max-left) | |
571 | (setq max-width (- value))) | |
572 | ((memq type '(cut cut-left)) | |
573 | (setq cut-width value)) | |
574 | ((eq type 'cut-right) | |
575 | (setq cut-width (- value))) | |
576 | ((eq type 'ignore) | |
577 | (setq ignore-value | |
578 | (if (stringp value) value (format "%s" value)))) | |
579 | ((eq type 'form) | |
580 | (setq tilde-form value)) | |
581 | (t | |
582 | (error "Unknown tilde type: %s" tilde))) | |
583 | t) | |
584 | (t | |
585 | nil))) | |
23f87bed MB |
586 | (cond |
587 | ;; User-defined spec -- find the spec name. | |
588 | ((eq (setq spec (char-after)) ?u) | |
eec82323 | 589 | (forward-char 1) |
23f87bed MB |
590 | (when (and (eq (setq user-defined (char-after)) ?&) |
591 | (looking-at "&\\([^;]+\\);")) | |
592 | (setq user-defined (match-string 1)) | |
593 | (goto-char (match-end 1)))) | |
594 | ;; extended spec | |
595 | ((and (eq spec ?&) (looking-at "&\\([^;]+\\);")) | |
596 | (setq extended-spec (intern (match-string 1))) | |
597 | (goto-char (match-end 1)))) | |
eec82323 LMI |
598 | (forward-char 1) |
599 | (delete-region spec-beg (point)) | |
600 | ||
601 | ;; Now we have all the relevant data on this spec, so | |
602 | ;; we start doing stuff. | |
603 | (insert "%") | |
604 | (if (eq spec ?%) | |
605 | ;; "%%" just results in a "%". | |
606 | (insert "%") | |
607 | (cond | |
608 | ;; Do tilde forms. | |
609 | ((eq spec ?@) | |
610 | (setq elem (list tilde-form ?s))) | |
611 | ;; Treat user defined format specifiers specially. | |
612 | (user-defined | |
613 | (setq elem | |
614 | (list | |
23f87bed MB |
615 | (list (intern (format |
616 | (if (stringp user-defined) | |
617 | "gnus-user-format-function-%s" | |
618 | "gnus-user-format-function-%c") | |
619 | user-defined)) | |
eec82323 LMI |
620 | 'gnus-tmp-header) |
621 | ?s))) | |
622 | ;; Find the specification from `spec-alist'. | |
23f87bed | 623 | ((setq elem (cdr (assq (or extended-spec spec) spec-alist)))) |
01c52d31 MB |
624 | ;; We used to use "%l" for displaying the grouplens score. |
625 | ((eq spec ?l) | |
626 | (setq elem '("" ?s))) | |
eec82323 LMI |
627 | (t |
628 | (setq elem '("*" ?s)))) | |
629 | (setq elem-type (cadr elem)) | |
630 | ;; Insert the new format elements. | |
23f87bed MB |
631 | (when (and pad-width |
632 | (not (and (featurep 'xemacs) | |
633 | gnus-use-correct-string-widths))) | |
eec82323 | 634 | (insert (number-to-string pad-width))) |
99d99081 | 635 | ;; Create the form to be evalled. |
23f87bed MB |
636 | (if (or max-width cut-width ignore-value |
637 | (and (featurep 'xemacs) | |
638 | gnus-use-correct-string-widths)) | |
eec82323 LMI |
639 | (progn |
640 | (insert ?s) | |
641 | (let ((el (car elem))) | |
642 | (cond ((= (cadr elem) ?c) | |
643 | (setq el (list 'char-to-string el))) | |
644 | ((= (cadr elem) ?d) | |
645 | (setq el (list 'int-to-string el)))) | |
646 | (when ignore-value | |
647 | (setq el (gnus-tilde-ignore-form el ignore-value))) | |
648 | (when cut-width | |
649 | (setq el (gnus-tilde-cut-form el cut-width))) | |
650 | (when max-width | |
651 | (setq el (gnus-tilde-max-form el max-width))) | |
23f87bed MB |
652 | (when pad-width |
653 | (setq el (gnus-pad-form el pad-width))) | |
eec82323 LMI |
654 | (push el flist))) |
655 | (insert elem-type) | |
656 | (push (car elem) flist)))) | |
23f87bed | 657 | (setq fstring (buffer-substring-no-properties (point-min) (point-max)))) |
eec82323 LMI |
658 | |
659 | ;; Do some postprocessing to increase efficiency. | |
660 | (setq | |
661 | result | |
662 | (cond | |
23f87bed | 663 | ;; Emptiness. |
eec82323 LMI |
664 | ((string= fstring "") |
665 | nil) | |
666 | ;; Not a format string. | |
667 | ((not (string-match "%" fstring)) | |
668 | (list fstring)) | |
669 | ;; A format string with just a single string spec. | |
670 | ((string= fstring "%s") | |
671 | (list (car flist))) | |
672 | ;; A single character. | |
673 | ((string= fstring "%c") | |
674 | (list (car flist))) | |
675 | ;; A single number. | |
676 | ((string= fstring "%d") | |
01c52d31 | 677 | (setq dontinsert t) |
eec82323 | 678 | (if insert |
a1d16a7b | 679 | `(insert (int-to-string ,(car flist))) |
eec82323 LMI |
680 | (list `(int-to-string ,(car flist))))) |
681 | ;; Just lots of chars and strings. | |
682 | ((string-match "\\`\\(%[cs]\\)+\\'" fstring) | |
683 | (nreverse flist)) | |
684 | ;; A single string spec at the beginning of the spec. | |
685 | ((string-match "\\`%[sc][^%]+\\'" fstring) | |
686 | (list (car flist) (substring fstring 2))) | |
687 | ;; A single string spec in the middle of the spec. | |
688 | ((string-match "\\`\\([^%]+\\)%[sc]\\([^%]+\\)\\'" fstring) | |
689 | (list (match-string 1 fstring) (car flist) (match-string 2 fstring))) | |
690 | ;; A single string spec in the end of the spec. | |
691 | ((string-match "\\`\\([^%]+\\)%[sc]\\'" fstring) | |
692 | (list (match-string 1 fstring) (car flist))) | |
23f87bed MB |
693 | ;; Only string (and %) specs (XEmacs only!) |
694 | ((and (featurep 'xemacs) | |
695 | gnus-make-format-preserve-properties | |
696 | (string-match | |
697 | "\\`\\([^%]*\\(%%\\|%-?\\([1-9][0-9]*\\)?s\\)\\)*[^%]*\\'" | |
698 | fstring)) | |
699 | (list (cons 'gnus-xmas-format (cons fstring (nreverse flist))))) | |
eec82323 LMI |
700 | ;; A more complex spec. |
701 | (t | |
702 | (list (cons 'format (cons fstring (nreverse flist))))))) | |
703 | ||
704 | (if insert | |
705 | (when result | |
706 | (if dontinsert | |
707 | result | |
708 | (cons 'insert result))) | |
709 | (cond ((stringp result) | |
710 | result) | |
711 | ((consp result) | |
712 | (cons 'concat result)) | |
713 | (t ""))))) | |
714 | ||
715 | (defun gnus-eval-format (format &optional alist props) | |
716 | "Eval the format variable FORMAT, using ALIST. | |
717 | If PROPS, insert the result." | |
718 | (let ((form (gnus-parse-format format alist props))) | |
719 | (if props | |
720 | (gnus-add-text-properties (point) (progn (eval form) (point)) props) | |
721 | (eval form)))) | |
722 | ||
6748645f LMI |
723 | (defun gnus-set-format (type &optional insertable) |
724 | (set (intern (format "gnus-%s-line-format-spec" type)) | |
725 | (gnus-parse-format | |
726 | (symbol-value (intern (format "gnus-%s-line-format" type))) | |
727 | (symbol-value (intern (format "gnus-%s-line-format-alist" type))) | |
728 | insertable))) | |
6748645f | 729 | |
eec82323 LMI |
730 | (provide 'gnus-spec) |
731 | ||
16409b0b | 732 | ;; Local Variables: |
c38e0c97 | 733 | ;; coding: utf-8 |
16409b0b GM |
734 | ;; End: |
735 | ||
eec82323 | 736 | ;;; gnus-spec.el ends here |