X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fgnus-spec.el;h=ff2802ed04b6e8f535e163fba7cc2db7dd8a5437;hb=4c4ee2ed7b5f6c14942c73a92ff0a761b78fe2dd;hp=d910ae6507a0893375db8a2ef60f3944fa314e08;hpb=1e91a4b4459e842a8e3020369afa83bc547d5341;p=elisp%2Fgnus.git- diff --git a/lisp/gnus-spec.el b/lisp/gnus-spec.el index d910ae6..ff2802e 100644 --- a/lisp/gnus-spec.el +++ b/lisp/gnus-spec.el @@ -1,7 +1,9 @@ ;;; gnus-spec.el --- format spec functions for Gnus -;; Copyright (C) 1996,97,98 Free Software Foundation, Inc. +;; Copyright (C) 1996, 1997, 1998, 1999, 2000 +;; Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen +;; Katsumi Yamaoka ;; Keywords: news ;; This file is part of GNU Emacs. @@ -27,6 +29,7 @@ (eval-when-compile (require 'cl)) +(require 'alist) (require 'gnus) ;;; Internal variables. @@ -118,14 +121,19 @@ (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)) + `((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-format-specs-compiled nil + "Alist of compiled format specs. Each element should be the form: +\(TYPE (FORMAT-STRING-1 . COMPILED-FUNCTION-1) + : + (FORMAT-STRING-n . COMPILED-FUNCTION-n)).") + (defvar gnus-article-mode-line-format-spec nil) (defvar gnus-summary-mode-line-format-spec nil) (defvar gnus-group-mode-line-format-spec nil) @@ -146,75 +154,101 @@ (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) + (value (symbol-value (intern var))) + (spec (set + (intern (format "%s-spec" var)) + (gnus-parse-format + value (symbol-value (intern (format "%s-alist" var))) + (not (string-match "mode" var))))) + (entry (assq type gnus-format-specs))) + (if entry + (let ((elem (assoc value entry))) + (if elem + (setcdr elem spec) + (setcdr entry (cons (cons value elem) (cdr entry))))) + (push (list type (cons value spec)) gnus-format-specs)) + (gnus-product-variable-touch 'gnus-format-specs) (pop-to-buffer "*Gnus Format*") (erase-buffer) (lisp-interaction-mode) (insert (pp-to-string spec)))) +(put 'gnus-search-or-regist-spec 'lisp-indent-function 1) +(defmacro gnus-search-or-regist-spec (mspec &rest body) + (let ((specs (nth 0 mspec)) (type (nth 1 mspec)) (format (nth 2 mspec)) + (spec (nth 3 mspec)) (entry (nth 4 mspec)) (elem (nth 5 mspec))) + `(let* ((,entry (assq ,type ,specs)) + (,elem (assoc ,format (cdr ,entry)))) + (or (cdr ,elem) + (when (progn ,@body) + (if ,entry + (if ,elem + (setcdr ,elem ,spec) + (setcdr ,entry (cons (cons ,format ,spec) (cdr ,entry)))) + (push (list ,type (cons ,format ,spec)) ,specs)) + (gnus-product-variable-touch (quote ,specs))) + ,spec)))) + +(defun gnus-update-format-specification-1 (type format val) + (set (intern (format "gnus-%s-line-format-spec" type)) + (gnus-search-or-regist-spec (gnus-format-specs-compiled + type format val entry elem) + (when (and gnus-compile-user-specs val) + (setq val (prog1 + (progn + (fset 'gnus-tmp-func `(lambda () ,val)) + (require 'bytecomp) + (let (byte-compile-warnings) + (byte-compile 'gnus-tmp-func)) + (gnus-byte-code 'gnus-tmp-func)) + (when (get-buffer "*Compile-Log*") + (bury-buffer "*Compile-Log*")) + (when (get-buffer "*Compile-Log-Show*") + (bury-buffer "*Compile-Log-Show*")))))))) + (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 - (cdr (assq 'version gnus-format-specs))))) - (setq gnus-format-specs nil)) + (when force + (message "%s" "Force update format specs.") + (setq gnus-format-specs nil + gnus-format-specs-compiled nil) + (gnus-product-variable-touch 'gnus-format-specs + 'gnus-format-specs-compiled)) ;; Go through all the formats and see whether they need updating. - (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.) - (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)) - ;; 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))))) - - (unless (assq 'version gnus-format-specs) - (push (cons 'version emacs-version) gnus-format-specs))) + (let (type val) + (save-excursion + (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.) + (let* ((new-format + (let ((buffer (intern (format "gnus-%s-buffer" type)))) + (when (and (boundp buffer) + (setq val (symbol-value buffer)) + (gnus-buffer-exists-p val)) + (set-buffer val)) + (symbol-value + (intern (format "gnus-%s-line-format" type)))))) + (or (gnus-update-format-specification-1 type new-format nil) + ;; This is a new format. + (gnus-update-format-specification-1 + type new-format + (gnus-search-or-regist-spec (gnus-format-specs + type new-format val entry elem) + (setq val (if (stringp 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)))) + ;; This is a function call or something. + new-format)))))))))) (defvar gnus-mouse-face-0 'highlight) (defvar gnus-mouse-face-1 'highlight) @@ -241,6 +275,19 @@ (point) (progn ,@form (point)) '(gnus-face t face ,(symbol-value (intern (format "gnus-face-%d" type)))))) +;;; Avoid byte-compile warning. +(defun gnus-tilde-pad-form (el pad-width) + "Dummy function except for XEmacs-mule. It will be redefined +by `gnus-xmas-redefine'." + (let ((val (if (symbolp el) (eval el) el))) + (` (, val)))) + +(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))) @@ -287,8 +334,10 @@ ;; 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. @@ -303,13 +352,17 @@ (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") + (= delim ?\{) + (= delim ?\«)) + (replace-match (concat "\"(" + (cond ((= delim ?\() "mouse") + ((= delim ?\{) "face") + (t "balloon")) " " number " \"")) (replace-match "\")\"")))) (goto-char (point-max)) @@ -333,7 +386,8 @@ ;; 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 ((xemacs-mule-p (and (featurep 'xemacs) (featurep 'mule))) + 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) @@ -341,7 +395,7 @@ (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 @@ -390,9 +444,9 @@ (t nil))) ;; User-defined spec -- find the spec name. - (when (= (setq spec (following-char)) ?u) + (when (eq (setq spec (char-after)) ?u) (forward-char 1) - (setq user-defined (following-char))) + (setq user-defined (char-after))) (forward-char 1) (delete-region spec-beg (point)) @@ -420,10 +474,11 @@ (setq elem '("*" ?s)))) (setq elem-type (cadr elem)) ;; Insert the new format elements. - (when pad-width - (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) + (if (or max-width cut-width ignore-value + (and pad-width xemacs-mule-p)) (progn (insert ?s) (let ((el (car elem))) @@ -437,6 +492,8 @@ (setq el (gnus-tilde-cut-form el cut-width))) (when max-width (setq el (gnus-tilde-max-form el max-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)))) @@ -505,13 +562,14 @@ If PROPS, insert the result." (require 'bytecomp) (let ((entries gnus-format-specs) (byte-compile-warnings '(unresolved callargs redefine)) - entry gnus-tmp-func) + entry type compiled-function) (save-excursion (gnus-message 7 "Compiling format specs...") (while entries - (setq entry (pop entries)) - (if (eq (car entry) 'version) + (setq entry (pop entries) + type (car entry)) + (if (memq type '(version gnus-version)) (setq gnus-format-specs (delq entry gnus-format-specs)) (let ((form (caddr entry))) (when (and (listp form) @@ -519,14 +577,19 @@ If PROPS, insert the result." (not (eq 'byte-code (car form))) ;; Under XEmacs, it's (funcall #) (not (and (eq 'funcall (car form)) - (compiled-function-p (cadr form))))) - (fset 'gnus-tmp-func `(lambda () ,form)) + (byte-code-function-p (cadr form))))) + (defalias 'gnus-tmp-func `(lambda () ,form)) (byte-compile 'gnus-tmp-func) - (setcar (cddr entry) (gnus-byte-code 'gnus-tmp-func)))))) + (setq compiled-function (gnus-byte-code 'gnus-tmp-func)) + (set (intern (format "gnus-%s-line-format-spec" type)) + compiled-function) + (let ((elem (cdr (assq type gnus-format-specs-compiled)))) + (if elem + (set-alist 'elem (cadr entry) compiled-function) + (setq elem (list (cadr entry) compiled-function))) + (set-alist 'gnus-format-specs-compiled type elem)))))) (push (cons 'version emacs-version) gnus-format-specs) - ;; Mark the .newsrc.eld file as "dirty". - (gnus-dribble-touch) (gnus-message 7 "Compiling user specs...done")))) (defun gnus-set-format (type &optional insertable) @@ -535,8 +598,13 @@ If PROPS, insert the result." (symbol-value (intern (format "gnus-%s-line-format" type))) (symbol-value (intern (format "gnus-%s-line-format-alist" type))) insertable))) - + +(gnus-ems-redefine) (provide 'gnus-spec) +;; Local Variables: +;; coding: iso-8859-1 +;; End: + ;;; gnus-spec.el ends here