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