X-Git-Url: http://cgit.sxemacs.org/?p=gnus;a=blobdiff_plain;f=lisp%2Fgnus-spec.el;h=e1879202ef354210b70299f7f6eecb9496125448;hp=73b37a9dc551c42f51dee04973a5ae4161da8ded;hb=789c31bee0f2558e907a9d174afae38fc44092d6;hpb=44a3de087b1d9a81a4b8bb2b3dd77be20b36b6cf diff --git a/lisp/gnus-spec.el b/lisp/gnus-spec.el index 73b37a9dc..e1879202e 100644 --- a/lisp/gnus-spec.el +++ b/lisp/gnus-spec.el @@ -1,37 +1,47 @@ -;;; gnus-spec.el --- format spec functions for Gnus -*- coding: iso-latin-1 -*- -;; Copyright (C) 1996, 1997, 1998, 1999, 2000 -;; Free Software Foundation, Inc. +;;; gnus-spec.el --- format spec functions for Gnus + +;; Copyright (C) 1996-2012 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; Keywords: news ;; This file is part of GNU Emacs. -;; GNU Emacs is free software; you can redistribute it and/or modify +;; GNU Emacs is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;; along with GNU Emacs. If not, see . ;;; Commentary: ;;; Code: +;; For Emacs <22.2 and XEmacs. +(eval-and-compile + (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) (eval-when-compile (require 'cl)) +(defvar gnus-newsrc-file-version) (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." + :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 Emacs does this anyway." + :version "22.1" :group 'gnus-format :type 'boolean) @@ -42,7 +52,7 @@ (defvar gnus-group-indentation "") ;; Format specs. The chunks below are the machine-generated forms -;; that are to be evaled as the result of the default format strings. +;; that are to be evalled as the result of the default format strings. ;; We write them in here to get them byte-compiled. That way the ;; default actions will be quite fast, while still retaining the full ;; flexibility of the user-defined format specs. @@ -74,6 +84,22 @@ (defvar gnus-tmp-article-number) (defvar gnus-mouse-face) (defvar gnus-mouse-face-prop) +(defvar gnus-tmp-header) +(defvar gnus-tmp-from) + +(declare-function gnus-summary-from-or-to-or-newsgroups "gnus-sum" + (header gnus-tmp-from)) + +(defmacro gnus-lrm-string-p (string) + (if (fboundp 'bidi-string-mark-left-to-right) + ;; LRM, RLM, PDF characters as integers to avoid breaking Emacs + ;; 23. + `(memq (aref ,string (1- (length ,string))) '(8206 8207 8236)) + nil)) + +(defvar gnus-lrm-string (if (ignore-errors (string 8206)) + (propertize (string 8206) 'invisible t) + "")) (defun gnus-summary-line-format-spec () (insert gnus-tmp-unread gnus-tmp-replied @@ -82,13 +108,17 @@ (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) + (if (gnus-lrm-string-p val) + (concat (substring val 0 23) gnus-lrm-string) + (substring val 0 23)) + val)) + gnus-tmp-closing-bracket)) (point)) gnus-mouse-face-prop gnus-mouse-face) (insert " " gnus-tmp-subject-or-nil "\n")) @@ -126,13 +156,15 @@ (defvar gnus-format-specs `((version . ,emacs-version) (gnus-version . ,(gnus-continuum-version)) - (group "%M\%S\%p\%P\%5y: %(%g%)%l\n" ,gnus-group-line-format-spec) + (group "%M\%S\%p\%P\%5y: %(%g%)\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) @@ -168,27 +200,36 @@ (pop-to-buffer "*Gnus Format*") (erase-buffer) (lisp-interaction-mode) - (insert (pp-to-string spec)))) + (insert (gnus-pp-to-string spec)))) (defun gnus-update-format-specifications (&optional force &rest types) - "Update all (necessary) format specifications." + "Update all (necessary) format specifications. +Return a list of updated types." ;; 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)) + ;; 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) + (let (new-format entry type val updated) (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.) (save-excursion - (let ((buffer (intern (format "gnus-%s-buffer" type))) - val) + (let ((buffer (intern (format "gnus-%s-buffer" type)))) (when (and (boundp buffer) (setq val (symbol-value buffer)) (gnus-buffer-exists-p val)) @@ -218,16 +259,37 @@ (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))))) + (set (intern (format "gnus-%s-line-format-spec" type)) val) + (push type updated)))) - (unless (assq 'version gnus-format-specs) - (push (cons 'version emacs-version) gnus-format-specs))) + (unless (assq 'version gnus-format-specs) + (push (cons 'version emacs-version) gnus-format-specs)) + updated)) -(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) +(defcustom gnus-mouse-face-0 'highlight + "The \"%(hello%)\" face." + :group 'gnus-format + :type 'face) + +(defcustom gnus-mouse-face-1 'highlight + "The \"%1(hello%)\" face." + :group 'gnus-format + :type 'face) + +(defcustom gnus-mouse-face-2 'highlight + "The \"%2(hello%)\" face." + :group 'gnus-format + :type 'face) + +(defcustom gnus-mouse-face-3 'highlight + "The \"%3(hello%)\" face." + :group 'gnus-format + :type 'face) + +(defcustom gnus-mouse-face-4 'highlight + "The \"%4(hello%)\" face." + :group 'gnus-format + :type 'face) (defun gnus-mouse-face-function (form type) `(gnus-put-text-property @@ -237,11 +299,30 @@ '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) +(defcustom gnus-face-0 'bold + "The \"%{hello%}\" face." + :group 'gnus-format + :type 'face) + +(defcustom gnus-face-1 'italic + "The \"%1{hello%}\" face." + :group 'gnus-format + :type 'face) + +(defcustom gnus-face-2 'bold-italic + "The \"%2{hello%}\" face." + :group 'gnus-format + :type 'face) + +(defcustom gnus-face-3 'bold + "The \"%3{hello%}\" face." + :group 'gnus-format + :type 'face) + +(defcustom gnus-face-4 'bold + "The \"%4{hello%}\" face." + :group 'gnus-format + :type 'face) (defun gnus-face-face-function (form type) `(gnus-add-text-properties @@ -251,24 +332,26 @@ (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) - ? )))))) + `(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 (gnus-char-width char))) string) - length)) + (apply #'+ (mapcar #'char-width string))) (defun gnus-correct-substring (string start &optional end) (let ((wstart 0) @@ -276,53 +359,67 @@ (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)) - (incf wseek (gnus-char-width (aref string seek))) + (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 (gnus-char-width (aref string seek))) + (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 (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) `(,substring-fun ,el (- (,length-fun ,el) ,max)) - `(,substring-fun ,el 0 ,max)) + `(if (gnus-lrm-string-p ,el) + (concat (,substring-fun ,el 0 ,max) ,gnus-lrm-string) + (,substring-fun ,el 0 ,max))) ,el) `(let ((val (eval ,el))) (if (> (,length-fun val) ,max) ,(if (< max-width 0) `(,substring-fun val (- (,length-fun val) ,max)) - `(,substring-fun val 0 ,max)) + `(if (gnus-lrm-string-p val) + (concat (,substring-fun val 0 ,max) ,gnus-lrm-string) + (,substring-fun 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 (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) @@ -345,26 +442,27 @@ (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 @@ -375,54 +473,60 @@ characters when given a pad value." ;; 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 @@ -432,7 +536,7 @@ characters when given a pad value." ((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 @@ -441,6 +545,41 @@ characters when given a pad value." (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-number (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 @@ -502,7 +641,7 @@ characters when given a pad value." t) (t nil))) - (cond + (cond ;; User-defined spec -- find the spec name. ((eq (setq spec (char-after)) ?u) (forward-char 1) @@ -531,7 +670,7 @@ characters when given a pad value." (user-defined (setq elem (list - (list (intern (format + (list (intern (format (if (stringp user-defined) "gnus-user-format-function-%s" "gnus-user-format-function-%c") @@ -540,6 +679,9 @@ characters when given a pad value." ?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))) (t (setq elem '("*" ?s)))) (setq elem-type (cadr elem)) @@ -548,7 +690,7 @@ characters when given a pad value." (not (and (featurep 'xemacs) gnus-use-correct-string-widths))) (insert (number-to-string pad-width))) - ;; Create the form to be evaled. + ;; Create the form to be evalled. (if (or max-width cut-width ignore-value (and (featurep 'xemacs) gnus-use-correct-string-widths)) @@ -566,11 +708,11 @@ characters when given a pad value." (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 @@ -590,9 +732,9 @@ characters when given a pad value." (list (car flist))) ;; A single number. ((string= fstring "%d") - (setq dontinsert) + (setq dontinsert t) (if insert - (list `(princ ,(car flist))) + `(insert (int-to-string ,(car flist))) (list `(int-to-string ,(car flist))))) ;; Just lots of chars and strings. ((string-match "\\`\\(%[cs]\\)+\\'" fstring) @@ -606,6 +748,13 @@ characters when given a pad value." ;; 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)))))))