;;; gnus-spec.el --- format spec functions for Gnus
-;; Copyright (C) 1996 Free Software Foundation, Inc.
+;; Copyright (C) 1996,97,98,99 Free Software Foundation, Inc.
-;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
+;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: news
;; This file is part of GNU Emacs.
;;; Code:
-(require 'gnus-load)
+(eval-when-compile (require 'cl))
+
(require 'gnus)
;;; Internal variables.
(defvar gnus-group-line-format-spec
(gnus-byte-code 'gnus-group-line-format-spec))
-(defvar gnus-format-specs
+(defvar gnus-format-specs
`((version . ,emacs-version)
(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: %-20,20n%]%) %s\n"
+ (summary "%U\%R\%z\%I\%(%[%4L: %-20,20n%]%) %s\n"
,gnus-summary-line-format-spec))
"Alist of format specs.")
(defun gnus-update-format-specifications (&optional force &rest types)
"Update all (necessary) format specifications."
;; Make the indentation array.
-
;; See whether all the stored info needs to be flushed.
(when (or force
(not (equal emacs-version
val)
(when (and (boundp buffer)
(setq val (symbol-value buffer))
- (get-buffer val)
- (buffer-name (get-buffer val)))
- (set-buffer (get-buffer val)))
+ (gnus-buffer-exists-p val))
+ (set-buffer val))
(setq new-format (symbol-value
- (intern (format "gnus-%s-line-format" type))))))
- (setq entry (cdr (assq type gnus-format-specs)))
- (if (and entry
- (equal (car entry) new-format))
- ;; Use the old format.
- (set (intern (format "gnus-%s-line-format-spec" type))
- (cadr entry))
- ;; This is a new format.
- (setq val
- (if (not (stringp new-format))
- ;; This is a function call or something.
- new-format
- ;; This is a "real" format.
- (gnus-parse-format
- new-format
- (symbol-value
- (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
- (progn
- (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))))
+ (intern (format "gnus-%s-line-format" type)))))
+ (setq entry (cdr (assq type gnus-format-specs)))
+ (if (and (car entry)
+ (equal (car entry) new-format))
+ ;; Use the old format.
+ (set (intern (format "gnus-%s-line-format-spec" type))
+ (cadr entry))
+ ;; This is a new format.
+ (setq val
+ (if (not (stringp new-format))
+ ;; This is a function call or something.
+ new-format
+ ;; This is a "real" format.
+ (gnus-parse-format
+ new-format
+ (symbol-value
+ (intern (format "gnus-%s-line-format-alist" type)))
+ (not (string-match "mode$" (symbol-name type))))))
+ ;; Enter the new format spec into the list.
+ (if entry
+ (progn
+ (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)))))
(unless (assq 'version gnus-format-specs)
(push (cons 'version emacs-version) gnus-format-specs)))
(defvar gnus-face-4 'bold)
(defun gnus-face-face-function (form type)
- `(gnus-put-text-property
+ `(gnus-add-text-properties
(point) (progn ,@form (point))
- 'face ',(symbol-value (intern (format "gnus-face-%d" type)))))
+ '(gnus-face t face ,(symbol-value (intern (format "gnus-face-%d" type))))))
-(defun gnus-max-width-function (el max-width)
- (or (numberp max-width) (signal 'wrong-type-argument '(numberp max-width)))
+(defun gnus-balloon-face-function (form type)
+ `(gnus-put-text-property
+ (point) (progn ,@form (point))
+ 'balloon-help
+ ,(intern (format "gnus-balloon-face-%d" type))))
+
+(defun gnus-tilde-max-form (el max-width)
+ "Return a form that limits EL to MAX-WIDTH."
+ (let ((max (abs max-width)))
+ (if (symbolp el)
+ `(if (> (length ,el) ,max)
+ ,(if (< max-width 0)
+ `(substring ,el (- (length el) ,max))
+ `(substring ,el 0 ,max))
+ ,el)
+ `(let ((val (eval ,el)))
+ (if (> (length val) ,max)
+ ,(if (< max-width 0)
+ `(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)))
+ (if (symbolp el)
+ `(if (> (length ,el) ,cut)
+ ,(if (< cut-width 0)
+ `(substring ,el 0 (- (length el) ,cut))
+ `(substring ,el ,cut))
+ ,el)
+ `(let ((val (eval ,el)))
+ (if (> (length val) ,cut)
+ ,(if (< cut-width 0)
+ `(substring val 0 (- (length val) ,cut))
+ `(substring val ,cut))
+ val)))))
+
+(defun gnus-tilde-ignore-form (el ignore-value)
+ "Return a form that is blank when EL is IGNORE-VALUE."
(if (symbolp el)
- `(if (> (length ,el) ,max-width)
- (substring ,el 0 ,max-width)
- ,el)
+ `(if (equal ,el ,ignore-value)
+ "" ,el)
`(let ((val (eval ,el)))
- (if (numberp val)
- (setq val (int-to-string val)))
- (if (> (length val) ,max-width)
- (substring val 0 ,max-width)
- val))))
+ (if (equal val ,ignore-value)
+ "" 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.
(if (string-match
- "\\`\\(.*\\)%[0-9]?[{(]\\(.*\\)%[0-9]?[})]\\(.*\n?\\)\\'"
+ "\\`\\(.*\\)%[0-9]?[{(«]\\(.*\\)%[0-9]?[»})]\\(.*\n?\\)\\'"
format)
(gnus-parse-complex-format format spec-alist)
;; This is a simple format.
(replace-match "\\\"" nil t))
(goto-char (point-min))
(insert "(\"")
- (while (re-search-forward "%\\([0-9]+\\)?\\([{}()]\\)" nil t)
+ (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")
+ (if (or (= delim ?\()
+ (= delim ?\{)
+ (= delim ?\«))
+ (replace-match (concat "\"("
+ (cond ((= delim ?\() "mouse")
+ ((= delim ?\{) "face")
+ (t "balloon"))
" " number " \""))
(replace-match "\")\""))))
(goto-char (point-max))
;; SPEC-ALIST and returns a list that can be eval'ed to return a
;; string.
(let ((max-width 0)
- spec flist fstring newspec elem beg result dontinsert)
+ spec flist fstring elem result dontinsert user-defined
+ type value pad-width spec-beg cut-width ignore-value
+ tilde-form tilde elem-type)
(save-excursion
(gnus-set-work-buffer)
(insert format)
(goto-char (point-min))
- (while (re-search-forward "%[-0-9]*\\(,[0-9]+\\)?\\([^0-9]\\)\\(.\\)?"
- nil t)
- (if (= (setq spec (string-to-char (match-string 2))) ?%)
- (setq newspec "%"
- beg (1+ (match-beginning 0)))
- ;; First check if there are any specs that look anything like
- ;; "%12,12A", ie. with a "max width specification". These have
- ;; to be treated specially.
- (if (setq beg (match-beginning 1))
- (setq max-width
- (string-to-int
- (buffer-substring
- (1+ (match-beginning 1)) (match-end 1))))
- (setq max-width 0)
- (setq beg (match-beginning 2)))
- ;; Find the specification from `spec-alist'.
- (unless (setq elem (cdr (assq spec spec-alist)))
- (setq elem '("*" ?s)))
- ;; Treat user defined format specifiers specially.
- (when (eq (car elem) 'gnus-tmp-user-defined)
+ (while (re-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)
+ (setq spec-beg (1- (point)))
+
+ ;; Parse this spec fully.
+ (while
+ (cond
+ ((looking-at "\\([-.0-9]+\\)\\(,[-0-9]+\\)?")
+ (setq pad-width (string-to-number (match-string 1)))
+ (when (match-beginning 2)
+ (setq max-width (string-to-number (buffer-substring
+ (1+ (match-beginning 2))
+ (match-end 2)))))
+ (goto-char (match-end 0)))
+ ((looking-at "~")
+ (forward-char 1)
+ (setq tilde (read (current-buffer))
+ type (car tilde)
+ value (cadr tilde))
+ (cond
+ ((memq type '(pad pad-left))
+ (setq pad-width value))
+ ((eq type 'pad-right)
+ (setq pad-width (- value)))
+ ((memq type '(max-right max))
+ (setq max-width value))
+ ((eq type 'max-left)
+ (setq max-width (- value)))
+ ((memq type '(cut cut-left))
+ (setq cut-width value))
+ ((eq type 'cut-right)
+ (setq cut-width (- value)))
+ ((eq type 'ignore)
+ (setq ignore-value
+ (if (stringp value) value (format "%s" value))))
+ ((eq type 'form)
+ (setq tilde-form value))
+ (t
+ (error "Unknown tilde type: %s" tilde)))
+ t)
+ (t
+ nil)))
+ ;; User-defined spec -- find the spec name.
+ (when (eq (setq spec (char-after)) ?u)
+ (forward-char 1)
+ (setq user-defined (char-after)))
+ (forward-char 1)
+ (delete-region spec-beg (point))
+
+ ;; Now we have all the relevant data on this spec, so
+ ;; we start doing stuff.
+ (insert "%")
+ (if (eq spec ?%)
+ ;; "%%" just results in a "%".
+ (insert "%")
+ (cond
+ ;; Do tilde forms.
+ ((eq spec ?@)
+ (setq elem (list tilde-form ?s)))
+ ;; Treat user defined format specifiers specially.
+ (user-defined
(setq elem
(list
- (list (intern (concat "gnus-user-format-function-"
- (match-string 3)))
- 'gnus-tmp-header) ?s))
- (delete-region (match-beginning 3) (match-end 3)))
- (if (not (zerop max-width))
- (let ((el (car elem)))
- (cond ((= (cadr elem) ?c)
- (setq el (list 'char-to-string el)))
- ((= (cadr elem) ?d)
- (setq el (list 'int-to-string el))))
- (setq flist (cons (gnus-max-width-function el max-width)
- flist))
- (setq newspec ?s))
- (progn
- (setq flist (cons (car elem) flist))
- (setq newspec (cadr elem)))))
- ;; Remove the old specification (and possibly a ",12" string).
- (delete-region beg (match-end 2))
- ;; Insert the new specification.
- (goto-char beg)
- (insert newspec))
- (setq fstring (buffer-substring 1 (point-max))))
+ (list (intern (format "gnus-user-format-function-%c"
+ user-defined))
+ 'gnus-tmp-header)
+ ?s)))
+ ;; Find the specification from `spec-alist'.
+ ((setq elem (cdr (assq spec spec-alist))))
+ (t
+ (setq elem '("*" ?s))))
+ (setq elem-type (cadr elem))
+ ;; Insert the new format elements.
+ (when pad-width
+ (insert (number-to-string pad-width)))
+ ;; Create the form to be evaled.
+ (if (or max-width cut-width ignore-value)
+ (progn
+ (insert ?s)
+ (let ((el (car elem)))
+ (cond ((= (cadr elem) ?c)
+ (setq el (list 'char-to-string el)))
+ ((= (cadr elem) ?d)
+ (setq el (list 'int-to-string el))))
+ (when ignore-value
+ (setq el (gnus-tilde-ignore-form el ignore-value)))
+ (when cut-width
+ (setq el (gnus-tilde-cut-form el cut-width)))
+ (when max-width
+ (setq el (gnus-tilde-max-form el max-width)))
+ (push el flist)))
+ (insert elem-type)
+ (push (car elem) flist))))
+ (setq fstring (buffer-string)))
+
;; Do some postprocessing to increase efficiency.
(setq
result
(defun gnus-compile ()
"Byte-compile the user-defined format specs."
(interactive)
+ (require 'bytecomp)
(let ((entries gnus-format-specs)
+ (byte-compile-warnings '(unresolved callargs redefine))
entry gnus-tmp-func)
(save-excursion
(gnus-message 7 "Compiling format specs...")
(setq entry (pop entries))
(if (eq (car entry) 'version)
(setq gnus-format-specs (delq entry gnus-format-specs))
- (when (and (listp (caddr entry))
- (not (eq 'byte-code (caaddr entry))))
- (fset 'gnus-tmp-func
- `(lambda () ,(caddr entry)))
- (byte-compile 'gnus-tmp-func)
- (setcar (cddr entry) (gnus-byte-code 'gnus-tmp-func)))))
+ (let ((form (caddr entry)))
+ (when (and (listp form)
+ ;; Under GNU Emacs, it's (byte-code ...)
+ (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)))))
+ (fset 'gnus-tmp-func `(lambda () ,form))
+ (byte-compile 'gnus-tmp-func)
+ (setcar (cddr entry) (gnus-byte-code 'gnus-tmp-func))))))
(push (cons 'version emacs-version) gnus-format-specs)
;; Mark the .newsrc.eld file as "dirty".
- (gnus-dribble-enter " ")
+ (gnus-dribble-touch)
(gnus-message 7 "Compiling user specs...done"))))
+(defun gnus-set-format (type &optional insertable)
+ (set (intern (format "gnus-%s-line-format-spec" type))
+ (gnus-parse-format
+ (symbol-value (intern (format "gnus-%s-line-format" type)))
+ (symbol-value (intern (format "gnus-%s-line-format-alist" type)))
+ insertable)))
+
+
(provide 'gnus-spec)
;;; gnus-spec.el ends here