;;; gnus-spec.el --- format spec functions for Gnus
-;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1996,97,98 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: news
(require 'gnus)
-(defcustom gnus-use-correct-string-widths (featurep 'xemacs)
- "*If non-nil, use correct functions for dealing with wide characters."
- :version "22.1"
- :group 'gnus-format
- :type 'boolean)
-
-(defcustom gnus-make-format-preserve-properties (featurep 'xemacs)
- "*If non-nil, use a replacement `format' function which preserves
-text properties. This is only needed on XEmacs, as FSF Emacs does this anyway."
- :version "22.1"
- :group 'gnus-format
- :type 'boolean)
-
;;; Internal variables.
(defvar gnus-summary-mark-positions nil)
(defvar gnus-tmp-article-number)
(defvar gnus-mouse-face)
(defvar gnus-mouse-face-prop)
-(defvar gnus-tmp-header)
-(defvar gnus-tmp-from)
(defun gnus-summary-line-format-spec ()
(insert gnus-tmp-unread gnus-tmp-replied
(point)
(progn
(insert
- (format "%c%4s: %-23s%c" gnus-tmp-opening-bracket gnus-tmp-lines
- (let ((val
- (inline
- (gnus-summary-from-or-to-or-newsgroups
- gnus-tmp-header gnus-tmp-from))))
- (if (> (length val) 23)
- (substring val 0 23)
- val))
- gnus-tmp-closing-bracket))
+ gnus-tmp-opening-bracket
+ (format "%4d: %-20s"
+ gnus-tmp-lines
+ (if (> (length gnus-tmp-name) 20)
+ (substring gnus-tmp-name 0 20)
+ gnus-tmp-name))
+ gnus-tmp-closing-bracket)
(point))
gnus-mouse-face-prop gnus-mouse-face)
(insert " " gnus-tmp-subject-or-nil "\n"))
(defvar gnus-format-specs
`((version . ,emacs-version)
- (gnus-version . ,(gnus-continuum-version))
- (group "%M\%S\%p\%P\%5y: %(%g%)\n" ,gnus-group-line-format-spec)
+ (group "%M\%S\%p\%P\%5y: %(%g%)%l\n" ,gnus-group-line-format-spec)
(summary-dummy "* %(: :%) %S\n"
,gnus-summary-dummy-line-format-spec)
- (summary "%U%R%z%I%(%[%4L: %-23,23f%]%) %s\n"
+ (summary "%U\%R\%z\%I\%(%[%4L: %-20,20n%]%) %s\n"
,gnus-summary-line-format-spec))
"Alist of format specs.")
-(defvar gnus-default-format-specs gnus-format-specs)
-
(defvar gnus-article-mode-line-format-spec nil)
(defvar gnus-summary-mode-line-format-spec nil)
(defvar gnus-group-mode-line-format-spec nil)
-;;; Phew. All that gruft is over with, fortunately.
+;;; Phew. All that gruft is over, fortunately.
;;;###autoload
(defun gnus-update-format (var)
(pop-to-buffer "*Gnus Format*")
(erase-buffer)
(lisp-interaction-mode)
- (insert (gnus-pp-to-string spec))))
+ (insert (pp-to-string spec))))
(defun gnus-update-format-specifications (&optional force &rest types)
- "Update all (necessary) format specifications.
-Return a list of updated types."
+ "Update all (necessary) format specifications."
;; Make the indentation array.
;; See whether all the stored info needs to be flushed.
(when (or force
- (not gnus-newsrc-file-version)
- (not (equal (gnus-continuum-version)
- (gnus-continuum-version gnus-newsrc-file-version)))
(not (equal emacs-version
(cdr (assq 'version gnus-format-specs)))))
(setq gnus-format-specs nil))
- ;; Flush the group format spec cache if there's the grouplens stuff
- ;; or it doesn't support decoded group names.
- (when (memq 'group types)
- (let* ((spec (assq 'group gnus-format-specs))
- (sspec (gnus-prin1-to-string (nth 2 spec))))
- (when (or (string-match " gnus-tmp-grouplens[ )]" sspec)
- (not (string-match " gnus-tmp-decoded-group[ )]" sspec)))
- (setq gnus-format-specs (delq spec gnus-format-specs)))))
;; Go through all the formats and see whether they need updating.
- (let (new-format entry type val updated)
+ (let (new-format entry type val)
(while (setq type (pop types))
- ;; Jump to the proper buffer to find out the value of the
- ;; variable, if possible. (It may be buffer-local.)
+ ;; Jump to the proper buffer to find out the value of
+ ;; the variable, if possible. (It may be buffer-local.)
(save-excursion
- (let ((buffer (intern (format "gnus-%s-buffer" type))))
+ (let ((buffer (intern (format "gnus-%s-buffer" type)))
+ val)
(when (and (boundp buffer)
(setq val (symbol-value buffer))
(gnus-buffer-exists-p val))
(gnus-parse-format
new-format
(symbol-value
- (intern (format "gnus-%s-line-format-alist" type)))
+ (intern (format "gnus-%s-line-format-alist"
+ (if (eq type 'article-mode)
+ 'summary-mode type))))
(not (string-match "mode$" (symbol-name type))))))
;; Enter the new format spec into the list.
(if entry
(setcar (cdr entry) val)
(setcar entry new-format))
(push (list type new-format val) gnus-format-specs))
- (set (intern (format "gnus-%s-line-format-spec" type)) val)
- (push type updated))))
+ (set (intern (format "gnus-%s-line-format-spec" type)) val)))))
- (unless (assq 'version gnus-format-specs)
- (push (cons 'version emacs-version) gnus-format-specs))
- updated))
+ (unless (assq 'version gnus-format-specs)
+ (push (cons 'version emacs-version) gnus-format-specs)))
(defvar gnus-mouse-face-0 'highlight)
(defvar gnus-mouse-face-1 'highlight)
(point) (progn ,@form (point))
'(gnus-face t face ,(symbol-value (intern (format "gnus-face-%d" type))))))
-(defun gnus-balloon-face-function (form type)
- `(gnus-put-text-property
- (point) (progn ,@form (point))
- ,(if (fboundp 'balloon-help-mode)
- ''balloon-help
- ''help-echo)
- ,(intern (format "gnus-balloon-face-%d" type))))
-
-(defun gnus-spec-tab (column)
- (if (> column 0)
- `(insert-char ? (max (- ,column (current-column)) 0))
- (let ((column (abs column)))
- `(if (> (current-column) ,column)
- (let ((end (point)))
- (if (= (move-to-column ,column) ,column)
- (delete-region (point) end)
- (delete-region (1- (point)) end)
- (insert " ")))
- (insert-char ? (max (- ,column (current-column)) 0))))))
-
-(defun gnus-correct-length (string)
- "Return the correct width of STRING."
- (let ((length 0))
- (mapcar (lambda (char) (incf length (char-width char))) string)
- length))
-
-(defun gnus-correct-substring (string start &optional end)
- (let ((wstart 0)
- (wend 0)
- (wseek 0)
- (seek 0)
- (length (length string))
- (string (concat string "\0")))
- ;; Find the start position.
- (while (and (< seek length)
- (< wseek start))
- (incf wseek (char-width (aref string seek)))
- (incf seek))
- (setq wstart seek)
- ;; Find the end position.
- (while (and (<= seek length)
- (or (not end)
- (<= wseek end)))
- (incf wseek (char-width (aref string seek)))
- (incf seek))
- (setq wend seek)
- (substring string wstart (1- wend))))
-
-(defun gnus-string-width-function ()
- (cond
- (gnus-use-correct-string-widths
- 'gnus-correct-length)
- ((fboundp 'string-width)
- 'string-width)
- (t
- 'length)))
-
-(defun gnus-substring-function ()
- (cond
- (gnus-use-correct-string-widths
- 'gnus-correct-substring)
- ((fboundp 'string-width)
- 'gnus-correct-substring)
- (t
- 'substring)))
-
(defun gnus-tilde-max-form (el max-width)
"Return a form that limits EL to MAX-WIDTH."
- (let ((max (abs max-width))
- (length-fun (gnus-string-width-function))
- (substring-fun (gnus-substring-function)))
+ (let ((max (abs max-width)))
(if (symbolp el)
- `(if (> (,length-fun ,el) ,max)
+ `(if (> (length ,el) ,max)
,(if (< max-width 0)
- `(,substring-fun ,el (- (,length-fun ,el) ,max))
- `(,substring-fun ,el 0 ,max))
+ `(substring ,el (- (length el) ,max))
+ `(substring ,el 0 ,max))
,el)
`(let ((val (eval ,el)))
- (if (> (,length-fun val) ,max)
+ (if (> (length val) ,max)
,(if (< max-width 0)
- `(,substring-fun val (- (,length-fun val) ,max))
- `(,substring-fun val 0 ,max))
+ `(substring val (- (length val) ,max))
+ `(substring val 0 ,max))
val)))))
(defun gnus-tilde-cut-form (el cut-width)
"Return a form that cuts CUT-WIDTH off of EL."
- (let ((cut (abs cut-width))
- (length-fun (gnus-string-width-function))
- (substring-fun (gnus-substring-function)))
+ (let ((cut (abs cut-width)))
(if (symbolp el)
- `(if (> (,length-fun ,el) ,cut)
+ `(if (> (length ,el) ,cut)
,(if (< cut-width 0)
- `(,substring-fun ,el 0 (- (,length-fun ,el) ,cut))
- `(,substring-fun ,el ,cut))
+ `(substring ,el 0 (- (length el) ,cut))
+ `(substring ,el ,cut))
,el)
`(let ((val (eval ,el)))
- (if (> (,length-fun val) ,cut)
+ (if (> (length val) ,cut)
,(if (< cut-width 0)
- `(,substring-fun val 0 (- (,length-fun val) ,cut))
- `(,substring-fun val ,cut))
+ `(substring val 0 (- (length val) ,cut))
+ `(substring val ,cut))
val)))))
(defun gnus-tilde-ignore-form (el ignore-value)
(if (equal val ,ignore-value)
"" val))))
-(defun gnus-pad-form (el pad-width)
- "Return a form that pads EL to PAD-WIDTH accounting for multi-column
-characters correctly. This is because `format' may pad to columns or to
-characters when given a pad value."
- (let ((pad (abs pad-width))
- (side (< 0 pad-width))
- (length-fun (gnus-string-width-function)))
- (if (symbolp el)
- `(let ((need (- ,pad (,length-fun ,el))))
- (if (> need 0)
- (concat ,(when side '(make-string need ?\ ))
- ,el
- ,(when (not side) '(make-string need ?\ )))
- ,el))
- `(let* ((val (eval ,el))
- (need (- ,pad (,length-fun val))))
- (if (> need 0)
- (concat ,(when side '(make-string need ?\ ))
- val
- ,(when (not side) '(make-string need ?\ )))
- val)))))
-
(defun gnus-parse-format (format spec-alist &optional insert)
;; This function parses the FORMAT string with the help of the
;; SPEC-ALIST and returns a list that can be eval'ed to return the
;; string. If the FORMAT string contains the specifiers %( and %)
;; the text between them will have the mouse-face text property.
- ;; If the FORMAT string contains the specifiers %[ and %], the text between
- ;; them will have the balloon-help text property.
- (let ((case-fold-search nil))
- (if (string-match
- "\\`\\(.*\\)%[0-9]?[{(«]\\(.*\\)%[0-9]?[»})]\\(.*\n?\\)\\'\\|%[-0-9]*=\\|%[-0-9]*\\*"
- format)
- (gnus-parse-complex-format format spec-alist)
- ;; This is a simple format.
- (gnus-parse-simple-format format spec-alist insert))))
+ (if (string-match
+ "\\`\\(.*\\)%[0-9]?[{(]\\(.*\\)%[0-9]?[})]\\(.*\n?\\)\\'"
+ format)
+ (gnus-parse-complex-format format spec-alist)
+ ;; This is a simple format.
+ (gnus-parse-simple-format format spec-alist insert)))
(defun gnus-parse-complex-format (format spec-alist)
- (let ((cursor-spec nil))
- (save-excursion
- (gnus-set-work-buffer)
- (insert format)
- (goto-char (point-min))
- (while (re-search-forward "\"" nil t)
- (replace-match "\\\"" nil t))
- (goto-char (point-min))
- (insert "(\"")
- ;; Convert all font specs into font spec lists.
- (while (re-search-forward "%\\([0-9]+\\)?\\([«»{}()]\\)" nil t)
- (let ((number (if (match-beginning 1)
- (match-string 1) "0"))
- (delim (aref (match-string 2) 0)))
- (if (or (= delim ?\()
- (= delim ?\{)
- (= delim ?\«))
- (replace-match (concat "\"("
- (cond ((= delim ?\() "mouse")
- ((= delim ?\{) "face")
- (t "balloon"))
- " " number " \"")
- t t)
- (replace-match "\")\""))))
- (goto-char (point-max))
- (insert "\")")
- ;; Convert point position commands.
- (goto-char (point-min))
- (let ((case-fold-search nil))
- (while (re-search-forward "%\\([-0-9]+\\)?\\*" nil t)
- (replace-match "\"(point)\"" t t)
- (setq cursor-spec t)))
- ;; Convert TAB commands.
- (goto-char (point-min))
- (while (re-search-forward "%\\([-0-9]+\\)=" nil t)
- (replace-match (format "\"(tab %s)\"" (match-string 1)) t t))
- ;; Convert the buffer into the spec.
- (goto-char (point-min))
- (let ((form (read (current-buffer))))
- (if cursor-spec
- `(let (gnus-position)
- ,@(gnus-complex-form-to-spec form spec-alist)
- (if gnus-position
- (gnus-put-text-property gnus-position (1+ gnus-position)
- 'gnus-position t)))
- `(progn
- ,@(gnus-complex-form-to-spec form spec-alist)))))))
+ (save-excursion
+ (gnus-set-work-buffer)
+ (insert format)
+ (goto-char (point-min))
+ (while (re-search-forward "\"" nil t)
+ (replace-match "\\\"" nil t))
+ (goto-char (point-min))
+ (insert "(\"")
+ (while (re-search-forward "%\\([0-9]+\\)?\\([{}()]\\)" nil t)
+ (let ((number (if (match-beginning 1)
+ (match-string 1) "0"))
+ (delim (aref (match-string 2) 0)))
+ (if (or (= delim ?\()
+ (= delim ?\{))
+ (replace-match (concat "\"(" (if (= delim ?\() "mouse" "face")
+ " " number " \""))
+ (replace-match "\")\""))))
+ (goto-char (point-max))
+ (insert "\")")
+ (goto-char (point-min))
+ (let ((form (read (current-buffer))))
+ (cons 'progn (gnus-complex-form-to-spec form spec-alist)))))
(defun gnus-complex-form-to-spec (form spec-alist)
(delq nil
(mapcar
(lambda (sform)
- (cond
- ((stringp sform)
- (gnus-parse-simple-format sform spec-alist t))
- ((eq (car sform) 'point)
- '(setq gnus-position (point)))
- ((eq (car sform) 'tab)
- (gnus-spec-tab (cadr sform)))
- (t
+ (if (stringp sform)
+ (gnus-parse-simple-format sform spec-alist t)
(funcall (intern (format "gnus-%s-face-function" (car sform)))
(gnus-complex-form-to-spec (cddr sform) spec-alist)
- (nth 1 sform)))))
+ (nth 1 sform))))
form)))
-
-(defun gnus-xmas-format (fstring &rest args)
- "A version of `format' which preserves text properties.
-
-Required for XEmacs, where the built in `format' function strips all text
-properties from both the format string and any inserted strings.
-
-Only supports the format sequence %s, and %% for inserting
-literal % characters. A pad width and an optional - (to right pad)
-are supported for %s."
- (let ((re "%%\\|%\\(-\\)?\\([1-9][0-9]*\\)?s")
- (n (length args)))
- (with-temp-buffer
- (insert fstring)
- (goto-char (point-min))
- (while (re-search-forward re nil t)
- (goto-char (match-end 0))
- (cond
- ((string= (match-string 0) "%%")
- (delete-char -1))
- (t
- (if (null args)
- (error 'wrong-number-of-arguments #'my-format n fstring))
- (let* ((minlen (string-to-int (or (match-string 2) "")))
- (arg (car args))
- (str (if (stringp arg) arg (format "%s" arg)))
- (lpad (null (match-string 1)))
- (padlen (max 0 (- minlen (length str)))))
- (replace-match "")
- (if lpad (insert-char ?\ padlen))
- (insert str)
- (unless lpad (insert-char ?\ padlen))
- (setq args (cdr args))))))
- (buffer-string))))
-
(defun gnus-parse-simple-format (format spec-alist &optional insert)
;; This function parses the FORMAT string with the help of the
;; SPEC-ALIST and returns a list that can be eval'ed to return a
;; string.
- (let ((max-width 0)
+ (let (max-width
spec flist fstring elem result dontinsert user-defined
type value pad-width spec-beg cut-width ignore-value
- tilde-form tilde elem-type extended-spec)
+ tilde-form tilde elem-type
+ (xemacs-mule-p (and gnus-xemacs (featurep 'mule))))
(save-excursion
(gnus-set-work-buffer)
(insert format)
(goto-char (point-min))
- (while (re-search-forward "%" nil t)
+ (while (search-forward "%" nil t)
(setq user-defined nil
spec-beg nil
pad-width nil
max-width nil
cut-width nil
ignore-value nil
- tilde-form nil
- extended-spec nil)
+ tilde-form nil)
(setq spec-beg (1- (point)))
;; Parse this spec fully.
t)
(t
nil)))
- (cond
- ;; User-defined spec -- find the spec name.
- ((eq (setq spec (char-after)) ?u)
+ ;; User-defined spec -- find the spec name.
+ (when (= (setq spec (following-char)) ?u)
(forward-char 1)
- (when (and (eq (setq user-defined (char-after)) ?&)
- (looking-at "&\\([^;]+\\);"))
- (setq user-defined (match-string 1))
- (goto-char (match-end 1))))
- ;; extended spec
- ((and (eq spec ?&) (looking-at "&\\([^;]+\\);"))
- (setq extended-spec (intern (match-string 1)))
- (goto-char (match-end 1))))
+ (setq user-defined (following-char)))
(forward-char 1)
(delete-region spec-beg (point))
(user-defined
(setq elem
(list
- (list (intern (format
- (if (stringp user-defined)
- "gnus-user-format-function-%s"
- "gnus-user-format-function-%c")
- user-defined))
+ (list (intern (format "gnus-user-format-function-%c"
+ user-defined))
'gnus-tmp-header)
?s)))
;; Find the specification from `spec-alist'.
- ((setq elem (cdr (assq (or extended-spec spec) spec-alist))))
- ;; We used to use "%l" for displaying the grouplens score.
- ((eq spec ?l)
- (setq elem '("" ?s)))
+ ((setq elem (cdr (assq spec spec-alist))))
(t
(setq elem '("*" ?s))))
(setq elem-type (cadr elem))
;; Insert the new format elements.
- (when (and pad-width
- (not (and (featurep 'xemacs)
- gnus-use-correct-string-widths)))
- (insert (number-to-string pad-width)))
+ (and pad-width (not xemacs-mule-p)
+ (insert (number-to-string pad-width)))
;; Create the form to be evaled.
(if (or max-width cut-width ignore-value
- (and (featurep 'xemacs)
- gnus-use-correct-string-widths))
+ (and pad-width xemacs-mule-p))
(progn
(insert ?s)
(let ((el (car elem)))
(setq el (gnus-tilde-cut-form el cut-width)))
(when max-width
(setq el (gnus-tilde-max-form el max-width)))
- (when pad-width
- (setq el (gnus-pad-form el pad-width)))
+ (and pad-width xemacs-mule-p
+ (setq el (gnus-tilde-pad-form el pad-width)))
(push el flist)))
(insert elem-type)
(push (car elem) flist))))
- (setq fstring (buffer-substring-no-properties (point-min) (point-max))))
+ (setq fstring (buffer-string)))
;; Do some postprocessing to increase efficiency.
(setq
result
(cond
- ;; Emptiness.
+ ;; Emptyness.
((string= fstring "")
nil)
;; Not a format string.
(list (car flist)))
;; A single number.
((string= fstring "%d")
- (setq dontinsert t)
+ (setq dontinsert)
(if insert
(list `(princ ,(car flist)))
(list `(int-to-string ,(car flist)))))
;; A single string spec in the end of the spec.
((string-match "\\`\\([^%]+\\)%[sc]\\'" fstring)
(list (match-string 1 fstring) (car flist)))
- ;; Only string (and %) specs (XEmacs only!)
- ((and (featurep 'xemacs)
- gnus-make-format-preserve-properties
- (string-match
- "\\`\\([^%]*\\(%%\\|%-?\\([1-9][0-9]*\\)?s\\)\\)*[^%]*\\'"
- fstring))
- (list (cons 'gnus-xmas-format (cons fstring (nreverse flist)))))
;; A more complex spec.
(t
(list (cons 'format (cons fstring (nreverse flist)))))))
(while entries
(setq entry (pop entries))
- (if (memq (car entry) '(gnus-version version))
+ (if (eq (car entry) 'version)
(setq gnus-format-specs (delq entry gnus-format-specs))
(let ((form (caddr entry)))
(when (and (listp form)
(not (eq 'byte-code (car form)))
;; Under XEmacs, it's (funcall #<compiled-function ...>)
(not (and (eq 'funcall (car form))
- (byte-code-function-p (cadr form)))))
- (defalias 'gnus-tmp-func `(lambda () ,form))
+ (compiled-function-p (cadr form)))))
+ (fset 'gnus-tmp-func `(lambda () ,form))
(byte-compile 'gnus-tmp-func)
(setcar (cddr entry) (gnus-byte-code 'gnus-tmp-func))))))
(symbol-value (intern (format "gnus-%s-line-format" type)))
(symbol-value (intern (format "gnus-%s-line-format-alist" type)))
insertable)))
+
(provide 'gnus-spec)
-;; Local Variables:
-;; coding: iso-8859-1
-;; End:
-
-;;; arch-tag: a4328fa1-1f84-4b09-97ad-4b5767cfd50f
;;; gnus-spec.el ends here
projects / elisp / gnus.git- / blobdiff