-;;; gnus-spec.el --- format spec functions for Gnus -*- coding: iso-latin-1 -*-
-;; Copyright (C) 1996, 1997, 1998, 1999, 2000
+;;; gnus-spec.el --- format spec functions for Gnus
+;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002
;; Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
(require 'gnus)
-(defcustom gnus-use-correct-string-widths t
+(defcustom gnus-use-correct-string-widths (featurep 'xemacs)
"*If non-nil, use correct functions for dealing with wide characters."
: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."
+ :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
- 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)
+ (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))
(point))
gnus-mouse-face-prop gnus-mouse-face)
(insert " " gnus-tmp-subject-or-nil "\n"))
(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,23n%]%) %s\n"
+ (summary "%U%R%z%I%(%[%4L: %-23,23f%]%) %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)
;; 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)
- (cdr (assq 'gnus-version gnus-format-specs))))
+ (gnus-continuum-version gnus-newsrc-file-version)))
(not (equal emacs-version
(cdr (assq 'version gnus-format-specs)))))
(setq gnus-format-specs nil))
(defun gnus-balloon-face-function (form type)
`(gnus-put-text-property
(point) (progn ,@form (point))
- 'balloon-help
+ ,(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 (make-string (max (- ,column (current-column)) 0) ? ))
- `(progn
- (if (> (current-column) ,(abs column))
- (delete-region (point)
- (- (point) (- (current-column) ,(abs column))))
- (insert (make-string (max (- ,(abs column) (current-column)) 0)
- ? ))))))
+ (let ((column (abs column)))
+ (if gnus-use-correct-string-widths
+ `(progn
+ (if (> (current-column) ,column)
+ (while (progn
+ (delete-backward-char 1)
+ (> (current-column) ,column))))
+ (insert (make-string (max (- ,column (current-column)) 0) ? )))
+ `(progn
+ (if (> (current-column) ,column)
+ (delete-region (point)
+ (- (point) (- (current-column) ,column)))
+ (insert (make-string (max (- ,column (current-column)) 0)
+ ? ))))))))
(defun gnus-correct-length (string)
"Return the correct width of STRING."
(wseek 0)
(seek 0)
(length (length string))
- (string (concat string "\0")))
+ (string (concat string "\0")))
;; Find the start position.
(while (and (< seek length)
(< wseek start))
(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 (if gnus-use-correct-string-widths
- 'gnus-correct-length
- 'length))
- (substring-fun (if gnus-use-correct-string-widths
- 'gnus-correct-substring
- 'substring)))
+ (length-fun (gnus-string-width-function))
+ (substring-fun (gnus-substring-function)))
(if (symbolp el)
`(if (> (,length-fun ,el) ,max)
,(if (< max-width 0)
(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 (if gnus-use-correct-string-widths
- 'gnus-correct-length
- 'length))
- (substring-fun (if gnus-use-correct-string-widths
- 'gnus-correct-substring
- 'substring)))
+ (length-fun (gnus-string-width-function))
+ (substring-fun (gnus-substring-function)))
(if (symbolp el)
`(if (> (,length-fun ,el) ,cut)
,(if (< cut-width 0)
(if (equal val ,ignore-value)
"" val))))
-(defun gnus-correct-pad-form (el pad-width)
+(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)))
+ (side (< 0 pad-width))
+ (length-fun (gnus-string-width-function)))
(if (symbolp el)
- `(let ((need (- ,pad (gnus-correct-length ,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 (gnus-correct-length ,el))))
+ (need (- ,pad (,length-fun val))))
(if (> need 0)
(concat ,(when side '(make-string need ?\ ))
- ,el
+ val
,(when (not side) '(make-string need ?\ )))
- ,el)))))
+ val)))))
(defun gnus-parse-format (format spec-alist &optional insert)
;; This function parses the FORMAT string with the help of the
;; them will have the balloon-help text property.
(let ((case-fold-search nil))
(if (string-match
- "\\`\\(.*\\)%[0-9]?[{(«]\\(.*\\)%[0-9]?[»})]\\(.*\n?\\)\\'"
- format)
- (gnus-parse-complex-format format spec-alist)
+ "\\`\\(.*\\)%[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))))
(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 "(\"")
- ;; 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]+\\)?C" nil t)
- (replace-match "\"(point)\"" t 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 the first element is '(point), we just remove it.
- (when (equal (car form) '(point))
- (pop form))
- (cons 'progn (gnus-complex-form-to-spec form 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)))))))
(defun gnus-complex-form-to-spec (form spec-alist)
(delq nil
((stringp sform)
(gnus-parse-simple-format sform spec-alist t))
((eq (car sform) 'point)
- `(gnus-put-text-property (1- (point)) (point) 'gnus-position t))
+ '(setq gnus-position (point)))
((eq (car sform) 'tab)
(gnus-spec-tab (cadr sform)))
(t
(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-string 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
t)
(t
nil)))
- (cond
+ (cond
;; User-defined spec -- find the spec name.
((eq (setq spec (char-after)) ?u)
(forward-char 1)
- (setq user-defined (char-after)))
+ (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)))
(user-defined
(setq elem
(list
- (list (intern (format "gnus-user-format-function-%c"
- user-defined))
+ (list (intern (format
+ (if (stringp user-defined)
+ "gnus-user-format-function-%s"
+ "gnus-user-format-function-%c")
+ user-defined))
'gnus-tmp-header)
?s)))
;; Find the specification from `spec-alist'.
(when max-width
(setq el (gnus-tilde-max-form el max-width)))
(when pad-width
- (setq el (gnus-correct-pad-form el pad-width)))
+ (setq el (gnus-pad-form el pad-width)))
(push el flist)))
(insert elem-type)
(push (car elem) flist))))
- (setq fstring (buffer-string)))
+ (setq fstring (buffer-substring-no-properties (point-min) (point-max))))
;; Do some postprocessing to increase efficiency.
(setq
;; 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)))))))
projects / gnus / blobdiff