152b4cbbe1ee49d65b60b8743c2c51d8ced7f19c
[gnus] / lisp / gnus-spec.el
1 ;;; gnus-spec.el --- format spec functions for Gnus
2
3 ;; Copyright (C) 1996-2012 Free Software Foundation, Inc.
4
5 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
6 ;; Keywords: news
7
8 ;; This file is part of GNU Emacs.
9
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 3 of the License, or
13 ;; (at your option) any later version.
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
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
18 ;; GNU General Public License for more details.
19
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
22
23 ;;; Commentary:
24
25 ;;; Code:
26
27 ;; For Emacs <22.2 and XEmacs.
28 (eval-and-compile
29   (unless (fboundp 'declare-function) (defmacro declare-function (&rest r))))
30 (eval-when-compile (require 'cl))
31 (defvar gnus-newsrc-file-version)
32
33 (require 'gnus)
34
35 (defcustom gnus-use-correct-string-widths (featurep 'xemacs)
36   "*If non-nil, use correct functions for dealing with wide characters."
37   :version "22.1"
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
43 text properties. This is only needed on XEmacs, as Emacs does this anyway."
44   :version "22.1"
45   :group 'gnus-format
46   :type 'boolean)
47
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
55 ;; that are to be evalled as the result of the default format strings.
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)
87 (defvar gnus-tmp-header)
88 (defvar gnus-tmp-from)
89
90 (declare-function gnus-summary-from-or-to-or-newsgroups "gnus-sum"
91                   (header gnus-tmp-from))
92
93 (defmacro gnus-lrm-string-p (string)
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))
98     nil))
99
100 (defvar gnus-lrm-string (if (ignore-errors (string 8206))
101                             (propertize (string 8206) 'invisible t)
102                           ""))
103
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
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)
117                     (if (gnus-lrm-string-p val)
118                         (concat (substring val 0 23) gnus-lrm-string)
119                       (substring val 0 23))
120                   val))
121               gnus-tmp-closing-bracket))
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)
158     (gnus-version . ,(gnus-continuum-version))
159     (group "%M\%S\%p\%P\%5y: %(%g%)\n" ,gnus-group-line-format-spec)
160     (summary-dummy "*  %(:                          :%) %S\n"
161                    ,gnus-summary-dummy-line-format-spec)
162     (summary "%U%R%z%I%(%[%4L: %-23,23f%]%) %s\n"
163              ,gnus-summary-line-format-spec))
164   "Alist of format specs.")
165
166 (defvar gnus-default-format-specs gnus-format-specs)
167
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
172 ;;; Phew.  All that gruft is over with, fortunately.
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)
203     (insert (gnus-pp-to-string spec))))
204
205 (defun gnus-update-format-specifications (&optional force &rest types)
206   "Update all (necessary) format specifications.
207 Return a list of updated types."
208   ;; Make the indentation array.
209   ;; See whether all the stored info needs to be flushed.
210   (when (or force
211             (not gnus-newsrc-file-version)
212             (not (equal (gnus-continuum-version)
213                         (gnus-continuum-version gnus-newsrc-file-version)))
214             (not (equal emacs-version
215                         (cdr (assq 'version gnus-format-specs)))))
216     (setq gnus-format-specs nil))
217   ;; Go through all the formats and see whether they need updating.
218   (let (new-format entry type val updated)
219     (while (setq type (pop types))
220       ;; Jump to the proper buffer to find out the value of the
221       ;; variable, if possible.  (It may be buffer-local.)
222       (save-excursion
223         (let ((buffer (intern (format "gnus-%s-buffer" type))))
224           (when (and (boundp buffer)
225                      (setq val (symbol-value buffer))
226                      (gnus-buffer-exists-p val))
227             (set-buffer val))
228           (setq new-format (symbol-value
229                             (intern (format "gnus-%s-line-format" type)))))
230         (setq entry (cdr (assq type gnus-format-specs)))
231         (if (and (car entry)
232                  (equal (car entry) new-format))
233             ;; Use the old format.
234             (set (intern (format "gnus-%s-line-format-spec" type))
235                  (cadr entry))
236           ;; This is a new format.
237           (setq val
238                 (if (not (stringp new-format))
239                     ;; This is a function call or something.
240                     new-format
241                   ;; This is a "real" format.
242                   (gnus-parse-format
243                    new-format
244                    (symbol-value
245                     (intern (format "gnus-%s-line-format-alist" type)))
246                    (not (string-match "mode$" (symbol-name type))))))
247           ;; Enter the new format spec into the list.
248           (if entry
249               (progn
250                 (setcar (cdr entry) val)
251                 (setcar entry new-format))
252             (push (list type new-format val) gnus-format-specs))
253           (set (intern (format "gnus-%s-line-format-spec" type)) val)
254           (push type updated))))
255
256     (unless (assq 'version gnus-format-specs)
257       (push (cons 'version emacs-version) gnus-format-specs))
258     updated))
259
260 (defcustom gnus-mouse-face-0 'highlight
261   "The \"%(hello%)\" face."
262   :group 'gnus-format
263   :type 'face)
264
265 (defcustom gnus-mouse-face-1 'highlight
266   "The \"%1(hello%)\" face."
267   :group 'gnus-format
268   :type 'face)
269
270 (defcustom gnus-mouse-face-2 'highlight
271   "The \"%2(hello%)\" face."
272   :group 'gnus-format
273   :type 'face)
274
275 (defcustom gnus-mouse-face-3 'highlight
276   "The \"%3(hello%)\" face."
277   :group 'gnus-format
278   :type 'face)
279
280 (defcustom gnus-mouse-face-4 'highlight
281   "The \"%4(hello%)\" face."
282   :group 'gnus-format
283   :type 'face)
284
285 (defun gnus-mouse-face-function (form type)
286   `(gnus-put-text-property
287     (point) (progn ,@form (point))
288     gnus-mouse-face-prop
289     ,(if (equal type 0)
290          'gnus-mouse-face
291        `(quote ,(symbol-value (intern (format "gnus-mouse-face-%d" type)))))))
292
293 (defcustom gnus-face-0 'bold
294   "The \"%{hello%}\" face."
295   :group 'gnus-format
296   :type 'face)
297
298 (defcustom gnus-face-1 'italic
299   "The \"%1{hello%}\" face."
300   :group 'gnus-format
301   :type 'face)
302
303 (defcustom gnus-face-2 'bold-italic
304   "The \"%2{hello%}\" face."
305   :group 'gnus-format
306   :type 'face)
307
308 (defcustom gnus-face-3 'bold
309   "The \"%3{hello%}\" face."
310   :group 'gnus-format
311   :type 'face)
312
313 (defcustom gnus-face-4 'bold
314   "The \"%4{hello%}\" face."
315   :group 'gnus-format
316   :type 'face)
317
318 (defun gnus-face-face-function (form type)
319   `(gnus-add-text-properties
320     (point) (progn ,@form (point))
321     '(gnus-face t face ,(symbol-value (intern (format "gnus-face-%d" type))))))
322
323 (defun gnus-balloon-face-function (form type)
324   `(gnus-put-text-property
325     (point) (progn ,@form (point))
326     ,(if (fboundp 'balloon-help-mode)
327          ''balloon-help
328        ''help-echo)
329     ,(intern (format "gnus-balloon-face-%d" type))))
330
331 (defun gnus-spec-tab (column)
332   (if (> column 0)
333       `(insert-char ?  (max (- ,column (current-column)) 0))
334     (let ((column (abs column)))
335       `(if (> (current-column) ,column)
336            (let ((end (point)))
337              (if (= (move-to-column ,column) ,column)
338                  (delete-region (point) end)
339                (delete-region (1- (point)) end)
340                (insert " ")))
341          (insert-char ?  (max (- ,column (current-column)) 0))))))
342
343 (defun gnus-correct-length (string)
344   "Return the correct width of STRING."
345   (apply #'+ (mapcar #'char-width string)))
346
347 (defun gnus-correct-substring (string start &optional end)
348   (let ((wstart 0)
349         (wend 0)
350         (wseek 0)
351         (seek 0)
352         (length (length string))
353         (string (concat string "\0")))
354     ;; Find the start position.
355     (while (and (< seek length)
356                 (< wseek start))
357       (incf wseek (char-width (aref string seek)))
358       (incf seek))
359     (setq wstart seek)
360     ;; Find the end position.
361     (while (and (<= seek length)
362                 (or (not end)
363                     (<= wseek end)))
364       (incf wseek (char-width (aref string seek)))
365       (incf seek))
366     (setq wend seek)
367     (substring string wstart (1- wend))))
368
369 (defun gnus-string-width-function ()
370   (cond
371    (gnus-use-correct-string-widths
372     'gnus-correct-length)
373    ((fboundp 'string-width)
374     'string-width)
375    (t
376     'length)))
377
378 (defun gnus-substring-function ()
379   (cond
380    (gnus-use-correct-string-widths
381     'gnus-correct-substring)
382    ((fboundp 'string-width)
383     'gnus-correct-substring)
384    (t
385     'substring)))
386
387 (defun gnus-tilde-max-form (el max-width)
388   "Return a form that limits EL to MAX-WIDTH."
389   (let ((max (abs max-width))
390         (length-fun (gnus-string-width-function))
391         (substring-fun (gnus-substring-function)))
392     (if (symbolp el)
393         `(if (> (,length-fun ,el) ,max)
394              ,(if (< max-width 0)
395                   `(,substring-fun ,el (- (,length-fun ,el) ,max))
396                 `(if (gnus-lrm-string-p ,el)
397                      (concat (,substring-fun ,el 0 ,max) ,gnus-lrm-string)
398                    (,substring-fun ,el 0 ,max)))
399            ,el)
400       `(let ((val (eval ,el)))
401          (if (> (,length-fun val) ,max)
402              ,(if (< max-width 0)
403                   `(,substring-fun val (- (,length-fun val) ,max))
404                 `(if (gnus-lrm-string-p val)
405                      (concat (,substring-fun val 0 ,max) ,gnus-lrm-string)
406                    (,substring-fun val 0 ,max)))
407            val)))))
408
409 (defun gnus-tilde-cut-form (el cut-width)
410   "Return a form that cuts CUT-WIDTH off of EL."
411   (let ((cut (abs cut-width))
412         (length-fun (gnus-string-width-function))
413         (substring-fun (gnus-substring-function)))
414     (if (symbolp el)
415         `(if (> (,length-fun ,el) ,cut)
416              ,(if (< cut-width 0)
417                   `(,substring-fun ,el 0 (- (,length-fun ,el) ,cut))
418                 `(,substring-fun ,el ,cut))
419            ,el)
420       `(let ((val (eval ,el)))
421          (if (> (,length-fun val) ,cut)
422              ,(if (< cut-width 0)
423                   `(,substring-fun val 0 (- (,length-fun val) ,cut))
424                 `(,substring-fun val ,cut))
425            val)))))
426
427 (defun gnus-tilde-ignore-form (el ignore-value)
428   "Return a form that is blank when EL is IGNORE-VALUE."
429   (if (symbolp el)
430       `(if (equal ,el ,ignore-value)
431            "" ,el)
432     `(let ((val (eval ,el)))
433        (if (equal val ,ignore-value)
434            "" val))))
435
436 (defun gnus-pad-form (el pad-width)
437   "Return a form that pads EL to PAD-WIDTH accounting for multi-column
438 characters correctly. This is because `format' may pad to columns or to
439 characters when given a pad value."
440   (let ((pad (abs pad-width))
441         (side (< 0 pad-width))
442         (length-fun (gnus-string-width-function)))
443     (if (symbolp el)
444         `(let ((need (- ,pad (,length-fun ,el))))
445            (if (> need 0)
446                (concat ,(when side '(make-string need ?\ ))
447                        ,el
448                        ,(when (not side) '(make-string need ?\ )))
449              ,el))
450       `(let* ((val (eval ,el))
451               (need (- ,pad (,length-fun val))))
452          (if (> need 0)
453              (concat ,(when side '(make-string need ?\ ))
454                      val
455                      ,(when (not side) '(make-string need ?\ )))
456            val)))))
457
458 (defun gnus-parse-format (format spec-alist &optional insert)
459   ;; This function parses the FORMAT string with the help of the
460   ;; SPEC-ALIST and returns a list that can be eval'ed to return the
461   ;; string.  If the FORMAT string contains the specifiers %( and %)
462   ;; the text between them will have the mouse-face text property.
463   ;; If the FORMAT string contains the specifiers %[ and %], the text between
464   ;; them will have the balloon-help text property.
465   (let ((case-fold-search nil))
466     (if (string-match
467          "\\`\\(.*\\)%[0-9]?[{(«]\\(.*\\)%[0-9]?[»})]\\(.*\n?\\)\\'\\|%[-0-9]*=\\|%[-0-9]*\\*"
468          format)
469         (gnus-parse-complex-format format spec-alist)
470       ;; This is a simple format.
471       (gnus-parse-simple-format format spec-alist insert))))
472
473 (defun gnus-parse-complex-format (format spec-alist)
474   (let ((cursor-spec nil))
475     (save-excursion
476       (gnus-set-work-buffer)
477       (insert format)
478       (goto-char (point-min))
479       (while (re-search-forward "\"" nil t)
480         (replace-match "\\\"" nil t))
481       (goto-char (point-min))
482       (insert "(\"")
483       ;; Convert all font specs into font spec lists.
484       (while (re-search-forward "%\\([0-9]+\\)?\\([«»{}()]\\)" nil t)
485         (let ((number (if (match-beginning 1)
486                           (match-string 1) "0"))
487               (delim (aref (match-string 2) 0)))
488           (if (or (= delim ?\()
489                   (= delim ?\{)
490                   (= delim ?\«))
491               (replace-match (concat "\"("
492                                      (cond ((= delim ?\() "mouse")
493                                            ((= delim ?\{) "face")
494                                            (t "balloon"))
495                                      " " number " \"")
496                              t t)
497             (replace-match "\")\""))))
498       (goto-char (point-max))
499       (insert "\")")
500       ;; Convert point position commands.
501       (goto-char (point-min))
502       (let ((case-fold-search nil))
503         (while (re-search-forward "%\\([-0-9]+\\)?\\*" nil t)
504           (replace-match "\"(point)\"" t t)
505           (setq cursor-spec t)))
506       ;; Convert TAB commands.
507       (goto-char (point-min))
508       (while (re-search-forward "%\\([-0-9]+\\)=" nil t)
509         (replace-match (format "\"(tab %s)\"" (match-string 1)) t t))
510       ;; Convert the buffer into the spec.
511       (goto-char (point-min))
512       (let ((form (read (current-buffer))))
513         (if cursor-spec
514             `(let (gnus-position)
515                ,@(gnus-complex-form-to-spec form spec-alist)
516                (if gnus-position
517                    (gnus-put-text-property gnus-position (1+ gnus-position)
518                                            'gnus-position t)))
519           `(progn
520              ,@(gnus-complex-form-to-spec form spec-alist)))))))
521
522 (defun gnus-complex-form-to-spec (form spec-alist)
523   (delq nil
524         (mapcar
525          (lambda (sform)
526            (cond
527             ((stringp sform)
528              (gnus-parse-simple-format sform spec-alist t))
529             ((eq (car sform) 'point)
530              '(setq gnus-position (point)))
531             ((eq (car sform) 'tab)
532              (gnus-spec-tab (cadr sform)))
533             (t
534              (funcall (intern (format "gnus-%s-face-function" (car sform)))
535                       (gnus-complex-form-to-spec (cddr sform) spec-alist)
536                       (nth 1 sform)))))
537          form)))
538
539
540 (defun gnus-xmas-format (fstring &rest args)
541   "A version of `format' which preserves text properties.
542
543 Required for XEmacs, where the built in `format' function strips all text
544 properties from both the format string and any inserted strings.
545
546 Only supports the format sequence %s, and %% for inserting
547 literal % characters. A pad width and an optional - (to right pad)
548 are supported for %s."
549   (let ((re "%%\\|%\\(-\\)?\\([1-9][0-9]*\\)?s")
550         (n (length args)))
551     (with-temp-buffer
552       (insert fstring)
553       (goto-char (point-min))
554       (while (re-search-forward re nil t)
555         (goto-char (match-end 0))
556         (cond
557          ((string= (match-string 0) "%%")
558           (delete-char -1))
559          (t
560           (if (null args)
561               (error 'wrong-number-of-arguments #'my-format n fstring))
562           (let* ((minlen (string-to-number (or (match-string 2) "")))
563                  (arg (car args))
564                  (str (if (stringp arg) arg (format "%s" arg)))
565                  (lpad (null (match-string 1)))
566                  (padlen (max 0 (- minlen (length str)))))
567             (replace-match "")
568             (if lpad (insert-char ?\  padlen))
569             (insert str)
570             (unless lpad (insert-char ?\  padlen))
571             (setq args (cdr args))))))
572       (buffer-string))))
573
574 (defun gnus-parse-simple-format (format spec-alist &optional insert)
575   ;; This function parses the FORMAT string with the help of the
576   ;; SPEC-ALIST and returns a list that can be eval'ed to return a
577   ;; string.
578   (let ((max-width 0)
579         spec flist fstring elem result dontinsert user-defined
580         type value pad-width spec-beg cut-width ignore-value
581         tilde-form tilde elem-type extended-spec)
582     (save-excursion
583       (gnus-set-work-buffer)
584       (insert format)
585       (goto-char (point-min))
586       (while (re-search-forward "%" nil t)
587         (setq user-defined nil
588               spec-beg nil
589               pad-width nil
590               max-width nil
591               cut-width nil
592               ignore-value nil
593               tilde-form nil
594               extended-spec nil)
595         (setq spec-beg (1- (point)))
596
597         ;; Parse this spec fully.
598         (while
599             (cond
600              ((looking-at "\\([-.0-9]+\\)\\(,[-0-9]+\\)?")
601               (setq pad-width (string-to-number (match-string 1)))
602               (when (match-beginning 2)
603                 (setq max-width (string-to-number (buffer-substring
604                                                    (1+ (match-beginning 2))
605                                                    (match-end 2)))))
606               (goto-char (match-end 0)))
607              ((looking-at "~")
608               (forward-char 1)
609               (setq tilde (read (current-buffer))
610                     type (car tilde)
611                     value (cadr tilde))
612               (cond
613                ((memq type '(pad pad-left))
614                 (setq pad-width value))
615                ((eq type 'pad-right)
616                 (setq pad-width (- value)))
617                ((memq type '(max-right max))
618                 (setq max-width value))
619                ((eq type 'max-left)
620                 (setq max-width (- value)))
621                ((memq type '(cut cut-left))
622                 (setq cut-width value))
623                ((eq type 'cut-right)
624                 (setq cut-width (- value)))
625                ((eq type 'ignore)
626                 (setq ignore-value
627                       (if (stringp value) value (format "%s" value))))
628                ((eq type 'form)
629                 (setq tilde-form value))
630                (t
631                 (error "Unknown tilde type: %s" tilde)))
632               t)
633              (t
634               nil)))
635         (cond
636          ;; User-defined spec -- find the spec name.
637          ((eq (setq spec (char-after)) ?u)
638           (forward-char 1)
639           (when (and (eq (setq user-defined (char-after)) ?&)
640                      (looking-at "&\\([^;]+\\);"))
641             (setq user-defined (match-string 1))
642             (goto-char (match-end 1))))
643          ;; extended spec
644          ((and (eq spec ?&) (looking-at "&\\([^;]+\\);"))
645           (setq extended-spec (intern (match-string 1)))
646           (goto-char (match-end 1))))
647         (forward-char 1)
648         (delete-region spec-beg (point))
649
650         ;; Now we have all the relevant data on this spec, so
651         ;; we start doing stuff.
652         (insert "%")
653         (if (eq spec ?%)
654             ;; "%%" just results in a "%".
655             (insert "%")
656           (cond
657            ;; Do tilde forms.
658            ((eq spec ?@)
659             (setq elem (list tilde-form ?s)))
660            ;; Treat user defined format specifiers specially.
661            (user-defined
662             (setq elem
663                   (list
664                    (list (intern (format
665                                   (if (stringp user-defined)
666                                       "gnus-user-format-function-%s"
667                                     "gnus-user-format-function-%c")
668                                   user-defined))
669                          'gnus-tmp-header)
670                    ?s)))
671            ;; Find the specification from `spec-alist'.
672            ((setq elem (cdr (assq (or extended-spec spec) spec-alist))))
673            ;; We used to use "%l" for displaying the grouplens score.
674            ((eq spec ?l)
675             (setq elem '("" ?s)))
676            (t
677             (setq elem '("*" ?s))))
678           (setq elem-type (cadr elem))
679           ;; Insert the new format elements.
680           (when (and pad-width
681                      (not (and (featurep 'xemacs)
682                                gnus-use-correct-string-widths)))
683             (insert (number-to-string pad-width)))
684           ;; Create the form to be evalled.
685           (if (or max-width cut-width ignore-value
686                   (and (featurep 'xemacs)
687                        gnus-use-correct-string-widths))
688               (progn
689                 (insert ?s)
690                 (let ((el (car elem)))
691                   (cond ((= (cadr elem) ?c)
692                          (setq el (list 'char-to-string el)))
693                         ((= (cadr elem) ?d)
694                          (setq el (list 'int-to-string el))))
695                   (when ignore-value
696                     (setq el (gnus-tilde-ignore-form el ignore-value)))
697                   (when cut-width
698                     (setq el (gnus-tilde-cut-form el cut-width)))
699                   (when max-width
700                     (setq el (gnus-tilde-max-form el max-width)))
701                   (when pad-width
702                     (setq el (gnus-pad-form el pad-width)))
703                   (push el flist)))
704             (insert elem-type)
705             (push (car elem) flist))))
706       (setq fstring (buffer-substring-no-properties (point-min) (point-max))))
707
708     ;; Do some postprocessing to increase efficiency.
709     (setq
710      result
711      (cond
712       ;; Emptiness.
713       ((string= fstring "")
714        nil)
715       ;; Not a format string.
716       ((not (string-match "%" fstring))
717        (list fstring))
718       ;; A format string with just a single string spec.
719       ((string= fstring "%s")
720        (list (car flist)))
721       ;; A single character.
722       ((string= fstring "%c")
723        (list (car flist)))
724       ;; A single number.
725       ((string= fstring "%d")
726        (setq dontinsert t)
727        (if insert
728            `(insert (int-to-string ,(car flist)))
729          (list `(int-to-string ,(car flist)))))
730       ;; Just lots of chars and strings.
731       ((string-match "\\`\\(%[cs]\\)+\\'" fstring)
732        (nreverse flist))
733       ;; A single string spec at the beginning of the spec.
734       ((string-match "\\`%[sc][^%]+\\'" fstring)
735        (list (car flist) (substring fstring 2)))
736       ;; A single string spec in the middle of the spec.
737       ((string-match "\\`\\([^%]+\\)%[sc]\\([^%]+\\)\\'" fstring)
738        (list (match-string 1 fstring) (car flist) (match-string 2 fstring)))
739       ;; A single string spec in the end of the spec.
740       ((string-match "\\`\\([^%]+\\)%[sc]\\'" fstring)
741        (list (match-string 1 fstring) (car flist)))
742       ;; Only string (and %) specs (XEmacs only!)
743       ((and (featurep 'xemacs)
744             gnus-make-format-preserve-properties
745             (string-match
746              "\\`\\([^%]*\\(%%\\|%-?\\([1-9][0-9]*\\)?s\\)\\)*[^%]*\\'"
747              fstring))
748        (list (cons 'gnus-xmas-format (cons fstring (nreverse flist)))))
749       ;; A more complex spec.
750       (t
751        (list (cons 'format (cons fstring (nreverse flist)))))))
752
753     (if insert
754         (when result
755           (if dontinsert
756               result
757             (cons 'insert result)))
758       (cond ((stringp result)
759              result)
760             ((consp result)
761              (cons 'concat result))
762             (t "")))))
763
764 (defun gnus-eval-format (format &optional alist props)
765   "Eval the format variable FORMAT, using ALIST.
766 If PROPS, insert the result."
767   (let ((form (gnus-parse-format format alist props)))
768     (if props
769         (gnus-add-text-properties (point) (progn (eval form) (point)) props)
770       (eval form))))
771
772 (defun gnus-compile ()
773   "Byte-compile the user-defined format specs."
774   (interactive)
775   (require 'bytecomp)
776   (let ((entries gnus-format-specs)
777         (byte-compile-warnings '(unresolved callargs redefine))
778         entry gnus-tmp-func)
779     (save-excursion
780       (gnus-message 7 "Compiling format specs...")
781
782       (while entries
783         (setq entry (pop entries))
784         (if (memq (car entry) '(gnus-version version))
785             (setq gnus-format-specs (delq entry gnus-format-specs))
786           (let ((form (caddr entry)))
787             (when (and (listp form)
788                        ;; Under GNU Emacs, it's (byte-code ...)
789                        (not (eq 'byte-code (car form)))
790                        ;; Under XEmacs, it's (funcall #<compiled-function ...>)
791                        (not (and (eq 'funcall (car form))
792                                  (byte-code-function-p (cadr form)))))
793               (defalias 'gnus-tmp-func `(lambda () ,form))
794               (byte-compile 'gnus-tmp-func)
795               (setcar (cddr entry) (gnus-byte-code 'gnus-tmp-func))))))
796
797       (push (cons 'version emacs-version) gnus-format-specs)
798       ;; Mark the .newsrc.eld file as "dirty".
799       (gnus-dribble-touch)
800       (gnus-message 7 "Compiling user specs...done"))))
801
802 (defun gnus-set-format (type &optional insertable)
803   (set (intern (format "gnus-%s-line-format-spec" type))
804        (gnus-parse-format
805         (symbol-value (intern (format "gnus-%s-line-format" type)))
806         (symbol-value (intern (format "gnus-%s-line-format-alist" type)))
807         insertable)))
808
809 (provide 'gnus-spec)
810
811 ;; Local Variables:
812 ;; coding: iso-8859-1
813 ;; End:
814
815 ;;; gnus-spec.el ends here