X-Git-Url: https://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fgnus-cus.el;h=eb0dc51936a8d0f4a2f6236ec67f581d5f3c3946;hb=f4c1b0232c4f4eef20110b1022acad129c2e6a51;hp=a2db8c7a80352063549677ef7e6aa3d869120285;hpb=1f4573a946a26468a0cb340195c20f1f21545acd;p=gnus diff --git a/lisp/gnus-cus.el b/lisp/gnus-cus.el index a2db8c7a8..eb0dc5193 100644 --- a/lisp/gnus-cus.el +++ b/lisp/gnus-cus.el @@ -1,27 +1,25 @@ ;;; gnus-cus.el --- customization commands for Gnus ;; Copyright (C) 1996, 1999, 2000, 2001, 2002, 2003, 2004, -;; 2005 Free Software Foundation, Inc. +;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. ;; Author: Per Abrahamsen ;; 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., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301, USA. +;; along with GNU Emacs. If not, see . ;;; Commentary: @@ -36,14 +34,6 @@ ;;; Widgets: -(defvar gnus-custom-map - (let ((map (make-keymap))) - (set-keymap-parent map widget-keymap) - (suppress-keymap map) - (define-key map [mouse-1] 'widget-move-and-invoke) - map) - "Keymap for editing Gnus customization buffers.") - (defun gnus-custom-mode () "Major mode for editing Gnus customization buffers. @@ -59,7 +49,7 @@ if that value is non-nil." (kill-all-local-variables) (setq major-mode 'gnus-custom-mode mode-name "Gnus Customize") - (use-local-map gnus-custom-map) + (use-local-map widget-keymap) ;; Emacs 21 stuff: (when (and (facep 'custom-button-face) (facep 'custom-button-pressed-face)) @@ -235,8 +225,11 @@ See `gnus-emphasis-alist'.") (const signature-file) (const organization) (const address) + (const x-face-file) (const name) - (const body)) + (const body) + (symbol) + (string :tag "Header")) (string :format "%v")))) "post style. See `gnus-posting-styles'.")) @@ -487,7 +480,7 @@ form, but who cares?" (widget-create 'sexp :tag "Method" :value (gnus-info-method info)))) - (use-local-map gnus-custom-map) + (use-local-map widget-keymap) (widget-setup) (buffer-enable-undo) (goto-char (point-min)))) @@ -771,6 +764,67 @@ eh?"))) ,group)))) widget) +(define-widget 'gnus-score-extra 'group + "Edit score entries for extra headers." + :convert-widget 'gnus-score-extra-convert) + +(defun gnus-score-extra-convert (widget) + ;; Set args appropriately. + (let* ((tag (widget-get widget :tag)) + (item `(const :format "" :value ,(downcase tag))) + (match '(string :tag "Match")) + (score '(choice :tag "Score" + (const :tag "default" nil) + (integer :format "%v" + :hide-front-space t))) + (expire '(choice :tag "Expire" + (const :tag "off" nil) + (integer :format "%v" + :hide-front-space t))) + (type '(choice :tag "Type" + :value s + ;; I should really create a forgiving :match + ;; function for each type below, that only + ;; looked at the first letter. + (const :tag "Regexp" r) + (const :tag "Regexp (fixed case)" R) + (const :tag "Substring" s) + (const :tag "Substring (fixed case)" S) + (const :tag "Exact" e) + (const :tag "Exact (fixed case)" E) + (const :tag "Word" w) + (const :tag "Word (fixed case)" W) + (const :tag "default" nil))) + (header (if gnus-extra-headers + (let (name) + `(choice :tag "Header" + ,@(mapcar (lambda (h) + (setq name (symbol-name h)) + (list 'const :tag name name)) + gnus-extra-headers) + (string :tag "Other" :format "%v"))) + '(string :tag "Header"))) + (group `(group ,match ,score ,expire ,type ,header)) + (doc (concat (or (widget-get widget :doc) + (concat "Change score based on the " tag + " header.\n"))))) + (widget-put + widget :args + `(,item + (repeat :inline t + :indent 0 + :tag ,tag + :doc ,doc + :format "%t:\n%h%v%i\n\n" + (choice :format "%v" + :value ("" nil nil s + ,(if gnus-extra-headers + (symbol-name (car gnus-extra-headers)) + "")) + ,group + sexp))))) + widget) + (defvar gnus-custom-scores) (defvar gnus-custom-score-alist) @@ -827,7 +881,7 @@ if you do all your changes will be lost. ") (gnus-score-string :tag "Subject") (gnus-score-string :tag "References") (gnus-score-string :tag "Xref") - (gnus-score-string :tag "Extra") + (gnus-score-extra :tag "Extra") (gnus-score-string :tag "Message-ID") (gnus-score-integer :tag "Lines") (gnus-score-integer :tag "Chars") @@ -881,7 +935,7 @@ articles in the thread. '(repeat :inline t :tag "Unknown entries" sexp))) - (use-local-map gnus-custom-map) + (use-local-map widget-keymap) (widget-setup))) (defun gnus-score-customize-done (&rest ignore) @@ -893,20 +947,18 @@ articles in the thread. (gnus-score-set 'touched '(t) alist)) (bury-buffer)) -(eval-when-compile - (defvar category-fields nil) - (defvar gnus-agent-cat-name) - (defvar gnus-agent-cat-score-file) - (defvar gnus-agent-cat-length-when-short) - (defvar gnus-agent-cat-length-when-long) - (defvar gnus-agent-cat-low-score) - (defvar gnus-agent-cat-high-score) - (defvar gnus-agent-cat-enable-expiration) - (defvar gnus-agent-cat-days-until-old) - (defvar gnus-agent-cat-predicate) - (defvar gnus-agent-cat-groups) - (defvar gnus-agent-cat-enable-undownloaded-faces) -) +(defvar category-fields nil) +(defvar gnus-agent-cat-name) +(defvar gnus-agent-cat-score-file) +(defvar gnus-agent-cat-length-when-short) +(defvar gnus-agent-cat-length-when-long) +(defvar gnus-agent-cat-low-score) +(defvar gnus-agent-cat-high-score) +(defvar gnus-agent-cat-enable-expiration) +(defvar gnus-agent-cat-days-until-old) +(defvar gnus-agent-cat-predicate) +(defvar gnus-agent-cat-groups) +(defvar gnus-agent-cat-enable-undownloaded-faces) (defun gnus-trim-whitespace (s) (when (string-match "\\`[ \n\t]+" s) @@ -1058,7 +1110,7 @@ articles in the thread. (gnus-agent-cat-prepare-category-field agent-enable-undownloaded-faces) - (use-local-map gnus-custom-map) + (use-local-map widget-keymap) (widget-setup) (buffer-enable-undo)))) @@ -1066,5 +1118,5 @@ articles in the thread. (provide 'gnus-cus) -;;; arch-tag: a37c285a-49bc-4235-8244-804536effeaf +;; arch-tag: a37c285a-49bc-4235-8244-804536effeaf ;;; gnus-cus.el ends here