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