Commit | Line | Data |
---|---|---|
eec82323 | 1 | ;;; gnus-cus.el --- customization commands for Gnus |
e84b4b86 TTN |
2 | |
3 | ;; Copyright (C) 1996, 1999, 2000, 2001, 2002, 2003, 2004, | |
114f9c96 | 4 | ;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. |
eec82323 LMI |
5 | |
6 | ;; Author: Per Abrahamsen <abraham@dina.kvl.dk> | |
7 | ;; Keywords: news | |
8 | ||
9 | ;; This file is part of GNU Emacs. | |
10 | ||
5e809f55 | 11 | ;; GNU Emacs is free software: you can redistribute it and/or modify |
eec82323 | 12 | ;; it under the terms of the GNU General Public License as published by |
5e809f55 GM |
13 | ;; the Free Software Foundation, either version 3 of the License, or |
14 | ;; (at your option) any later version. | |
eec82323 LMI |
15 | |
16 | ;; GNU Emacs is distributed in the hope that it will be useful, | |
17 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
5e809f55 | 18 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
eec82323 LMI |
19 | ;; GNU General Public License for more details. |
20 | ||
21 | ;; You should have received a copy of the GNU General Public License | |
5e809f55 | 22 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. |
eec82323 LMI |
23 | |
24 | ;;; Commentary: | |
25 | ||
26 | ;;; Code: | |
27 | ||
28 | (require 'wid-edit) | |
23f87bed MB |
29 | (require 'gnus) |
30 | (require 'gnus-agent) | |
eec82323 | 31 | (require 'gnus-score) |
16409b0b | 32 | (require 'gnus-topic) |
23f87bed | 33 | (require 'gnus-art) |
eec82323 LMI |
34 | |
35 | ;;; Widgets: | |
36 | ||
eec82323 LMI |
37 | (defun gnus-custom-mode () |
38 | "Major mode for editing Gnus customization buffers. | |
39 | ||
40 | The following commands are available: | |
41 | ||
42 | \\[widget-forward] Move to next button or editable field. | |
43 | \\[widget-backward] Move to previous button or editable field. | |
44 | \\[widget-button-click] Activate button under the mouse pointer. | |
45 | \\[widget-button-press] Activate button under point. | |
46 | ||
47 | Entry to this mode calls the value of `gnus-custom-mode-hook' | |
48 | if that value is non-nil." | |
49 | (kill-all-local-variables) | |
50 | (setq major-mode 'gnus-custom-mode | |
51 | mode-name "Gnus Customize") | |
16f18d05 | 52 | (use-local-map widget-keymap) |
16409b0b GM |
53 | ;; Emacs 21 stuff: |
54 | (when (and (facep 'custom-button-face) | |
55 | (facep 'custom-button-pressed-face)) | |
56 | (set (make-local-variable 'widget-button-face) | |
57 | 'custom-button-face) | |
58 | (set (make-local-variable 'widget-button-pressed-face) | |
59 | 'custom-button-pressed-face) | |
60 | (set (make-local-variable 'widget-mouse-face) | |
61 | 'custom-button-pressed-face)) | |
62 | (when (and (boundp 'custom-raised-buttons) | |
63 | (symbol-value 'custom-raised-buttons)) | |
64 | (set (make-local-variable 'widget-push-button-prefix) "") | |
65 | (set (make-local-variable 'widget-push-button-suffix) "") | |
66 | (set (make-local-variable 'widget-link-prefix) "") | |
67 | (set (make-local-variable 'widget-link-suffix) "")) | |
cfcd5c91 | 68 | (gnus-run-mode-hooks 'gnus-custom-mode-hook)) |
eec82323 LMI |
69 | |
70 | ;;; Group Customization: | |
71 | ||
72 | (defconst gnus-group-parameters | |
23f87bed | 73 | '((extra-aliases (choice |
16409b0b GM |
74 | :tag "Extra Aliases" |
75 | (list | |
76 | :tag "List" | |
77 | (editable-list | |
78 | :inline t | |
79 | (gnus-email-address :tag "Address"))) | |
80 | (gnus-email-address :tag "Address")) "\ | |
81 | Store messages posted from or to this address in this group. | |
82 | ||
83 | You must be using gnus-group-split for this to work. The VALUE of the | |
84 | nnmail-split-fancy SPLIT generated for this group will match these | |
85 | addresses.") | |
86 | ||
87 | (split-regexp (regexp :tag "gnus-group-split Regular Expression") "\ | |
88 | Like gnus-group-split Address, but expects a regular expression.") | |
89 | ||
90 | (split-exclude (list :tag "gnus-group-split Restricts" | |
91 | (editable-list | |
92 | :inline t (regexp :tag "Restrict"))) "\ | |
93 | Regular expression that cancels gnus-group-split matches. | |
94 | ||
95 | Each entry is added to the nnmail-split-fancy SPLIT as a separate | |
96 | RESTRICT clause.") | |
97 | ||
98 | (split-spec (choice :tag "gnus-group-split Overrider" | |
99 | (sexp :tag "Fancy Split") | |
100 | (const :tag "Catch All" catch-all) | |
101 | (const :tag "Ignore" nil)) "\ | |
102 | Override all other gnus-group-split fields. | |
103 | ||
104 | In `Fancy Split', you can enter any nnmail-split-fancy SPLIT. Note | |
105 | that the name of this group won't be automatically assumed, you have | |
106 | to add it to the SPLITs yourself. This means you can use such splits | |
107 | to split messages to other groups too. | |
108 | ||
109 | If you select `Catch All', this group will get postings for any | |
110 | messages not matched in any other group. It overrides the variable | |
111 | gnus-group-split-default-catch-all-group. | |
112 | ||
113 | Selecting `Ignore' forces no SPLIT to be generated for this group, | |
114 | disabling all other gnus-group-split fields.") | |
eec82323 LMI |
115 | |
116 | (broken-reply-to (const :tag "Broken Reply To" t) "\ | |
117 | Ignore `Reply-To' headers in this group. | |
118 | ||
119 | That can be useful if you're reading a mailing list group where the | |
120 | listserv has inserted `Reply-To' headers that point back to the | |
121 | listserv itself. This is broken behavior. So there!") | |
122 | ||
123 | (to-group (string :tag "To Group") "\ | |
16409b0b | 124 | All posts will be sent to the specified group.") |
eec82323 LMI |
125 | |
126 | (gcc-self (choice :tag "GCC" | |
127 | :value t | |
5aa22ef9 | 128 | (const :tag "To current group" t) |
eec82323 LMI |
129 | (const none) |
130 | (string :format "%v" :hide-front-space t)) "\ | |
131 | Specify default value for GCC header. | |
132 | ||
a4f5043f | 133 | If this symbol is present in the group parameter list and set to t, |
16409b0b | 134 | new composed messages will be `Gcc''d to the current group. If it is |
eec82323 LMI |
135 | present and set to `none', no `Gcc:' header will be generated, if it |
136 | is present and a string, this string will be inserted literally as a | |
137 | `gcc' header (this symbol takes precedence over any default `Gcc' | |
138 | rules as described later).") | |
139 | ||
eec82323 LMI |
140 | (expiry-wait (choice :tag "Expire Wait" |
141 | :value never | |
142 | (const never) | |
143 | (const immediate) | |
144 | (number :hide-front-space t | |
145 | :format "%v")) "\ | |
146 | When to expire. | |
147 | ||
148 | Overrides any `nnmail-expiry-wait' and `nnmail-expiry-wait-function' | |
16409b0b | 149 | when expiring expirable messages. The value can either be a number of |
eec82323 LMI |
150 | days (not necessarily an integer) or the symbols `never' or |
151 | `immediate'.") | |
152 | ||
16409b0b | 153 | (expiry-target (choice :tag "Expiry Target" |
23f87bed MB |
154 | :value delete |
155 | (const delete) | |
156 | (function :format "%v" nnmail-) | |
157 | string) "\ | |
16409b0b GM |
158 | Where expired messages end up. |
159 | ||
23f87bed | 160 | Overrides `nnmail-expiry-target'.") |
16409b0b | 161 | |
eec82323 LMI |
162 | (score-file (file :tag "Score File") "\ |
163 | Make the specified file into the current score file. | |
164 | This means that all score commands you issue will end up in this file.") | |
165 | ||
166 | (adapt-file (file :tag "Adapt File") "\ | |
167 | Make the specified file into the current adaptive file. | |
168 | All adaptive score entries will be put into this file.") | |
169 | ||
170 | (admin-address (gnus-email-address :tag "Admin Address") "\ | |
171 | Administration address for a mailing list. | |
172 | ||
173 | When unsubscribing to a mailing list you should never send the | |
174 | unsubscription notice to the mailing list itself. Instead, you'd | |
175 | send messages to the administrative address. This parameter allows | |
176 | you to put the admin address somewhere convenient.") | |
177 | ||
178 | (display (choice :tag "Display" | |
179 | :value default | |
180 | (const all) | |
23f87bed MB |
181 | (integer) |
182 | (const default) | |
183 | (sexp :tag "Other")) "\ | |
eec82323 LMI |
184 | Which articles to display on entering the group. |
185 | ||
186 | `all' | |
187 | Display all articles, both read and unread. | |
188 | ||
23f87bed MB |
189 | `integer' |
190 | Display the last NUMBER articles in the group. This is the same as | |
191 | entering the group with C-u NUMBER. | |
192 | ||
eec82323 LMI |
193 | `default' |
194 | Display the default visible articles, which normally includes | |
23f87bed MB |
195 | unread and ticked articles. |
196 | ||
197 | `Other' | |
198 | Display the articles that satisfy the S-expression. The S-expression | |
199 | should be in an array form.") | |
eec82323 LMI |
200 | |
201 | (comment (string :tag "Comment") "\ | |
6748645f LMI |
202 | An arbitrary comment on the group.") |
203 | ||
204 | (visible (const :tag "Permanently visible" t) "\ | |
23f87bed | 205 | Always display this group, even when there are no unread articles in it.") |
711a4be3 JB |
206 | |
207 | (highlight-words | |
16409b0b GM |
208 | (choice :tag "Highlight words" |
209 | :value nil | |
210 | (repeat (list (regexp :tag "Highlight regexp") | |
211 | (number :tag "Group for entire word" 0) | |
212 | (number :tag "Group for displayed part" 0) | |
711a4be3 | 213 | (symbol :tag "Face" |
16409b0b GM |
214 | gnus-emphasis-highlight-words)))) |
215 | "highlight regexps. | |
23f87bed | 216 | See `gnus-emphasis-alist'.") |
158d6e07 SZ |
217 | |
218 | (posting-style | |
219 | (choice :tag "Posting style" | |
220 | :value nil | |
221 | (repeat (list | |
23f87bed | 222 | (choice :tag "Type" |
158d6e07 SZ |
223 | :value nil |
224 | (const signature) | |
23f87bed MB |
225 | (const signature-file) |
226 | (const organization) | |
227 | (const address) | |
7dafe00b | 228 | (const x-face-file) |
23f87bed | 229 | (const name) |
7dafe00b MB |
230 | (const body) |
231 | (symbol) | |
232 | (string :tag "Header")) | |
158d6e07 SZ |
233 | (string :format "%v")))) |
234 | "post style. | |
23f87bed | 235 | See `gnus-posting-styles'.")) |
16409b0b GM |
236 | "Alist of valid group or topic parameters. |
237 | ||
238 | Each entry has the form (NAME TYPE DOC), where NAME is the parameter | |
239 | itself (a symbol), TYPE is the parameters type (a sexp widget), and | |
240 | DOC is a documentation string for the parameter.") | |
241 | ||
242 | (defconst gnus-extra-topic-parameters | |
243 | '((subscribe (regexp :tag "Subscribe") "\ | |
23f87bed MB |
244 | If `gnus-subscribe-newsgroup-method' or |
245 | `gnus-subscribe-options-newsgroup-method' is set to | |
16409b0b | 246 | `gnus-subscribe-topics', new groups that matches this regexp will |
23f87bed MB |
247 | automatically be subscribed to this topic") |
248 | (subscribe-level (integer :tag "Subscribe Level" :value 1) "\ | |
249 | If this topic parameter is set, when new groups are subscribed | |
250 | automatically under this topic (via the `subscribe' topic parameter) | |
251 | assign this level to the group, rather than the default level | |
252 | set in `gnus-level-default-subscribed'")) | |
16409b0b | 253 | "Alist of topic parameters that are not also group parameters. |
eec82323 LMI |
254 | |
255 | Each entry has the form (NAME TYPE DOC), where NAME is the parameter | |
256 | itself (a symbol), TYPE is the parameters type (a sexp widget), and | |
257 | DOC is a documentation string for the parameter.") | |
258 | ||
16409b0b GM |
259 | (defconst gnus-extra-group-parameters |
260 | '((uidvalidity (string :tag "IMAP uidvalidity") "\ | |
261 | Server-assigned value attached to IMAP groups, used to maintain consistency.")) | |
262 | "Alist of group parameters that are not also topic parameters. | |
263 | ||
264 | Each entry has the form (NAME TYPE DOC), where NAME is the parameter | |
265 | itself (a symbol), TYPE is the parameters type (a sexp widget), and | |
266 | DOC is a documentation string for the parameter.") | |
23f87bed MB |
267 | |
268 | (eval-and-compile | |
269 | (defconst gnus-agent-parameters | |
270 | '((agent-predicate | |
271 | (sexp :tag "Selection Predicate" :value false) | |
272 | "Predicate used to automatically select articles for downloading." | |
273 | gnus-agent-cat-predicate) | |
274 | (agent-score | |
275 | (choice :tag "Score File" :value nil | |
276 | (const file :tag "Use group's score files") | |
277 | (repeat (list (string :format "%v" :tag "File name")))) | |
278 | "Which score files to use when using score to select articles to fetch. | |
279 | ||
280 | `nil' | |
281 | All articles will be scored to zero (0). | |
282 | ||
283 | `file' | |
284 | The group's score files will be used to score the articles. | |
285 | ||
286 | `List' | |
287 | A list of score file names." | |
288 | gnus-agent-cat-score-file) | |
289 | (agent-short-article | |
290 | (integer :tag "Max Length of Short Article" :value "") | |
291 | "The SHORT predicate will evaluate to true when the article is | |
292 | shorter than this length." gnus-agent-cat-length-when-short) | |
293 | (agent-long-article | |
294 | (integer :tag "Min Length of Long Article" :value "") | |
295 | "The LONG predicate will evaluate to true when the article is | |
296 | longer than this length." gnus-agent-cat-length-when-long) | |
297 | (agent-low-score | |
298 | (integer :tag "Low Score Limit" :value "") | |
299 | "The LOW predicate will evaluate to true when the article scores | |
300 | lower than this limit." gnus-agent-cat-low-score) | |
301 | (agent-high-score | |
302 | (integer :tag "High Score Limit" :value "") | |
303 | "The HIGH predicate will evaluate to true when the article scores | |
304 | higher than this limit." gnus-agent-cat-high-score) | |
305 | (agent-days-until-old | |
306 | (integer :tag "Days Until Old" :value "") | |
307 | "The OLD predicate will evaluate to true when the fetched article | |
308 | has been stored locally for at least this many days." | |
309 | gnus-agent-cat-days-until-old) | |
310 | (agent-enable-expiration | |
311 | (radio :tag "Expire in this Group or Topic" :value nil | |
312 | (const :format "Enable " ENABLE) | |
313 | (const :format "Disable " DISABLE)) | |
314 | "\nEnable, or disable, agent expiration in this group or topic." | |
315 | gnus-agent-cat-enable-expiration) | |
316 | (agent-enable-undownloaded-faces | |
317 | (boolean :tag "Enable Agent Faces") | |
318 | "Have the summary buffer use the agent's undownloaded faces. | |
319 | These faces, when enabled, act as a warning that an article has not | |
320 | been fetched into either the agent nor the cache. This is of most use | |
321 | to users who use the agent as a cache (i.e. they only operate on | |
322 | articles that have been downloaded). Leave disabled to display normal | |
323 | article faces even when the article hasn't been downloaded." | |
324 | gnus-agent-cat-enable-undownloaded-faces)) | |
325 | "Alist of group parameters that are not also topic parameters. | |
326 | ||
327 | Each entry has the form (NAME TYPE DOC ACCESSOR), where NAME is the | |
328 | parameter itself (a symbol), TYPE is the parameters type (a sexp | |
329 | widget), DOC is a documentation string for the parameter, and ACCESSOR | |
330 | is a function (symbol) that extracts the current value from the | |
331 | category.")) | |
332 | ||
eec82323 LMI |
333 | (defvar gnus-custom-params) |
334 | (defvar gnus-custom-method) | |
335 | (defvar gnus-custom-group) | |
16409b0b | 336 | (defvar gnus-custom-topic) |
eec82323 | 337 | |
16409b0b GM |
338 | (defun gnus-group-customize (group &optional topic) |
339 | "Edit the group or topic on the current line." | |
340 | (interactive (list (gnus-group-group-name) (gnus-group-topic-name))) | |
6748645f | 341 | (let (info |
eec82323 LMI |
342 | (types (mapcar (lambda (entry) |
343 | `(cons :format "%v%h\n" | |
344 | :doc ,(nth 2 entry) | |
345 | (const :format "" ,(nth 0 entry)) | |
346 | ,(nth 1 entry))) | |
23f87bed MB |
347 | (append (reverse gnus-group-parameters-more) |
348 | gnus-group-parameters | |
16409b0b GM |
349 | (if group |
350 | gnus-extra-group-parameters | |
23f87bed MB |
351 | gnus-extra-topic-parameters)))) |
352 | (agent (mapcar (lambda (entry) | |
353 | (let ((type (nth 1 entry)) | |
354 | vcons) | |
355 | (if (listp type) | |
356 | (setq type (copy-sequence type))) | |
357 | ||
358 | (setq vcons (cdr (memq :value type))) | |
359 | ||
360 | (if (symbolp (car vcons)) | |
361 | (condition-case nil | |
362 | (setcar vcons (symbol-value (car vcons))) | |
363 | (error))) | |
364 | `(cons :format "%v%h\n" | |
365 | :doc ,(nth 2 entry) | |
366 | (const :format "" ,(nth 0 entry)) | |
367 | ,type))) | |
368 | (if gnus-agent | |
369 | gnus-agent-parameters)))) | |
16409b0b | 370 | (unless (or group topic) |
eec82323 | 371 | (error "No group on current line")) |
16409b0b | 372 | (when (and group topic) |
23f87bed | 373 | (error "Both a group an topic on current line")) |
16409b0b | 374 | (unless (or topic (setq info (gnus-get-info group))) |
eec82323 LMI |
375 | (error "Killed group; can't be edited")) |
376 | ;; Ready. | |
23f87bed | 377 | (gnus-kill-buffer (gnus-get-buffer-create "*Gnus Customize*")) |
6748645f | 378 | (switch-to-buffer (gnus-get-buffer-create "*Gnus Customize*")) |
eec82323 LMI |
379 | (gnus-custom-mode) |
380 | (make-local-variable 'gnus-custom-group) | |
381 | (setq gnus-custom-group group) | |
16409b0b GM |
382 | (make-local-variable 'gnus-custom-topic) |
383 | (setq gnus-custom-topic topic) | |
384 | (buffer-disable-undo) | |
eec82323 | 385 | (widget-insert "Customize the ") |
16409b0b GM |
386 | (if group |
387 | (widget-create 'info-link | |
388 | :help-echo "Push me to learn more." | |
389 | :tag "group parameters" | |
390 | "(gnus)Group Parameters") | |
391 | (widget-create 'info-link | |
392 | :help-echo "Push me to learn more." | |
393 | :tag "topic parameters" | |
394 | "(gnus)Topic Parameters")) | |
eec82323 | 395 | (widget-insert " for <") |
16409b0b | 396 | (widget-insert (gnus-group-decoded-name (or group topic))) |
eec82323 LMI |
397 | (widget-insert "> and press ") |
398 | (widget-create 'push-button | |
399 | :tag "done" | |
400 | :help-echo "Push me when done customizing." | |
401 | :action 'gnus-group-customize-done) | |
402 | (widget-insert ".\n\n") | |
403 | (make-local-variable 'gnus-custom-params) | |
23f87bed MB |
404 | |
405 | (let ((values (if group | |
406 | (gnus-info-params info) | |
407 | (gnus-topic-parameters topic)))) | |
408 | ||
409 | ;; The parameters in values may contain duplicates. This is | |
410 | ;; normally OK as assq returns the first. However, right here | |
411 | ;; every duplicate ends up being displayed. So, rather than | |
412 | ;; display them, remove them from the list. | |
413 | ||
414 | (let ((tmp (setq values (gnus-copy-sequence values))) | |
415 | elem) | |
416 | (while (cdr tmp) | |
417 | (while (setq elem (assq (caar tmp) (cdr tmp))) | |
418 | (delq elem tmp)) | |
419 | (setq tmp (cdr tmp)))) | |
420 | ||
421 | (setq gnus-custom-params | |
422 | (apply 'widget-create 'group | |
423 | :value values | |
424 | (delq nil | |
425 | (list `(set :inline t | |
426 | :greedy t | |
427 | :tag "Parameters" | |
428 | :format "%t:\n%h%v" | |
429 | :doc "\ | |
16409b0b GM |
430 | These special parameters are recognized by Gnus. |
431 | Check the [ ] for the parameters you want to apply to this group or | |
432 | to the groups in this topic, then edit the value to suit your taste." | |
23f87bed MB |
433 | ,@types) |
434 | (when gnus-agent | |
435 | `(set :inline t | |
436 | :greedy t | |
437 | :tag "Agent Parameters" | |
438 | :format "%t:\n%h%v" | |
439 | :doc "\ These agent parameters are | |
440 | recognized by Gnus. They control article selection and expiration for | |
441 | use in the unplugged cache. Check the [ ] for the parameters you want | |
442 | to apply to this group or to the groups in this topic, then edit the | |
443 | value to suit your taste. | |
444 | ||
445 | For those interested, group parameters override topic parameters while | |
446 | topic parameters override agent category parameters. Underlying | |
447 | category parameters are the customizable variables." ,@agent)) | |
448 | '(repeat :inline t | |
449 | :tag "Variables" | |
450 | :format "%t:\n%h%v%i\n\n" | |
451 | :doc "\ | |
eec82323 LMI |
452 | Set variables local to the group you are entering. |
453 | ||
454 | If you want to turn threading off in `news.answers', you could put | |
455 | `(gnus-show-threads nil)' in the group parameters of that group. | |
456 | `gnus-show-threads' will be made into a local variable in the summary | |
a4f5043f | 457 | buffer you enter, and the form nil will be `eval'ed there. |
eec82323 LMI |
458 | |
459 | This can also be used as a group-specific hook function, if you'd | |
460 | like. If you want to hear a beep when you enter a group, you could | |
461 | put something like `(dummy-variable (ding))' in the parameters of that | |
462 | group. `dummy-variable' will be set to the result of the `(ding)' | |
463 | form, but who cares?" | |
23f87bed MB |
464 | (list :format "%v" :value (nil nil) |
465 | (symbol :tag "Variable") | |
466 | (sexp :tag | |
467 | "Value"))) | |
468 | ||
469 | '(repeat :inline t | |
470 | :tag "Unknown entries" | |
471 | sexp)))))) | |
16409b0b GM |
472 | (when group |
473 | (widget-insert "\n\nYou can also edit the ") | |
474 | (widget-create 'info-link | |
475 | :tag "select method" | |
476 | :help-echo "Push me to learn more about select methods." | |
477 | "(gnus)Select Methods") | |
478 | (widget-insert " for the group.\n") | |
479 | (setq gnus-custom-method | |
480 | (widget-create 'sexp | |
481 | :tag "Method" | |
482 | :value (gnus-info-method info)))) | |
16f18d05 | 483 | (use-local-map widget-keymap) |
16409b0b GM |
484 | (widget-setup) |
485 | (buffer-enable-undo) | |
486 | (goto-char (point-min)))) | |
eec82323 LMI |
487 | |
488 | (defun gnus-group-customize-done (&rest ignore) | |
489 | "Apply changes and bury the buffer." | |
490 | (interactive) | |
16409b0b GM |
491 | (if gnus-custom-topic |
492 | (gnus-topic-set-parameters gnus-custom-topic | |
493 | (widget-value gnus-custom-params)) | |
494 | (gnus-group-edit-group-done 'params gnus-custom-group | |
495 | (widget-value gnus-custom-params)) | |
496 | (gnus-group-edit-group-done 'method gnus-custom-group | |
497 | (widget-value gnus-custom-method))) | |
eec82323 LMI |
498 | (bury-buffer)) |
499 | ||
500 | ;;; Score Customization: | |
501 | ||
502 | (defconst gnus-score-parameters | |
503 | '((mark (number :tag "Mark") "\ | |
504 | The value of this entry should be a number. | |
505 | Any articles with a score lower than this number will be marked as read.") | |
506 | ||
507 | (expunge (number :tag "Expunge") "\ | |
508 | The value of this entry should be a number. | |
509 | Any articles with a score lower than this number will be removed from | |
510 | the summary buffer.") | |
511 | ||
512 | (mark-and-expunge (number :tag "Mark-and-expunge") "\ | |
513 | The value of this entry should be a number. | |
514 | Any articles with a score lower than this number will be marked as | |
515 | read and removed from the summary buffer.") | |
516 | ||
517 | (thread-mark-and-expunge (number :tag "Thread-mark-and-expunge") "\ | |
518 | The value of this entry should be a number. | |
519 | All articles that belong to a thread that has a total score below this | |
520 | number will be marked as read and removed from the summary buffer. | |
521 | `gnus-thread-score-function' says how to compute the total score | |
522 | for a thread.") | |
523 | ||
6748645f | 524 | (files (repeat :inline t :tag "Files" file) "\ |
eec82323 LMI |
525 | The value of this entry should be any number of file names. |
526 | These files are assumed to be score files as well, and will be loaded | |
527 | the same way this one was.") | |
528 | ||
6748645f | 529 | (exclude-files (repeat :inline t :tag "Exclude-files" file) "\ |
eec82323 LMI |
530 | The clue of this entry should be any number of files. |
531 | These files will not be loaded, even though they would normally be so, | |
532 | for some reason or other.") | |
533 | ||
534 | (eval (sexp :tag "Eval" :value nil) "\ | |
535 | The value of this entry will be `eval'el. | |
536 | This element will be ignored when handling global score files.") | |
537 | ||
538 | (read-only (boolean :tag "Read-only" :value t) "\ | |
539 | Read-only score files will not be updated or saved. | |
540 | Global score files should feature this atom.") | |
541 | ||
542 | (orphan (number :tag "Orphan") "\ | |
543 | The value of this entry should be a number. | |
544 | Articles that do not have parents will get this number added to their | |
545 | scores. Imagine you follow some high-volume newsgroup, like | |
546 | `comp.lang.c'. Most likely you will only follow a few of the threads, | |
547 | also want to see any new threads. | |
548 | ||
549 | You can do this with the following two score file entries: | |
550 | ||
551 | (orphan -500) | |
552 | (mark-and-expunge -100) | |
553 | ||
554 | When you enter the group the first time, you will only see the new | |
555 | threads. You then raise the score of the threads that you find | |
556 | interesting (with `I T' or `I S'), and ignore (`C y') the rest. | |
557 | Next time you enter the group, you will see new articles in the | |
558 | interesting threads, plus any new threads. | |
559 | ||
560 | I.e.---the orphan score atom is for high-volume groups where there | |
561 | exist a few interesting threads which can't be found automatically | |
562 | by ordinary scoring rules.") | |
563 | ||
564 | (adapt (choice :tag "Adapt" | |
565 | (const t) | |
566 | (const ignore) | |
567 | (sexp :format "%v" | |
568 | :hide-front-space t)) "\ | |
569 | This entry controls the adaptive scoring. | |
a4f5043f | 570 | If it is t, the default adaptive scoring rules will be used. If it |
eec82323 LMI |
571 | is `ignore', no adaptive scoring will be performed on this group. If |
572 | it is a list, this list will be used as the adaptive scoring rules. | |
a4f5043f | 573 | If it isn't present, or is something other than t or `ignore', the |
eec82323 LMI |
574 | default adaptive scoring rules will be used. If you want to use |
575 | adaptive scoring on most groups, you'd set `gnus-use-adaptive-scoring' | |
a4f5043f | 576 | to t, and insert an `(adapt ignore)' in the groups where you do not |
eec82323 | 577 | want adaptive scoring. If you only want adaptive scoring in a few |
a4f5043f | 578 | groups, you'd set `gnus-use-adaptive-scoring' to nil, and insert |
eec82323 LMI |
579 | `(adapt t)' in the score files of the groups where you want it.") |
580 | ||
581 | (adapt-file (file :tag "Adapt-file") "\ | |
582 | All adaptive score entries will go to the file named by this entry. | |
583 | It will also be applied when entering the group. This atom might | |
584 | be handy if you want to adapt on several groups at once, using the | |
585 | same adaptive file for a number of groups.") | |
586 | ||
587 | (local (repeat :tag "Local" | |
588 | (group :value (nil nil) | |
589 | (symbol :tag "Variable") | |
590 | (sexp :tag "Value"))) "\ | |
591 | The value of this entry should be a list of `(VAR VALUE)' pairs. | |
592 | Each VAR will be made buffer-local to the current summary buffer, | |
593 | and set to the value specified. This is a convenient, if somewhat | |
594 | strange, way of setting variables in some groups if you don't like | |
595 | hooks much.") | |
596 | (touched (sexp :format "Touched\n") "Internal variable.")) | |
597 | "Alist of valid symbolic score parameters. | |
598 | ||
599 | Each entry has the form (NAME TYPE DOC), where NAME is the parameter | |
600 | itself (a symbol), TYPE is the parameters type (a sexp widget), and DOC is a | |
601 | documentation string for the parameter.") | |
602 | ||
603 | (define-widget 'gnus-score-string 'group | |
604 | "Edit score entries for string-valued headers." | |
605 | :convert-widget 'gnus-score-string-convert) | |
606 | ||
607 | (defun gnus-score-string-convert (widget) | |
608 | ;; Set args appropriately. | |
609 | (let* ((tag (widget-get widget :tag)) | |
610 | (item `(const :format "" :value ,(downcase tag))) | |
611 | (match '(string :tag "Match")) | |
612 | (score '(choice :tag "Score" | |
16409b0b GM |
613 | (const :tag "default" nil) |
614 | (integer :format "%v" | |
615 | :hide-front-space t))) | |
eec82323 LMI |
616 | (expire '(choice :tag "Expire" |
617 | (const :tag "off" nil) | |
618 | (integer :format "%v" | |
619 | :hide-front-space t))) | |
620 | (type '(choice :tag "Type" | |
621 | :value s | |
622 | ;; I should really create a forgiving :match | |
623 | ;; function for each type below, that only | |
624 | ;; looked at the first letter. | |
625 | (const :tag "Regexp" r) | |
626 | (const :tag "Regexp (fixed case)" R) | |
627 | (const :tag "Substring" s) | |
628 | (const :tag "Substring (fixed case)" S) | |
629 | (const :tag "Exact" e) | |
630 | (const :tag "Exact (fixed case)" E) | |
631 | (const :tag "Word" w) | |
632 | (const :tag "Word (fixed case)" W) | |
633 | (const :tag "default" nil))) | |
634 | (group `(group ,match ,score ,expire ,type)) | |
635 | (doc (concat (or (widget-get widget :doc) | |
636 | (concat "Change score based on the " tag | |
637 | " header.\n")) | |
638 | " | |
639 | You can have an arbitrary number of score entries for this header, | |
640 | each score entry has four elements: | |
641 | ||
642 | 1. The \"match element\". This should be the string to look for in the | |
643 | header. | |
644 | ||
645 | 2. The \"score element\". This number should be an integer in the | |
646 | neginf to posinf interval. This number is added to the score | |
647 | of the article if the match is successful. If this element is | |
648 | not present, the `gnus-score-interactive-default-score' number | |
649 | will be used instead. This is 1000 by default. | |
650 | ||
651 | 3. The \"date element\". This date says when the last time this score | |
652 | entry matched, which provides a mechanism for expiring the | |
653 | score entries. It this element is not present, the score | |
654 | entry is permanent. The date is represented by the number of | |
655 | days since December 31, 1 ce. | |
656 | ||
657 | 4. The \"type element\". This element specifies what function should | |
658 | be used to see whether this score entry matches the article. | |
659 | ||
660 | There are the regexp, as well as substring types, and exact match, | |
661 | and word match types. If this element is not present, Gnus will | |
662 | assume that substring matching should be used. There is case | |
663 | sensitive variants of all match types."))) | |
664 | (widget-put widget :args `(,item | |
665 | (repeat :inline t | |
666 | :indent 0 | |
667 | :tag ,tag | |
668 | :doc ,doc | |
669 | :format "%t:\n%h%v%i\n\n" | |
670 | (choice :format "%v" | |
671 | :value ("" nil nil s) | |
672 | ,group | |
673 | sexp))))) | |
674 | widget) | |
675 | ||
676 | (define-widget 'gnus-score-integer 'group | |
677 | "Edit score entries for integer-valued headers." | |
678 | :convert-widget 'gnus-score-integer-convert) | |
679 | ||
680 | (defun gnus-score-integer-convert (widget) | |
681 | ;; Set args appropriately. | |
682 | (let* ((tag (widget-get widget :tag)) | |
683 | (item `(const :format "" :value ,(downcase tag))) | |
684 | (match '(integer :tag "Match")) | |
685 | (score '(choice :tag "Score" | |
16409b0b GM |
686 | (const :tag "default" nil) |
687 | (integer :format "%v" | |
688 | :hide-front-space t))) | |
eec82323 LMI |
689 | (expire '(choice :tag "Expire" |
690 | (const :tag "off" nil) | |
691 | (integer :format "%v" | |
692 | :hide-front-space t))) | |
693 | (type '(choice :tag "Type" | |
694 | :value < | |
695 | (const <) | |
696 | (const >) | |
697 | (const =) | |
698 | (const >=) | |
699 | (const <=))) | |
700 | (group `(group ,match ,score ,expire ,type)) | |
701 | (doc (concat (or (widget-get widget :doc) | |
702 | (concat "Change score based on the " tag | |
703 | " header."))))) | |
704 | (widget-put widget :args `(,item | |
705 | (repeat :inline t | |
706 | :indent 0 | |
707 | :tag ,tag | |
708 | :doc ,doc | |
709 | :format "%t:\n%h%v%i\n\n" | |
710 | ,group)))) | |
711 | widget) | |
712 | ||
713 | (define-widget 'gnus-score-date 'group | |
714 | "Edit score entries for date-valued headers." | |
715 | :convert-widget 'gnus-score-date-convert) | |
716 | ||
717 | (defun gnus-score-date-convert (widget) | |
718 | ;; Set args appropriately. | |
719 | (let* ((tag (widget-get widget :tag)) | |
720 | (item `(const :format "" :value ,(downcase tag))) | |
721 | (match '(string :tag "Match")) | |
722 | (score '(choice :tag "Score" | |
16409b0b GM |
723 | (const :tag "default" nil) |
724 | (integer :format "%v" | |
725 | :hide-front-space t))) | |
eec82323 LMI |
726 | (expire '(choice :tag "Expire" |
727 | (const :tag "off" nil) | |
728 | (integer :format "%v" | |
729 | :hide-front-space t))) | |
730 | (type '(choice :tag "Type" | |
731 | :value regexp | |
732 | (const regexp) | |
733 | (const before) | |
734 | (const at) | |
735 | (const after))) | |
736 | (group `(group ,match ,score ,expire ,type)) | |
737 | (doc (concat (or (widget-get widget :doc) | |
738 | (concat "Change score based on the " tag | |
739 | " header.")) | |
740 | " | |
741 | For the Date header we have three kinda silly match types: `before', | |
742 | `at' and `after'. I can't really imagine this ever being useful, but, | |
743 | like, it would feel kinda silly not to provide this function. Just in | |
744 | case. You never know. Better safe than sorry. Once burnt, twice | |
745 | shy. Don't judge a book by its cover. Never not have sex on a first | |
746 | date. (I have been told that at least one person, and I quote, | |
747 | \"found this function indispensable\", however.) | |
748 | ||
749 | A more useful match type is `regexp'. With it, you can match the date | |
750 | string using a regular expression. The date is normalized to ISO8601 | |
751 | compact format first---`YYYYMMDDTHHMMSS'. If you want to match all | |
752 | articles that have been posted on April 1st in every year, you could | |
753 | use `....0401.........' as a match string, for instance. (Note that | |
754 | the date is kept in its original time zone, so this will match | |
755 | articles that were posted when it was April 1st where the article was | |
756 | posted from. Time zones are such wholesome fun for the whole family, | |
757 | eh?"))) | |
758 | (widget-put widget :args `(,item | |
759 | (repeat :inline t | |
760 | :indent 0 | |
761 | :tag ,tag | |
762 | :doc ,doc | |
763 | :format "%t:\n%h%v%i\n\n" | |
764 | ,group)))) | |
765 | widget) | |
766 | ||
4b70e299 MB |
767 | (define-widget 'gnus-score-extra 'group |
768 | "Edit score entries for extra headers." | |
769 | :convert-widget 'gnus-score-extra-convert) | |
770 | ||
771 | (defun gnus-score-extra-convert (widget) | |
772 | ;; Set args appropriately. | |
773 | (let* ((tag (widget-get widget :tag)) | |
774 | (item `(const :format "" :value ,(downcase tag))) | |
775 | (match '(string :tag "Match")) | |
776 | (score '(choice :tag "Score" | |
777 | (const :tag "default" nil) | |
778 | (integer :format "%v" | |
779 | :hide-front-space t))) | |
780 | (expire '(choice :tag "Expire" | |
781 | (const :tag "off" nil) | |
782 | (integer :format "%v" | |
783 | :hide-front-space t))) | |
784 | (type '(choice :tag "Type" | |
785 | :value s | |
786 | ;; I should really create a forgiving :match | |
787 | ;; function for each type below, that only | |
788 | ;; looked at the first letter. | |
789 | (const :tag "Regexp" r) | |
790 | (const :tag "Regexp (fixed case)" R) | |
791 | (const :tag "Substring" s) | |
792 | (const :tag "Substring (fixed case)" S) | |
793 | (const :tag "Exact" e) | |
794 | (const :tag "Exact (fixed case)" E) | |
795 | (const :tag "Word" w) | |
796 | (const :tag "Word (fixed case)" W) | |
797 | (const :tag "default" nil))) | |
798 | (header (if gnus-extra-headers | |
799 | (let (name) | |
800 | `(choice :tag "Header" | |
801 | ,@(mapcar (lambda (h) | |
802 | (setq name (symbol-name h)) | |
803 | (list 'const :tag name name)) | |
804 | gnus-extra-headers) | |
805 | (string :tag "Other" :format "%v"))) | |
806 | '(string :tag "Header"))) | |
807 | (group `(group ,match ,score ,expire ,type ,header)) | |
808 | (doc (concat (or (widget-get widget :doc) | |
809 | (concat "Change score based on the " tag | |
810 | " header.\n"))))) | |
811 | (widget-put | |
812 | widget :args | |
813 | `(,item | |
814 | (repeat :inline t | |
815 | :indent 0 | |
816 | :tag ,tag | |
817 | :doc ,doc | |
818 | :format "%t:\n%h%v%i\n\n" | |
819 | (choice :format "%v" | |
820 | :value ("" nil nil s | |
821 | ,(if gnus-extra-headers | |
822 | (symbol-name (car gnus-extra-headers)) | |
823 | "")) | |
824 | ,group | |
825 | sexp))))) | |
826 | widget) | |
827 | ||
eec82323 LMI |
828 | (defvar gnus-custom-scores) |
829 | (defvar gnus-custom-score-alist) | |
830 | ||
831 | (defun gnus-score-customize (file) | |
23f87bed MB |
832 | "Customize score file FILE. |
833 | When called interactively, FILE defaults to the current score file. | |
834 | This can be changed using the `\\[gnus-score-change-score-file]' command." | |
eec82323 | 835 | (interactive (list gnus-current-score-file)) |
23f87bed | 836 | (unless file |
b66c24b4 JB |
837 | (error "No score file for %s" |
838 | (gnus-group-decoded-name gnus-newsgroup-name))) | |
eec82323 LMI |
839 | (let ((scores (gnus-score-load file)) |
840 | (types (mapcar (lambda (entry) | |
16409b0b GM |
841 | `(group :format "%v%h\n" |
842 | :doc ,(nth 2 entry) | |
843 | (const :format "" ,(nth 0 entry)) | |
844 | ,(nth 1 entry))) | |
845 | gnus-score-parameters))) | |
eec82323 | 846 | ;; Ready. |
6748645f LMI |
847 | (kill-buffer (gnus-get-buffer-create "*Gnus Customize*")) |
848 | (switch-to-buffer (gnus-get-buffer-create "*Gnus Customize*")) | |
eec82323 LMI |
849 | (gnus-custom-mode) |
850 | (make-local-variable 'gnus-custom-score-alist) | |
851 | (setq gnus-custom-score-alist scores) | |
852 | (widget-insert "Customize the ") | |
853 | (widget-create 'info-link | |
854 | :help-echo "Push me to learn more." | |
855 | :tag "score entries" | |
856 | "(gnus)Score File Format") | |
857 | (widget-insert " for\n\t") | |
858 | (widget-insert file) | |
859 | (widget-insert "\nand press ") | |
860 | (widget-create 'push-button | |
861 | :tag "done" | |
862 | :help-echo "Push me when done customizing." | |
863 | :action 'gnus-score-customize-done) | |
864 | (widget-insert ".\n | |
865 | Check the [ ] for the entries you want to apply to this score file, then | |
866 | edit the value to suit your taste. Don't forget to mark the checkbox, | |
867 | if you do all your changes will be lost. ") | |
868 | (widget-create 'push-button | |
869 | :action (lambda (&rest ignore) | |
870 | (require 'gnus-audio) | |
871 | (gnus-audio-play "Evil_Laugh.au")) | |
872 | "Bhahahah!") | |
873 | (widget-insert "\n\n") | |
874 | (make-local-variable 'gnus-custom-scores) | |
875 | (setq gnus-custom-scores | |
876 | (widget-create 'group | |
877 | :value scores | |
878 | `(checklist :inline t | |
879 | :greedy t | |
880 | (gnus-score-string :tag "From") | |
881 | (gnus-score-string :tag "Subject") | |
882 | (gnus-score-string :tag "References") | |
883 | (gnus-score-string :tag "Xref") | |
4b70e299 | 884 | (gnus-score-extra :tag "Extra") |
eec82323 LMI |
885 | (gnus-score-string :tag "Message-ID") |
886 | (gnus-score-integer :tag "Lines") | |
887 | (gnus-score-integer :tag "Chars") | |
888 | (gnus-score-date :tag "Date") | |
889 | (gnus-score-string :tag "Head" | |
890 | :doc "\ | |
891 | Match all headers in the article. | |
892 | ||
893 | Using one of `Head', `Body', `All' will slow down scoring considerable. | |
894 | ") | |
895 | (gnus-score-string :tag "Body" | |
896 | :doc "\ | |
897 | Match the body sans header of the article. | |
898 | ||
899 | Using one of `Head', `Body', `All' will slow down scoring considerable. | |
900 | ") | |
901 | (gnus-score-string :tag "All" | |
902 | :doc "\ | |
903 | Match the entire article, including both headers and body. | |
904 | ||
905 | Using one of `Head', `Body', `All' will slow down scoring | |
906 | considerable. | |
907 | ") | |
908 | (gnus-score-string :tag | |
909 | "Followup" | |
910 | :doc "\ | |
911 | Score all followups to the specified authors. | |
912 | ||
913 | This entry is somewhat special, in that it will match the `From:' | |
914 | header, and affect the score of not only the matching articles, but | |
915 | also all followups to the matching articles. This allows you | |
916 | e.g. increase the score of followups to your own articles, or decrease | |
917 | the score of followups to the articles of some known trouble-maker. | |
918 | ") | |
919 | (gnus-score-string :tag "Thread" | |
920 | :doc "\ | |
921 | Add a score entry on all articles that are part of a thread. | |
922 | ||
923 | This match key works along the same lines as the `Followup' match key. | |
924 | If you say that you want to score on a (sub-)thread that is started by | |
925 | an article with a `Message-ID' X, then you add a `thread' match. This | |
926 | will add a new `thread' match for each article that has X in its | |
927 | `References' header. (These new `thread' matches will use the | |
928 | `Message-ID's of these matching articles.) This will ensure that you | |
929 | can raise/lower the score of an entire thread, even though some | |
930 | articles in the thread may not have complete `References' headers. | |
931 | Note that using this may lead to undeterministic scores of the | |
932 | articles in the thread. | |
933 | ") | |
934 | ,@types) | |
935 | '(repeat :inline t | |
936 | :tag "Unknown entries" | |
937 | sexp))) | |
16f18d05 | 938 | (use-local-map widget-keymap) |
eec82323 LMI |
939 | (widget-setup))) |
940 | ||
941 | (defun gnus-score-customize-done (&rest ignore) | |
942 | "Reset the score alist with the present value." | |
943 | (let ((alist gnus-custom-score-alist) | |
944 | (value (widget-value gnus-custom-scores))) | |
945 | (setcar alist (car value)) | |
946 | (setcdr alist (cdr value)) | |
947 | (gnus-score-set 'touched '(t) alist)) | |
948 | (bury-buffer)) | |
949 | ||
9efa445f DN |
950 | (defvar category-fields nil) |
951 | (defvar gnus-agent-cat-name) | |
952 | (defvar gnus-agent-cat-score-file) | |
953 | (defvar gnus-agent-cat-length-when-short) | |
954 | (defvar gnus-agent-cat-length-when-long) | |
955 | (defvar gnus-agent-cat-low-score) | |
956 | (defvar gnus-agent-cat-high-score) | |
957 | (defvar gnus-agent-cat-enable-expiration) | |
958 | (defvar gnus-agent-cat-days-until-old) | |
959 | (defvar gnus-agent-cat-predicate) | |
960 | (defvar gnus-agent-cat-groups) | |
961 | (defvar gnus-agent-cat-enable-undownloaded-faces) | |
23f87bed MB |
962 | |
963 | (defun gnus-trim-whitespace (s) | |
964 | (when (string-match "\\`[ \n\t]+" s) | |
965 | (setq s (substring s (match-end 0)))) | |
966 | (when (string-match "[ \n\t]+\\'" s) | |
967 | (setq s (substring s 0 (match-beginning 0)))) | |
968 | s) | |
969 | ||
970 | (defmacro gnus-agent-cat-prepare-category-field (parameter) | |
971 | (let* ((entry (assq parameter gnus-agent-parameters)) | |
972 | (field (nth 3 entry))) | |
973 | `(let* ((type (copy-sequence | |
974 | (nth 1 (assq ',parameter gnus-agent-parameters)))) | |
975 | (val (,field info)) | |
976 | (deflt (if (,field defaults) | |
977 | (concat " [" (gnus-trim-whitespace | |
978 | (gnus-pp-to-string (,field defaults))) | |
01c52d31 | 979 | "]"))) |
23f87bed MB |
980 | symb) |
981 | ||
982 | (if (eq (car type) 'radio) | |
983 | (let* ((rtype (nreverse type)) | |
984 | (rt rtype)) | |
985 | (while (listp (or (cadr rt) 'not-list)) | |
986 | (setq rt (cdr rt))) | |
987 | ||
988 | (setcdr rt (cons '(const :format "Inherit " nil) (cdr rt))) | |
989 | (setq type (nreverse rtype)))) | |
990 | ||
991 | (if deflt | |
992 | (let ((tag (cdr (memq :tag type)))) | |
993 | (when (string-match "\n" deflt) | |
994 | (while (progn (setq deflt (replace-match "\n " t t | |
995 | deflt)) | |
996 | (string-match "\n" deflt (match-end 0)))) | |
997 | (setq deflt (concat "\n" deflt))) | |
998 | ||
999 | (setcar tag (concat (car tag) deflt)))) | |
1000 | ||
1001 | (widget-insert "\n") | |
1002 | ||
1003 | (setq val (if val | |
1004 | (widget-create type :value val) | |
1005 | (widget-create type)) | |
1006 | symb (set (make-local-variable ',field) val)) | |
1007 | ||
1008 | (widget-put symb :default val) | |
1009 | (widget-put symb :accessor ',field) | |
1010 | (push symb category-fields)))) | |
1011 | ||
1012 | (defun gnus-agent-customize-category (category) | |
1013 | "Edit the CATEGORY." | |
1014 | (interactive (list (gnus-category-name))) | |
1015 | (let ((info (assq category gnus-category-alist)) | |
1016 | (defaults (list nil '(agent-predicate . false) | |
1017 | (cons 'agent-enable-expiration | |
1018 | gnus-agent-enable-expiration) | |
1019 | '(agent-days-until-old . 7) | |
1020 | (cons 'agent-length-when-short | |
1021 | gnus-agent-short-article) | |
1022 | (cons 'agent-length-when-long gnus-agent-long-article) | |
1023 | (cons 'agent-low-score gnus-agent-low-score) | |
1024 | (cons 'agent-high-score gnus-agent-high-score)))) | |
1025 | ||
1026 | (let ((old (get-buffer "*Gnus Agent Category Customize*"))) | |
1027 | (when old | |
1028 | (gnus-kill-buffer old))) | |
1029 | (switch-to-buffer (gnus-get-buffer-create | |
1030 | "*Gnus Agent Category Customize*")) | |
1031 | ||
1032 | (let ((inhibit-read-only t)) | |
1033 | (gnus-custom-mode) | |
1034 | (buffer-disable-undo) | |
1035 | ||
1036 | (let* ((name (gnus-agent-cat-name info))) | |
1037 | (widget-insert "Customize the Agent Category '") | |
1038 | (widget-insert (symbol-name name)) | |
1039 | (widget-insert "' and press ") | |
1040 | (widget-create | |
1041 | 'push-button | |
1042 | :notify | |
1043 | '(lambda (&rest ignore) | |
1044 | (let* ((info (assq gnus-agent-cat-name gnus-category-alist)) | |
1045 | (widgets category-fields)) | |
1046 | (while widgets | |
1047 | (let* ((widget (pop widgets)) | |
1048 | (value (condition-case nil (widget-value widget) (error)))) | |
1049 | (eval `(setf (,(widget-get widget :accessor) ',info) | |
1050 | ',value))))) | |
1051 | (gnus-category-write) | |
1052 | (gnus-kill-buffer (current-buffer)) | |
1053 | (when (get-buffer gnus-category-buffer) | |
1054 | (switch-to-buffer (get-buffer gnus-category-buffer)) | |
1055 | (gnus-category-list))) | |
1056 | "Done") | |
1057 | (widget-insert | |
1058 | "\n Note: Empty fields default to the customizable global\ | |
1059 | variables.\n\n") | |
1060 | ||
1061 | (set (make-local-variable 'gnus-agent-cat-name) | |
1062 | name)) | |
1063 | ||
1064 | (set (make-local-variable 'category-fields) nil) | |
1065 | (gnus-agent-cat-prepare-category-field agent-predicate) | |
1066 | ||
1067 | (gnus-agent-cat-prepare-category-field agent-score) | |
1068 | (gnus-agent-cat-prepare-category-field agent-short-article) | |
1069 | (gnus-agent-cat-prepare-category-field agent-long-article) | |
1070 | (gnus-agent-cat-prepare-category-field agent-low-score) | |
1071 | (gnus-agent-cat-prepare-category-field agent-high-score) | |
1072 | ||
1073 | ;; The group list is NOT handled with | |
1074 | ;; gnus-agent-cat-prepare-category-field as I don't want the | |
1075 | ;; group list to appear when customizing a topic. | |
1076 | (widget-insert "\n") | |
b66c24b4 JB |
1077 | |
1078 | (let ((symb | |
1079 | (set | |
23f87bed MB |
1080 | (make-local-variable 'gnus-agent-cat-groups) |
1081 | (widget-create | |
1082 | `(choice | |
1083 | :format "%[Select Member Groups%]\n%v" :value ignore | |
1084 | (const :menu-tag "do not change" :tag "" :value ignore) | |
1085 | (checklist :entry-format "%b %v" | |
1086 | :menu-tag "display group selectors" | |
1087 | :greedy t | |
1088 | :value | |
1089 | ,(delq nil | |
1090 | (mapcar | |
1091 | (lambda (newsrc) | |
1092 | (car (member | |
1093 | (gnus-info-group newsrc) | |
1094 | (gnus-agent-cat-groups info)))) | |
1095 | (cdr gnus-newsrc-alist))) | |
1096 | ,@(mapcar (lambda (newsrc) | |
1097 | `(const ,(gnus-info-group newsrc))) | |
1098 | (cdr gnus-newsrc-alist)))))))) | |
1099 | ||
1100 | (widget-put symb :default (gnus-agent-cat-groups info)) | |
1101 | (widget-put symb :accessor 'gnus-agent-cat-groups) | |
1102 | (push symb category-fields)) | |
1103 | ||
1104 | (widget-insert "\nExpiration Settings ") | |
1105 | ||
1106 | (gnus-agent-cat-prepare-category-field agent-enable-expiration) | |
1107 | (gnus-agent-cat-prepare-category-field agent-days-until-old) | |
1108 | ||
1109 | (widget-insert "\nVisual Settings ") | |
1110 | ||
1111 | (gnus-agent-cat-prepare-category-field agent-enable-undownloaded-faces) | |
1112 | ||
16f18d05 | 1113 | (use-local-map widget-keymap) |
23f87bed MB |
1114 | (widget-setup) |
1115 | (buffer-enable-undo)))) | |
1116 | ||
eec82323 LMI |
1117 | ;;; The End: |
1118 | ||
1119 | (provide 'gnus-cus) | |
1120 | ||
1121 | ;;; gnus-cus.el ends here |