/[emacs]/emacs/lisp/gnus/gnus-spec.el
ViewVC logotype

Diff of /emacs/lisp/gnus/gnus-spec.el

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.5.24.1 by handa, Fri Mar 12 00:02:58 2004 UTC revision 1.5.24.2 by miles, Thu Sep 9 09:36:26 2004 UTC
# Line 1  Line 1 
1  ;;; gnus-spec.el --- format spec functions for Gnus  -*- coding: iso-latin-1 -*-  ;;; gnus-spec.el --- format spec functions for Gnus
2  ;; Copyright (C) 1996, 1997, 1998, 1999, 2000  ;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004
3  ;;        Free Software Foundation, Inc.  ;;        Free Software Foundation, Inc.
4    
5  ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>  ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
# Line 30  Line 30 
30    
31  (require 'gnus)  (require 'gnus)
32    
33    (defcustom gnus-use-correct-string-widths (featurep 'xemacs)
34      "*If non-nil, use correct functions for dealing with wide characters."
35      :group 'gnus-format
36      :type 'boolean)
37    
38    (defcustom gnus-make-format-preserve-properties (featurep 'xemacs)
39      "*If non-nil, use a replacement `format' function which preserves
40    text properties. This is only needed on XEmacs, as FSF Emacs does this anyway."
41      :group 'gnus-format
42      :type 'boolean)
43    
44  ;;; Internal variables.  ;;; Internal variables.
45    
46  (defvar gnus-summary-mark-positions nil)  (defvar gnus-summary-mark-positions nil)
# Line 69  Line 80 
80  (defvar gnus-tmp-article-number)  (defvar gnus-tmp-article-number)
81  (defvar gnus-mouse-face)  (defvar gnus-mouse-face)
82  (defvar gnus-mouse-face-prop)  (defvar gnus-mouse-face-prop)
83    (defvar gnus-tmp-header)
84    (defvar gnus-tmp-from)
85    
86  (defun gnus-summary-line-format-spec ()  (defun gnus-summary-line-format-spec ()
87    (insert gnus-tmp-unread gnus-tmp-replied    (insert gnus-tmp-unread gnus-tmp-replied
# Line 77  Line 90 
90     (point)     (point)
91     (progn     (progn
92       (insert       (insert
93        gnus-tmp-opening-bracket        (format "%c%4s: %-23s%c" gnus-tmp-opening-bracket gnus-tmp-lines
94        (format "%4d: %-20s"                (let ((val
95                gnus-tmp-lines                       (inline
96                (if (> (length gnus-tmp-name) 20)                         (gnus-summary-from-or-to-or-newsgroups
97                    (substring gnus-tmp-name 0 20)                          gnus-tmp-header gnus-tmp-from))))
98                  gnus-tmp-name))                  (if (> (length val) 23)
99        gnus-tmp-closing-bracket)                      (substring val 0 23)
100                      val))
101                  gnus-tmp-closing-bracket))
102       (point))       (point))
103     gnus-mouse-face-prop gnus-mouse-face)     gnus-mouse-face-prop gnus-mouse-face)
104    (insert " " gnus-tmp-subject-or-nil "\n"))    (insert " " gnus-tmp-subject-or-nil "\n"))
# Line 120  Line 135 
135    
136  (defvar gnus-format-specs  (defvar gnus-format-specs
137    `((version . ,emacs-version)    `((version . ,emacs-version)
138        (gnus-version . ,(gnus-continuum-version))
139      (group "%M\%S\%p\%P\%5y: %(%g%)%l\n" ,gnus-group-line-format-spec)      (group "%M\%S\%p\%P\%5y: %(%g%)%l\n" ,gnus-group-line-format-spec)
140      (summary-dummy "*  %(:                          :%) %S\n"      (summary-dummy "*  %(:                          :%) %S\n"
141                     ,gnus-summary-dummy-line-format-spec)                     ,gnus-summary-dummy-line-format-spec)
142      (summary "%U\%R\%z\%I\%(%[%4L: %-20,20n%]%) %s\n"      (summary "%U%R%z%I%(%[%4L: %-23,23f%]%) %s\n"
143               ,gnus-summary-line-format-spec))               ,gnus-summary-line-format-spec))
144    "Alist of format specs.")    "Alist of format specs.")
145    
146    (defvar gnus-default-format-specs gnus-format-specs)
147    
148  (defvar gnus-article-mode-line-format-spec nil)  (defvar gnus-article-mode-line-format-spec nil)
149  (defvar gnus-summary-mode-line-format-spec nil)  (defvar gnus-summary-mode-line-format-spec nil)
150  (defvar gnus-group-mode-line-format-spec nil)  (defvar gnus-group-mode-line-format-spec nil)
151    
152  ;;; Phew.  All that gruft is over, fortunately.  ;;; Phew.  All that gruft is over with, fortunately.
153    
154  ;;;###autoload  ;;;###autoload
155  (defun gnus-update-format (var)  (defun gnus-update-format (var)
# Line 162  Line 180 
180      (pop-to-buffer "*Gnus Format*")      (pop-to-buffer "*Gnus Format*")
181      (erase-buffer)      (erase-buffer)
182      (lisp-interaction-mode)      (lisp-interaction-mode)
183      (insert (pp-to-string spec))))      (insert (gnus-pp-to-string spec))))
184    
185  (defun gnus-update-format-specifications (&optional force &rest types)  (defun gnus-update-format-specifications (&optional force &rest types)
186    "Update all (necessary) format specifications."    "Update all (necessary) format specifications."
187    ;; Make the indentation array.    ;; Make the indentation array.
188    ;; See whether all the stored info needs to be flushed.    ;; See whether all the stored info needs to be flushed.
189    (when (or force    (when (or force
190                (not gnus-newsrc-file-version)
191                (not (equal (gnus-continuum-version)
192                            (gnus-continuum-version gnus-newsrc-file-version)))
193              (not (equal emacs-version              (not (equal emacs-version
194                          (cdr (assq 'version gnus-format-specs)))))                          (cdr (assq 'version gnus-format-specs)))))
195      (setq gnus-format-specs nil))      (setq gnus-format-specs nil))
# Line 176  Line 197 
197    ;; Go through all the formats and see whether they need updating.    ;; Go through all the formats and see whether they need updating.
198    (let (new-format entry type val)    (let (new-format entry type val)
199      (while (setq type (pop types))      (while (setq type (pop types))
200        ;; Jump to the proper buffer to find out the value of        ;; Jump to the proper buffer to find out the value of the
201        ;; the variable, if possible.  (It may be buffer-local.)        ;; variable, if possible.  (It may be buffer-local.)
202        (save-excursion        (save-excursion
203          (let ((buffer (intern (format "gnus-%s-buffer" type)))          (let ((buffer (intern (format "gnus-%s-buffer" type)))
204                val)                val)
# Line 243  Line 264 
264  (defun gnus-balloon-face-function (form type)  (defun gnus-balloon-face-function (form type)
265    `(gnus-put-text-property    `(gnus-put-text-property
266      (point) (progn ,@form (point))      (point) (progn ,@form (point))
267      'balloon-help      ,(if (fboundp 'balloon-help-mode)
268             ''balloon-help
269           ''help-echo)
270      ,(intern (format "gnus-balloon-face-%d" type))))      ,(intern (format "gnus-balloon-face-%d" type))))
271    
272    (defun gnus-spec-tab (column)
273      (if (> column 0)
274          `(insert (make-string (max (- ,column (current-column)) 0) ? ))
275        (let ((column (abs column)))
276          (if gnus-use-correct-string-widths
277              `(progn
278                 (if (> (current-column) ,column)
279                     (while (progn
280                              (delete-backward-char 1)
281                              (> (current-column) ,column))))
282                 (insert (make-string (max (- ,column (current-column)) 0) ? )))
283            `(progn
284               (if (> (current-column) ,column)
285                   (delete-region (point)
286                                  (- (point) (- (current-column) ,column)))
287                 (insert (make-string (max (- ,column (current-column)) 0)
288                                      ? ))))))))
289    
290    (defun gnus-correct-length (string)
291      "Return the correct width of STRING."
292      (let ((length 0))
293        (mapcar (lambda (char) (incf length (gnus-char-width char))) string)
294        length))
295    
296    (defun gnus-correct-substring (string start &optional end)
297      (let ((wstart 0)
298            (wend 0)
299            (wseek 0)
300            (seek 0)
301            (length (length string))
302            (string (concat string "\0")))
303        ;; Find the start position.
304        (while (and (< seek length)
305                    (< wseek start))
306          (incf wseek (gnus-char-width (aref string seek)))
307          (incf seek))
308        (setq wstart seek)
309        ;; Find the end position.
310        (while (and (<= seek length)
311                    (or (not end)
312                        (<= wseek end)))
313          (incf wseek (gnus-char-width (aref string seek)))
314          (incf seek))
315        (setq wend seek)
316        (substring string wstart (1- wend))))
317    
318    (defun gnus-string-width-function ()
319      (cond
320       (gnus-use-correct-string-widths
321        'gnus-correct-length)
322       ((fboundp 'string-width)
323        'string-width)
324       (t
325        'length)))
326    
327    (defun gnus-substring-function ()
328      (cond
329       (gnus-use-correct-string-widths
330        'gnus-correct-substring)
331       ((fboundp 'string-width)
332        'gnus-correct-substring)
333       (t
334        'substring)))
335    
336  (defun gnus-tilde-max-form (el max-width)  (defun gnus-tilde-max-form (el max-width)
337    "Return a form that limits EL to MAX-WIDTH."    "Return a form that limits EL to MAX-WIDTH."
338    (let ((max (abs max-width)))    (let ((max (abs max-width))
339            (length-fun (gnus-string-width-function))
340            (substring-fun (gnus-substring-function)))
341      (if (symbolp el)      (if (symbolp el)
342          `(if (> (length ,el) ,max)          `(if (> (,length-fun ,el) ,max)
343               ,(if (< max-width 0)               ,(if (< max-width 0)
344                    `(substring ,el (- (length el) ,max))                    `(,substring-fun ,el (- (,length-fun ,el) ,max))
345                  `(substring ,el 0 ,max))                  `(,substring-fun ,el 0 ,max))
346             ,el)             ,el)
347        `(let ((val (eval ,el)))        `(let ((val (eval ,el)))
348           (if (> (length val) ,max)           (if (> (,length-fun val) ,max)
349               ,(if (< max-width 0)               ,(if (< max-width 0)
350                    `(substring val (- (length val) ,max))                    `(,substring-fun val (- (,length-fun val) ,max))
351                  `(substring val 0 ,max))                  `(,substring-fun val 0 ,max))
352             val)))))             val)))))
353    
354  (defun gnus-tilde-cut-form (el cut-width)  (defun gnus-tilde-cut-form (el cut-width)
355    "Return a form that cuts CUT-WIDTH off of EL."    "Return a form that cuts CUT-WIDTH off of EL."
356    (let ((cut (abs cut-width)))    (let ((cut (abs cut-width))
357            (length-fun (gnus-string-width-function))
358            (substring-fun (gnus-substring-function)))
359      (if (symbolp el)      (if (symbolp el)
360          `(if (> (length ,el) ,cut)          `(if (> (,length-fun ,el) ,cut)
361               ,(if (< cut-width 0)               ,(if (< cut-width 0)
362                    `(substring ,el 0 (- (length el) ,cut))                    `(,substring-fun ,el 0 (- (,length-fun ,el) ,cut))
363                  `(substring ,el ,cut))                  `(,substring-fun ,el ,cut))
364             ,el)             ,el)
365        `(let ((val (eval ,el)))        `(let ((val (eval ,el)))
366           (if (> (length val) ,cut)           (if (> (,length-fun val) ,cut)
367               ,(if (< cut-width 0)               ,(if (< cut-width 0)
368                    `(substring val 0 (- (length val) ,cut))                    `(,substring-fun val 0 (- (,length-fun val) ,cut))
369                  `(substring val ,cut))                  `(,substring-fun val ,cut))
370             val)))))             val)))))
371    
372  (defun gnus-tilde-ignore-form (el ignore-value)  (defun gnus-tilde-ignore-form (el ignore-value)
# Line 287  Line 378 
378         (if (equal val ,ignore-value)         (if (equal val ,ignore-value)
379             "" val))))             "" val))))
380    
381    (defun gnus-pad-form (el pad-width)
382      "Return a form that pads EL to PAD-WIDTH accounting for multi-column
383    characters correctly. This is because `format' may pad to columns or to
384    characters when given a pad value."
385      (let ((pad (abs pad-width))
386            (side (< 0 pad-width))
387            (length-fun (gnus-string-width-function)))
388        (if (symbolp el)
389            `(let ((need (- ,pad (,length-fun ,el))))
390               (if (> need 0)
391                   (concat ,(when side '(make-string need ?\ ))
392                           ,el
393                           ,(when (not side) '(make-string need ?\ )))
394                 ,el))
395          `(let* ((val (eval ,el))
396                  (need (- ,pad (,length-fun val))))
397             (if (> need 0)
398                 (concat ,(when side '(make-string need ?\ ))
399                         val
400                         ,(when (not side) '(make-string need ?\ )))
401               val)))))
402    
403  (defun gnus-parse-format (format spec-alist &optional insert)  (defun gnus-parse-format (format spec-alist &optional insert)
404    ;; This function parses the FORMAT string with the help of the    ;; This function parses the FORMAT string with the help of the
405    ;; SPEC-ALIST and returns a list that can be eval'ed to return the    ;; SPEC-ALIST and returns a list that can be eval'ed to return the
# Line 294  Line 407 
407    ;; the text between them will have the mouse-face text property.    ;; the text between them will have the mouse-face text property.
408    ;; If the FORMAT string contains the specifiers %[ and %], the text between    ;; If the FORMAT string contains the specifiers %[ and %], the text between
409    ;; them will have the balloon-help text property.    ;; them will have the balloon-help text property.
410    (if (string-match    (let ((case-fold-search nil))
411         "\\`\\(.*\\)%[0-9]?[{(«]\\(.*\\)%[0-9]?[»})]\\(.*\n?\\)\\'"      (if (string-match
412         format)           "\\`\\(.*\\)%[0-9]?[{(«]\\(.*\\)%[0-9]?[»})]\\(.*\n?\\)\\'\\|%[-0-9]*=\\|%[-0-9]*\\*"
413        (gnus-parse-complex-format format spec-alist)           format)
414      ;; This is a simple format.          (gnus-parse-complex-format format spec-alist)
415      (gnus-parse-simple-format format spec-alist insert)))        ;; This is a simple format.
416          (gnus-parse-simple-format format spec-alist insert))))
417    
418  (defun gnus-parse-complex-format (format spec-alist)  (defun gnus-parse-complex-format (format spec-alist)
419    (save-excursion    (let ((cursor-spec nil))
420      (gnus-set-work-buffer)      (save-excursion
421      (insert format)        (gnus-set-work-buffer)
422      (goto-char (point-min))        (insert format)
423      (while (re-search-forward "\"" nil t)        (goto-char (point-min))
424        (replace-match "\\\"" nil t))        (while (re-search-forward "\"" nil t)
425      (goto-char (point-min))          (replace-match "\\\"" nil t))
426      (insert "(\"")        (goto-char (point-min))
427      (while (re-search-forward "%\\([0-9]+\\)?\\([«»{}()]\\)" nil t)        (insert "(\"")
428        (let ((number (if (match-beginning 1)        ;; Convert all font specs into font spec lists.
429                          (match-string 1) "0"))        (while (re-search-forward "%\\([0-9]+\\)?\\([«»{}()]\\)" nil t)
430              (delim (aref (match-string 2) 0)))          (let ((number (if (match-beginning 1)
431          (if (or (= delim ?\()                            (match-string 1) "0"))
432                  (= delim ?\{)                (delim (aref (match-string 2) 0)))
433                  (= delim ?\«))            (if (or (= delim ?\()
434              (replace-match (concat "\"("                    (= delim ?\{)
435                                     (cond ((= delim ?\() "mouse")                    (= delim ?\«))
436                                           ((= delim ?\{) "face")                (replace-match (concat "\"("
437                                           (t "balloon"))                                       (cond ((= delim ?\() "mouse")
438                                     " " number " \""))                                             ((= delim ?\{) "face")
439            (replace-match "\")\""))))                                             (t "balloon"))
440      (goto-char (point-max))                                       " " number " \"")
441      (insert "\")")                               t t)
442      (goto-char (point-min))              (replace-match "\")\""))))
443      (let ((form (read (current-buffer))))        (goto-char (point-max))
444        (cons 'progn (gnus-complex-form-to-spec form spec-alist)))))        (insert "\")")
445          ;; Convert point position commands.
446          (goto-char (point-min))
447          (let ((case-fold-search nil))
448            (while (re-search-forward "%\\([-0-9]+\\)?\\*" nil t)
449              (replace-match "\"(point)\"" t t)
450              (setq cursor-spec t)))
451          ;; Convert TAB commands.
452          (goto-char (point-min))
453          (while (re-search-forward "%\\([-0-9]+\\)=" nil t)
454            (replace-match (format "\"(tab %s)\"" (match-string 1)) t t))
455          ;; Convert the buffer into the spec.
456          (goto-char (point-min))
457          (let ((form (read (current-buffer))))
458            (if cursor-spec
459                `(let (gnus-position)
460                   ,@(gnus-complex-form-to-spec form spec-alist)
461                   (if gnus-position
462                       (gnus-put-text-property gnus-position (1+ gnus-position)
463                                               'gnus-position t)))
464              `(progn
465                 ,@(gnus-complex-form-to-spec form spec-alist)))))))
466    
467  (defun gnus-complex-form-to-spec (form spec-alist)  (defun gnus-complex-form-to-spec (form spec-alist)
468    (delq nil    (delq nil
469          (mapcar          (mapcar
470           (lambda (sform)           (lambda (sform)
471             (if (stringp sform)             (cond
472                 (gnus-parse-simple-format sform spec-alist t)              ((stringp sform)
473                 (gnus-parse-simple-format sform spec-alist t))
474                ((eq (car sform) 'point)
475                 '(setq gnus-position (point)))
476                ((eq (car sform) 'tab)
477                 (gnus-spec-tab (cadr sform)))
478                (t
479               (funcall (intern (format "gnus-%s-face-function" (car sform)))               (funcall (intern (format "gnus-%s-face-function" (car sform)))
480                        (gnus-complex-form-to-spec (cddr sform) spec-alist)                        (gnus-complex-form-to-spec (cddr sform) spec-alist)
481                        (nth 1 sform))))                        (nth 1 sform)))))
482           form)))           form)))
483    
484    
485    (defun gnus-xmas-format (fstring &rest args)
486      "A version of `format' which preserves text properties.
487    
488    Required for XEmacs, where the built in `format' function strips all text
489    properties from both the format string and any inserted strings.
490    
491    Only supports the format sequence %s, and %% for inserting
492    literal % characters. A pad width and an optional - (to right pad)
493    are supported for %s."
494      (let ((re "%%\\|%\\(-\\)?\\([1-9][0-9]*\\)?s")
495            (n (length args)))
496        (with-temp-buffer
497          (insert fstring)
498          (goto-char (point-min))
499          (while (re-search-forward re nil t)
500            (goto-char (match-end 0))
501            (cond
502             ((string= (match-string 0) "%%")
503              (delete-char -1))
504             (t
505              (if (null args)
506                  (error 'wrong-number-of-arguments #'my-format n fstring))
507              (let* ((minlen (string-to-int (or (match-string 2) "")))
508                     (arg (car args))
509                     (str (if (stringp arg) arg (format "%s" arg)))
510                     (lpad (null (match-string 1)))
511                     (padlen (max 0 (- minlen (length str)))))
512                (replace-match "")
513                (if lpad (insert-char ?\  padlen))
514                (insert str)
515                (unless lpad (insert-char ?\  padlen))
516                (setq args (cdr args))))))
517          (buffer-string))))
518    
519  (defun gnus-parse-simple-format (format spec-alist &optional insert)  (defun gnus-parse-simple-format (format spec-alist &optional insert)
520    ;; This function parses the FORMAT string with the help of the    ;; This function parses the FORMAT string with the help of the
521    ;; SPEC-ALIST and returns a list that can be eval'ed to return a    ;; SPEC-ALIST and returns a list that can be eval'ed to return a
# Line 347  Line 523 
523    (let ((max-width 0)    (let ((max-width 0)
524          spec flist fstring elem result dontinsert user-defined          spec flist fstring elem result dontinsert user-defined
525          type value pad-width spec-beg cut-width ignore-value          type value pad-width spec-beg cut-width ignore-value
526          tilde-form tilde elem-type)          tilde-form tilde elem-type extended-spec)
527      (save-excursion      (save-excursion
528        (gnus-set-work-buffer)        (gnus-set-work-buffer)
529        (insert format)        (insert format)
# Line 359  Line 535 
535                max-width nil                max-width nil
536                cut-width nil                cut-width nil
537                ignore-value nil                ignore-value nil
538                tilde-form nil)                tilde-form nil
539                  extended-spec nil)
540          (setq spec-beg (1- (point)))          (setq spec-beg (1- (point)))
541    
542          ;; Parse this spec fully.          ;; Parse this spec fully.
# Line 400  Line 577 
577                t)                t)
578               (t               (t
579                nil)))                nil)))
580          ;; User-defined spec -- find the spec name.          (cond
581          (when (eq (setq spec (char-after)) ?u)           ;; User-defined spec -- find the spec name.
582             ((eq (setq spec (char-after)) ?u)
583            (forward-char 1)            (forward-char 1)
584            (setq user-defined (char-after)))            (when (and (eq (setq user-defined (char-after)) ?&)
585                         (looking-at "&\\([^;]+\\);"))
586                (setq user-defined (match-string 1))
587                (goto-char (match-end 1))))
588             ;; extended spec
589             ((and (eq spec ?&) (looking-at "&\\([^;]+\\);"))
590              (setq extended-spec (intern (match-string 1)))
591              (goto-char (match-end 1))))
592          (forward-char 1)          (forward-char 1)
593          (delete-region spec-beg (point))          (delete-region spec-beg (point))
594    
# Line 421  Line 606 
606             (user-defined             (user-defined
607              (setq elem              (setq elem
608                    (list                    (list
609                     (list (intern (format "gnus-user-format-function-%c"                     (list (intern (format
610                                           user-defined))                                    (if (stringp user-defined)
611                                          "gnus-user-format-function-%s"
612                                        "gnus-user-format-function-%c")
613                                      user-defined))
614                           'gnus-tmp-header)                           'gnus-tmp-header)
615                     ?s)))                     ?s)))
616             ;; Find the specification from `spec-alist'.             ;; Find the specification from `spec-alist'.
617             ((setq elem (cdr (assq spec spec-alist))))             ((setq elem (cdr (assq (or extended-spec spec) spec-alist))))
618             (t             (t
619              (setq elem '("*" ?s))))              (setq elem '("*" ?s))))
620            (setq elem-type (cadr elem))            (setq elem-type (cadr elem))
621            ;; Insert the new format elements.            ;; Insert the new format elements.
622            (when pad-width            (when (and pad-width
623                         (not (and (featurep 'xemacs)
624                                   gnus-use-correct-string-widths)))
625              (insert (number-to-string pad-width)))              (insert (number-to-string pad-width)))
626            ;; Create the form to be evaled.            ;; Create the form to be evaled.
627            (if (or max-width cut-width ignore-value)            (if (or max-width cut-width ignore-value
628                      (and (featurep 'xemacs)
629                           gnus-use-correct-string-widths))
630                (progn                (progn
631                  (insert ?s)                  (insert ?s)
632                  (let ((el (car elem)))                  (let ((el (car elem)))
# Line 448  Line 640 
640                      (setq el (gnus-tilde-cut-form el cut-width)))                      (setq el (gnus-tilde-cut-form el cut-width)))
641                    (when max-width                    (when max-width
642                      (setq el (gnus-tilde-max-form el max-width)))                      (setq el (gnus-tilde-max-form el max-width)))
643                      (when pad-width
644                        (setq el (gnus-pad-form el pad-width)))
645                    (push el flist)))                    (push el flist)))
646              (insert elem-type)              (insert elem-type)
647              (push (car elem) flist))))              (push (car elem) flist))))
648        (setq fstring (buffer-string)))        (setq fstring (buffer-substring-no-properties (point-min) (point-max))))
649    
650      ;; Do some postprocessing to increase efficiency.      ;; Do some postprocessing to increase efficiency.
651      (setq      (setq
652       result       result
653       (cond       (cond
654        ;; Emptyness.        ;; Emptiness.
655        ((string= fstring "")        ((string= fstring "")
656         nil)         nil)
657        ;; Not a format string.        ;; Not a format string.
# Line 487  Line 681 
681        ;; A single string spec in the end of the spec.        ;; A single string spec in the end of the spec.
682        ((string-match "\\`\\([^%]+\\)%[sc]\\'" fstring)        ((string-match "\\`\\([^%]+\\)%[sc]\\'" fstring)
683         (list (match-string 1 fstring) (car flist)))         (list (match-string 1 fstring) (car flist)))
684          ;; Only string (and %) specs (XEmacs only!)
685          ((and (featurep 'xemacs)
686                gnus-make-format-preserve-properties
687                (string-match
688                 "\\`\\([^%]*\\(%%\\|%-?\\([1-9][0-9]*\\)?s\\)\\)*[^%]*\\'"
689                 fstring))
690           (list (cons 'gnus-xmas-format (cons fstring (nreverse flist)))))
691        ;; A more complex spec.        ;; A more complex spec.
692        (t        (t
693         (list (cons 'format (cons fstring (nreverse flist)))))))         (list (cons 'format (cons fstring (nreverse flist)))))))
# Line 522  If PROPS, insert the result." Line 723  If PROPS, insert the result."
723    
724        (while entries        (while entries
725          (setq entry (pop entries))          (setq entry (pop entries))
726          (if (eq (car entry) 'version)          (if (memq (car entry) '(gnus-version version))
727              (setq gnus-format-specs (delq entry gnus-format-specs))              (setq gnus-format-specs (delq entry gnus-format-specs))
728            (let ((form (caddr entry)))            (let ((form (caddr entry)))
729              (when (and (listp form)              (when (and (listp form)
# Line 531  If PROPS, insert the result." Line 732  If PROPS, insert the result."
732                         ;; Under XEmacs, it's (funcall #<compiled-function ...>)                         ;; Under XEmacs, it's (funcall #<compiled-function ...>)
733                         (not (and (eq 'funcall (car form))                         (not (and (eq 'funcall (car form))
734                                   (byte-code-function-p (cadr form)))))                                   (byte-code-function-p (cadr form)))))
735                (fset 'gnus-tmp-func `(lambda () ,form))                (defalias 'gnus-tmp-func `(lambda () ,form))
736                (byte-compile 'gnus-tmp-func)                (byte-compile 'gnus-tmp-func)
737                (setcar (cddr entry) (gnus-byte-code 'gnus-tmp-func))))))                (setcar (cddr entry) (gnus-byte-code 'gnus-tmp-func))))))
738    

Legend:
Removed from v.1.5.24.1  
changed lines
  Added in v.1.5.24.2

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26