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