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>
6 ;; Katsumi Yamaoka <yamaoka@jpl.org>
9 ;; This file is part of GNU Emacs.
11 ;; GNU Emacs is free software; you can redistribute it and/or modify
12 ;; it under the terms of the GNU General Public License as published by
13 ;; the Free Software Foundation; either version 2, or (at your option)
16 ;; GNU Emacs is distributed in the hope that it will be useful,
17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19 ;; GNU General Public License for more details.
21 ;; You should have received a copy of the GNU General Public License
22 ;; along with GNU Emacs; see the file COPYING. If not, write to the
23 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
24 ;; Boston, MA 02111-1307, USA.
30 (eval-when-compile (require 'cl))
35 ;;; Internal variables.
37 (defvar gnus-summary-mark-positions nil)
38 (defvar gnus-group-mark-positions nil)
39 (defvar gnus-group-indentation "")
41 ;; Format specs. The chunks below are the machine-generated forms
42 ;; that are to be evaled as the result of the default format strings.
43 ;; We write them in here to get them byte-compiled. That way the
44 ;; default actions will be quite fast, while still retaining the full
45 ;; flexibility of the user-defined format specs.
47 ;; First we have lots of dummy defvars to let the compiler know these
48 ;; are really dynamic variables.
50 (defvar gnus-tmp-unread)
51 (defvar gnus-tmp-replied)
52 (defvar gnus-tmp-score-char)
53 (defvar gnus-tmp-indentation)
54 (defvar gnus-tmp-opening-bracket)
55 (defvar gnus-tmp-lines)
56 (defvar gnus-tmp-name)
57 (defvar gnus-tmp-closing-bracket)
58 (defvar gnus-tmp-subject-or-nil)
59 (defvar gnus-tmp-subject)
60 (defvar gnus-tmp-marked)
61 (defvar gnus-tmp-marked-mark)
62 (defvar gnus-tmp-subscribed)
63 (defvar gnus-tmp-process-marked)
64 (defvar gnus-tmp-number-of-unread)
65 (defvar gnus-tmp-group-name)
66 (defvar gnus-tmp-group)
67 (defvar gnus-tmp-article-number)
68 (defvar gnus-tmp-unread-and-unselected)
69 (defvar gnus-tmp-news-method)
70 (defvar gnus-tmp-news-server)
71 (defvar gnus-tmp-article-number)
72 (defvar gnus-mouse-face)
73 (defvar gnus-mouse-face-prop)
75 (defun gnus-summary-line-format-spec ()
76 (insert gnus-tmp-unread gnus-tmp-replied
77 gnus-tmp-score-char gnus-tmp-indentation)
78 (gnus-put-text-property
82 gnus-tmp-opening-bracket
85 (if (> (length gnus-tmp-name) 20)
86 (substring gnus-tmp-name 0 20)
88 gnus-tmp-closing-bracket)
90 gnus-mouse-face-prop gnus-mouse-face)
91 (insert " " gnus-tmp-subject-or-nil "\n"))
93 (defvar gnus-summary-line-format-spec
94 (gnus-byte-code 'gnus-summary-line-format-spec))
96 (defun gnus-summary-dummy-line-format-spec ()
98 (gnus-put-text-property
103 gnus-mouse-face-prop gnus-mouse-face)
104 (insert " " gnus-tmp-subject "\n"))
106 (defvar gnus-summary-dummy-line-format-spec
107 (gnus-byte-code 'gnus-summary-dummy-line-format-spec))
109 (defun gnus-group-line-format-spec ()
110 (insert gnus-tmp-marked-mark gnus-tmp-subscribed
111 gnus-tmp-process-marked
112 gnus-group-indentation
113 (format "%5s: " gnus-tmp-number-of-unread))
114 (gnus-put-text-property
117 (insert gnus-tmp-group "\n")
119 gnus-mouse-face-prop gnus-mouse-face))
120 (defvar gnus-group-line-format-spec
121 (gnus-byte-code 'gnus-group-line-format-spec))
123 (defvar gnus-format-specs
124 `((group ("%M\%S\%p\%P\%5y: %(%g%)%l\n" ,gnus-group-line-format-spec))
125 (summary-dummy ("* %(: :%) %S\n"
126 ,gnus-summary-dummy-line-format-spec))
127 (summary ("%U\%R\%z\%I\%(%[%4L: %-20,20n%]%) %s\n"
128 ,gnus-summary-line-format-spec)))
129 "Alist of format specs.")
131 (defvar gnus-format-specs-compiled nil
132 "Alist of compiled format specs. Each element should be the form:
133 \(TYPE (FORMAT-STRING-1 . COMPILED-FUNCTION-1)
135 (FORMAT-STRING-n . COMPILED-FUNCTION-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 ;;; Avoid byte-compile warning.
279 (defun gnus-tilde-pad-form (el pad-width)
280 "Dummy function except for XEmacs-mule. It will be redefined
281 by `gnus-xmas-redefine'."
282 (let ((val (if (symbolp el) (eval el) el)))
285 (defun gnus-balloon-face-function (form type)
286 `(gnus-put-text-property
287 (point) (progn ,@form (point))
289 ,(intern (format "gnus-balloon-face-%d" type))))
291 (defun gnus-tilde-max-form (el max-width)
292 "Return a form that limits EL to MAX-WIDTH."
293 (let ((max (abs max-width)))
295 `(if (> (length ,el) ,max)
297 `(substring ,el (- (length el) ,max))
298 `(substring ,el 0 ,max))
300 `(let ((val (eval ,el)))
301 (if (> (length val) ,max)
303 `(substring val (- (length val) ,max))
304 `(substring val 0 ,max))
307 (defun gnus-tilde-cut-form (el cut-width)
308 "Return a form that cuts CUT-WIDTH off of EL."
309 (let ((cut (abs cut-width)))
311 `(if (> (length ,el) ,cut)
313 `(substring ,el 0 (- (length el) ,cut))
314 `(substring ,el ,cut))
316 `(let ((val (eval ,el)))
317 (if (> (length val) ,cut)
319 `(substring val 0 (- (length val) ,cut))
320 `(substring val ,cut))
323 (defun gnus-tilde-ignore-form (el ignore-value)
324 "Return a form that is blank when EL is IGNORE-VALUE."
326 `(if (equal ,el ,ignore-value)
328 `(let ((val (eval ,el)))
329 (if (equal val ,ignore-value)
332 (defun gnus-parse-format (format spec-alist &optional insert)
333 ;; This function parses the FORMAT string with the help of the
334 ;; SPEC-ALIST and returns a list that can be eval'ed to return the
335 ;; string. If the FORMAT string contains the specifiers %( and %)
336 ;; the text between them will have the mouse-face text property.
337 ;; If the FORMAT string contains the specifiers %[ and %], the text between
338 ;; them will have the balloon-help text property.
340 "\\`\\(.*\\)%[0-9]?[{(«]\\(.*\\)%[0-9]?[»})]\\(.*\n?\\)\\'"
342 (gnus-parse-complex-format format spec-alist)
343 ;; This is a simple format.
344 (gnus-parse-simple-format format spec-alist insert)))
346 (defun gnus-parse-complex-format (format spec-alist)
348 (gnus-set-work-buffer)
350 (goto-char (point-min))
351 (while (re-search-forward "\"" nil t)
352 (replace-match "\\\"" nil t))
353 (goto-char (point-min))
355 (while (re-search-forward "%\\([0-9]+\\)?\\([«»{}()]\\)" nil t)
356 (let ((number (if (match-beginning 1)
357 (match-string 1) "0"))
358 (delim (aref (match-string 2) 0)))
359 (if (or (= delim ?\()
362 (replace-match (concat "\"("
363 (cond ((= delim ?\() "mouse")
364 ((= delim ?\{) "face")
367 (replace-match "\")\""))))
368 (goto-char (point-max))
370 (goto-char (point-min))
371 (let ((form (read (current-buffer))))
372 (cons 'progn (gnus-complex-form-to-spec form spec-alist)))))
374 (defun gnus-complex-form-to-spec (form spec-alist)
379 (gnus-parse-simple-format sform spec-alist t)
380 (funcall (intern (format "gnus-%s-face-function" (car sform)))
381 (gnus-complex-form-to-spec (cddr sform) spec-alist)
385 (defun gnus-parse-simple-format (format spec-alist &optional insert)
386 ;; This function parses the FORMAT string with the help of the
387 ;; SPEC-ALIST and returns a list that can be eval'ed to return a
389 (let ((xemacs-mule-p (and (featurep 'xemacs) (featurep 'mule)))
391 spec flist fstring elem result dontinsert user-defined
392 type value pad-width spec-beg cut-width ignore-value
393 tilde-form tilde elem-type)
395 (gnus-set-work-buffer)
397 (goto-char (point-min))
398 (while (search-forward "%" nil t)
399 (setq user-defined nil
406 (setq spec-beg (1- (point)))
408 ;; Parse this spec fully.
411 ((looking-at "\\([-.0-9]+\\)\\(,[-0-9]+\\)?")
412 (setq pad-width (string-to-number (match-string 1)))
413 (when (match-beginning 2)
414 (setq max-width (string-to-number (buffer-substring
415 (1+ (match-beginning 2))
417 (goto-char (match-end 0)))
420 (setq tilde (read (current-buffer))
424 ((memq type '(pad pad-left))
425 (setq pad-width value))
426 ((eq type 'pad-right)
427 (setq pad-width (- value)))
428 ((memq type '(max-right max))
429 (setq max-width value))
431 (setq max-width (- value)))
432 ((memq type '(cut cut-left))
433 (setq cut-width value))
434 ((eq type 'cut-right)
435 (setq cut-width (- value)))
438 (if (stringp value) value (format "%s" value))))
440 (setq tilde-form value))
442 (error "Unknown tilde type: %s" tilde)))
446 ;; User-defined spec -- find the spec name.
447 (when (eq (setq spec (char-after)) ?u)
449 (setq user-defined (char-after)))
451 (delete-region spec-beg (point))
453 ;; Now we have all the relevant data on this spec, so
454 ;; we start doing stuff.
457 ;; "%%" just results in a "%".
462 (setq elem (list tilde-form ?s)))
463 ;; Treat user defined format specifiers specially.
467 (list (intern (format "gnus-user-format-function-%c"
471 ;; Find the specification from `spec-alist'.
472 ((setq elem (cdr (assq spec spec-alist))))
474 (setq elem '("*" ?s))))
475 (setq elem-type (cadr elem))
476 ;; Insert the new format elements.
477 (and pad-width (not xemacs-mule-p)
478 (insert (number-to-string pad-width)))
479 ;; Create the form to be evaled.
480 (if (or max-width cut-width ignore-value
481 (and pad-width xemacs-mule-p))
484 (let ((el (car elem)))
485 (cond ((= (cadr elem) ?c)
486 (setq el (list 'char-to-string el)))
488 (setq el (list 'int-to-string el))))
490 (setq el (gnus-tilde-ignore-form el ignore-value)))
492 (setq el (gnus-tilde-cut-form el cut-width)))
494 (setq el (gnus-tilde-max-form el max-width)))
495 (and pad-width xemacs-mule-p
496 (setq el (gnus-tilde-pad-form el pad-width)))
499 (push (car elem) flist))))
500 (setq fstring (buffer-string)))
502 ;; Do some postprocessing to increase efficiency.
507 ((string= fstring "")
509 ;; Not a format string.
510 ((not (string-match "%" fstring))
512 ;; A format string with just a single string spec.
513 ((string= fstring "%s")
515 ;; A single character.
516 ((string= fstring "%c")
519 ((string= fstring "%d")
522 (list `(princ ,(car flist)))
523 (list `(int-to-string ,(car flist)))))
524 ;; Just lots of chars and strings.
525 ((string-match "\\`\\(%[cs]\\)+\\'" fstring)
527 ;; A single string spec at the beginning of the spec.
528 ((string-match "\\`%[sc][^%]+\\'" fstring)
529 (list (car flist) (substring fstring 2)))
530 ;; A single string spec in the middle of the spec.
531 ((string-match "\\`\\([^%]+\\)%[sc]\\([^%]+\\)\\'" fstring)
532 (list (match-string 1 fstring) (car flist) (match-string 2 fstring)))
533 ;; A single string spec in the end of the spec.
534 ((string-match "\\`\\([^%]+\\)%[sc]\\'" fstring)
535 (list (match-string 1 fstring) (car flist)))
536 ;; A more complex spec.
538 (list (cons 'format (cons fstring (nreverse flist)))))))
544 (cons 'insert result)))
545 (cond ((stringp result)
548 (cons 'concat result))
551 (defun gnus-eval-format (format &optional alist props)
552 "Eval the format variable FORMAT, using ALIST.
553 If PROPS, insert the result."
554 (let ((form (gnus-parse-format format alist props)))
556 (gnus-add-text-properties (point) (progn (eval form) (point)) props)
559 (defun gnus-compile ()
560 "Byte-compile the user-defined format specs."
563 (let ((entries gnus-format-specs)
564 (byte-compile-warnings '(unresolved callargs redefine))
565 entry type compiled-function)
567 (gnus-message 7 "Compiling format specs...")
570 (setq entry (pop entries)
572 (if (memq type '(version gnus-version))
573 (setq gnus-format-specs (delq entry gnus-format-specs))
574 (let ((form (caddr entry)))
575 (when (and (listp form)
576 ;; Under GNU Emacs, it's (byte-code ...)
577 (not (eq 'byte-code (car form)))
578 ;; Under XEmacs, it's (funcall #<compiled-function ...>)
579 (not (and (eq 'funcall (car form))
580 (byte-code-function-p (cadr form)))))
581 (defalias 'gnus-tmp-func `(lambda () ,form))
582 (byte-compile 'gnus-tmp-func)
583 (setq compiled-function (gnus-byte-code 'gnus-tmp-func))
584 (set (intern (format "gnus-%s-line-format-spec" type))
586 (let ((elem (cdr (assq type gnus-format-specs-compiled))))
588 (set-alist 'elem (cadr entry) compiled-function)
589 (setq elem (list (cadr entry) compiled-function)))
590 (set-alist 'gnus-format-specs-compiled type elem))))))
592 (push (cons 'version emacs-version) gnus-format-specs)
593 (gnus-message 7 "Compiling user specs...done"))))
595 (defun gnus-set-format (type &optional insertable)
596 (set (intern (format "gnus-%s-line-format-spec" type))
598 (symbol-value (intern (format "gnus-%s-line-format" type)))
599 (symbol-value (intern (format "gnus-%s-line-format-alist" type)))
607 ;; coding: iso-8859-1
610 ;;; gnus-spec.el ends here