(eval-when-compile (require 'cl))
(require 'gnus)
(defvar gnus-summary-mark-positions nil)
(defvar gnus-group-mark-positions nil)
(defvar gnus-group-indentation "")
(defvar gnus-tmp-unread)
(defvar gnus-tmp-replied)
(defvar gnus-tmp-score-char)
(defvar gnus-tmp-indentation)
(defvar gnus-tmp-opening-bracket)
(defvar gnus-tmp-lines)
(defvar gnus-tmp-name)
(defvar gnus-tmp-closing-bracket)
(defvar gnus-tmp-subject-or-nil)
(defvar gnus-tmp-subject)
(defvar gnus-tmp-marked)
(defvar gnus-tmp-marked-mark)
(defvar gnus-tmp-subscribed)
(defvar gnus-tmp-process-marked)
(defvar gnus-tmp-number-of-unread)
(defvar gnus-tmp-group-name)
(defvar gnus-tmp-group)
(defvar gnus-tmp-article-number)
(defvar gnus-tmp-unread-and-unselected)
(defvar gnus-tmp-news-method)
(defvar gnus-tmp-news-server)
(defvar gnus-tmp-article-number)
(defvar gnus-mouse-face)
(defvar gnus-mouse-face-prop)
(defun gnus-summary-line-format-spec ()
(insert gnus-tmp-unread gnus-tmp-replied
gnus-tmp-score-char gnus-tmp-indentation)
(gnus-put-text-property
(point)
(progn
(insert
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-summary-line-format-spec
(gnus-byte-code 'gnus-summary-line-format-spec))
(defun gnus-summary-dummy-line-format-spec ()
(insert "* ")
(gnus-put-text-property
(point)
(progn
(insert ": :")
(point))
gnus-mouse-face-prop gnus-mouse-face)
(insert " " gnus-tmp-subject "\n"))
(defvar gnus-summary-dummy-line-format-spec
(gnus-byte-code 'gnus-summary-dummy-line-format-spec))
(defun gnus-group-line-format-spec ()
(insert gnus-tmp-marked-mark gnus-tmp-subscribed
gnus-tmp-process-marked
gnus-group-indentation
(format "%5s: " gnus-tmp-number-of-unread))
(gnus-put-text-property
(point)
(progn
(insert gnus-tmp-group "\n")
(1- (point)))
gnus-mouse-face-prop gnus-mouse-face))
(defvar gnus-group-line-format-spec
(gnus-byte-code 'gnus-group-line-format-spec))
(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"
,gnus-summary-line-format-spec))
"Alist of 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)
(defun gnus-update-format (var)
"Update the format specification near point."
(interactive
(list
(save-excursion
(eval-defun nil)
(re-search-forward "[ \t\n]" nil t)
(when (re-search-backward "\\(gnus-[-a-z]+-line-format\\)" nil t)
(match-string 1)))))
(let* ((type (intern (progn (string-match "gnus-\\([-a-z]+\\)-line" var)
(match-string 1 var))))
(entry (assq type gnus-format-specs))
value spec)
(when entry
(setq gnus-format-specs (delq entry gnus-format-specs)))
(set
(intern (format "%s-spec" var))
(gnus-parse-format (setq value (symbol-value (intern var)))
(symbol-value (intern (format "%s-alist" var)))
(not (string-match "mode" var))))
(setq spec (symbol-value (intern (format "%s-spec" var))))
(push (list type value spec) gnus-format-specs)
(pop-to-buffer "*Gnus Format*")
(erase-buffer)
(lisp-interaction-mode)
(insert (pp-to-string spec))))
(defun gnus-update-format-specifications (&optional force &rest types)
"Update all (necessary) format specifications."
(when (or force
(not (equal emacs-version
(cdr (assq 'version gnus-format-specs)))))
(setq gnus-format-specs nil))
(let (new-format entry type val)
(while (setq type (pop types))
(save-excursion
(let ((buffer (intern (format "gnus-%s-buffer" type)))
val)
(when (and (boundp buffer)
(setq val (symbol-value buffer))
(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 (car entry)
(equal (car entry) new-format))
(set (intern (format "gnus-%s-line-format-spec" type))
(cadr entry))
(setq val
(if (not (stringp new-format))
new-format
(gnus-parse-format
new-format
(symbol-value
(intern (format "gnus-%s-line-format-alist" type)))
(not (string-match "mode$" (symbol-name type))))))
(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-mouse-face-0 'highlight)
(defvar gnus-mouse-face-1 'highlight)
(defvar gnus-mouse-face-2 'highlight)
(defvar gnus-mouse-face-3 'highlight)
(defvar gnus-mouse-face-4 'highlight)
(defun gnus-mouse-face-function (form type)
`(gnus-put-text-property
(point) (progn ,@form (point))
gnus-mouse-face-prop
,(if (equal type 0)
'gnus-mouse-face
`(quote ,(symbol-value (intern (format "gnus-mouse-face-%d" type)))))))
(defvar gnus-face-0 'bold)
(defvar gnus-face-1 'italic)
(defvar gnus-face-2 'bold-italic)
(defvar gnus-face-3 'bold)
(defvar gnus-face-4 'bold)
(defun gnus-face-face-function (form type)
`(gnus-add-text-properties
(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))
'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 (equal ,el ,ignore-value)
"" ,el)
`(let ((val (eval ,el)))
(if (equal val ,ignore-value)
"" val))))
(defun gnus-parse-format (format spec-alist &optional insert)
(if (string-match
"\\`\\(.*\\)%[0-9]?[{(«]\\(.*\\)%[0-9]?[»})]\\(.*\n?\\)\\'"
format)
(gnus-parse-complex-format format spec-alist)
(gnus-parse-simple-format format spec-alist insert)))
(defun gnus-parse-complex-format (format 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 ?\{)
(= delim ?\«))
(replace-match (concat "\"("
(cond ((= delim ?\() "mouse")
((= delim ?\{) "face")
(t "balloon"))
" " 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)
(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))))
form)))
(defun gnus-parse-simple-format (format spec-alist &optional insert)
(let ((max-width 0)
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 "%" 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)))
(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)))
(when (eq (setq spec (char-after)) ?u)
(forward-char 1)
(setq user-defined (char-after)))
(forward-char 1)
(delete-region spec-beg (point))
(insert "%")
(if (eq spec ?%)
(insert "%")
(cond
((eq spec ?@)
(setq elem (list tilde-form ?s)))
(user-defined
(setq elem
(list
(list (intern (format "gnus-user-format-function-%c"
user-defined))
'gnus-tmp-header)
?s)))
((setq elem (cdr (assq spec spec-alist))))
(t
(setq elem '("*" ?s))))
(setq elem-type (cadr elem))
(when pad-width
(insert (number-to-string pad-width)))
(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)))
(setq
result
(cond
((string= fstring "")
nil)
((not (string-match "%" fstring))
(list fstring))
((string= fstring "%s")
(list (car flist)))
((string= fstring "%c")
(list (car flist)))
((string= fstring "%d")
(setq dontinsert)
(if insert
(list `(princ ,(car flist)))
(list `(int-to-string ,(car flist)))))
((string-match "\\`\\(%[cs]\\)+\\'" fstring)
(nreverse flist))
((string-match "\\`%[sc][^%]+\\'" fstring)
(list (car flist) (substring fstring 2)))
((string-match "\\`\\([^%]+\\)%[sc]\\([^%]+\\)\\'" fstring)
(list (match-string 1 fstring) (car flist) (match-string 2 fstring)))
((string-match "\\`\\([^%]+\\)%[sc]\\'" fstring)
(list (match-string 1 fstring) (car flist)))
(t
(list (cons 'format (cons fstring (nreverse flist)))))))
(if insert
(when result
(if dontinsert
result
(cons 'insert result)))
(cond ((stringp result)
result)
((consp result)
(cons 'concat result))
(t "")))))
(defun gnus-eval-format (format &optional alist props)
"Eval the format variable FORMAT, using ALIST.
If PROPS, insert the result."
(let ((form (gnus-parse-format format alist props)))
(if props
(gnus-add-text-properties (point) (progn (eval form) (point)) props)
(eval form))))
(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...")
(while entries
(setq entry (pop entries))
(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)))
(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)
(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)