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