1 ;;; gnus-spec.el --- format spec functions for Gnus
2 ;; Copyright (C) 1996, 1997, 1998, 1999, 2000
3 ;; Free Software Foundation, Inc.
5 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
8 ;; This file is part of GNU Emacs.
10 ;; GNU Emacs is free software; you can redistribute it and/or modify
11 ;; it under the terms of the GNU General Public License as published by
12 ;; the Free Software Foundation; either version 2, or (at your option)
15 ;; GNU Emacs is distributed in the hope that it will be useful,
16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 ;; GNU General Public License for more details.
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with GNU Emacs; see the file COPYING. If not, write to the
22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
23 ;; Boston, MA 02111-1307, USA.
29 (eval-when-compile (require 'cl))
34 ;;; Internal variables.
36 (defvar gnus-summary-mark-positions nil)
37 (defvar gnus-group-mark-positions nil)
38 (defvar gnus-group-indentation "")
40 ;; Format specs. The chunks below are the machine-generated forms
41 ;; that are to be evaled as the result of the default format strings.
42 ;; We write them in here to get them byte-compiled. That way the
43 ;; default actions will be quite fast, while still retaining the full
44 ;; flexibility of the user-defined format specs.
46 ;; First we have lots of dummy defvars to let the compiler know these
47 ;; are really dynamic variables.
49 (defvar gnus-tmp-unread)
50 (defvar gnus-tmp-replied)
51 (defvar gnus-tmp-score-char)
52 (defvar gnus-tmp-indentation)
53 (defvar gnus-tmp-opening-bracket)
54 (defvar gnus-tmp-lines)
55 (defvar gnus-tmp-name)
56 (defvar gnus-tmp-closing-bracket)
57 (defvar gnus-tmp-subject-or-nil)
58 (defvar gnus-tmp-subject)
59 (defvar gnus-tmp-marked)
60 (defvar gnus-tmp-marked-mark)
61 (defvar gnus-tmp-subscribed)
62 (defvar gnus-tmp-process-marked)
63 (defvar gnus-tmp-number-of-unread)
64 (defvar gnus-tmp-group-name)
65 (defvar gnus-tmp-group)
66 (defvar gnus-tmp-article-number)
67 (defvar gnus-tmp-unread-and-unselected)
68 (defvar gnus-tmp-news-method)
69 (defvar gnus-tmp-news-server)
70 (defvar gnus-tmp-article-number)
71 (defvar gnus-mouse-face)
72 (defvar gnus-mouse-face-prop)
74 (defun gnus-summary-line-format-spec ()
75 (insert gnus-tmp-unread gnus-tmp-replied
76 gnus-tmp-score-char gnus-tmp-indentation)
77 (gnus-put-text-property
81 gnus-tmp-opening-bracket
84 (if (> (length gnus-tmp-name) 20)
85 (substring gnus-tmp-name 0 20)
87 gnus-tmp-closing-bracket)
89 gnus-mouse-face-prop gnus-mouse-face)
90 (insert " " gnus-tmp-subject-or-nil "\n"))
92 (defvar gnus-summary-line-format-spec
93 (gnus-byte-code 'gnus-summary-line-format-spec))
95 (defun gnus-summary-dummy-line-format-spec ()
97 (gnus-put-text-property
102 gnus-mouse-face-prop gnus-mouse-face)
103 (insert " " gnus-tmp-subject "\n"))
105 (defvar gnus-summary-dummy-line-format-spec
106 (gnus-byte-code 'gnus-summary-dummy-line-format-spec))
108 (defun gnus-group-line-format-spec ()
109 (insert gnus-tmp-marked-mark gnus-tmp-subscribed
110 gnus-tmp-process-marked
111 gnus-group-indentation
112 (format "%5s: " gnus-tmp-number-of-unread))
113 (gnus-put-text-property
116 (insert gnus-tmp-group "\n")
118 gnus-mouse-face-prop gnus-mouse-face))
119 (defvar gnus-group-line-format-spec
120 (gnus-byte-code 'gnus-group-line-format-spec))
122 (defvar gnus-format-specs
123 `((group ("%M\%S\%p\%P\%5y: %(%g%)%l\n" ,gnus-group-line-format-spec))
124 (summary-dummy ("* %(: :%) %S\n"
125 ,gnus-summary-dummy-line-format-spec))
126 (summary ("%U\%R\%z\%I\%(%[%4L: %-20,20n%]%) %s\n"
127 ,gnus-summary-line-format-spec)))
128 "Alist of format specs.")
130 (defvar gnus-format-specs-compiled nil
131 "Alist of compiled format specs.
132 Each element should be the form:
133 \(TYPE (FORMAT-STRING-1 . BYTECODE-1)
135 (FORMAT-STRING-n . BYTECODE-n)).")
137 (defvar gnus-article-mode-line-format-spec nil)
138 (defvar gnus-summary-mode-line-format-spec nil)
139 (defvar gnus-group-mode-line-format-spec nil)
141 ;;; Phew. All that gruft is over, fortunately.
144 (defun gnus-update-format (var)
145 "Update the format specification near point."
150 ;; Find the end of the current word.
151 (re-search-forward "[ \t\n]" nil t)
153 (when (re-search-backward "\\(gnus-[-a-z]+-line-format\\)" nil t)
155 (let* ((type (intern (progn (string-match "gnus-\\([-a-z]+\\)-line" var)
156 (match-string 1 var))))
157 (value (symbol-value (intern var)))
159 (intern (format "%s-spec" var))
161 value (symbol-value (intern (format "%s-alist" var)))
162 (not (string-match "mode" var)))))
163 (entry (assq type gnus-format-specs)))
165 (let ((elem (assoc value entry)))
168 (setcdr entry (cons (cons value elem) (cdr entry)))))
169 (push (list type (cons value spec)) gnus-format-specs))
170 (gnus-product-variable-touch 'gnus-format-specs)
172 (pop-to-buffer "*Gnus Format*")
174 (lisp-interaction-mode)
175 (insert (pp-to-string spec))))
177 (put 'gnus-search-or-regist-spec 'lisp-indent-function 1)
178 (defmacro gnus-search-or-regist-spec (mspec &rest body)
179 (let ((specs (nth 0 mspec)) (type (nth 1 mspec)) (format (nth 2 mspec))
180 (spec (nth 3 mspec)) (entry (nth 4 mspec)) (elem (nth 5 mspec)))
181 `(let* ((,entry (assq ,type ,specs))
182 (,elem (assoc ,format (cdr ,entry))))
188 (setcdr ,entry (cons (cons ,format ,spec) (cdr ,entry))))
189 (push (list ,type (cons ,format ,spec)) ,specs))
190 (gnus-product-variable-touch (quote ,specs)))
193 (defun gnus-update-format-specification-1 (type format val)
194 (set (intern (format "gnus-%s-line-format-spec" type))
195 (gnus-search-or-regist-spec (gnus-format-specs-compiled
196 type format val entry elem)
197 (when (and gnus-compile-user-specs val)
200 (fset 'gnus-tmp-func `(lambda () ,val))
202 (let (byte-compile-warnings)
203 (byte-compile 'gnus-tmp-func))
204 (gnus-byte-code 'gnus-tmp-func))
205 (when (get-buffer "*Compile-Log*")
206 (bury-buffer "*Compile-Log*"))
207 (when (get-buffer "*Compile-Log-Show*")
208 (bury-buffer "*Compile-Log-Show*"))))))))
210 (defun gnus-update-format-specifications (&optional force &rest types)
211 "Update all (necessary) format specifications."
212 ;; Make the indentation array.
213 ;; See whether all the stored info needs to be flushed.
215 (message "%s" "Force update format specs.")
216 (setq gnus-format-specs nil
217 gnus-format-specs-compiled nil)
218 (gnus-product-variable-touch 'gnus-format-specs
219 'gnus-format-specs-compiled))
221 ;; Go through all the formats and see whether they need updating.
224 (while (setq type (pop types))
225 ;; Jump to the proper buffer to find out the value of
226 ;; the variable, if possible. (It may be buffer-local.)
228 (let ((buffer (intern (format "gnus-%s-buffer" type))))
229 (when (and (boundp buffer)
230 (setq val (symbol-value buffer))
231 (gnus-buffer-exists-p val))
234 (intern (format "gnus-%s-line-format" type))))))
235 (or (gnus-update-format-specification-1 type new-format nil)
236 ;; This is a new format.
237 (gnus-update-format-specification-1
239 (gnus-search-or-regist-spec (gnus-format-specs
240 type new-format val entry elem)
241 (setq val (if (stringp new-format)
242 ;; This is a "real" format.
246 (intern (format "gnus-%s-line-format-alist"
248 (not (string-match "mode$"
249 (symbol-name type))))
250 ;; This is a function call or something.
253 (defvar gnus-mouse-face-0 'highlight)
254 (defvar gnus-mouse-face-1 'highlight)
255 (defvar gnus-mouse-face-2 'highlight)
256 (defvar gnus-mouse-face-3 'highlight)
257 (defvar gnus-mouse-face-4 'highlight)
259 (defun gnus-mouse-face-function (form type)
260 `(gnus-put-text-property
261 (point) (progn ,@form (point))
265 `(quote ,(symbol-value (intern (format "gnus-mouse-face-%d" type)))))))
267 (defvar gnus-face-0 'bold)
268 (defvar gnus-face-1 'italic)
269 (defvar gnus-face-2 'bold-italic)
270 (defvar gnus-face-3 'bold)
271 (defvar gnus-face-4 'bold)
273 (defun gnus-face-face-function (form type)
274 `(gnus-add-text-properties
275 (point) (progn ,@form (point))
276 '(gnus-face t face ,(symbol-value (intern (format "gnus-face-%d" type))))))
278 (defun gnus-balloon-face-function (form type)
279 `(gnus-put-text-property
280 (point) (progn ,@form (point))
282 ,(intern (format "gnus-balloon-face-%d" type))))
284 (defun gnus-tilde-max-form (el max-width)
285 "Return a form that limits EL to MAX-WIDTH."
286 (let ((max (abs max-width)))
288 `(if (> (length ,el) ,max)
290 `(substring ,el (- (length el) ,max))
291 `(substring ,el 0 ,max))
293 `(let ((val (eval ,el)))
294 (if (> (length val) ,max)
296 `(substring val (- (length val) ,max))
297 `(substring val 0 ,max))
300 (defun gnus-tilde-cut-form (el cut-width)
301 "Return a form that cuts CUT-WIDTH off of EL."
302 (let ((cut (abs cut-width)))
304 `(if (> (length ,el) ,cut)
306 `(substring ,el 0 (- (length el) ,cut))
307 `(substring ,el ,cut))
309 `(let ((val (eval ,el)))
310 (if (> (length val) ,cut)
312 `(substring val 0 (- (length val) ,cut))
313 `(substring val ,cut))
316 (defun gnus-tilde-ignore-form (el ignore-value)
317 "Return a form that is blank when EL is IGNORE-VALUE."
319 `(if (equal ,el ,ignore-value)
321 `(let ((val (eval ,el)))
322 (if (equal val ,ignore-value)
325 (defun gnus-parse-format (format spec-alist &optional insert)
326 ;; This function parses the FORMAT string with the help of the
327 ;; SPEC-ALIST and returns a list that can be eval'ed to return the
328 ;; string. If the FORMAT string contains the specifiers %( and %)
329 ;; the text between them will have the mouse-face text property.
330 ;; If the FORMAT string contains the specifiers %[ and %], the text between
331 ;; them will have the balloon-help text property.
333 "\\`\\(.*\\)%[0-9]?[{(«]\\(.*\\)%[0-9]?[»})]\\(.*\n?\\)\\'"
335 (gnus-parse-complex-format format spec-alist)
336 ;; This is a simple format.
337 (gnus-parse-simple-format format spec-alist insert)))
339 (defun gnus-parse-complex-format (format spec-alist)
341 (gnus-set-work-buffer)
343 (goto-char (point-min))
344 (while (re-search-forward "\"" nil t)
345 (replace-match "\\\"" nil t))
346 (goto-char (point-min))
348 (while (re-search-forward "%\\([0-9]+\\)?\\([«»{}()]\\)" nil t)
349 (let ((number (if (match-beginning 1)
350 (match-string 1) "0"))
351 (delim (aref (match-string 2) 0)))
352 (if (or (= delim ?\()
355 (replace-match (concat "\"("
356 (cond ((= delim ?\() "mouse")
357 ((= delim ?\{) "face")
360 (replace-match "\")\""))))
361 (goto-char (point-max))
363 (goto-char (point-min))
364 (let ((form (read (current-buffer))))
365 (cons 'progn (gnus-complex-form-to-spec form spec-alist)))))
367 (defun gnus-complex-form-to-spec (form spec-alist)
372 (gnus-parse-simple-format sform spec-alist t)
373 (funcall (intern (format "gnus-%s-face-function" (car sform)))
374 (gnus-complex-form-to-spec (cddr sform) spec-alist)
378 (defun gnus-parse-simple-format (format spec-alist &optional insert)
379 ;; This function parses the FORMAT string with the help of the
380 ;; SPEC-ALIST and returns a list that can be eval'ed to return a
383 spec flist fstring elem result dontinsert user-defined
384 type value pad-width spec-beg cut-width ignore-value
385 tilde-form tilde elem-type)
387 (gnus-set-work-buffer)
389 (goto-char (point-min))
390 (while (re-search-forward "%" nil t)
391 (setq user-defined nil
398 (setq spec-beg (1- (point)))
400 ;; Parse this spec fully.
403 ((looking-at "\\([-.0-9]+\\)\\(,[-0-9]+\\)?")
404 (setq pad-width (string-to-number (match-string 1)))
405 (when (match-beginning 2)
406 (setq max-width (string-to-number (buffer-substring
407 (1+ (match-beginning 2))
409 (goto-char (match-end 0)))
412 (setq tilde (read (current-buffer))
416 ((memq type '(pad pad-left))
417 (setq pad-width value))
418 ((eq type 'pad-right)
419 (setq pad-width (- value)))
420 ((memq type '(max-right max))
421 (setq max-width value))
423 (setq max-width (- value)))
424 ((memq type '(cut cut-left))
425 (setq cut-width value))
426 ((eq type 'cut-right)
427 (setq cut-width (- value)))
430 (if (stringp value) value (format "%s" value))))
432 (setq tilde-form value))
434 (error "Unknown tilde type: %s" tilde)))
438 ;; User-defined spec -- find the spec name.
439 (when (eq (setq spec (char-after)) ?u)
441 (setq user-defined (char-after)))
443 (delete-region spec-beg (point))
445 ;; Now we have all the relevant data on this spec, so
446 ;; we start doing stuff.
449 ;; "%%" just results in a "%".
454 (setq elem (list tilde-form ?s)))
455 ;; Treat user defined format specifiers specially.
459 (list 'condition-case 'err
460 (list (intern (format "gnus-user-format-function-%c"
466 "Error occured in `gnus-user-format-function-%c: %%s"
470 ;; Find the specification from `spec-alist'.
471 ((setq elem (cdr (assq spec spec-alist))))
473 (setq elem '("*" ?s))))
474 (setq elem-type (cadr elem))
475 ;; Insert the new format elements.
477 (insert (number-to-string pad-width)))
478 ;; Create the form to be evaled.
479 (if (or max-width cut-width ignore-value)
482 (let ((el (car elem)))
483 (cond ((= (cadr elem) ?c)
484 (setq el (list 'char-to-string el)))
486 (setq el (list 'int-to-string el))))
488 (setq el (gnus-tilde-ignore-form el ignore-value)))
490 (setq el (gnus-tilde-cut-form el cut-width)))
492 (setq el (gnus-tilde-max-form el max-width)))
495 (push (car elem) flist))))
496 (setq fstring (buffer-string)))
498 ;; Do some postprocessing to increase efficiency.
503 ((string= fstring "")
505 ;; Not a format string.
506 ((not (string-match "%" fstring))
508 ;; A format string with just a single string spec.
509 ((string= fstring "%s")
511 ;; A single character.
512 ((string= fstring "%c")
515 ((string= fstring "%d")
518 (list `(princ ,(car flist)))
519 (list `(int-to-string ,(car flist)))))
520 ;; Just lots of chars and strings.
521 ((string-match "\\`\\(%[cs]\\)+\\'" fstring)
523 ;; A single string spec at the beginning of the spec.
524 ((string-match "\\`%[sc][^%]+\\'" fstring)
525 (list (car flist) (substring fstring 2)))
526 ;; A single string spec in the middle of the spec.
527 ((string-match "\\`\\([^%]+\\)%[sc]\\([^%]+\\)\\'" fstring)
528 (list (match-string 1 fstring) (car flist) (match-string 2 fstring)))
529 ;; A single string spec in the end of the spec.
530 ((string-match "\\`\\([^%]+\\)%[sc]\\'" fstring)
531 (list (match-string 1 fstring) (car flist)))
532 ;; A more complex spec.
534 (list (cons 'format (cons fstring (nreverse flist)))))))
540 (cons 'insert result)))
541 (cond ((stringp result)
544 (cons 'concat result))
547 (defun gnus-eval-format (format &optional alist props)
548 "Eval the format variable FORMAT, using ALIST.
549 If PROPS, insert the result."
550 (let ((form (gnus-parse-format format alist props)))
552 (gnus-add-text-properties (point) (progn (eval form) (point)) props)
555 (defun gnus-compile ()
556 "Byte-compile the user-defined format specs."
559 (let ((entries gnus-format-specs)
560 (byte-compile-warnings '(unresolved callargs redefine))
563 (gnus-message 7 "Compiling format specs...")
566 (setq entry (pop entries)
568 (if (memq type '(version gnus-version))
569 (setq gnus-format-specs (delq entry gnus-format-specs))
570 (let ((form (caddr entry)))
571 (when (and (listp form)
572 ;; Under GNU Emacs, it's (byte-code ...)
573 (not (eq 'byte-code (car form)))
574 ;; Under XEmacs, it's (funcall #<compiled-function ...>)
575 (not (and (eq 'funcall (car form))
576 (byte-code-function-p (cadr form)))))
577 (fset 'gnus-tmp-func `(lambda () ,form))
578 (byte-compile 'gnus-tmp-func)
579 (setq bytecode (gnus-byte-code 'gnus-tmp-func))
580 (set (intern (format "gnus-%s-line-format-spec" type)) bytecode)
581 (set-alist 'gnus-format-specs-compiled type bytecode)))))
583 (push (cons 'version emacs-version) gnus-format-specs)
584 (gnus-message 7 "Compiling user specs...done"))))
586 (defun gnus-set-format (type &optional insertable)
587 (set (intern (format "gnus-%s-line-format-spec" type))
589 (symbol-value (intern (format "gnus-%s-line-format" type)))
590 (symbol-value (intern (format "gnus-%s-line-format-alist" type)))
596 ;; coding: iso-8859-1
599 ;;; gnus-spec.el ends here