1 ;;; tinygnus.el --- Gnus Plug-in. Additional functions. UBE fight etc.
3 ;; This file is not part of Emacs
7 ;; Copyright (C) 1997-2007 Jari Aalto
8 ;; Keywords: extensions
10 ;; Maintainer: Jari Aalto
12 ;; To get information on this program, call M-x tinygnus-version.
13 ;; Look at the code with folding.el.
15 ;; This program is free software; you can redistribute it and/or modify it
16 ;; under the terms of the GNU General Public License as published by the Free
17 ;; Software Foundation; either version 2 of the License, or (at your option)
20 ;; This program is distributed in the hope that it will be useful, but
21 ;; WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
22 ;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
25 ;; You should have received a copy of the GNU General Public License
26 ;; along with program; see the file COPYING. If not, write to the
27 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
28 ;; Boston, MA 02110-1301, USA.
30 ;; Visit <http://www.gnu.org/copyleft/gpl.html> for more information
37 ;; ....................................................... &t-install ...
38 ;; Put this file on your Emacs-Lisp load path, add following into your
39 ;; ~/.gnus startup file. This file should be loaded only after gnus
42 ;; (require 'tinygnus)
44 ;; Alternatively you can add this autoload code to integrate the package
47 ;; (add-hook 'gnus-startup-hook '(lambda () (require 'tinygnus)))
49 ;; If you have any questions, use this function to contact maintainer
51 ;; M-x tinygnus-submit-bug-report
56 ;; ..................................................... &t-commentary ...
63 ;; I haven't have a chance to try the new Gnus for a long time
64 ;; because the envinronment didn't have Emacs 19.34. And when the
65 ;; sysadm installed it, I started slowly moving from my dear RMAIL
66 ;; (which I had configured to work very well) to the bold and beatiful
67 ;; Gnus. I had also started using procmail and subscribed to many
68 ;; mailing lists, so the only choice to manage all my mail was
69 ;; Gnus. Here you find some functions that I found useful.
71 ;; Overview of features
73 ;; o Automatic reload of files when entring group with SPACE
74 ;; (mimic Newsgroup behavior)
75 ;; o You can have compresses .eld file. If you compress .gnus to
76 ;; .gnus.gz then the .eld files will be compressed too to .eld.gz
77 ;; This saves you disk space in low quota account.
79 ;; o Fast read group by showing only unread (newly arrived)
80 ;; articles. Speeds up reading your mail groups.
81 ;; o Show immediately dormants in non-nntp groups. Some people
82 ;; use dormant mark ? in their private mail groups as `todo'
83 ;; and to be able to see those todo articles immediately saves
84 ;; you 5x time, when you don't have to separately limit to
87 ;; o Ready %uX user function that you can use in the *-line-format
89 ;; o Group User format function: "expiry", Tell the expiry value
90 ;; for the group and varaious other values.
91 ;; o Group User format function: "comment", Tell the group comment.
92 ;; o Group User format function: "tick", Tell if group has ticks.
94 ;; o Send UBE complaint to all postmasters in Received headers.
95 ;; The ip addresses of postmasters are nslookup verified. You
96 ;; can select either individual article or process mark multiple
101 ;; o Procmail information can be found at
102 ;; http://www.procmail.org/ and http://pm-doc.sourceforge.net/
103 ;; o Gnus can be found at http://www.gnus.org/
105 ;; Fighting against UBE messages
107 ;; Please visit http://spam.abuse.net/ for up to date information.
108 ;; Other good sites: http://spamcop.net/ and http://www.spamcop.com/
110 ;; [2000-11] Automatically generated Gnus blacklist by Brian Edmonds
111 ;; is at http://www.gweep.bc.ca/~edmonds/usenet/index.html
113 ;; Many of us receive UBE (Unsolicited Bulk Email) and if we don't do
114 ;; anything to stop them, then the practice comes approved de facto
115 ;; internet convention. It is important that you complaint about every
116 ; piece of UBE you may receive, your vote counts and it will also
117 ;; give you satisfaction to know that most of the postmasters kick off
118 ;; the idiot in the other end of the wire. There are two functions
121 ;; tinygnus-article-ube-send-to-postmasters U UBE
122 ;; tinygnus-summary-ube-send-to-postmasters C-c'u send UBE
124 ;; The first function is fully interactive and it reads the current
125 ;; active article and composes `forward' message to all postmasters
126 ;; mentioned in the `received' header chain. Before sending you have
127 ;; a chance to reformat the article anyway you like.
129 ;; The latter function is useful to batch send complaints: you
130 ;; process mark(#) articles in summary buffer, Hit C-c'u, and each
131 ;; article is processes and complaint is sent to postmasters. Before
132 ;; sending message, the function asks confirmation. You can suppress
133 ;; the confirmation with `C-u' prefix argument. _Note_: It may take some
134 ;; time to compose all complaints if you have marked many articles,
135 ;; because parsing *Received:* headers and checking them with `nslookup'
136 ;; may be slow. If you use `procmail' or Gnus split methods to flter
137 ;; your UBE mail to one single newsgroup, say `junk.ube', Then you can
138 ;; mark all messages in the newsgroup and handle all the UBE you have
139 ;; received in a whip.
141 ;; Why is the complaint message sent to *postmaster* address, while
142 ;; recent sites have set up an *abuse* addresses as well? That's
143 ;; simply because RFC822 requires that each site must have postmaster
144 ;; account and you should be able to count on delivery to that address.
146 ;; [RFC822] (...) standard specifies a single, reserved mailbox address
147 ;; (local-part) which is to be valid at each site. Mail sent to that
148 ;; address is to be routed to a person responsible for the site's
149 ;; mail system or to a person with responsibility for general site
150 ;; operation. The name of the reserved local-part address is:
153 ;; From the standard, "postmaster@domain" is required to be valid.
154 ;; Some domains have opened specific addresses where you can send
155 ;; these complains, e.g. abuse@aol.com, fraud@uu.net. If you know a
156 ;; specific address where to send the complaint, update
157 ;; `tinygnus-:ube-abuse-account-table'
159 ;; Gathering information from articles (e.g. URLs)
161 ;; If you read group that has very high traffic, and don't have to
162 ;; time to read all articles, but you're are still interested in
163 ;; seeing if there are any good urls mentioned, you can use function
164 ;; below. It will not record duplicate urls, only unique ones.
166 ;; C-c ' g u tinygnus-summary-gather-urls
168 ;; Function steps through all marked articles (Mark command in summary
169 ;; buffer is in M P submap), examines each message and puts the urls
170 ;; in `tinygnus-:output-buffer'. You can clear and display with
173 ;; C-c ' g d tinygnus-summary-gather-display
174 ;; C-c ' g c tinygnus-summary-gather-clear
176 ;; Configuring the user format functions
178 ;; Before you load this file, it might be good to configure variable
179 ;; `tinygnus-:uff-table' so that it won't clash the definitions of
180 ;; your own `gnus-user-format-function-X'. If you load this file
181 ;; without modifying the table, it will replace all existing functions
182 ;; according to that table. In case you don't know what this is all
183 ;; about, go to Emacs info pages `C-h' `i', go to Gnus node, press
184 ;; 's' to search for 'Summary Buffer Lines' RET. Look at the specifier
185 ;; %uX, where X is anything.
187 ;; Miscellaneous commands
189 ;; `tinygnus-make-group-from-dir-nndoc' can be used to generate all nndoc
190 ;; groups fast from bunch of mailboxes that you dropped to some
191 ;; directory. You might have downloaded archives of mailing lists
192 ;; sorted by month and year and you want to genrate Gnus groups for
195 ;; Nnml handling commands
197 ;; TinyGnus is mainly designed for nnml backend. Gnus can be easily
198 ;; used for mailing lists; Gnus customisations; moving groups from one
199 ;; place to another. In TinyGnus there are some exotic functions that
200 ;; may prove handy when you have the same need. See below.
202 ;; `tinygnus-make-group-nnml-from-dir'. If you have nnml
203 ;; groups in ~/Mail; this function can create the equivalent nnml
204 ;; groups to your gnus easily. Give a REGEXP to match directories to
205 ;; include for group creation (E.g. "list\." for all
206 ;; mailing list list.* directories)
208 ;; `tinygnus-make-group-from-dir-nnml-procmail-spool'. A procmail
209 ;; (never mind if you don't know what that is); is a tool to deliver
210 ;; each incoming mail to correct mailbox as it arrives and it is very
211 ;; efective for filtering mailing lists. Procmail users have to
212 ;; reserve separate directory for these mailboxes; usually
213 ;; ~/Mail/spool/ and all files end to *.spool ( list.ding.spool,
214 ;; work.lab.spool ... ). Keeping Gnus aware of the mailboxes in the
215 ;; ~/Mail/spool would normally be manual work, but this function can
216 ;; create the nnml groups for you for each found spool file from the
219 ;; `tinygnus-group-parameter-mailing-list'. Use this to read the last
220 ;; nnml mail from the directory and suggest an email address from
221 ;; From, To, Cc, Reply-To to be inserted into the group parameter
222 ;; `to-list'. When you start a fresh Gnus and create nnml groups, which
223 ;; are mailing lists (e.g. from old mail); the tedious part is to
224 ;; recover the "list status" of the group and insert correct `to-list'
225 ;; field into each group. With This function; just mark the groups
226 ;; where you want to add the parameter and you're set in few minutes.
228 ;; Enhanced Gnus functions
230 ;; Enter group in Topic mode with SPC
232 ;; Function `gnus-topic-read-group' is enhanced to maximize speed of
233 ;; reading new articles. Normally when you enter Group, gnus shows
234 ;; unread and ticked articles, but if you have any previously ticked
235 ;; articles in group, making the summary buffer is slow. If we ignore
236 ;; the ticked articles and display only the newly arrived, unread,
237 ;; articles, the time to generate Summary buffer is far less. If you
238 ;; have many private mail,work, mailing list groups, this saves you
239 ;; from lot of time to be able to track new messages.
241 ;; Show dormants immediately in non-nntp groups
243 ;; Function `gnus-summary-limit-children' is enhanced so that it will
244 ;; include dormant articles in Summary creation in non-nntp groups.
245 ;; Some people found out that the dormant mark ? is handy in mail
246 ;; groups to mean `todo' or `see this later' or `urgent'. Normally
247 ;; gnus treats all groups the same: nntp or private mail makes no
248 ;; difference. However the dormant mark can be used to mean different
249 ;; meaning in nntp group and non-nntp groups and this enchancement
250 ;; does just that. You get fast Summary with dormants now and you
251 ;; don't need to separately limit the buffer to show the dormants. To
252 ;; turn off this feature, set `tinygnus-:show-dormants' to nil.
254 ;; Compressed Gnus newsrc files
256 ;; Having a unix account that has unlimited disk space is very rare
257 ;; and for that reason being able to keep files in compressed format s
258 ;; preferrable to avoid going over Quota with message "Quota limit
259 ;; exceed, remove nnnK withing N days...".
261 ;; Gnus has compression support for Group files, but not for the
262 ;; bloating .newsrc or .eld files. Gawk. They consume your disk real
263 ;; fast because they become big in no time.
265 ;; For that reason there is included adviced Gnus code that
266 ;; automatically starts using compressed startup files if your
267 ;; `gnus-init-file' has extension `.gz'. Changing from normal init
268 ;; file to compressed one is easy:
270 ;; . gzip your .newsrc and .eld files
271 ;; . (setq tinygnus-:z ".gz")
272 ;; . M-x load-library RET tinygnus RET
274 ;; If you later want to restore this settings: Unzip, do (setq
275 ;; tinygnus-:z nil), and reload the package. But if you're low
276 ;; of quota, you propably do the reverse operation.
280 ;; This file installs only features to Gnus 5.8.2 (Emacs 20.5) and
281 ;; if you're using newer gnus version the advice code is not activated.
282 ;; Using this package should be safe with any existing Gnus version
285 ;; Line format example for *Group* buffer
287 ;; The personal Group buffer line can be configured as follows. If you
288 ;; try this with very old Gnus, drop away that fancy ~(cut 6) and use
291 ;; (setq gnus-topic-line-format "%i%(%{%n%}%) %A -- %g %v\n")
293 ;; (add-hook 'gnus-select-group-hook 'gnus-group-set-timestamp)
295 ;; (setq gnus-group-line-format
296 ;; "%M%S%p%3uZ[%L]%-4uE%uT %5y: %-40,40g %7,7~(cut 6)d %uC\n")
298 ;; Which looks like the following in the buffer, notice that the topic
302 ;; [2]3.g 0: nnml:list.ding 30T1810
303 ;; [2]3. 0: nnml:list.ntemacs 30T1819
304 ;; * [2]3. ! 0: nnml:list.procmail 30T1850
305 ;; [2]2.t 33: nnml:list.flamenco 30T1849
308 ;; | The whole "2.t" comes from %uE
311 ;; There you can see the benefit of the user functions. The [2] tells
312 ;; the group level, "2.t" says "2" day total Expiry, "." means that the
313 ;; period is explicitely defined as a group parameter and "t" means
314 ;; that total expiry in the group parameter list is on. Do you
315 ;; see the extra `g' at the top line? It tells that the `gcc-self'
316 ;; group parameter is activated in group parameter list. If group has
317 ;; ticked articles, the %uT will show it. The %ud says "Day 30 in the
318 ;; month, Time 18:10" when you read the group.
320 ;; All these additional functions that display these status informations
321 ;; can be found from this package.
323 ;; Displaying the group parameter info
325 ;; As you saw above, the %uE function, or more precisely,
326 ;; `tinygnus-uff-group-expiry' controls what information is returned by
327 ;; looking at `tinygnus-:uff-table'. Please configure it to display
328 ;; whatever you want from group parameters.
330 ;; Article wash functions
332 ;; If you are interested, you can add following function(s) to the
333 ;; `gnus-article-display-hook'
335 ;; o `tinygnus-article-fix-msword-quotes'
337 ;; Debuging Gnus: can't select group
339 ;; If something is wrong with the Gnus and you can't enter the group
340 ;; for a reason or another, something has happened to your setup.
341 ;; There is *experimental* funtions in this package that may shed some
342 ;; help. The first thing to try is calling
343 ;; `tinygnus-gnus-debug-investigate-problem' Which asks for a group
344 ;; name, give fully qualifies name like "nnml:list.ding". This
345 ;; function is geared towards debugging nnml groups, so you may
346 ;; not benefit a lot for other backends.
348 ;; Thre is no detailled instructions how to fix the situation after
349 ;; the function has run, but the printed results in
350 ;; `tinygnus-:debug-buffer' should at least give better clues. LOOK
351 ;; CLOSELY THE RESULTS. And supply them to gnus newsgroup or mailing
352 ;; list. Maybe someone can by looking at the values what's the
355 ;; o It's mostly trial and error; after you get used to reading
356 ;; what values are important and what to do with it.
357 ;; o The `tinygnus-gnus-debug-investigate-problem' is EXPERIMENTAL
358 ;; and it is not guarranteed to work with any Gnus version.
359 ;; It was created to debug setup problems with 5.8.2 1999-12-24.
361 ;; Gnus summary minor mode
363 ;; `tinygnus-summary-mode' is turned on when summary buffer gets
364 ;; created. There are some keybindings that you may wish to
365 ;; relocate for faster access, e.g. the search functions that
366 ;; repeat the last search. In Gnus, pressing Esc-s to search again
367 ;; would require a confirmation of the search string each time,
368 ;; while using ``tinygnus-gnus-summary-search-article-forward' uses
369 ;; the supplied string immediatedly. To relocate keys, use this code:
371 ;; (defun my-tinygnus-summary-mode-hook ()
372 ;; "Define new keybindings."
373 ;; (let* ((map tinygnus-:summary-mode-map))
374 ;; (define-key map [(alt ?<)]
375 ;; 'tinygnus-gnus-summary-search-article-forward)
376 ;; (define-key map [(control ?<)]
377 ;; 'tinygnus-gnus-summary-search-article-backward)))
379 ;; (add-hook 'tinygnus-summary-mode-hook
380 ;; 'my-tinygnus-summary-mode-hook)
392 ;;; ......................................................... &require ...
395 (message (locate-library "gnus")) ;; Leave location to compile output
396 ;; 2000-01 When compiling CVS gnus with XEmacs ....
400 (message " ** tinygnus.el: Wow, (require 'gnus) dies on error %s"
401 (prin1-to-string err)))))
407 (autoload 'gnus-summary-mark-article "gnus-sum")
408 (autoload 'gnus-summary-select-article "gnus-sum")
409 (autoload 'gnus-summary-work-articles "gnus-sum")
410 (autoload 'gnus-summary-move-article "gnus-sum")
411 (autoload 'gnus-summary-show-all-threads "gnus-sum")
412 (autoload 'gnus-summary-first-subject "gnus-sum")
413 (autoload 'gnus-summary-mark-article-as-read "gnus-sum")
414 (autoload 'gnus-summary-find-next "gnus-sum")
415 (autoload 'gnus-summary-mark-as-read-forward "gnus-sum")
416 (autoload 'gnus-summary-mark-as-expirable "gnus-sum")
417 (autoload 'gnus-summary-search-article-forward "gnus-sum")
418 (autoload 'gnus-read-move-group-name "gnus-sum")
419 (autoload 'gnus-set-global-variables "gnus-sum")
420 (autoload 'gnus-set-mode-line "gnus-sum")
421 (autoload 'nnfolder-group-pathname "nnfolder")
424 (ti::package-use-dynamic-compilation)
428 ;; Yes, this variable is purposively put to "tinypath" package.
429 ;; See that package for better explanation.
431 (defconst tinypath-:gnus-load-path
432 (locate-library "gnus"))
433 (message "tinygnus.el: Gnus path %s"
434 (or tinypath-:gnus-load-path "<path not found>"))
435 (defvar bbdb/gnus-summary-show-bbdb-names)
436 (defvar bbdb/gnus-summary-prefer-bbdb-data)
437 (defvar bbdb/gnus-summary-prefer-real-names)
438 (defvar bbdb/gnus-summary-mark-known-posters)
439 (defvar bbdb-message-marker-field)
440 (defvar bbdb/gnus-summary-known-poster-mark)
441 (defvar bbdb-canonicalize-net-hook)
442 (defvar gnus-last-search-regexp)
443 (defvar gnus-expirable-mark)
444 (defvar gnus-init-inhibit)
445 (defvar mail-send-hook)
446 (defvar tinyurl-mode)
447 (defvar gnus-version)
448 (if (not (locate-library "bbdb"))
450 tinymail.el: ** No bbdb.el along load-path. Please do not compile this file.
451 http://bbdb.sourceforge.net/")
452 (autoload 'bbdb-search-simple "bbdb")
453 (autoload 'bbdb-canonicalize-address "bbdb")
454 (autoload 'bbdb-record-net "bbdb")
455 (autoload 'bbdb-record-getprop "bbdb")
456 (autoload 'bbdb-record-name "bbdb")))
459 ;;{{{ trquire: advanced
463 ;; (autoload 'mail-header-extra "nnheader.el" "" nil 'macro) ;; 2000-01 Gnus
465 ;; ................................................... version check ...
467 (defun tinygnus-check-gnus-installation-libraries ()
468 "Verify that new enough Gnus version is installed to the Emacs."
472 (let* ((name (if (stringp lib)
474 (prin1-to-string lib)))
475 (path (locate-library name))
476 (status (ignore-errors
479 (load path 'noerr)))))
481 (message "TinyGnus: ** [ERROR] couldn't load %s %s. "
485 "Load error or package not along `load-path'."
486 " Please check Gnus path>")))
488 (dolist (lib '(gnus-group
494 ;; mm-util defined mm-char-int, which is used
495 ;; in gnus.el::gnus-continuum-version
497 ;; => continuum fails, if mm-char-int is not defined.
502 (defun tinygnus-check-gnus-installation-gnus ()
503 "Verify that new enough Gnus version is installed to the Emacs."
504 ;; Standard Gnus than comes with Old Emacs versions
505 ;; is not accepted. User must be running development
506 ;; version of Gnus or the latest Emacs
508 (unless (or (ti::emacs-p "21.1")
509 (ti::xemacs-p "21.4"))
510 (message (emacs-version))
513 ;; Win32 installs to emacs-20.6
514 "emacs-[0-9]+\\.[0-9]+"
515 ;; Unix Emacs installs to /usr/share/emacs/20.6/lisp/
516 "\\|/emacs/[0-9]+\\.[0-9]+/")
517 (or tinypath-:gnus-load-path
518 (locate-library "gnus")
521 (defun tinygnus-check-gnus-installation-emacs ()
522 "Verify that new enough Gnus version is installed to the Emacs."
524 ((not (fboundp 'mail-header-extra))
525 "nnheader.el::mail-header-extra was not defined.")
526 ((tinygnus-check-gnus-installation-gnus))))
528 (defun tinygnus-check-gnus-installation ()
529 "Verify that new enough Gnus version is installed to the Emacs."
530 (let* ((i (tinygnus-check-gnus-installation-libraries))
533 (when (string-match "rest" (ti::function-args-p 'mm-char-int))
534 ;; Hm, the function is alias to `ignore', fix it.
535 (defalias 'mm-char-int 'identity))
539 (format "%d load errors happened" i)
540 (tinygnus-check-gnus-installation-emacs)))
544 ** tinygnus.el: [Error: %s]
546 Emacs version is %s. %s
547 This file works and compiles only with the very
548 latest development gnus.
549 http://www.gnus.org/dist/ => gnus.tar.gz (see time stamps)
550 Be sure to include latest Gnus along the `load-path'
551 when you compile this file.
552 If you do not plan to use Gnus, ignore this message.
553 -- You will now see load aborted message --"
555 (if (boundp 'gnus-version)
557 "<error loading gnus.el>")
560 "\n ** tinygnus.el: [Gnus from Emacs installation - no good]"
562 (error "Load aborted. See *Messages* buffer"))))
564 (tinygnus-check-gnus-installation))
567 ;;{{{ setup: variables
569 (ti::package-defgroup-tiny TinyGnus tinygnus-: extensions
570 "Gnus utilities grabbag.")
572 (defcustom tinygnus-:load-hook nil
573 "*Hook run when file has been loaded."
577 (defcustom tinygnus-:summary-ube-send-to-postmasters-hook nil
578 "Hook run after each UBE message has been forwarded to postmasters."
582 (defcustom tinygnus-:article-ube-send-to-postmasters-hook nil
583 "Hook run after the UBE forward has been composed.
585 `tinygnus-article-ube-send-to-postmasters'
586 `tinygnus-:use-postmaster-addresses'"
590 ;; but it was not a good idea to reduce to top level domain.
593 ;; nslookup sdn-ts-037txfwoRP08.dialsprint.net OK
594 ;; nslookup dialsprint.net NOK
596 ;; So the top level domain addresses are not necessarily reliable.
597 ;; Hm. Too bad. This could have been general function, but now it seems that
598 ;; you have to use some regexp based function
600 ;; xx.aol.com --> aol.com
603 (defcustom tinygnus-:canonilize-ip-functions
604 '(tinygnus-domain tinygnus-article-received-top-level-domain-maybe)
605 "List of function to change host address.
606 Function should top level domain for passed HOST.
607 Eg: '(\"aa.foo.com\" \"bb.foo.com\") --> '(\"foo.com\")
609 `tinygnus-:domain-table'"
610 :type '(list function)
613 (defcustom tinygnus-:ube-forward-mail-addresses
614 ;; "uce@ftc.gov" no more active
616 "*Addresses of archives where to send UBE messages."
620 (defcustom tinygnus-:show-dormants t
621 "*If non-nil, show dormants immediately when entering non-nntp group.
622 Some people like to use dormant mark ? as `important todo' in their
623 private mail groups, while gnus usually reserves dormant mark to
624 articles that do not need to show up if there is no replies."
628 (defcustom tinygnus-:save-mail-notify-regexp (user-login-name)
629 "Regexp to match To field when mail is saved.
630 A message is printed in the echo area when the regexp matches.
632 `tinygnus-save-mail-notify'"
636 (defcustom tinygnus-:nslookup-file
637 (ti::package-config-file-prefix "tinygnus.el")
638 "File where to store `tinygnus-:nslookup-table' cache.
639 This speeds up processing the UBE messages so that nslookup hosts can
640 be found from cache instead of calling expensive `nslookup'"
644 (defcustom tinygnus-:z nil ;; ".gz"
645 "*Extension to use in .newsrc and .eld files.
646 If you set this to `.gz' then compressed files are in use.
647 You have to reload the package every time you change this settings."
651 (defcustom tinygnus-:gnus-version-for-advice "."
652 "Which version of gnus should have compressed .eld.gz support."
656 (defcustom tinygnus-:ube-exclude-ip-regexp nil
657 "Regexp to matc IP domains that are not included in SPAM complain.
658 When function `tinygnus-ube-send-to-postmasters' is called, all the IP
659 addresses in Received headers are gathered and a message to all
660 ostmasters are composed. This regexp filter out the read IP addresses.
662 A good value would be to filter out your local domain."
666 (defcustom tinygnus-:ube-abuse-account-table
667 '(("aol\\|globecomm\\|nortel\\.net\\|\\<usa\\.net"
672 . "postmaster@attglobal.net")
677 "The account address where to send complaint.
678 Many domains have opened `abuse' address in addition to RFC `postmaster'.
680 1) If regexp matches the domain, the complaint is directed to `ACCOUNT@DOMAIN'
681 2) If the ACCOUNT contains `@', then the ACCOUNT is supposed to have complete
682 email address where to send complaint
688 :type '(repeat (list regexp (string :tag "Account")))
691 (defcustom tinygnus-:domain-table
692 '(("aol\\." . "aol.com")
693 ("soon\\.fi" . "soon.fi")
694 ("yahoo" . "yahoo.com")
695 ("wanadoo" . "wanadoo.fr")
696 ("compuserve" . "compuserve.com")
697 ("dialsprint" . "dialsprint.net")
698 ("\\<uu\\.net\\>" . "uu.net"))
699 "If REGEXP match address, use DOMAIN-ADDRESS.
700 This table will efectively filter out duplicate addresses, e.g.
701 xx.foo.com yy.foo.com are same as foo.com
704 '((REGEXP . DOMAIN-ADDRESS)
705 (REGEXP . DOMAIN-ADDRESS)
707 :type '(repeat (list regexp (string :tag "Domain")))
710 (defcustom tinygnus-:uff-table
712 ;; *Group* buffer format functions in big letter
714 (?C tinygnus-uff-group-comment)
715 (?E tinygnus-uff-group-expiry)
716 (?F tinygnus-uff-summary-line-bbdb)
717 (?N tinygnus-uff-message-count)
718 (?T tinygnus-uff-group-tick)
719 (?Z tinygnus-uff-group-file-size)
723 (?d tinygnus-uff-summary-date))
724 "The gnus-user-format-function map table.
732 The CH is the `X' character is used to run gnus-user-format-fnction-X
733 where the FUNCTION will be mapped. For example if you want to
734 run expiry function through %uE modified the elt in the pable is
736 (?E tinygnus-uff-group-expiry)"
738 (char :tag "gnus-user-format-fnction-")
739 (symbol :tag "Used TinyGnus function"))
742 (defcustom tinygnus-:uff-summary-date
743 '(format "%02d-%02d" (string-to-int date-mon) date-day)
744 "This variable contain Lisp FORM to return summary line date string.
745 If you want to customize this variable you have to look at the source
746 code of `tinygnus-uff-summary-date' and use the dynamically bound variables.
750 '(format \"%02d-%02d\" (string-to-int date-mon) date-day)
752 Which returns ISO date parts YY-MM. It is good to selects as brief
753 date string as possible because the summary line is quite crowded place.
755 Here is value for YY-MM-DD:
757 '(format \"%s-%02d-%02d\"
758 (ti::string-right date-yyyy 2)
759 (string-to-int date-mon)
764 (defcustom tinygnus-:expiry-in-group-string "."
765 "Character to add to the end of expiry count if value is defined in group.
766 When `tinygnus-uff-group-expiry' is called the number of days is returned.
767 But if the expiry-wait is defined in group parameters, this string
768 is added to the number."
772 (defcustom tinygnus-:additional-group-info
773 '((gcc-self t eq "g")
774 (total-expire t eq "t"))
775 "*What additional grup parameter `tinygnus-uff-group-expiry' would return.
776 When GROUP-PARAM run agains TEST is equal to VALUE then
777 return RETURNED-STRING. You should return only one character in
778 string to save space.
780 For example the following entry
782 (gcc-self t eq \"c\")
784 Will cause following test, the GCC-SELF-VALUE is read from group.
786 (if (eq GCC-SELF-VALUE t) ..return \"c\")
789 '((GROUP-PARAM VALUE TEST RETURNED-STRING)
792 (symbol :tag "Group param")
793 (sexp :tag "wanted value")
794 (function :tag "test function")
795 (string :tag "returned val"))
798 (defcustom tinygnus-:get-news-symbolic-levels
799 '(("primary Mail" . 1)
800 ("secondary Mail" . 2)
801 ("mailing lists" . 3)
802 ("mail, some" . '(1 2 3))
804 ("News, all" . 'gnus-group-get-new-news)
805 ("Mail, all" . 'gnus-group-get-new-mail))
806 "*Symbolic `gnus-get-new-news' levels.
809 '((COMPETION-STRING . NUMBER-OR-FUNCTION-OR-LIST)
814 The completion name is offered when you call
815 `tinygnus-gnus-group-get-news-symbolic' and all news at level NUMBER is
818 NUMBER-OR-FUNCTION-OR-LIST
820 If the parameter is number, News in that Group level is read.
822 If the cdr parameter is function, then the function is called
825 If the parmeter is list of numbers like '(1 2) then all news on
826 those group levels are read."
835 (defvar tinygnus-:use-postmaster-addresses nil
836 "Variable contains postmaster address used to compose UBE response.
837 You can use this in `tinygnus-:article-ube-send-to-postmasters-hook'
838 This variable also has following properties: 'ip-list 'ns-list (nslookup)")
840 (defvar tinygnus-:output-buffer "*tinygnus-buffer*"
841 "Temporary buffer to store miscellaneous user selected information.")
843 ;; Reloading file will reset this; which is good.
844 ;; By sitting on the Group Line in *Group* Try
846 ;; (get 'tinygnus-:gnus-group-info (make-symbol (gnus-group-group-name)))
847 ;; (symbol-plist 'tinygnus-group-info)
849 (defconst tinygnus-:gnus-group-info nil
850 "Miscellaneous group information kept in property list.
851 Keyed by full prefixed group name.")
853 (defvar tinygnus-:nslookup-table nil
854 "List of nslookup's.")
859 ;;; ........................................................... &debug ...
861 ;;;###autoload (autoload 'tinygnus-debug-toggle "tinygnus" "" t)
862 ;;;###autoload (autoload 'tinygnus-debug-show "tinygnus" "" t)
864 (eval-and-compile (ti::macrof-debug-standard "tinygnus" "-:"))
870 ;;;###autoload (autoload 'tinygnus-version "tinygnus" "Display commentary." t)
873 (ti::macrof-version-bug-report
877 "$Id: tinygnus.el,v 2.72 2007/08/03 20:16:25 jaalto Exp $"
878 '(tinygnus-:version-id
881 tinygnus-:gnus-group-info
882 tinygnus-:summary-ube-send-to-postmasters-hook
883 tinygnus-:article-ube-send-to-postmasters-hook
884 tinygnus-:canonilize-ip-functions
885 tinygnus-:ube-forward-mail-addresses
886 tinygnus-:output-buffer
887 tinygnus-:nslookup-table
888 tinygnus-:show-dormants
889 tinygnus-:save-mail-notify-regexp
890 tinygnus-:nslookup-file
892 tinygnus-:gnus-version-for-advice
893 tinygnus-:ube-exclude-ip-regexp
894 tinygnus-:ube-abuse-account-table
895 tinygnus-:use-postmaster-addresses
896 tinygnus-:domain-table
898 tinygnus-:uff-summary-date
899 tinygnus-:expiry-in-group-string
900 tinygnus-:additional-group-info
901 tinygnus-:get-news-symbolic-levels)
902 '(tinygnus-:debug-buffer)))
904 ;;;###autoload (autoload 'tinygnus-summary-install-mode "tinygnus" "" t)
905 ;;;###autoload (autoload 'tinygnus-summary-mode "tinygnus" "" t)
906 ;;;###autoload (autoload 'turn-on-tinygnus-summary-mode "tinygnus" "" t)
907 ;;;###autoload (autoload 'turn-off-tinygnus-summary-mode "tinygnus" "" t)
908 ;;;###autoload (autoload 'tinygnus-summary-commentary "tinygnus" "" t)
909 ;;;###autoload (autoload 'tinygnus-summary-version "tinygnus" "" t)
912 (ti::macrof-minor-mode-wizard
913 "tinygnus-summary-" " Tg" "\C-c'" "Tgnus" 'TinyGnus "tinygnus-:summary-"
916 This minor mode defines some additional commands to Gnus Group buffer.
917 See also `tinygnus-summary-mode'
921 Prefix key to access the minor mode is defined in
922 `tinygnus-:summary-mode-prefix-key' which is by deafult C - c '
924 \\{tinygnus-:summary-mode-prefix-map}"
926 "Gnus summary mode extras"
927 (progn ;Some mode specific things
928 (when (and tinygnus-summary-mode
929 (not (eq major-mode 'gnus-summary-mode)))
930 (setq tinygnus-summary-mode nil)
932 "TinyGnus mode can only be used in summary buffer. Mode is now `%' "
933 (symbol-name major-mode))))
934 "TinyGnus summary mode"
936 tinygnus-:summary-mode-easymenu-name
938 ["Repeat search forward" tinygnus-gnus-summary-search-article-forward t]
939 ["Repeat search backward" tinygnus-gnus-summary-search-article-backward t]
941 ["Send UBE complaint" tinygnus-summary-ube-send-to-postmasters t]
942 ["Catchup, expire" tinygnus-gnus-summary-catchup-with-expire-all t]
943 ["Catchup this user" tinygnus-summary-expunge-all-from-user t]
944 ["Catchup, expire non-replied"
945 tinygnus-gnus-summary-catchup-with-expire-not-replied t]
946 ["Catchup, read" tinygnus-gnus-summary-catchup-with-read-all t]
947 ;;; ["Toggle original" tinygnus-summary-toggle-original t]
949 ["Gather headers" tinygnus-summary-gather-headers t]
950 ["Gather URLs" tinygnus-summary-gather-urls t]
951 ["Gather, display buffer" tinygnus-summary-gather-display t]
952 ["Gather, clear buffer" tinygnus-summary-gather-clear t]
954 ["Toggle original article" tinygnus-summary-toggle-original t]
955 ["Reload Gnus init file" tinygnus-gnus-group-read-init-file t]
957 ["Debug show" tinygnus-debug-show t]
958 ["Debug TinyGnus" tinygnus-debug-toggle t]
960 ;; ["Keyboard menu" tinygnus-menu-main t]
961 ["Package version" tinygnus-summary-version t]
962 ["Package commentary" tinygnus-summary-commentary t]
963 ["Mode help" tinygnus-summary-mode-help t]
964 ["Mode off" turn-off-tinygnus-summary-mode t])
966 (define-key map "M" 'tinygnus-summary-move-article)
967 ;; And the X-window keys, Unfortunately these may be
968 ;; be under the ESC key in some keyboards.
969 ;; see also `w32-alt-is-meta'
970 (define-key root-map [(alt s)]
971 'tinygnus-gnus-summary-search-article-forward)
972 (define-key root-map [(alt r)]
973 'tinygnus-gnus-summary-search-article-backward)
974 (define-key map "u" 'tinygnus-summary-ube-send-to-postmasters)
975 (define-key map "e" 'tinygnus-gnus-summary-catchup-with-expire-all)
976 (define-key map "E" 'tinygnus-gnus-summary-catchup-with-expire-not-replied)
977 (define-key map "C" 'tinygnus-summary-expunge-all-from-user)
978 (define-key map "d" 'tinygnus-gnus-summary-catchup-all-with-delete)
979 (define-key map "r" 'tinygnus-gnus-group-read-init-file)
980 (define-key map "t" 'tinygnus-summary-compose-current-mail-as-template)
981 (define-key map " " 'tinygnus-summary-toggle-original)
982 (define-key map "gh" 'tinygnus-summary-gather-headers)
983 (define-key map "gu" 'tinygnus-summary-gather-urls)
984 (define-key map "gd" 'tinygnus-summary-gather-display)
985 (define-key map "gc" 'tinygnus-summary-gather-clear)
986 (define-key map "Ds" 'tinygnus-debug-show)
987 (define-key map "Ds" 'tinygnus-debug-toggle)
988 (define-key map "?" 'tinygnus-summary-mode-help)
989 (define-key map "Hm" 'tinygnus-summary-mode-help)
990 (define-key map "Hc" 'tinygnus-summary-commentary)
991 (define-key map "Hv" 'tinygnus-summary-version)
992 (define-key map "x" 'turn-off-tinygnus-summary-mode))))
994 ;;; ----------------------------------------------------------------------
996 ;;;###autoload (autoload 'tinygnus-group-install-mode "tinygnus" "" t)
997 ;;;###autoload (autoload 'tinygnus-group-mode "tinygnus" "" t)
998 ;;;###autoload (autoload 'turn-on-tinygnus-group-mode "tinygnus" "" t)
999 ;;;###autoload (autoload 'turn-off-tinygnus-group-mode "tinygnus" "" t)
1000 ;;;###autoload (autoload 'tinygnus-group-commentary "tinygnus" "" t)
1001 ;;;###autoload (autoload 'tinygnus-group-version "tinygnus" "" t)
1004 (ti::macrof-minor-mode-wizard
1005 "tinygnus-group-" " Tg" "\C-c'" "Tgnus" 'TinyGnus "tinygnus-:group-"
1011 Prefix key to access the minor mode is defined in `tinygnus-:group-mode-prefix-key'
1013 \\{tinygnus-:group-mode-prefix-map}"
1015 (progn ;Some mode specific things
1016 (when (and tinygnus-group-mode
1017 (not (eq major-mode 'gnus-group-mode)))
1018 (setq tinygnus-group-mode nil)
1019 (error "Mode Can only be used in Gnus Group buffer.")))
1020 "Gnus group mode extras"
1022 tinygnus-:group-mode-easymenu-name
1023 ["Read news with symbolic levels" tinygnus-gnus-group-get-news-symbolic t]
1024 ["Crash box delete" tinygnus-crash-box-delete t]
1025 ["Crash box find-file" tinygnus-crash-box-find-file t]
1026 ;;; ["Make group from file" tinygnus-make-group-from-file t]
1028 ["Set Group level in region" tinygnus-group-set-current-level-region t]
1029 ["Add to-list mailing list parameter" tinygnus-group-parameter-mailing-list t]
1030 ["nndoc Create groups from directory" tinygnus-make-group-from-dir-nndoc t]
1031 ["nnml Read procmail spool and make groups"
1032 tinygnus-make-group-from-dir-nnml-procmail-spool t]
1033 ["nnml Recreate marked groups" tinygnus-make-group-nnml t]
1034 ["nnml Create groups from directory" tinygnus-make-group-nnml-from-dir t]
1036 ["Debug show" tinygnus-debug-show t]
1037 ["Debug TinyGnus" tinygnus-debug-toggle t]
1038 ["Debug Gnus group" tinygnus-gnus-debug-investigate-problem t]
1040 ["Reload Gnus init file" tinygnus-gnus-group-read-init-file t]
1041 ["Package version" tinygnus-group-version t]
1042 ["Package commentary" tinygnus-group-commentary t]
1043 ["Mode help" tinygnus-group-mode-help t]
1044 ["Mode off" turn-off-tinygnus-group-mode t])
1046 ;; The ' prefix is usually free
1047 ;; "c" map for CrashBox
1048 (define-key map "g" 'tinygnus-gnus-group-get-news-symbolic)
1049 (define-key map "cd" 'tinygnus-crash-box-delete)
1050 (define-key map "cf" 'tinygnus-crash-box-find-file)
1051 (define-key map "mn" 'tinygnus-make-group-nnml)
1052 (define-key map "mN" 'tinygnus-make-group-nnml-from-dir)
1053 (define-key map "mf" 'tinygnus-make-group-from-file)
1054 (define-key map "md" 'tinygnus-make-group-from-dir-nndoc)
1055 (define-key map "mp" 'tinygnus-make-group-from-dir-nnml-procmail-spool)
1056 (define-key map "ds" 'tinygnus-debug-show)
1057 (define-key map "dd" 'tinygnus-debug-toggle)
1058 (define-key map "dgo" 'tinygnus-gnus-debug-on)
1059 (define-key map "dgf" 'tinygnus-gnus-debug-off)
1060 (define-key map "dgi" 'tinygnus-gnus-debug-investigate-problem)
1061 (define-key map "pm" 'tinygnus-group-parameter-mailing-list)
1062 (define-key map "lr" 'tinygnus-group-set-current-level-region)
1063 (define-key map "N" 'tinygnus-move-group-to-native-nnml)
1064 (define-key map "?" 'tinygnus-group-mode-help)
1065 (define-key map "Hm" 'tinygnus-group-mode-help)
1066 (define-key map "Hc" 'tinygnus-group-commentary)
1067 (define-key map "Hv" 'tinygnus-group-version)
1068 (define-key map "r" 'tinygnus-gnus-group-read-init-file)
1069 (define-key map "x" 'turn-off-tinygnus-group-mode))))
1071 ;;; ----------------------------------------------------------------------
1073 (defun tinygnus-group-help ()
1076 (describe-function 'tinygnus-group-mode))
1078 ;;; ----------------------------------------------------------------------
1080 (defun tinygnus-gnus-group-read-init-file ()
1081 "Read Gnus init file always. sets `init-file-user' to t."
1084 ;; Without these Gnus won't read the init file
1085 ;; ´letf' is needed, because you cannot have macro expansion
1086 ;; inside special form `let'. `letf' is just like let, but
1087 ;; all values must be in (var value) format.
1089 (letf ((gnus-init-inhibit nil)
1090 ((ti::compat-load-user-init-file) t))
1091 (gnus-group-read-init-file)))
1096 ;;; ----------------------------------------------------------------------
1099 (defun tinygnus-install (&optional uninstall)
1100 "Install package. Optionally UNINSTALL."
1102 (let* ((list '((gnus-group-mode
1103 gnus-group-mode-hook
1104 (turn-on-tinygnus-group-mode))
1106 gnus-summary-mode-hook
1107 (turn-on-tinygnus-summary-mode))
1109 gnus-article-mode-hook
1110 (tinygnus-article-mode-keys))))
1113 (tinygnus-uff-table-install)
1114 (ti::add-hooks 'tinygnus-:summary-ube-send-to-postmasters-hook
1115 'tinygnus-mark-deleted
1117 (ti::add-hooks 'tinygnus-:summary-mode-define-keys-hook
1118 'tinygnus-summary-mode-define-keys
1120 (ti::add-hooks 'tinygnus-:group-mode-define-keys-hook
1121 'tinygnus-group-mode-define-keys
1123 (ti::add-hooks 'tinygnus-:article-ube-send-to-postmasters-hook
1124 '(tinygnus-ube-cc-spam-archive
1125 tinygnus-ube-postmaster-inform)
1127 ;; Run the hook functions immediately if GNUS is already present.
1128 (ti::dolist-buffer-list
1129 (memq major-mode (mapcar 'car list))
1133 (dolist (func (nth 2 (assq major-mode list)))
1136 (setq hook (nth 1 elt)
1137 hook-list (nth 2 elt))
1138 (ti::add-hooks hook hook-list uninstall))))
1140 ;;; ----------------------------------------------------------------------
1142 (defun tinygnus-article-mode-keys ()
1143 "Install default keybindings to GNUS map."
1144 (define-key gnus-article-mode-map "U"
1145 'tinygnus-article-ube-send-to-postmasters))
1147 ;;; ----------------------------------------------------------------------
1149 (defun tinygnus-uff-table-install ()
1150 "Install `tinygnus-:uff-table'. Previous Gnus user functions will be wiped."
1154 (dolist (elt tinygnus-:uff-table)
1155 (unless (fboundp (setq func (nth 1 elt)))
1156 (error "Internal error. tinygnus-:uff-table, No func %s" func))
1158 (intern (format "gnus-user-format-function-%s"
1159 (char-to-string (car elt)))))
1160 (defalias gnus-func func))))
1165 ;;; ----------------------------------------------------------------------
1167 (defun tinygnus-gnus-compile ()
1168 "Compile all that is needed to get peak performance."
1170 (tinygnus-gnus-compile-1
1171 (mapcar (function (lambda (x) (car x)))
1172 tinygnus-:uff-table)))
1174 ;;; ----------------------------------------------------------------------
1176 (defun tinygnus-gnus-compile-1 (char-list)
1177 "Compile the line formats and their user functions: CHAR-LIST."
1179 (let* ((fmt "gnus-user-format-function-%s")
1182 (message "TinyGnus: Compiling relevant parts...")
1183 (save-window-excursion ;; Gnus and Compile changes the windowcfg
1185 ;; File: gnus, Node: Compilation
1187 ;; format specification variables ... `M-x' `gnus-compile' after you've
1188 ;; This will result in the new specs being byte-compiled, and you'll get
1191 ;; ...user-generated function %uX are not compiled though
1192 ;; See also M-x `gnus-update-format'
1194 (dolist (ch char-list)
1195 (setq func (format fmt (char-to-string ch)))
1196 (setq sym (intern-soft func))
1197 ;;; (ti::d! func (fboundp sym))
1198 (if (not (fboundp sym))
1199 (error "Not exist: %s" func)
1200 (byte-compile sym)))
1201 ;; see if we can find this
1202 (when (not (fboundp 'gnus-update-format-specifications))
1203 (load "gnus-spec" 'noerr))
1204 ;; Update all formats in all Gnus buffer.
1205 ;; Node: Formatting Variables
1206 ;; Currently Gnus uses the following formatting variables:
1208 ((fboundp 'gnus-update-format-specifications)
1209 (ti::funcall 'gnus-update-format-specifications 'force))
1210 ((fboundp 'gnus-update-format) ;19.34
1211 (dolist (var '("gnus-group-line-format"
1212 "gnus-group-mode-line-format"
1213 "gnus-summary-line-format"
1214 "gnus-summary-mode-line-format"
1215 ;; Don't compile these because would require
1216 ;; unnecessary packages
1217 ;; "gnus-topic-line-format"
1218 ;; "gnus-server-mode-line-format"
1219 ;; "gnus-server-line-format"
1220 "gnus-article-mode-line-format"))
1221 ;; Use caution, I have several Gnus versions around.
1222 ;; Define only those that exist.
1223 (when (and (intern-soft var) (boundp (intern-soft var)))
1224 (gnus-update-format var)))))
1225 (if (get-buffer "*Gnus Format*") ;Where did this come from?
1226 (kill-buffer "*Gnus Format*")))
1227 ;; Too bad that this command gives compilation errors because
1228 ;; the variables are dynamically bound in each user function
1229 (when (fboundp 'gnus-compile) ;New Gnus only
1235 ;;; ----------------------------------------------------------------------
1237 (defmacro tinygnus-set-group ()
1238 "Set variable `group'."
1240 (setq group (symbol-value 'gnus-newsgroup-name))
1241 (error "Can't know the group"))))
1243 ;;; ----------------------------------------------------------------------
1245 (put 'tinygnus-summary-map-articles-macro 'lisp-indent-function 0)
1246 (defmacro tinygnus-summary-map-articles-macro (&rest body)
1247 "Map through marked mesaes in Summary buffer and execute BODY.
1248 The variable `nbr' has the current article number. Use command
1249 (return) to stop the loop."
1251 (let* ((articles (gnus-summary-work-articles nil))
1252 gnus-article-display-hook ;Do not run this
1253 gnus-article-prepare-hook
1254 gnus-select-article-hook
1255 gnus-article-mode-hook
1256 gnus-visual-mark-article-hook)
1257 ;; ByteComp silencer, unused variables
1258 (if gnus-article-display-hook (setq gnus-article-display-hook t))
1259 (if gnus-article-prepare-hook (setq gnus-article-prepare-hook t))
1260 (if gnus-select-article-hook (setq gnus-select-article-hook t))
1261 (if gnus-article-mode-hook (setq gnus-article-mode-hook t))
1262 (if gnus-visual-mark-article-hook (setq gnus-visual-mark-article-hook t))
1263 ;; (gnus-summary-save-process-mark)
1264 (dolist (nbr articles)
1267 ;;; ----------------------------------------------------------------------
1269 (put 'tinygnus-summary-map-article-body-macro 'lisp-indent-function 0)
1270 (defmacro tinygnus-summary-map-article-body-macro (&rest body)
1271 "Run BODY inside articles that are marked.
1272 Variable `out' contains the output buffer and `buffer' points
1273 to the article buffer."
1275 (let* ((out (get-buffer-create tinygnus-:output-buffer))
1277 (tinygnus-summary-map-articles-macro
1278 (gnus-summary-select-article 'all nil 'pseudo nbr)
1279 (setq buffer (get-buffer gnus-original-article-buffer))
1281 (with-current-buffer buffer
1285 ;;; ----------------------------------------------------------------------
1287 (put 'tinygnus-output-buffer-macro 'lisp-indent-function 0)
1288 (defmacro tinygnus-output-buffer-macro (&rest body)
1289 "Run BODY if `tinygnus-:output-buffer' exists. Signal error otherwise."
1291 (let* ((buffer (get-buffer tinygnus-:output-buffer)))
1294 (error "TinyGnus: buffer %s does not exist." tinygnus-:output-buffer)))))
1296 ;;; ----------------------------------------------------------------------
1298 (defmacro tinygnus-files-from-dir-macro (dir &rest body)
1299 "Read all files from DIR and do BODY.
1300 You can refer to `file' when processing the files. Stop loop with
1303 (let* ((files (tinygnus-read-files-from-dir (, dir))))
1304 (when (or (not (interactive-p))
1305 (and (interactive-p)
1308 "Found %d files, Proceed " (length files)))))
1309 (dolist (file files)
1312 ;;; ----------------------------------------------------------------------
1314 (put 'tinygnus-summary-map-lines 'lisp-indent-function 0)
1315 (defmacro tinygnus-summary-map-line-macro (&rest body)
1316 "Map line by line and run BODY in Summary buffer."
1322 (forward-line 1)))))
1324 ;;; ----------------------------------------------------------------------
1327 (defun tinygnus-mark-deleted ()
1328 "Mark current article expirable(mail) or deleted(news)."
1331 ((string-match "nntp" gnus-newsgroup-name )
1332 (gnus-summary-mark-article nil))
1334 (gnus-summary-mark-article gnus-expirable-mark))))
1336 ;;; ----------------------------------------------------------------------
1338 (defun tinygnus-compose-return-address (address)
1339 "Check that ADDRESS is usable. Discard er 0.0.0.
1340 Returns [N.N.N] for pure ip addresses."
1342 ;; Drop addresses ^000.* or .0.0
1343 ((string-match "^0+\\.\\|\\.0+\\.0|^127" address))
1344 ((string-match "^[0-9.]+$" address)
1345 (format "[%s]" address))
1346 (address))) ;Return as is
1348 ;;; ----------------------------------------------------------------------
1349 ;;; #todo: Actually how can we tell when the address is same in the domain?
1351 ;;; postmaster@hub6.compuserve.com is same as postmaster@compuserve.com
1353 ;;; And we don't want to send duplicates, ehm?
1355 ;;;(defun tinygnus-address-uniquefy (list)
1356 ;;; "Leave only shortest domain name: like DOMAIN.com over some.DOMAIN.com"
1357 ;;; (let* (array ret domain)
1358 ;;; (dolist (elt list)
1359 ;;; (setq array (split-string elt "[.]")
1360 ;;; domain (nth 1 (nreverse array))))))
1362 ;;; ----------------------------------------------------------------------
1364 (defun tinygnus-ube-cc-spam-archive ()
1365 "Send copy of message to SPam archives.
1367 http://www.spam-archive.org/ --> spam-list@toby.han.de
1368 http://www.ftc.gov/os/9806/email.htm --> uce@ftc.gov"
1369 (dolist (address tinygnus-:ube-forward-mail-addresses)
1370 (ti::mail-add-to-field-string "CC" address "To")))
1372 ;;; ----------------------------------------------------------------------
1374 (defun tinygnus-ube-postmaster-inform ()
1375 "Add a short Preface chapter to postmasters about UBE."
1376 (ti::mail-text-start 'move)
1379 To postmasters: Please investigate this UBE (Unsolicited Bulk Email)
1380 message and take the necessary actions to prevent delivering similar
1381 messages in the future. You may have an open SMTP Relay or there
1382 is a person that is abusing your accounts.
1384 Thank you beforehand for your co-operation to stop UBE in the net.\n"))
1386 ;;; ----------------------------------------------------------------------
1389 (defun tinygnus-nslookup-save (&optional read)
1390 "READ or save `tinygnus-:nslookup-table' to `tinygnus-:nslookup-file'.
1391 See function `tinygnus-article-ube-send-to-postmasters'."
1393 (let* ((fid "tinygnus-nslookup-save")
1394 (file tinygnus-:nslookup-file))
1395 (unless fid ;; No-op. XEmacs byte compiler silencer
1397 (when (and (stringp file)
1398 ;; 1) If we're saving, then go ahead
1399 ;; 2) If we're reading, check that file exists
1401 (file-exists-p file)))
1402 (if (string-match "\\.gz$" file)
1403 (ti::use-file-compression))
1404 (tinygnus-debug fid (if read "read") file)
1408 (put 'tinygnus-:nslookup-table 'pos (length tinygnus-:nslookup-table))
1410 "TinyGnus: nslookup loaded."))
1412 (ti::write-file-variable-state
1414 "TinyGnus.el nslookup cache file"
1415 '(tinygnus-:nslookup-table)))))))
1417 ;;; ----------------------------------------------------------------------
1419 (defun tinygnus-nslookup-maybe-save ()
1420 "Save every 5th new nslookup."
1421 (let* ((fid "tinygnus-nslookup-maybe-save")
1422 (count (get 'tinygnus-:nslookup-table 'pos))
1423 (len (length tinygnus-:nslookup-table)))
1424 (unless fid ;; No-op. XEmacs byte compiler silencer
1426 (when (or (not (integerp count))
1427 (> (- len count) 4))
1428 (tinygnus-debug fid "Calling save" len)
1429 (tinygnus-nslookup-save)
1430 (put 'tinygnus-:nslookup-table 'pos len))))
1433 ;;{{{ Article functions
1435 ;;; ----------------------------------------------------------------------
1437 (defun tinygnus-summary-expunge-all-from-user ()
1438 "Expunge all posts and followups from the current author"
1440 (save-window-excursion
1441 (gnus-summary-show-article)
1442 (gnus-summary-select-article-buffer)
1443 (let ((author (gnus-fetch-field "From")))
1444 (gnus-summary-score-entry
1445 "from" author 'substring -500000
1446 (+ (date-to-day (time-stamp-string)) gnus-score-expiry-days))
1447 (gnus-summary-score-entry
1448 "followup" author 'substring -500000
1449 (+ (date-to-day (time-stamp-string)) gnus-score-expiry-days)))))
1451 ;;; ----------------------------------------------------------------------
1453 (defun tinygnus-summary-compose-current-mail-as-template ()
1454 "Use current article as template and compose new mail."
1456 (let ((article (gnus-summary-article-number)))
1457 (gnus-setup-message 'reply-yank
1458 (gnus-summary-select-article t)
1459 (set-buffer gnus-original-article-buffer)
1460 ;; see message.el - message-supersede
1461 (let ( ;; (sender (message-fetch-field "sender"))
1462 ;; (from (message-fetch-field "from"))
1463 (buffer (current-buffer)))
1464 ;; Get a normal message buffer.
1465 (message-pop-to-buffer (message-buffer-name "mail from template"))
1466 (insert-buffer-substring buffer)
1467 (message-narrow-to-head)
1468 ;; Remove unwanted headers.
1469 (message-remove-header "Message-ID")
1470 (message-remove-header "Content-Type")
1471 (when message-ignored-supersedes-headers
1472 (message-remove-header message-ignored-supersedes-headers t))
1473 ;; insert mail-header-separator if needed
1474 (if (re-search-backward
1475 (concat "\n" mail-header-separator "\n") nil t)
1476 (goto-char (point-max))
1477 (insert mail-header-separator))
1482 (when (gnus-buffer-exists-p ,gnus-summary-buffer)
1484 (set-buffer ,gnus-summary-buffer)
1485 (gnus-cache-possibly-remove-article ,article nil nil nil t)
1486 (gnus-summary-mark-as-read ,article gnus-canceled-mark)))))
1487 message-send-actions))))
1489 ;;; ----------------------------------------------------------------------
1491 (defun tinygnus-summary-toggle-original ()
1492 "Toggle showing original article and *Article*."
1494 (let* ((wlist (ti::window-list))
1499 ;; Is there any "article" buffer in this
1501 (setq name (buffer-name (setq disp-buffer (window-buffer win))))
1502 (when (string-match "article" name)
1506 ((eq disp-buffer (get-buffer gnus-article-buffer))
1507 (if (null (setq buffer (get-buffer gnus-original-article-buffer)))
1508 (message "Can't find: %s" gnus-original-article-buffer)
1509 ;; If we didn't found the window; user occupied the full
1512 (pop-to-buffer buffer)
1513 (select-window disp-win)
1514 (switch-to-buffer buffer))
1517 (gnus-summary-select-article)
1518 (pop-to-buffer gnus-article-buffer)))))
1520 ;;; ----------------------------------------------------------------------
1522 (defun tinygnus-summary-ube-send-to-postmasters (&optional no-confirm)
1523 "Process all marked articles and send coplaint to postmasters.
1524 If NO-CONFIRM is non-nil, then the messages are enst directly without
1527 (let* ((fid "tinygnus-summary-ube-send-to-postmasters")
1530 (unless fid ;; No-op. XEmacs byte compiler silencer
1532 ;; (gnus-summary-save-process-mark)
1533 (tinygnus-summary-map-articles-macro
1534 (tinygnus-debug fid nbr)
1535 (gnus-summary-select-article 'all nil 'pseudo nbr)
1536 (message "TinyGnus: UBE processing article %d" nbr)
1537 (tinygnus-article-ube-send-to-postmasters
1538 'send (not no-confirm)
1540 (run-hooks 'tinygnus-:summary-ube-send-to-postmasters-hook)
1544 (message "TinyGnus: Mapped %d ube messgaes" count))))
1546 ;;; ----------------------------------------------------------------------
1548 (defun tinygnus-domain (address)
1549 "Change ADDRESS xx.domain.com --> domain.com using `tinygnus-:domain-table'."
1550 (let* ((ret address))
1551 (when tinygnus-:domain-table
1552 (dolist (elt tinygnus-:domain-table)
1553 (when (string-match (car elt) address)
1554 (setq ret (cdr elt))
1555 (if (not (stringp ret))
1556 (error "Invalid format in tinygnus-:domain-table: %s" elt))
1560 ;;; ----------------------------------------------------------------------
1562 (defun tinygnus-article-ube-identify ()
1563 "Examine all headers in Post and try to identify UBE source.
1564 This function will run `traceroute' to the found address and from
1565 the output, the upstream provider is usually the ISP where you can send
1566 complaint if the destination address won't handle your notes.
1568 The upstream provider in yraceroute output is the second/third last rows
1575 ;;; ----------------------------------------------------------------------
1577 (defun ti::mail-ip-top-level-domain (host)
1578 "Convert HOST a.b.c => b.c domain."
1579 (when (string-match "\\.\\([^.]+\\.[^.]+\\)$" host)
1580 (match-string 1 host)))
1582 ;;; ----------------------------------------------------------------------
1584 (defun tinygnus-article-received-top-level-domain-maybe (host)
1585 "If HOST looks suspicious, return HOST x.y.z => y.z.
1588 sdn-ap-002watacoP1727.foo.net => foo.net."
1589 (when (and (stringp host)
1590 ;; Skip 123.123.123.123
1591 (not (ti::mail-ip-raw-p host)))
1592 (let ((name (if (or (string-match "^\\([^.]+\\)\\....+\\..+$" host)
1593 (string-match "^\\([^.]+\\)\\....+\\..+$" host))
1594 (match-string 1 host))))
1595 (when (and (stringp name)
1596 (string-match "[0-9-]" name))
1597 (setq host (ti::mail-ip-top-level-domain host)))))
1600 ;;; ----------------------------------------------------------------------
1602 (defun tinygnus-article-received-list-handle (received)
1603 "Treat 3 sequence list differently.
1604 The first address(X) in Received header may be forged
1606 Received: from X ( Y [Z] ) by
1608 From which we get addresses
1612 The X May look like:
1614 adsl-156-62-239.asm.foo.net
1616 Shorten the address to 2 significant parts only
1619 (when (eq 3 (length received))
1620 (let ((first (car received))
1621 (rest (cdr received)))
1622 (when (string-match "\\.\\([^.]+\\.[^.]+\\)$" first)
1623 (setq first (match-string 1 first))
1625 (setq received rest))))
1628 ;;; ----------------------------------------------------------------------
1630 (defun tinygnus-host-canonilize (host)
1631 "Send HOST to `tinygnus-:canonilize-ip-functions'."
1632 (let ((fid "tinygnus-host-canonilize")
1634 (unless fid ;; No-op. XEmacs byte compiler silencer
1636 (dolist (function tinygnus-:canonilize-ip-functions)
1637 (when (setq ret (funcall function host))
1639 (format "%s: %s (%s => %s)" fid function host ret))
1643 ;;; ----------------------------------------------------------------------
1645 (defun tinygnus-nslookup-filter (list)
1646 "Filter out duplicates.
1654 ns-lookup-list Need nslookup.
1655 ns-list known addresses.
1659 `tinygnus-:nslookup-table' contains previous nslookup address."
1660 (let ((fid "tinygnus-nslookup-filter")
1664 (unless fid ;; No-op. XEmacs byte compiler silencer
1668 ;; Filter out dupliates
1669 ;; xx.aaa.com --> aaa.com
1671 (setq ip (tinygnus-host-canonilize ip))
1672 (if (or (null tinygnus-:nslookup-table)
1673 (and (null (setq elt
1674 (assoc ip tinygnus-:nslookup-table)))
1676 (rassoc ip tinygnus-:nslookup-table)))))
1677 ;; Not known, put into ask list
1678 ;; Sometimes we get address 8.8.5/8.7.3, which is actually
1679 ;; a sendmail version. Filter out false hits
1680 (if (not (string-match "/" ip))
1681 (push ip ns-lookup-list))
1682 ;; This is from cache. We have done the lookup already.
1683 (push (list ip elt) ns-list))))
1684 (tinygnus-debug fid "NS-LOOKUP-LIST" (nreverse ns-lookup-list))
1685 (tinygnus-debug fid "NS-LIST" (nreverse ns-list))
1686 (list ns-lookup-list
1689 ;;; ----------------------------------------------------------------------
1691 (defun tinygnus-nslookup-do (list)
1692 "Run nslookup for LIST.
1693 Failed addresses are returned in ERR-LIST. Good address
1694 are added to `tinygnus-:nslookup-table'.
1698 '(err-list ok-list)."
1699 (let ((fid "tinygnus-nslookup-do") ; Function id
1701 (unless fid ;; No-op. XEmacs byte compiler silencer
1703 (error "Sorry, this is disabled for now. New Spam mode is in sketch table.")
1704 ;; #todo: ti::mail-nslookup function has changed.
1705 (dolist (elt (ti::mail-nslookup list nil 'verb))
1706 (tinygnus-debug fid elt)
1707 (if (nth 1 elt) ;; Add new members to the cache.
1708 (add-to-list 'tinygnus-:nslookup-table (nth 1 elt))
1709 (push (car elt) err-list)))
1710 (tinygnus-debug fid "ERR-LIST" (mapcar 'car err-list))
1713 ;;; ----------------------------------------------------------------------
1715 (defun tinygnus-nslookup-examine-ip-top-level (ip-list)
1716 "Examine IP-LIST by converting x.y.z => y.z."
1718 (dolist (ip ip-list)
1719 ;; Treat only DNS names, not raw ip's: a.b.c.d => c.d
1720 (unless (ti::mail-ip-raw-p ip)
1722 (ti::mail-ip-top-level-domain ip))
1723 (multiple-value-bind (nok)
1724 (tinygnus-nslookup-do ip)
1725 (unless nok ;; Succeeded, top level was ok
1726 (pushnew ip list :test 'string=)))))
1729 ;;; ----------------------------------------------------------------------
1731 (defun tinygnus-nslookup-examine-ip-list (ip-list)
1732 "Examine `Received:' header IP-LIST.
1735 '(ns-err-list ns-list)."
1738 (dolist (received ip-list) ; '((IP IP IP) ..)
1739 (setq received (tinygnus-article-received-list-handle received))
1740 (multiple-value-bind (need-lookup ok)
1741 (tinygnus-nslookup-filter received)
1743 (setq ns-list (append ok ns-list)))
1744 ;; Now run nslookup for ip's that are not known and
1745 ;; add them to total list.
1746 (multiple-value-bind (nok)
1747 (tinygnus-nslookup-do need-lookup)
1749 (setq ns-err-list (append nok ns-err-list))))))
1750 ;; In case non of the IPs succeeded, do rigorous search.
1751 ;; Maybe top level domans are ok
1754 "TinyGnus: complete nslookup failure. Next: top-level search.")
1755 (setq ns-list (tinygnus-nslookup-examine-ip-top-level ns-err-list)))
1759 ;;; ----------------------------------------------------------------------
1761 (defun tinygnus-ube-address-compose (ns-list)
1762 "Compose UBE return addresses from NS-LIST."
1763 (let* ((fid "tinygnus-ube-address-compose")
1769 (unless fid ;; No-op. XEmacs byte compiler silencer.
1771 ;; ns-list: '(IP (name . addr))
1773 ;; | the nslookup results
1774 ;; Ip in the message
1775 (dolist (elt ns-list)
1776 (setq str (car-safe (nth 1 elt))
1777 ip (cdr-safe (nth 1 elt)))
1778 ;; The reverse lookup:
1779 ;; nslookup mail.eic.com.mx : 200.23.239.146
1780 ;; nslookup mty.eic.com.mx : 200.23.239.146
1782 ;; Ie. the IP numeric addresses are the same, thus we don't send
1783 ;; double copies to different symbolic addresses.
1785 ;; The tmp-list will hold numeric ip addresses '((IP . t) (IP .t) ..)
1786 ;; and if the ip is already there, the message to that site has
1787 ;; already been composed,
1789 (if (and ip (assoc ip tmp-list))
1792 (push (cons ip str) tmp-list)))
1793 ;;; (ti::d! done str ip tmp-list)
1797 (let ((abuse-list tinygnus-:ube-abuse-account-table)
1801 (setq str (tinygnus-host-canonilize str))
1802 (setq tmp (ti::list-find abuse-list str))
1805 (string-match "@" tmp))
1809 (setq login (concat (cdr tmp) "@"))
1810 (setq login "postmaster@"))
1811 (when (setq str (tinygnus-compose-return-address str))
1812 (setq email (concat login str)))))
1814 (add-to-list 'addr-list email))))
1816 ;; There is no point to send complaint to address where nslookup
1818 (message "TinyGnus: %s nslookup failed" (car str))
1819 (setq str (car elt))
1820 (when (stringp (tinygnus-compose-return-address str))
1821 (add-to-list 'ns-err-list str)))))
1822 ;; Save the values so that hook functions can use them.
1823 (setq tinygnus-:use-postmaster-addresses addr-list)
1824 (put 'tinygnus-:use-postmaster-addresses 'ns-list ns-list)
1825 (tinygnus-debug fid "ADDR-LIST" addr-list)
1828 ;;; ----------------------------------------------------------------------
1830 (defun tinygnus-article-ube-send-to-postmasters
1831 (&optional send confirm kill)
1832 "Parse all Received-headers and complain about UBE aka Spam.
1833 This function runs nslookup for each Received-header, so it may take
1834 some time to get all valid postmaster addresses. The found unique numeric
1835 and symbolic IP addresses are used when composing message to postmasters.
1837 We do not use any mail arresses that are in the message, because mail
1838 addresses cannot be checked and are usually forged in UBE message.
1842 SEND Flag, If prefix arg given, send the message.
1843 CONFIRM Flag, If SEND is non-nil, should the sending be confirmed.
1844 KILL Flag, if non-nil, kill possible mail that was being composed.
1848 `tinygnus-:ube-exclude-ip-regexp'
1849 `tinygnus-:use-postmaster-addresses'
1850 `tinygnus-:nslookup-table'
1851 `tinygnus-:nslookup-file'"
1853 (let* ((message-included-forward-headers ".")
1854 (fid 'tinygnus-article-ube-send-to-postmasters)
1855 ;; Add-on package to message.el that generates keywords.
1856 ;; DO NOT be intercative.
1857 (message-keyword-interactive nil)
1858 ;; Disable PGP auto signing.
1860 ;; Make copy, we modify this in correct buffer
1861 (mail-send-hook mail-send-hook)
1868 (unless fid ;; No-op. XEmacs byte compiler silencer
1870 (unless message-included-forward-headers ;; Byte Compiler silencer
1871 (setq message-included-forward-headers nil))
1872 ;; ................................................. byte-compiler ...
1873 ;; Quiet Byte Compiler, unused variable.
1875 (setq tinypgp-mode nil))
1876 (unless mail-send-hook
1877 (setq mail-send-hook nil))
1878 (if (and (boundp 'message-keyword-interactive)
1879 message-keyword-interactive)
1880 (setq message-keyword-interactive t))
1881 ;; ......................................................... check ...
1882 (unless (get-buffer gnus-original-article-buffer)
1883 (error "TinyGnus: panic, no gnus-original-article-buffer exist."))
1884 ;; Get the cache table if not set
1885 (or tinygnus-:nslookup-table
1886 (tinygnus-nslookup-save 'read))
1887 (with-current-buffer gnus-original-article-buffer
1888 (setq subject (mail-fetch-field "Subject"))
1890 ;; ............................................ received-headers ...
1891 ;; We have to do nslookup for each ip to find out if
1892 ;; it is alive and filter out duplicates
1893 (setq ip-list (ti::mail-parse-received tinygnus-:ube-exclude-ip-regexp))
1894 (tinygnus-debug fid "IP-LIST" ip-list)
1895 (put 'tinygnus-:use-postmaster-addresses 'ip-list ip-list)
1896 ;; ........................................ &check-need-nslookup ...
1897 ;; Check if we have done nslookup for this already.
1898 (multiple-value-bind (nok ok)
1899 (tinygnus-nslookup-examine-ip-list ip-list)
1900 (setq ns-err-list nok
1902 (setq addr-list (tinygnus-ube-address-compose ns-list))
1906 "'%s' Could not read ip addresses. Check ti::mail-parse-received."
1909 ;; The list is in order of appearence: Reference headers top-down,
1910 ;; but the originating address is at the end. We reverse the list
1911 ;; so that we get originator, next and the 2nd next ...
1912 (setq addr-list (nreverse addr-list))
1914 (setq buffer (get-buffer (message-buffer-name "mail"))))
1915 (with-current-buffer buffer (set-buffer-modified-p nil))
1916 (kill-buffer buffer))
1917 (message-forward nil)
1918 (ti::mail-kill-field "^Subject" (format "ABUSE (Was: %s)" subject))
1919 (ti::mail-kill-field "^To" (car addr-list))
1920 (when (setq addr-list (cdr addr-list))
1921 (ti::mail-add-field "CC" (ti::list-join addr-list ", ")
1923 (tinygnus-nslookup-maybe-save)
1924 ;; disable few settings, like TinyPgp
1925 (setq tinypgp-mode nil
1926 mail-send-hook (delq 'tinypgp-auto-action mail-send-hook))
1927 (run-hooks 'tinygnus-:article-ube-send-to-postmasters-hook)
1929 (ti::mail-text-start 'move)
1930 (insert "\nReceived header IP addresses that failed nslookup,\n"
1931 "possibly forged:\n")
1932 (dolist (elt ns-err-list)
1933 (insert " " elt "\n")))
1935 (if (or (null confirm)
1939 (y-or-n-p "Send to postmasters? "))))
1940 (message-send-and-exit nil))))))))
1942 ;;; ----------------------------------------------------------------------
1944 (defun tinygnus-article-fix-msword-quotes ()
1945 "Fixes MsWord style `smart quotes' back to normal ascii ones."
1947 (with-current-buffer (symbol-value 'gnus-article-buffer)
1948 (let ((buffer-read-only nil)
1949 (inhibit-read-only t))
1950 (subst-char-in-region (point-min) (point-max) ?\221 ?`)
1951 (subst-char-in-region (point-min) (point-max) ?\222 ?')
1952 (subst-char-in-region (point-min) (point-max) ?\223 ?\")
1953 (subst-char-in-region (point-min) (point-max) ?\224 ?\"))))
1957 ;;{{{ user Format functions
1959 ;;; ----------------------------------------------------------------------
1961 (defun tinygnus-uff-group-tick (params)
1962 "Return `gnus-ticked-mark' if there are ticked articles in this group.
1963 Otherwise return empty ` '. PARAMS is passed by gnus."
1964 (if (cdr (assq 'tick (symbol-value 'gnus-tmp-marked)))
1965 (char-to-string (symbol-value 'gnus-ticked-mark))
1968 ;;; ----------------------------------------------------------------------
1970 (defun tinygnus-uff-group-comment (params)
1971 "Return the comment field of a group. PARAMS is passed by gnus."
1972 (if (not (boundp 'gnus-tmp-group))
1974 (let* ((comment1 (gnus-group-get-parameter
1975 (symbol-value 'gnus-tmp-group )
1977 (comment2 (if (consp comment1)
1982 (concat "(" comment2 ")")))))
1984 ;;; ----------------------------------------------------------------------
1986 (defun tinygnus-uff-message-count (params)
1987 "Return nubmber of message in file backend. Ignore PARAMS."
1988 (if (not (boundp 'gnus-tmp-group))
1990 (let* ((group (symbol-value 'gnus-tmp-group))
1991 (path (tinygnus-group-pathname group)))
1993 ((not (stringp path))
1995 ((string-match "^/.*@" path)
1997 ((file-directory-p path) ;nnml
1998 ;; Don't count "." ".." and ".overview"
2000 (- (length (directory-files path)) 3))
2001 ((file-exists-p path)
2002 ;; #todo: unfinished
2003 ;; It's tougher with One file backends
2006 ;;; ----------------------------------------------------------------------
2007 ;;; #todo: 1999-02 This function is not tested. Inserted as is
2009 (defun tinygnus-uff-summary-line-bbdb (&optional header)
2010 "Display To: fields in summary buffers (g To From Newsgroups)
2011 This is a copy of bbdb/gnus-summary-get-author, where FROM is replaced
2014 replace %f, %n or %uB in `gnus-summary-line-format' by this user function.
2015 in groups where you want to use it."
2016 (let* ((to (cdr-safe (assoc 'To (mail-header-extra header))))
2017 (data (and bbdb/gnus-summary-show-bbdb-names
2018 (ignore-errors (mail-extract-address-components to))))
2020 (net (car (cdr data)))
2024 (if (and net bbdb-canonicalize-net-hook)
2025 (bbdb-canonicalize-address net)
2027 (if (and record name (member (downcase name) (bbdb-record-net record)))
2031 (or (and bbdb/gnus-summary-prefer-bbdb-data
2032 (or (and bbdb/gnus-summary-prefer-real-names
2033 (and record (bbdb-record-name record)))
2034 (and record (bbdb-record-net record)
2035 (nth 0 (bbdb-record-net record)))))
2036 (and bbdb/gnus-summary-prefer-real-names
2037 (or (and (equal bbdb/gnus-summary-prefer-real-names 'bbdb)
2040 net to "**UNKNOWN**"))
2043 (or (and record bbdb/gnus-summary-mark-known-posters
2044 (or (bbdb-record-getprop
2045 record bbdb-message-marker-field)
2046 bbdb/gnus-summary-known-poster-mark))
2050 ;;; ----------------------------------------------------------------------
2051 ;;; By Gary Lawrence Murphy (garym@sos.on.ca) in
2052 ;;; http://www.lebel.org/gnus/garym.gnus.el
2054 ;;; Used by permission 1997-09-29
2056 (defun tinygnus-uff-summary-date (header)
2057 "Return a date string from the Article HEADER.
2058 The format of date string is defined in `tinygnus-:uff-summary-date'"
2059 (let* ((header-lines (mail-header-lines header))
2060 (header-date (mail-header-date header))
2061 (date-vector (ignore-errors (timezone-parse-date header-date))))
2062 ;; If value is nil, then `header-date' contained something that couldn't
2063 ;; be parsed by `timezone-parse-date'
2064 (if (null date-vector)
2066 (let* ((date-yyyy (aref date-vector 0))
2067 (date-mon (aref date-vector 1))
2068 (date-day (string-to-int (aref date-vector 2)))
2069 (string-lines (if (> header-lines 9999)
2071 (number-to-string header-lines)))
2072 (string-mon (or (capitalize
2074 (1- (string-to-number date-mon))
2075 timezone-months-assoc)))
2077 (string-day (format "%d" (or date-day "?"))))
2078 ;; No-ops. Bytecomp silencers. User can use these dynamically bound
2079 ;; variables in tinygnus-:uff-summary-date, but ByteCompiler can't
2080 ;; kow that and it would say: variable bound but not referenced.
2082 ;; Using "IF no-op-test NOTHING" statements silence byte compiler
2083 (if (null string-day) (setq string-day t))
2084 (if (null string-mon) (setq string-mon t))
2085 (if (null string-lines) (setq string-lines t))
2086 (if (null date-yyyy) (setq date-yyyy t))
2087 (if tinygnus-:uff-summary-date
2088 (eval tinygnus-:uff-summary-date)
2091 ;;; ----------------------------------------------------------------------
2093 (defun tinygnus-uff-group-expiry (params)
2094 "Return the Expiry value for the group.
2095 Note: This function assumes that `nnmail-expiry-wait-function' is _not_
2096 used. Instead you should use `gnus-auto-expirable-newsgroups'
2097 and group parameter `nnmail-expiry-wait' combination.
2098 PARAMS is passed by gnus.
2104 or following where N is expiry number in days
2106 char If the expiration value is symbol, the first character from it
2107 is returned. Eg 'i' for 'immediate.
2109 N Global `nnmail-expiry-wait' used
2111 N. Value was defined in Group parameter. See
2112 `tinygnus-:expiry-in-group-string'
2114 ? Something is wrong
2118 `tinygnus-:additional-group-info' Additional chacters added"
2119 (if (not (boundp 'gnus-tmp-group))
2121 (let* ((group (symbol-value 'gnus-tmp-group))
2122 ;;; (re gnus-auto-expirable-newsgroups)
2123 (group-char tinygnus-:expiry-in-group-string)
2124 (fmt "%s") ; I used to have e:%s
2129 ;; ................................................... file test ...
2130 ;; Looking the expiry value makes sense only for groups that
2131 ;; have associated file. Do not check e.g. nntp
2132 (when (tinygnus-group-pathname group)
2135 (gnus-group-get-parameter group 'expiry-wait)
2136 (gnus-group-get-parameter group 'nnmail-expiry-wait)))
2137 ;; .................................................. expiry get ...
2144 (format fmt (concat (int-to-string arg) group-char )))
2146 (substring (symbol-name arg) 0 1))
2149 ((gnus-group-auto-expirable-p group)
2151 ((numberp nnmail-expiry-wait)
2152 (format fmt (int-to-string nnmail-expiry-wait)))
2153 ((symbolp nnmail-expiry-wait)
2154 (substring (symbol-name arg) 0 1))
2158 ;; This group isn't defined as expirable.
2160 ;; ......................................................... other ...
2161 (dolist (elt tinygnus-:additional-group-info)
2162 (setq param (nth 0 elt)
2168 (if (eq param 'total-expire)
2169 ;; Ask from gnus directly.
2170 (gnus-group-total-expirable-p group)
2171 (funcall func arg val)))
2173 (setq ret (concat ret str))))
2176 ;;; ----------------------------------------------------------------------
2178 (defun tinygnus-uff-group-file-size (arg)
2179 "Return File size if the group has attached file.
2180 ARG is passed by gnus.
2184 @ Group has ange-ftp like path.
2185 ? The path does not exist.
2186 N Filesize in kilos (1000byte count) filesize lower that 1000 is
2188 ;; ARG is nil usually when us is called.
2190 (if (not (and (boundp 'gnus-tmp-group) ;current group name
2191 (string-match "nnfolder" (symbol-value 'gnus-tmp-group))))
2193 (let* ((group (symbol-value 'gnus-tmp-group))
2194 (path (tinygnus-group-pathname group))
2197 ((not (stringp path))
2199 ((string-match "^/.*@" path)
2201 ((not (file-exists-p path))
2202 ;; Ugh; file does not exist? Make a warning to group buffer
2205 ;; Display file size in kilos, if size is < 1000, do not
2208 (setq size (nth 7 (file-attributes path)))
2209 (setq size (/ size 1000))
2212 (int-to-string size)))))))
2215 ;;{{{ Summary: misc functions
2217 ;;; ----------------------------------------------------------------------
2219 (defun tinygnus-summary-move-article (&optional n)
2220 "Move articles N to another mail group.
2221 See `tinygnus-:summary-move-article-table'"
2223 (let* ((group gnus-newsgroup-name)
2224 (articles (gnus-summary-work-articles n))
2225 (prefix (gnus-group-real-prefix group))
2227 (pfx (or (ti::string-match ".*:\\([^.]+.\\)" 1 group) ""))
2228 select-method ;Make it nil
2231 (gnus-read-move-group-name
2233 (concat (symbol-value
2234 (intern (format "gnus-current-%s-group" action)))
2237 (gnus-summary-move-article
2239 to-newsgroup select-method action)))
2241 ;;; ----------------------------------------------------------------------
2242 ;;; See gnus-sum.el::gnus-summary-catchup-all
2243 ;;; (&optional all quietly to-here not-mark)
2245 (defun tinygnus-gnus-summary-catchup-all-with-mark
2246 (&optional all to-here not-mark mark-char)
2247 "Mark rest of the articles with marker char.
2253 (gnus-set-global-variables)
2254 (gnus-summary-show-all-threads)
2255 (when (gnus-summary-first-subject (not all))
2257 (if to-here (< (point) to-here) t)
2258 (gnus-summary-mark-article-as-read mark-char)
2259 (gnus-summary-find-next (not all)))))
2260 (gnus-set-mode-line 'summary))
2262 ;;; ----------------------------------------------------------------------
2264 (defun tinygnus-gnus-summary-catchup-with-expire-all (&optional all)
2265 "Mark rest or ALL articles expriable."
2267 (tinygnus-gnus-summary-catchup-all-with-mark
2271 gnus-expirable-mark))
2273 ;;; ----------------------------------------------------------------------
2275 (defun tinygnus-gnus-summary-catchup-with-read-all (&optional all)
2276 "Mark rest or ALL articles expriable."
2278 (tinygnus-gnus-summary-catchup-all-with-mark
2284 ;;; ----------------------------------------------------------------------
2286 (defun tinygnus-gnus-summary-search-article-backward ()
2287 "Repeat last search backward."
2289 (tinygnus-gnus-summary-search-article-forward t))
2291 ;;; ----------------------------------------------------------------------
2293 (defun tinygnus-gnus-summary-search-article-forward (&optional backward)
2294 "Repeat last search forward or BACKWARD."
2296 (when (stringp gnus-last-search-regexp)
2297 (gnus-summary-search-article-forward
2298 gnus-last-search-regexp backward)
2299 (message "Searched: %s" gnus-last-search-regexp)))
2301 ;;; ----------------------------------------------------------------------
2303 (defun tinygnus-summary-gather-headers ()
2304 "Read marked messages and gather all headers to `tinygnus-:output-buffer'.
2305 When you see some suspicious messages, the headers are all you need to spot
2306 the problem. This function makes it easy to collect such messages."
2308 (tinygnus-summary-map-article-body-macro
2310 ((re-search-forward "^[ \t]*$" nil t)
2312 (append-to-buffer out (point-min) (point)))
2314 (message "TinyGnus: Problem with article number %d" nbr)))))
2316 ;;; ----------------------------------------------------------------------
2318 (defun tinygnus-summary-gather-urls (&optional arg verb)
2319 "Gathel all urls from marked messages. Duplicate ulrs are not gathered.
2322 ARG If non-nil, then include `group:atricle-nbr:' prefix to the
2323 beginning of each gathered url.
2324 VERB Verbose messages."
2327 (let* (subject-field
2332 (tinygnus-summary-map-article-body-macro
2333 (setq ;;; from-field (mail-fetch-field "From")
2334 subject-field (mail-fetch-field "Subject"))
2336 (while (re-search-forward "\\(http\\|ftp\\|telnet\\|wais\\):/" nil t)
2338 (setq url (buffer-substring-no-properties
2339 (line-beginning-position) (line-end-position)))
2340 (with-current-buffer out
2342 (unless (re-search-forward (regexp-quote url) nil t)
2345 (insert (format "%s:%d: %s\n" gnus-newsgroup-name nbr url))
2346 (insert url "\n")))))
2349 (message "TinyGnus: msg %d, %d (%d urls) %s"
2350 nbr count total subject-field)))
2351 ;; Turn on th URL jump mode.
2352 (with-current-buffer tinygnus-:output-buffer
2353 (when (and (fboundp 'turn-on-tinyurl-mode-1)
2354 (boundp 'tinyurl-mode)
2355 (null (symbol-value 'tinyurl-mode)))
2356 (turn-on-tinyurl-mode-1)))))
2358 ;;; ----------------------------------------------------------------------
2360 (defun tinygnus-summary-gather-display ()
2361 "Display `tinygnus-:output-buffer'."
2363 (tinygnus-output-buffer-macro (pop-to-buffer buffer)))
2365 ;;; ----------------------------------------------------------------------
2367 (defun tinygnus-summary-gather-clear ()
2368 "Clear `tinygnus-:output-buffer'."
2370 (let* ((buffer (get-buffer-create tinygnus-:output-buffer)))
2371 (ti::erase-buffer buffer)
2373 (message "TinyGnus: %s cleared" tinygnus-:output-buffer))))
2377 ;;{{{ Summary: exist, enter
2379 ;;; ............................................... &summary-functions ...
2382 ;;; It is annoying that gnus won't re-read the file groups automatically
2383 ;;; if the file underneath has changed. Eg if you have appended to a file
2384 ;;; that is known to gnus, you should press "g" to rescan the file
2386 ;;; This piece of code saves the file attributes when you exit the Group
2387 ;;; and when you re-enter it it checks if the file size is still
2388 ;;; the same. If not, then it performs automatig "g" to re-read the file.
2390 ;;; So, you only have to hit SPACE to read the group and leave the
2391 ;;; details to the rest of the code.
2393 (add-hook 'gnus-summary-prepare-exit-hook 'tinygnus-summary-prepare-exit-hook)
2394 (add-hook 'gnus-select-group-hook 'tinygnus-select-group-hook)
2396 ;;; ----------------------------------------------------------------------
2398 (defun tinygnus-summary-prepare-exit-hook ()
2399 "Save the group data before exit."
2400 (tinygnus-group-params-set))
2402 ;;; ----------------------------------------------------------------------
2404 (defun tinygnus-group-file-p (group)
2405 "Test if GROUP is file group."
2406 (string-match "nnfolder\\|nndoc\\|archive" group))
2408 ;;; ----------------------------------------------------------------------
2409 ;;; gnus-valid-select-methods (("nntp" post address prompt-address) ...
2410 ;;; gnus-server-alist
2411 ;;; ( ("cache" nnspool "cache")
2412 ;;; ("mbox" nnfolder "mbox"
2413 ;;; (nnfolder-directory "~/Mail/mbox")
2414 ;;; (nnfolder-active-file "~/Mail/mbox/active")
2415 ;;; (nnfolder-get-new-mail nil)
2416 ;;; (nnfolder-inhibit-expiry t)
2420 ;;; gnus-group-real-prefix (group)
2422 ;;; gnus-server-to-method (server)
2423 ;;; gnus-server-get-method (group method)
2424 ;;; gnus-group-prefixed-name (group method)
2425 ;;; ...whole name from GROUP and METHOD.
2427 (defun tinygnus-group-pathname (&optional group)
2428 "Return path of the GROUP."
2429 (tinygnus-set-group)
2430 (let* ((method (gnus-group-method group))
2431 ;; (pfx (gnus-group-prefixed-name group method))
2432 ;; (server1 (assoc server gnus-server-alist))
2433 (group1 (ignore-errors (gnus-group-real-name group))))
2437 ((eq (car method) 'nnfolder)
2438 ;; (setq dir (memq 'nnfolder-directory method))
2439 (or (ignore-errors (nnfolder-group-pathname group1))
2441 ((eq (car method) 'nnml)
2442 (or (ignore-errors (nnmail-group-pathname
2443 group1 (symbol-value 'nnml-directory)))
2445 ((eq (car method) 'nnmh)
2446 (or (ignore-errors (nnmail-group-pathname
2447 group1 (symbol-value 'nnmh-directory)))
2450 ;;; ----------------------------------------------------------------------
2452 (defun tinygnus-group-params-set (&optional group)
2453 "Save extra GROUP information to group symbol plist."
2454 (tinygnus-set-group)
2455 (let* ((path (tinygnus-group-pathname group))
2456 (sym 'tinygnus-:gnus-group-info)
2460 (file-exists-p path))
2462 ((file-directory-p path) ;nnml
2463 ;; If you use nnml, then it's not that important to
2464 ;; know the filesize. It would be too slow to map over all files
2465 ;; and sum up the total size for nnml files.
2467 ;; The nnfolder and others use single file, so getting the filesize
2468 ;; is much simpler and faster.
2471 (setq attr (file-attributes path))
2472 (setq list ;Make date list ((ATTR . VAL) ..)
2476 (cons 'file-attr attr)
2477 (cons 'file-size (nth 7 attr))
2478 (cons 'file-mod-time (nth 5 attr))))
2479 (put sym (make-symbol gnus-newsgroup-name) list))))))
2481 ;;; ----------------------------------------------------------------------
2483 (defun tinygnus-select-group-hook (&optional group)
2484 "Actions when GROUP is entered.
2485 If this is file group, check if the underlying file has changed and
2486 read it. Otherwise do nothing. This is like doing 'g' before entering
2488 (tinygnus-set-group)
2489 (let* ((sym 'tinygnus-:gnus-group-info)
2490 (path (tinygnus-group-pathname))
2495 ;; Warn about missing .overview file
2497 (setq s1 (ti::file-make-path path ".overview"))
2498 (when (and (string= "nnml" (or (car (gnus-group-method group)) ""))
2499 (not (file-exists-p s1)))
2501 "TinyGnus: .overview missing, Run nnml-generate-nov-databases")
2503 (when (and (setq path (tinygnus-group-pathname))
2504 (setq info (get sym (make-symbol group))))
2505 ;; If we enter gruop for the first time the EXIT INFO is not
2506 ;; yet available. When this is second time the info is there.
2508 ((null (setq path (cdr (assq 'file-path info))))
2509 (message "TinyGnus: invalid INFO for group."))
2510 ((null (file-exists-p path))
2511 (message "TinyGnus: File does not exist any more, %s" path))
2513 (setq attr-now (file-attributes path)
2514 attr-was (assq 'file-attr info))
2515 (when (not (eq (setq s1 (nth 7 attr-now))
2516 (setq s2 (nth 7 attr-was))))
2518 "My Gnus: File sizes differ, rereading... %s (%d/%d) "
2520 (gnus-group-get-new-news-this-group)))))))
2522 ;;; ----------------------------------------------------------------------
2524 (defun tinygnus-gnus-summary-catchup-with-expire-not-replied ()
2525 "Mark all not replied messages as read (nntp) or expired (other backends)."
2527 (tinygnus-summary-map-line-macro
2528 (when (and (looking-at "^ .*")
2529 (not (looking-at "^.*Re:")))
2531 (if (string-match "nntp" (or gnus-newsgroup-name "nntp"))
2532 (gnus-summary-mark-as-read-forward 1)
2533 (gnus-summary-mark-as-expirable 1))))))
2536 ;;{{{ Group: e.g. Symbolic get levels
2538 ;;; ----------------------------------------------------------------------
2540 (defun tinygnus-mail-extract-address-components (field)
2541 "Extract addresses from current buffer matching FIELD."
2542 (when (setq field (mail-fetch-field field))
2543 (setq field (nth 1 (mail-extract-address-components field)))))
2545 ;;; ----------------------------------------------------------------------
2547 (defun tinygnus-group-parameter-mailing-list (n)
2548 "Set `to-list' group parameter to one that is found from mails. This
2549 function is handy if you just dropped a nnml directory under gnus
2550 containing mailing list messages and you want to add the `to-list'
2551 defiitions easily to group parameters. (usually recovering the mailing list
2552 properties for Group.)
2554 The list of email address choices is gathered from last article in the group
2555 by looking at To, From, Reply-To, CC. Answer empty string \"\" if none
2556 match the mailing list address and fix the `to-list' Group parameter by hand
2559 (dolist (group (gnus-group-process-prefix n))
2560 ;; (setq group (gnus-group-group-name)))
2562 ;;; (name (gnus-group-real-name group))
2563 ;;; (method (gnus-find-method-for-group group))
2564 ;;; (type (nth 0 method)) ;; 'nnml
2565 ;;; (server (or (nth 1 (assoc 'nnml-address method))
2566 ;;; (nth 1 method)))
2567 ;;; (dir (nth 1 (assoc 'nnml-directory method)))
2568 ;;; (new-name (concat server "." name))
2569 (to-list (gnus-group-get-parameter group 'to-list))
2572 (gnus-group-remove-mark group)
2574 (message "TinyGnus: %s `to-list' already set to %s" group to-list)
2576 (tinygnus-nnml-find-file (current-buffer) group)
2577 (dolist (field '("From" "To" "Cc" "Reply-To"))
2579 (tinygnus-mail-extract-address-components field))
2580 (push address list)))
2583 (format "TinyGnus: SET %s to-list? " group)
2584 (ti::list-to-assoc-menu list)))
2585 (unless (ti::nil-p to-list)
2586 (message "TinyGnus: %s `to-list' set to %s" group to-list)
2587 (gnus-group-set-parameter group 'to-list to-list)))))))
2589 ;;; ----------------------------------------------------------------------
2591 (defun tinygnus-group-set-current-level-region (beg end level)
2592 "Map over region BEG and END and set groups to LEVEL."
2593 (interactive "r\nnTinyGnus set level to region: ")
2594 (let* ((lines (count-lines beg end)))
2595 (goto-char (min beg end))
2596 (gnus-group-set-current-level lines level)))
2598 ;;; ----------------------------------------------------------------------
2600 (defun tinygnus-read-files-from-dir (dir)
2601 "Return files from DIR in sorted order."
2603 (ti::directory-files
2606 '(not (file-directory-p arg)))))
2607 (sort files 'string<)))
2609 ;;; ----------------------------------------------------------------------
2611 (defun tinygnus-move-group-to-native-nnml (n)
2612 "Move nnml+SOME:name under nnml:SOME.name."
2614 (let* ((nnml-server (assoc "nnml" gnus-server-alist))
2615 (nnml-dir (or (assoc 'nnml-directory nnml-server)
2617 (dolist (group (gnus-group-process-prefix n))
2618 ;; (setq group (gnus-group-group-name)))
2619 (let* ((level (gnus-group-group-level))
2620 (name (gnus-group-real-name group))
2621 (method (gnus-find-method-for-group group))
2622 ;;; (type (nth 0 method)) ;; 'nnml
2623 (server (or (nth 1 (assoc 'nnml-address method))
2625 (dir (nth 1 (assoc 'nnml-directory method)))
2626 (new-name (concat server "." name))
2631 ((not (and nnml-dir dir))
2632 (message "TinyGnus: move nmml doesn't know directory for %s" group))
2633 ((not (file-directory-p dir))
2634 (message "TinyGnus: move nmml directory not exist %s %s" group dir))
2636 (setq from (nnheader-concat dir name))
2637 (setq new-dir (nnheader-concat nnml-dir new-name))
2638 ;;; (ti::d! nnml-dir new-name from new-dir)
2639 (setq status (ti::directory-move from new-dir))
2640 (if (not (ti::nil-p status))
2641 (message "TinGnus: ERROR while move %s %s %s" from new-dir status)
2642 (message "Tinygnus: Moving %s --> %s" group new-dir)
2643 (gnus-group-goto-group group)
2644 (gnus-group-kill-group)
2645 (gnus-group-make-group new-name '(nnml ""))
2646 (gnus-group-set-current-level 1 level))))))))
2648 ;;; ----------------------------------------------------------------------
2650 (defun tinygnus-make-group-nnml-from-dir (dir regexp)
2651 "Create nnml groups from DIR matching REGEXP."
2652 (interactive "DTinyGnus Nnml from directory: \nsRegexp: ")
2653 (let* ((files (directory-files
2654 (expand-file-name dir )
2656 (dolist (group files)
2657 (when (file-directory-p (nnheader-concat dir group))
2658 ;;; (if (tinygnus-nnml-group-alist-p group)
2659 ;;; (message "TinyGnus: Alredy in Gnus %s. Ignored." group)
2660 (ignore-errors (gnus-group-make-group group '(nnml "")))
2661 (message "Tinygnus: Created nnml group %s" group)))))
2663 ;;; ----------------------------------------------------------------------
2665 (defun tinygnus-make-group-nnml (n)
2666 "Kill marked nnml groups and recreate them."
2669 (dolist (group (gnus-group-process-prefix n))
2670 ;; (setq group (gnus-group-group-name)))
2671 (gnus-group-remove-mark group)
2672 (if (not (string-match "nnml" group))
2673 (message "TinyGnus: Recreate skipping non-nnml group %s" group)
2674 ;; (gnus-delete-line)
2675 (push (cons group (gnus-group-group-level))
2677 (dolist (elt nnml-list)
2678 (let* ((group (car elt))
2680 (name (gnus-group-real-name group))
2681 (method (gnus-find-method-for-group group))
2682 (type (nth 0 method)) ;; 'nnml
2683 (server (or (nth 1 (assoc 'nnml-address method))
2686 (if nnml-list ;; Byte Compiler silencer
2689 ((not (and method type server))
2690 (message "TinyGnus: Recreating failure. NIL method for %s" group))
2692 (setq type (format "%s:" (symbol-name type)))
2693 (gnus-group-goto-group group)
2694 (gnus-group-kill-group)
2695 (gnus-group-make-group name type)
2696 (gnus-group-set-current-level 1 level)
2697 (message "Tinygnus: Recreating group %s with level %d"
2700 ;;; ----------------------------------------------------------------------
2702 (defun tinygnus-make-group-from-file (method)
2703 "Make nndoc group from FILE with METHOD."
2706 (setq file (read-file-name "Make group from file: " nil nil t))
2707 (if (or (file-directory-p file)
2708 (not (file-readable-p file)))
2709 (error "invalid file: %s" file))
2713 (ti::list-to-assoc-menu '("nndoc" "nnfolder" "nnmbox" "nnspool"))
2717 (list (list (make-symbol method) file)))) ;; interactive
2718 (gnus-group-make-group
2719 (file-name-nondirectory (nth 1 method))
2722 ;;; ----------------------------------------------------------------------
2724 (defun tinygnus-make-group-from-dir-nndoc (dir)
2725 "Read DIR and make all files as nndoc groups."
2726 (interactive "Ddirectory: ")
2727 (tinygnus-files-from-dir-macro
2729 (ignore-errors (gnus-group-make-doc-group file nil))))
2731 ;;; ----------------------------------------------------------------------
2733 (defun tinygnus-make-group-from-dir-nnml-procmail-spool ()
2734 "This function is for old Gnus only that has `nnmail-procmail-directory'.
2735 Read and convert them to nnml backends.
2736 Say you have these files in in directory:
2738 junk.daemon.spool list.java-linux.spool mail.emacs.spool
2739 junk.dupli.spool list.java.spool mail.default.spool
2740 junk.null.spool list.jcvs.spool
2742 then each of these spool files would become a nnml backend folder, so that
2743 `nnmail-procmail-suffix' is removed from the end filenames.
2745 This function is primarily meant for promail users that create spool file
2746 categories on the fly eg for new mailing lists. Alternatively, if you
2747 have to start Gnus from scratch, it is nice to have function to create
2748 nnml backends with one call."
2750 (if (not (boundp 'nnmail-procmail-directory))
2751 (error "sorry, this Gnus doen no longer have nnmail-procmail-directory.")
2752 (when (y-or-n-p "Create many nnml backend folders from spool? ")
2753 (tinygnus-files-from-dir-macro
2754 (symbol-value 'nnmail-procmail-directory)
2756 (let* ((name (replace-regexp-in-string
2757 (symbol-value 'nnmail-procmail-suffix)
2759 (file-name-nondirectory file))))
2760 (gnus-group-make-group name (quote (nnml "")))))))))
2762 ;;; ----------------------------------------------------------------------
2764 (defun tinygnus-get-crash-box ()
2765 "Return Gnus crash box."
2767 ((boundp 'mail-source-crash-box)
2768 (symbol-value 'mail-source-crash-box))
2769 ((boundp 'nnmail-crash-box)
2770 (symbol-value 'nnmail-crash-box))
2772 (error "TinyGnus: Can't find crash box for Gnus any more.\
2773 Contact maintainer."))))
2775 ;;; ----------------------------------------------------------------------
2777 (defun tinygnus-crash-box-delete ()
2778 "Delete `nnmail-crash-box'."
2780 (let* ((box (tinygnus-get-crash-box)))
2782 ((not (file-exists-p box))
2783 (message "TinyGnus: File not found: %s" box))
2784 ((and (file-exists-p box)
2787 "TinyGnus: Really delete crashbox %s"
2790 (ti::kill-buffer-safe box)))
2792 ;;; ----------------------------------------------------------------------
2794 (defun tinygnus-crash-box-find-file ()
2795 "Find-file Gnus crash-box."
2797 (let* ((box (tinygnus-get-crash-box)))
2799 ((not (file-exists-p box))
2800 (message "TinyGnus: File not found: %s" box))
2802 (find-file-other-window box)))))
2804 ;;; ----------------------------------------------------------------------
2805 ;;; Note: if yo hit just "3 g"; GNUS will read all level up till 3,
2806 ;;; so you would actually read levels 1,2,3 and not just 3 :-)
2808 (defun tinygnus-gnus-group-get-news-symbolic (elt)
2809 "Ask for symbolic name which represents level where to get news.
2810 f ELT is nil then gel news for all groups.
2813 `tinygnus-:get-news-symbolic-levels'"
2815 (let* ((table tinygnus-:get-news-symbolic-levels)
2820 "Get new nwes [empty=all levels]: "
2821 tinygnus-:get-news-symbolic-levels nil nil))
2822 (list (assoc ans table) )))
2823 (let* ((cdr-elt (if elt (cdr elt))))
2824 (if (integerp cdr-elt) ; 1-- > '(1)
2825 (setq cdr-elt (ti::list-make cdr-elt)))
2828 (message "Reading all cdr-elts.")
2830 (call-interactively 'gnus-group-get-new-news))
2832 (call-interactively cdr-elt))
2833 ((ti::listp cdr-elt)
2835 (message (format "Reading level %d" n)) (sit-for 0.5)
2836 (gnus-group-get-new-news n))))))
2839 ;;{{{ Debugging Gnus
2841 ;;; ----------------------------------------------------------------------
2843 (defun tinygnus-gnus-debug-insert-line (key value &optional id)
2844 "Insert KEY and VALUE into buffer. Optionally prefix with function ID."
2845 (with-current-buffer (get-buffer-create tinygnus-:debug-buffer)
2847 (insert (format " %s%-30s: %s\n"
2850 (format " [%s] " (ti::string-value id)))
2851 (if (stringp key) key (prin1-to-string key))
2852 (ti::string-value value)))))
2854 ;;; ----------------------------------------------------------------------
2856 (put 'tinygnus-debug-gnus-macro 'lisp-indent-function 1)
2857 (put 'tinygnus-debug-gnus-macro 'edebug-form-spec '(body))
2858 (defmacro tinygnus-debug-gnus-macro (func &rest body)
2859 "Instantiate `pr' function to print debug information about FUNC."
2862 (tinygnus-gnus-debug-insert-line x y (, func))))
2865 ;;; ----------------------------------------------------------------------
2867 (defun tinygnus-nnml-group-alist-p (group)
2868 "Check if GROUP is in `nnml-group-alist'."
2869 (assoc group nnml-group-alist))
2871 ;;; ----------------------------------------------------------------------
2873 (defun tinygnus-gnus-newsrc-alist (function)
2874 "Return elts from `gnus-newsrc-alist' according to FUNCTION."
2880 ;; (("dummy.group" 0 nil) ("comp.security.ssh" 3 nil nil nil) ...
2881 (dolist (elt gnus-newsrc-alist)
2883 ;;; method (gnus-find-method-for-group group)
2884 ;;; backend (car method)
2885 ;;; server (cdr method)
2887 (when (funcall function group)
2891 ;;; ----------------------------------------------------------------------
2893 (defun tinygnus-nnml-file-range (dir)
2894 "Find the article range in directory (FIRST . LAST)."
2895 (let* ((files (directory-files dir nil "^[0-9]+$"))
2899 (< (string-to-number a) (string-to-number b))))))
2901 (cons (string-to-number (car list))
2902 (string-to-number (car (nreverse list))) ))))
2904 ;;; ----------------------------------------------------------------------
2906 (defun tinygnus-group-directory (group)
2907 "Return directory for GROUP."
2908 (let* ((method (gnus-find-method-for-group group))
2909 (type (nth 0 method)) ;; 'nnml
2910 ;;; (server (or (nth 1 (assoc 'nnml-address method))
2911 ;;; (nth 1 method)))
2914 ((string-match (symbol-name type) "nnml")
2916 (or (nth 1 (assoc 'nnml-directory method))
2918 (nnheader-concat base (gnus-group-real-name group)))
2920 (error "TinyGnus: Non-nnm;l backends not implemented.")))))
2922 ;;; ----------------------------------------------------------------------
2924 (defun tinygnus-nnml-find-file (buffer group &optional nbr)
2925 "Find to BUFFER a nnml GROUP article NBR or last article."
2926 (let* ((dir (tinygnus-group-directory group))
2928 (cdr (tinygnus-nnml-file-range dir))))
2929 (path (concat (file-name-as-directory dir)
2930 (int-to-string file))))
2931 (with-current-buffer (get-buffer-create buffer)
2933 (insert-file-contents-literally path)
2936 ;;; ----------------------------------------------------------------------
2937 ;;; ("sfnet.atk.laitteet.pc" (85772 . 90896))
2939 (defun tinygnus-gnus-debug-update-nnml-group-alist (group dir &optional replace)
2940 "Update `nnml-group-alist' to have the GROUP with DIR.
2941 Possibly REPLCE existing entry."
2942 (let ((exist-p (tinygnus-nnml-group-alist-p group))
2944 (if (not (file-directory-p dir))
2945 (message "TinyLisp: No directory %s %s" group dir)
2948 (if (not (setq range (tinygnus-nnml-file-range dir)))
2949 (message "TinyLisp: No files %s %s" group dir)
2950 (message "TinyGnus: Adding to `nnml-group-alist' %s" dir)
2952 (aput 'nnml-group-alist group range))
2953 (push (list group range) nnml-group-alist))))))
2956 (defadvice gnus-open-server (around tinygnus-debug dis)
2957 ;; (gnus-command-method)
2958 ;; "Open a connection to GNUS-COMMAND-METHOD."
2960 (tinygnus-gnus-debug-insert-line x y 'gnus-open-server )))
2961 (pr '(CALL-ARGS gnus-command-method)
2962 (list gnus-command-method))
2963 (when (stringp gnus-command-method)
2964 (setq gnus-command-method (gnus-server-to-method gnus-command-method)))
2965 (let ((elem (assoc gnus-command-method gnus-opened-servers)))
2966 ;; If this method was previously denied, we just return nil.
2967 (pr 'gnus-opened-servers elem)
2970 (if (eq (nth 1 elem) 'denied)
2972 (gnus-message 1 "Denied server")
2975 (pr '(gnus-get-function gnus-command-method 'open-server)
2976 (gnus-get-function gnus-command-method 'open-server))
2978 (funcall (gnus-get-function gnus-command-method 'open-server)
2979 (nth 1 gnus-command-method)
2980 (nthcdr 2 gnus-command-method))))
2981 ;; If this hasn't been opened before, we add it to the list.
2983 (setq elem (list gnus-command-method nil)
2984 gnus-opened-servers (cons elem gnus-opened-servers)))
2985 ;; Set the status of this server.
2986 (setcar (cdr elem) (if result 'ok 'denied))
2987 ;; Return the result from the "open" call.
2989 (pr 'RETURN-VALUE ad-return-value))))
2992 (defadvice gnus-summary-read-group-1 (around t-tinygnus-debug dis)
2993 "Output trace to tinygnus-:debug-buffer"
2994 ;; (group show-all no-article kill-buffer no-display &optional select-articles)
2996 (tinygnus-gnus-debug-insert-line x y 'gnus-summary-read-group-1 )))
2997 ;; Killed foreign groups can't be entered.
2998 (when (and (not (gnus-group-native-p group))
2999 (not (gnus-gethash group gnus-newsrc-hashtb)))
3000 (error "Dead non-native groups can't be entered"))
3001 (gnus-message 5 "Retrieving newsgroup: %s..." group)
3002 (let* ((new-group (gnus-summary-setup-buffer group))
3003 (quit-config (gnus-group-quit-config group))
3004 (did-select (and new-group (gnus-select-newsgroup
3005 group show-all select-articles))))
3006 (pr 'my-gnus-summary-read-group-1::new-group new-group)
3007 (pr 'my-gnus-summary-read-group-1::quit-config quit-config)
3008 (pr 'my-gnus-summary-read-group-1::did-select did-select)
3010 ;; This summary buffer exists already, so we just select it.
3012 (gnus-set-global-variables)
3014 (gnus-kill-or-deaden-summary kill-buffer))
3015 (gnus-configure-windows 'summary 'force)
3016 (gnus-set-mode-line 'summary)
3017 (gnus-summary-position-point)
3020 ;; We couldn't select this group.
3022 (when (and (eq major-mode 'gnus-summary-mode)
3023 (not (equal (current-buffer) kill-buffer)))
3024 (kill-buffer (current-buffer))
3025 (if (not quit-config)
3027 ;; Update the info -- marks might need to be removed,
3029 (gnus-summary-update-info)
3030 (set-buffer gnus-group-buffer)
3031 (gnus-group-jump-to-group group)
3032 (gnus-group-next-unread-group 1))
3033 (gnus-handle-ephemeral-exit quit-config)))
3034 (gnus-message 3 "Can't select group")
3036 ;; The user did a `C-g' while prompting for number of articles,
3037 ;; so we exit this group.
3038 ((eq did-select 'quit)
3039 (and (eq major-mode 'gnus-summary-mode)
3040 (not (equal (current-buffer) kill-buffer))
3041 (kill-buffer (current-buffer)))
3043 (gnus-kill-or-deaden-summary kill-buffer))
3044 (if (not quit-config)
3046 (set-buffer gnus-group-buffer)
3047 (gnus-group-jump-to-group group)
3048 (gnus-group-next-unread-group 1)
3049 (gnus-configure-windows 'group 'force))
3050 (gnus-handle-ephemeral-exit quit-config))
3051 ;; Finally signal the quit.
3053 ;; The group was successfully selected.
3055 (gnus-set-global-variables)
3056 ;; Save the active value in effect when the group was entered.
3057 (setq gnus-newsgroup-active
3059 (gnus-active gnus-newsgroup-name)))
3060 ;; You can change the summary buffer in some way with this hook.
3061 (gnus-run-hooks 'gnus-select-group-hook)
3062 ;; Set any local variables in the group parameters.
3063 (gnus-summary-set-local-parameters gnus-newsgroup-name)
3064 (gnus-update-format-specifications
3065 nil 'summary 'summary-mode 'summary-dummy)
3066 (gnus-update-summary-mark-positions)
3067 ;; Do score processing.
3068 (when gnus-use-scoring
3069 (gnus-possibly-score-headers))
3070 ;; Check whether to fill in the gaps in the threads.
3071 (when gnus-build-sparse-threads
3072 (gnus-build-sparse-threads))
3073 ;; Find the initial limit.
3074 (if gnus-show-threads
3076 (let ((gnus-newsgroup-dormant nil))
3077 (gnus-summary-initial-limit show-all))
3078 (gnus-summary-initial-limit show-all))
3079 ;; When untreaded, all articles are always shown.
3080 (setq gnus-newsgroup-limit
3082 (lambda (header) (mail-header-number header))
3083 gnus-newsgroup-headers)))
3084 ;; Generate the summary buffer.
3086 (gnus-summary-prepare))
3087 (when gnus-use-trees
3088 (gnus-tree-open group)
3089 (setq gnus-summary-highlight-line-function
3090 'gnus-tree-highlight-article))
3091 ;; If the summary buffer is empty, but there are some low-scored
3092 ;; articles or some excluded dormants, we include these in the
3094 (when (and (zerop (buffer-size))
3096 (cond (gnus-newsgroup-dormant
3097 (gnus-summary-limit-include-dormant))
3098 ((and gnus-newsgroup-scored show-all)
3099 (gnus-summary-limit-include-expunged t))))
3100 ;; Function `gnus-apply-kill-file' must be called in this hook.
3101 (gnus-run-hooks 'gnus-apply-kill-hook)
3102 (if (and (zerop (buffer-size))
3105 ;; This newsgroup is empty.
3106 (gnus-summary-catchup-and-exit nil t)
3107 (gnus-message 6 "No unread news")
3109 (gnus-kill-or-deaden-summary kill-buffer))
3110 ;; Return nil from this function.
3112 ;; Hide conversation thread subtrees. We cannot do this in
3113 ;; gnus-summary-prepare-hook since kill processing may not
3114 ;; work with hidden articles.
3115 (and gnus-show-threads
3116 gnus-thread-hide-subtree
3117 (gnus-summary-hide-all-threads))
3119 (gnus-kill-or-deaden-summary kill-buffer))
3120 ;; Show first unread article if requested.
3121 (if (and (not no-article)
3123 gnus-newsgroup-unreads
3124 gnus-auto-select-first)
3126 (gnus-configure-windows 'summary)
3128 ((eq gnus-auto-select-first 'best)
3129 (gnus-summary-best-unread-article))
3130 ((eq gnus-auto-select-first t)
3131 (gnus-summary-first-unread-article))
3132 ((gnus-functionp gnus-auto-select-first)
3133 (funcall gnus-auto-select-first))))
3134 ;; Don't select any articles, just move point to the first
3135 ;; article in the group.
3136 (goto-char (point-min))
3137 (gnus-summary-position-point)
3138 (gnus-configure-windows 'summary 'force)
3139 (gnus-set-mode-line 'summary))
3140 (when (get-buffer-window gnus-group-buffer t)
3141 ;; Gotta use windows, because recenter does weird stuff if
3142 ;; the current buffer ain't the displayed window.
3143 (let ((owin (selected-window)))
3144 (select-window (get-buffer-window gnus-group-buffer t))
3145 (when (gnus-group-goto-group group)
3147 (select-window owin)))
3148 ;; Mark this buffer as "prepared".
3149 (setq gnus-newsgroup-prepared t)
3150 (gnus-run-hooks 'gnus-summary-prepared-hook)
3151 (setq ad-return-value t)))))))
3154 (defadvice gnus-select-newsgroup (around tinygnus-debug dis)
3155 ;; (group &optional read-all select-articles)
3156 "Output trace to tinygnus-:debug-buffer"
3157 ;; (group &optional read-all select-articles)
3158 ;; "Select newsgroup GROUP.
3159 ;;If READ-ALL is non-nil, all articles in the group are selected.
3160 ;; If SELECT-ARTICLES, only select those articles from GROUP."
3162 (tinygnus-gnus-debug-insert-line x y 'gnus-select-newsgroup)))
3163 (pr '(CALL-ARGS group read-all select-articles)
3164 (list group read-all select-articles))
3166 (let* ((entry (gnus-gethash group gnus-newsrc-hashtb))
3167 ;;!!! Dirty hack; should be removed.
3168 (gnus-summary-ignore-duplicates
3169 (if (eq (car (gnus-find-method-for-group group)) 'nnvirtual)
3171 gnus-summary-ignore-duplicates))
3172 (info (nth 2 entry))
3173 articles fetched-articles cached)
3174 (pr 'gnus-current-select-method gnus-current-select-method)
3175 (pr '(gnus-find-method-for-group group) (gnus-find-method-for-group group))
3176 (unless (gnus-check-server
3177 (setq gnus-current-select-method
3178 (gnus-find-method-for-group group)))
3179 (error "Couldn't open server"))
3180 (or (and entry (not (eq (car entry) t))) ; Either it's active...
3181 (gnus-activate-group group) ; Or we can activate it...
3182 (progn ; Or we bug out.
3183 (when (equal major-mode 'gnus-summary-mode)
3184 (kill-buffer (current-buffer)))
3185 (error "Couldn't request group %s: %s"
3186 group (gnus-status-message group))))
3187 (unless (gnus-request-group group t)
3188 (when (equal major-mode 'gnus-summary-mode)
3189 (kill-buffer (current-buffer)))
3190 (error "Couldn't request group %s: %s"
3191 group (gnus-status-message group)))
3192 (setq gnus-newsgroup-name group)
3193 (setq gnus-newsgroup-unselected nil)
3194 (setq gnus-newsgroup-unreads (gnus-list-of-unread-articles group))
3195 (gnus-summary-setup-default-charset)
3196 ;; Adjust and set lists of article marks.
3198 (gnus-adjust-marked-articles info))
3199 ;; Kludge to avoid having cached articles nixed out in virtual groups.
3200 (when (gnus-virtual-group-p group)
3201 (setq cached gnus-newsgroup-cached))
3202 (setq gnus-newsgroup-unreads
3203 (gnus-set-difference
3204 (gnus-set-difference gnus-newsgroup-unreads gnus-newsgroup-marked)
3205 gnus-newsgroup-dormant))
3206 (setq gnus-newsgroup-processable nil)
3207 (gnus-update-read-articles group gnus-newsgroup-unreads)
3208 (if (setq articles select-articles)
3209 (setq gnus-newsgroup-unselected
3210 (gnus-sorted-intersection
3211 gnus-newsgroup-unreads
3212 (gnus-sorted-complement gnus-newsgroup-unreads articles)))
3213 (setq articles (gnus-articles-to-read group read-all)))
3219 ;;(gnus-message 3 "Couldn't select newsgroup -- no articles to display")
3221 ((eq articles 0) nil)
3223 ;; Init the dependencies hash table.
3224 (setq gnus-newsgroup-dependencies
3225 (gnus-make-hashtable (length articles)))
3226 (gnus-set-global-variables)
3227 ;; Retrieve the headers and read them in.
3228 (gnus-message 5 "Fetching headers for %s..." gnus-newsgroup-name)
3229 (setq gnus-newsgroup-headers
3231 (setq gnus-headers-retrieved-by
3232 (gnus-retrieve-headers
3233 articles gnus-newsgroup-name
3234 ;; We might want to fetch old headers, but
3235 ;; not if there is only 1 article.
3237 (not (eq gnus-fetch-old-headers 'some))
3238 (not (numberp gnus-fetch-old-headers)))
3239 (> (length articles) 1))
3240 gnus-fetch-old-headers))))
3241 (gnus-get-newsgroup-headers-xover
3242 articles nil nil gnus-newsgroup-name t)
3243 (gnus-get-newsgroup-headers)))
3244 (gnus-message 5 "Fetching headers for %s...done" gnus-newsgroup-name)
3245 ;; Kludge to avoid having cached articles nixed out in virtual groups.
3247 (setq gnus-newsgroup-cached cached))
3248 ;; Suppress duplicates?
3249 (when gnus-suppress-duplicates
3250 (gnus-dup-suppress-articles))
3251 ;; Set the initial limit.
3252 (setq gnus-newsgroup-limit (copy-sequence articles))
3253 ;; Remove canceled articles from the list of unread articles.
3254 (setq gnus-newsgroup-unreads
3255 (gnus-set-sorted-intersection
3256 gnus-newsgroup-unreads
3257 (setq fetched-articles
3258 (mapcar (lambda (headers) (mail-header-number headers))
3259 gnus-newsgroup-headers))))
3260 ;; Removed marked articles that do not exist.
3261 (gnus-update-missing-marks
3262 (gnus-sorted-complement fetched-articles articles))
3263 ;; We might want to build some more threads first.
3264 (when (and gnus-fetch-old-headers
3265 (eq gnus-headers-retrieved-by 'nov))
3266 (if (eq gnus-fetch-old-headers 'invisible)
3267 (gnus-build-all-threads)
3268 (gnus-build-old-threads)))
3269 ;; Let the Gnus agent mark articles as read.
3271 (gnus-agent-get-undownloaded-list))
3272 ;; Remove list identifiers from subject
3273 (when gnus-list-identifiers
3274 (gnus-summary-remove-list-identifiers))
3275 ;; Check whether auto-expire is to be done in this group.
3276 (setq gnus-newsgroup-auto-expire
3277 (gnus-group-auto-expirable-p group))
3278 ;; Set up the article buffer now, if necessary.
3279 (unless gnus-single-article-buffer
3280 (gnus-article-setup-buffer))
3281 ;; First and last article in this newsgroup.
3282 (when gnus-newsgroup-headers
3283 (setq gnus-newsgroup-begin
3284 (mail-header-number (car gnus-newsgroup-headers))
3287 (gnus-last-element gnus-newsgroup-headers))))
3288 ;; GROUP is successfully selected.
3289 (or gnus-newsgroup-headers t))))
3290 (pr 'RETURN-VALUE ad-return-value))))
3293 (defadvice gnus-summary-read-group-1 (around tinygnus-debug dis)
3294 ;; (group show-all no-article kill-buffer no-display &optional select-articles)
3295 ;; Killed foreign groups can't be entered.
3296 (tinygnus-debug-gnus-macro 'gnus-summary-read-group-1
3298 (list group show-all no-article kill-buffer no-display select-articles))
3299 (when (and (not (gnus-group-native-p group))
3300 (not (gnus-gethash group gnus-newsrc-hashtb)))
3301 (error "Dead non-native groups can't be entered"))
3302 (gnus-message 5 "Retrieving newsgroup: %s..." group)
3303 (let* ((new-group (gnus-summary-setup-buffer group))
3304 (quit-config (gnus-group-quit-config group))
3305 (did-select (and new-group (gnus-select-newsgroup
3306 group show-all select-articles))))
3308 ;; This summary buffer exists already, so we just select it.
3310 (gnus-set-global-variables)
3312 (gnus-kill-or-deaden-summary kill-buffer))
3313 (gnus-configure-windows 'summary 'force)
3314 (gnus-set-mode-line 'summary)
3315 (gnus-summary-position-point)
3318 ;; We couldn't select this group.
3320 (when (and (eq major-mode 'gnus-summary-mode)
3321 (not (equal (current-buffer) kill-buffer)))
3322 (kill-buffer (current-buffer))
3323 (if (not quit-config)
3325 ;; Update the info -- marks might need to be removed,
3327 (gnus-summary-update-info)
3328 (set-buffer gnus-group-buffer)
3329 (gnus-group-jump-to-group group)
3330 (gnus-group-next-unread-group 1))
3331 (gnus-handle-ephemeral-exit quit-config)))
3332 (gnus-message 3 "Can't select group")
3334 ;; The user did a `C-g' while prompting for number of articles,
3335 ;; so we exit this group.
3336 ((eq did-select 'quit)
3337 (and (eq major-mode 'gnus-summary-mode)
3338 (not (equal (current-buffer) kill-buffer))
3339 (kill-buffer (current-buffer)))
3341 (gnus-kill-or-deaden-summary kill-buffer))
3342 (if (not quit-config)
3344 (set-buffer gnus-group-buffer)
3345 (gnus-group-jump-to-group group)
3346 (gnus-group-next-unread-group 1)
3347 (gnus-configure-windows 'group 'force))
3348 (gnus-handle-ephemeral-exit quit-config))
3349 ;; Finally signal the quit.
3351 ;; The group was successfully selected.
3353 (gnus-set-global-variables)
3354 ;; Save the active value in effect when the group was entered.
3355 (setq gnus-newsgroup-active
3357 (gnus-active gnus-newsgroup-name)))
3358 ;; You can change the summary buffer in some way with this hook.
3359 (gnus-run-hooks 'gnus-select-group-hook)
3360 ;; Set any local variables in the group parameters.
3361 (gnus-summary-set-local-parameters gnus-newsgroup-name)
3362 (gnus-update-format-specifications
3363 nil 'summary 'summary-mode 'summary-dummy)
3364 (gnus-update-summary-mark-positions)
3365 ;; Do score processing.
3366 (when gnus-use-scoring
3367 (gnus-possibly-score-headers))
3368 ;; Check whether to fill in the gaps in the threads.
3369 (when gnus-build-sparse-threads
3370 (gnus-build-sparse-threads))
3371 ;; Find the initial limit.
3372 (if gnus-show-threads
3374 (let ((gnus-newsgroup-dormant nil))
3375 (gnus-summary-initial-limit show-all))
3376 (gnus-summary-initial-limit show-all))
3377 ;; When untreaded, all articles are always shown.
3378 (setq gnus-newsgroup-limit
3380 (lambda (header) (mail-header-number header))
3381 gnus-newsgroup-headers)))
3382 ;; Generate the summary buffer.
3384 (gnus-summary-prepare))
3385 (when gnus-use-trees
3386 (gnus-tree-open group)
3387 (setq gnus-summary-highlight-line-function
3388 'gnus-tree-highlight-article))
3389 ;; If the summary buffer is empty, but there are some low-scored
3390 ;; articles or some excluded dormants, we include these in the
3392 (when (and (zerop (buffer-size))
3394 (cond (gnus-newsgroup-dormant
3395 (gnus-summary-limit-include-dormant))
3396 ((and gnus-newsgroup-scored show-all)
3397 (gnus-summary-limit-include-expunged t))))
3398 ;; Function `gnus-apply-kill-file' must be called in this hook.
3399 (gnus-run-hooks 'gnus-apply-kill-hook)
3400 (if (and (zerop (buffer-size))
3403 ;; This newsgroup is empty.
3404 (gnus-summary-catchup-and-exit nil t)
3405 (gnus-message 6 "No unread news")
3407 (gnus-kill-or-deaden-summary kill-buffer))
3408 ;; Return nil from this function.
3410 ;; Hide conversation thread subtrees. We cannot do this in
3411 ;; gnus-summary-prepare-hook since kill processing may not
3412 ;; work with hidden articles.
3413 (and gnus-show-threads
3414 gnus-thread-hide-subtree
3415 (gnus-summary-hide-all-threads))
3417 (gnus-kill-or-deaden-summary kill-buffer))
3418 ;; Show first unread article if requested.
3419 (if (and (not no-article)
3421 gnus-newsgroup-unreads
3422 gnus-auto-select-first)
3424 (gnus-configure-windows 'summary)
3426 ((eq gnus-auto-select-first 'best)
3427 (gnus-summary-best-unread-article))
3428 ((eq gnus-auto-select-first t)
3429 (gnus-summary-first-unread-article))
3430 ((gnus-functionp gnus-auto-select-first)
3431 (funcall gnus-auto-select-first))))
3432 ;; Don't select any articles, just move point to the first
3433 ;; article in the group.
3434 (goto-char (point-min))
3435 (gnus-summary-position-point)
3436 (gnus-configure-windows 'summary 'force)
3437 (gnus-set-mode-line 'summary))
3438 (when (get-buffer-window gnus-group-buffer t)
3439 ;; Gotta use windows, because recenter does weird stuff if
3440 ;; the current buffer ain't the displayed window.
3441 (let ((owin (selected-window)))
3442 (select-window (get-buffer-window gnus-group-buffer t))
3443 (when (gnus-group-goto-group group)
3445 (select-window owin)))
3446 ;; Mark this buffer as "prepared".
3447 (setq gnus-newsgroup-prepared t)
3448 (gnus-run-hooks 'gnus-summary-prepared-hook)
3449 (setq ad-return-value t)))))))
3452 (defadvice gnus-activate-group (around tinygnus-debug dis)
3453 "Output trace to tinygnus-:debug-buffer"
3454 ;; (group &optional scan dont-check method)
3455 ;; Check whether a group has been activated or not.
3456 ;; If SCAN, request a scan of that group as well.
3457 (tinygnus-debug-gnus-macro 'gnus-activate-group
3458 (pr '(CALL-ARGS group &optional scan dont-check method)
3459 (list group scan dont-check method))
3460 (let ((method (or method (inline (gnus-find-method-for-group group))))
3465 (and (inline (gnus-check-server method))
3466 ;; We escape all bugs and quit here to make it posxsible to
3467 ;; continue if a group is so out-there that it reports bugs
3471 (gnus-check-backend-function 'request-scan (car method))
3472 (gnus-request-scan group method))
3475 (inline (gnus-request-group group dont-check method))
3478 (setq active (gnus-parse-active))
3480 (pr "(parse-active)NNTP buffer conatins no data"
3482 (pr 'gnus-parse-active active))
3483 ;; If there are no articles in the group, the GROUP
3484 ;; command may have responded with the `(0 . 0)'. We
3485 ;; ignore this if we already have an active entry
3487 (if (and (zerop (car active))
3488 (zerop (cdr active))
3489 (gnus-active group))
3491 (gnus-set-active group active)
3492 ;; Return the new active info.
3495 ;;; --> nnagent-request-scan calls this too
3498 (defadvice nnml-request-group (around tinygnus-debug dis)
3499 ;; (group &optional server dont-check)
3500 "Output trace to tinygnus-:debug-buffer"
3501 (tinygnus-debug-gnus-macro 'nnml-request-group
3502 (pr '(CALL-ARGS group dont-check gnus-command-method)
3503 (list group dont-check gnus-command-method))
3506 (let ((pathname-coding-system 'binary))
3507 (cond ((not (nnml-possibly-change-directory group server))
3508 (nnheader-report 'nnml "Invalid group (no such directory)"))
3509 ((not (file-exists-p nnml-current-directory))
3510 (nnheader-report 'nnml
3511 "Directory %s does not exist"
3512 nnml-current-directory))
3513 ((not (file-directory-p nnml-current-directory))
3514 (nnheader-report 'nnml
3515 "%s is not a directory"
3516 nnml-current-directory))
3517 (dont-check (nnheader-report 'nnml "Group %s selected" group)
3519 (t (nnheader-re-read-dir nnml-current-directory)
3520 (nnmail-activate 'nnml)
3521 (let ((active (nth 1 (assoc group nnml-group-alist))))
3523 (nnheader-report 'nnml "No such group: %s" group)
3524 (nnheader-report 'nnml "Selected group %s" group)
3525 (nnheader-insert "211 %d %d %d %s
3526 " (max (1+ (- (cdr active) (car active))) 0) (car active) (cdr active) group)))))))))
3528 (defadvice nnml-possibly-change-directory (around tinygnus-debug dis)
3529 ;; (group &optional server)
3530 "Output trace to tinygnus-:debug-buffer"
3531 (tinygnus-debug-gnus-macro 'nnml-possibly-change-directory
3532 (pr '(CALL-ARGS group server) (list group server))
3534 (not (nnml-server-opened server)))
3535 (nnml-open-server server))
3540 (let ((pathname (nnmail-group-pathname group nnml-directory))
3541 (pathname-coding-system 'binary))
3542 (pr 'nnmail-group-pathname pathname)
3543 (pr 'nnml-current-directory nnml-current-directory)
3544 (when (not (equal pathname nnml-current-directory))
3545 (setq nnml-current-directory pathname
3546 nnml-current-group group
3547 nnml-article-file-alist nil))
3548 (file-exists-p nnml-current-directory))))
3549 (pr 'RETURN-VALUE ad-return-value)))
3552 (defadvice gnus-request-group (around tinygnus-debug dis)
3553 ;; (defun my-gnus-request-group (group &optional dont-check gnus-command-method)
3554 ;; (group &optional dont-check gnus-command-method)
3555 ;; "Request GROUP. If DONT-CHECK, no information is required."
3556 "Output trace to tinygnus-:debug-buffer"
3557 (tinygnus-debug-gnus-macro 'gnus-request-group
3558 (pr '(CALL-ARGS group &optional dont-check gnus-command-method)
3559 (list group dont-check gnus-command-method))
3560 (let ((gnus-command-method
3561 (or gnus-command-method (inline (gnus-find-method-for-group group)))))
3562 (when (stringp gnus-command-method)
3563 (setq gnus-command-method
3564 (inline (gnus-server-to-method gnus-command-method)))
3565 (pr 'gnus-command-method gnus-command-method))
3566 (let* ((function (inline (gnus-get-function gnus-command-method
3568 (group (gnus-group-real-name group))
3569 (server (nth 1 gnus-command-method))
3573 (pr 'FUNCALL function)
3574 (pr 'FUNCALL-SYMBOL-FUNC (symbol-function function))
3577 (pr 'DONT-CHECK dont-check)
3578 (when (string-match "nnml-request-group"
3579 (prin1-to-string (symbol-function function)))
3580 (pr '(nnml-server-opened server) (nnml-server-opened server))
3581 ;; FIXME: nnml-directory may be in server parameters
3582 (setq dir (nnmail-group-pathname group nnml-directory))
3583 (pr '(nnmail-group-pathname group nnml-directory) dir)
3584 (pr 'nnml-directory nnml-directory)
3585 (pr 'nnml-current-directory nnml-current-directory)
3586 (setq stat (assoc group nnml-group-alist))
3587 (pr '(assoc group nnml-group-alist) stat)
3589 (pr "ERROR: Gnus doesn't know about ACTIVE file" "")
3590 (pr 'nnml-group-alist nnml-group-alist)
3592 (when (and (file-directory-p dir)
3593 (or (file-exists-p (concat dir "active"))
3594 (file-exists-p (concat dir ".agentview")))
3595 (y-or-n-p "Group not in `nnml-group-alist'. Update? "))
3596 (tinygnus-gnus-debug-update-nnml-group-alist group dir)))
3597 (unless (string-match "nnml" group)
3598 (pr "ERROR: group name doesn not contain NNML?"
3599 "Gnus can't read group!!!")))
3601 (funcall function group server dont-check))
3602 (pr 'nnml-status-string nnml-status-string)
3603 (pr 'RETURN-VALUE ret)
3604 (setq ad-return-value ret)))))
3606 ;;; ----------------------------------------------------------------------
3608 (defun tinygnus-gnus-debug-investigate-problem (group)
3609 "Debug why you can't select NNML/Agent NNTP group."
3613 "TinyGnus group to debug: "
3614 (ti::list-to-assoc-menu (list (gnus-group-group-name))))))
3615 (let* ((method (gnus-find-method-for-group group))
3616 (server (nth 1 method))
3617 (buffer (get-buffer-create tinygnus-:debug-buffer))
3623 ;; make shorter function name
3625 (tinygnus-gnus-debug-insert-line x y)))
3626 (with-current-buffer buffer
3627 (tinygnus-gnus-debug-on)
3629 (insert (format "\nGNUS DEBUG SESSION (group: %s) %s\n\n"
3631 (ti::date-standard-date 'minutes)))
3632 (pr 'nnml-directory nnml-directory)
3633 (pr 'gnus-agent-directory gnus-agent-directory)
3634 (pr 'gnus-find-method-for-group method)
3635 (pr 'request-group (gnus-get-function method 'request-group))
3636 (pr 'gnus-group-real-name (gnus-group-real-name group))
3637 (pr 'gnus-group-method (gnus-group-method group))
3638 (pr 'gnus-group-real-prefix (gnus-group-real-prefix group))
3639 (pr 'gnus-server-status (gnus-server-status method))
3640 (pr 'gnus-server-opened (gnus-server-opened method))
3641 (pr '(gnus-group-find-parameter nnml-directory)
3642 (gnus-group-find-parameter nnml-directory))
3643 (pr '(gnus-info-params (gnus-get-info group))
3644 (gnus-info-params (gnus-get-info group)))
3645 (pr '(assoc server gnus-server-alist)
3646 (assoc server gnus-server-alist))
3647 (pr 'gnus-group-name-to-method (gnus-group-name-to-method group))
3648 (pr 'gnus-server-to-method (gnus-server-to-method gnus-command-method))
3649 (pr '(gnus-active group) (gnus-active group))
3650 (pr '(gnus-check-server method) (gnus-check-server method))
3651 (pr 'gnus-agent-covered-methods gnus-agent-covered-methods)
3652 (pr '(gnus-methods-using 'respool) (gnus-methods-using 'respool))
3653 ;; ....................................... Active article list ...
3654 (setq tmp1 (gnus-active group))
3655 (setq tmp2 (gnus-activate-group group))
3656 (pr '(gnus-active group) tmp1)
3657 (pr '(gnus-activate-group group) tmp2)
3658 (unless (or tmp1 tmp2)
3659 (pr "ERROR: Gnus DOES NOT HAVE INFO ABOUT FILE RANGE. (active)"
3661 ;; .................................................... server ...
3662 (setq elt (assoc method gnus-opened-servers))
3663 (pr 'gnus-opened-servers elt)
3664 (pr '(gnus-get-function method 'open-server)
3665 (gnus-get-function method 'open-server))
3666 (pr '(gnus-request-group group nil method)
3667 (gnus-request-group group nil method))
3668 (setq info (gnus-get-info group))
3669 (pr 'gnus-get-info info)
3670 (pr 'nnml-directory nnml-directory)
3671 (pr 'nnml-current-directory nnml-current-directory)
3672 (setq info-method (gnus-info-method info))
3673 (pr "(gnus-info-method info)" info-method)
3674 (pr 'gnus-server-extend-method
3675 (gnus-server-extend-method group info-method))
3676 (pr 'gnus-group-entry (gnus-group-entry group))
3677 ;; (gnus-activate-group group)
3678 (tinygnus-gnus-debug-off)
3679 (display-buffer (current-buffer))
3680 (message "TinyGnus: Investigation ready. Check results from %s"
3681 tinygnus-:debug-buffer)))))
3683 ;;; ----------------------------------------------------------------------
3685 (defun tinygnus-fix-nnml-groups ()
3686 "Step throught every nnml group and make sure they have
3687 proper files created and Gnus knows about them via `nnml-group-alist'.
3689 Agent groups are also NNML groups, so this will also step through nntp
3690 backends when Gnus is unplugged."
3692 (let* ((list (tinygnus-gnus-newsrc-alist
3695 (or (string-match "nnml" group)
3696 (and (null gnus-plugged)
3697 (eq (car (gnus-find-method-for-group group))
3709 (message "TinyGnus: NNML-DIRECTORY is %s" nnml-directory)
3710 (message "TinyGnus: GNUS-AGENT-DIRECTORY is %s" gnus-agent-directory)
3712 (setq group (car elt)
3713 method (gnus-find-method-for-group group)
3714 server (nth 1 method)
3715 function (gnus-get-function method 'request-group)
3716 real-name (gnus-group-real-name group))
3717 (setq elt (assoc method gnus-opened-servers))
3718 (setq open-server (gnus-get-function method 'open-server))
3719 (when (eq (nth 1 elt) 'denied)
3720 (message "TinyGnus: Group has denied server %s Trying to open %s ..."
3721 group (prin1-to-string open-server))
3722 (setq status (nth 1 method)
3723 status2 (nthcdr 2 method))
3725 (message "TinyGnus: Open Server didn't succeed"))
3727 (message "TinyGnus: status 2 error %s" (prin1-to-string status2))))
3728 ;; see gnus-int.el gnus-request-group
3729 (unless (funcall function real-name (nth 1 method) nil)
3730 (message "TinyGnus: Group %s problem [%s] Trying to fix..."
3731 group nnml-status-string)
3732 (nnml-possibly-change-directory group server)
3733 (setq dir (nnmail-group-pathname group nnml-directory))
3734 (ti::d! group nnml-current-directory dir)
3735 (if (not (file-directory-p dir))
3736 (message "TinyGnus: Unable to fix %s, no directory %s" group dir)
3737 (tinygnus-gnus-debug-update-nnml-group-alist group dir))))))
3739 ;;; ----------------------------------------------------------------------
3741 (defun tinygnus-gnus-debug-on (&optional verb)
3742 "Turn on Gnus debug. See `tinygnus-:debug-buffer'. VERB.
3743 If you experience a problem during entering a group
3746 couldn't open server
3748 Call this function and it will record the state of several Gnus functions
3749 and call parameters and gateher them to `tinygnus-:debug-buffer'. Examining
3750 the results may reveal where the problem is."
3753 (let ((re "^tinygnus-debug"))
3756 (substitute-command-keys
3758 "TinyGnus: Gnus debug is now on (advices on). "
3759 "Show debug \\[tinygnus-debug-show]."))))
3760 (ad-enable-regexp re)
3761 ;; (ad-update-regexp re)
3762 (ad-activate-regexp re)))
3764 ;;; ----------------------------------------------------------------------
3766 (defun tinygnus-gnus-debug-off (&optional verb)
3767 "Turn off Gnus debug. See `tinygnus-:debug-buffer'. VERB."
3770 (let ((re "^tinygnus-debug"))
3773 (substitute-command-keys
3775 "TinyGnus: Gnus debug is now off (advices off). "
3776 "Show debug \\[tinygnus-debug-show]."))))
3777 (ad-disable-regexp re)
3778 (ad-update-regexp re)))
3783 ;;; .......................................................... &advice ...
3785 ;;; ----------------------------------------------------------------------
3786 ;;; Dormant handling is hard coded in gnus, and the fastest way to
3787 ;;; show them is include them in summary generation phase.
3788 ;;; Called by gnus-sum.el::gnus-summary-initial-limit
3790 ;;; #Todo: 2000-01 puts gnus to infinite loop. Fix this.
3792 (defadvice gnus-summary-limit-children (around tinygnus-show-dormants dis)
3793 "Replace function if `tinygnus-:show-dormants' is t.
3794 Make dormants immediately visible in non-nntp groups."
3795 (if (null tinygnus-:show-dormants)
3797 ;; Return 1 if this subthread is visible and 0 if it is not
3798 (when (ad-get-arg 0) ;thread flag
3800 ;; This part is copied from gnus-sum.el
3801 ((and (not (string-match "nntp" gnus-newsgroup-name))
3803 (if (cdr (ad-get-arg 0))
3804 (apply '+ (mapcar 'gnus-summary-limit-children
3805 (cdr (ad-get-arg 0))))
3807 (number (mail-header-number (car (ad-get-arg 0)))))
3808 ;; In original gnus this test would suppress dormants.
3809 (when (and (memq number gnus-newsgroup-dormant)
3811 (push number gnus-newsgroup-limit)
3812 (setq ad-return-value 1)))))
3816 ;;; ----------------------------------------------------------------------
3818 (defadvice gnus-topic-read-group
3819 (around tinygnus-fast-read-unread-articles act)
3820 "Read only unread/newly arrived articles. If no new articles, read as usual.
3821 If given prefix arg 2 x \\[universal-argument] (NO-THREADS) then all threads
3822 with unread articles will be displayed.
3824 To put it simply: When you see new articles in Group, entering the
3825 group only shows those new articles. This makes reading group faster."
3826 (let* ((fid "gnus-topic-read-group")
3827 (arg (ad-get-arg 0))
3828 ;; See also (gnus-group-group-name)
3829 (groups (gnus-group-process-prefix nil))
3830 (group (car groups))
3832 (unless fid ;; No-op. XEmacs byte compiler silencer
3834 ;; Parameter GROUP is not defined if you hit SPC on TOPIC
3835 ;; to collapse or open it.
3838 (or (null arg) (equal arg '16))
3839 (eq 1 (length groups))
3840 (string-match "nnml" group)
3841 (not (memq (car-safe (gnus-group-method group)) '(nntp)))
3842 (let ((gnus-fetch-old-headers (if arg t nil)))
3844 (gnus-list-of-unread-articles group))))
3845 (message "TinyGnus Advice: reading NEW articles.")
3847 (gnus-group-read-group nil t nil unread-arts))
3849 (message "TinyGnus Advice: Normal reading...")
3850 ;; As usual, no new articles.
3854 ;;{{{ 19.34 compressed .eld support
3856 ;;; ..................................................... &compression ...
3857 ;;; - sometimes I have _very_ limited quota and I woul wish gnus would allow
3858 ;;; using compresses files, but it doesn't by default.
3859 ;;; - These advices make Gnus use compressed startup files.
3860 ;;; - The functins are copied directly from Gnus kit and needed modifications
3865 ;;; gnus.el::gnus Find the current startup file name.
3866 ;;; (setq gnus-current-startup-file (gnus-make-newsrc-file gnus-startup-file))
3868 ;;; --++-- --++-- --++-- --++-- --++-- --++-- --++-- --+ &advice-start --
3870 (string-match tinygnus-:gnus-version-for-advice gnus-version)
3871 (stringp tinygnus-:z))
3873 (defadvice gnus-check-first-time-used (around tinygnus act)
3875 (if (or (> (length gnus-newsrc-alist) 1)
3876 (file-exists-p (concat gnus-startup-file (concat ".eld" tinygnus-:z)))
3877 (file-exists-p gnus-startup-file)
3878 (file-exists-p (concat gnus-startup-file ".el"))
3879 (file-exists-p (concat gnus-startup-file ".eld")))
3881 (gnus-message 6 "First time user; subscribing you to default groups")
3882 (unless (gnus-read-active-file-p)
3883 (gnus-read-active-file))
3884 (setq gnus-newsrc-last-checked-date (current-time-string))
3885 (let ((groups gnus-default-subscribed-newsgroups)
3889 (setq groups (or groups gnus-backup-default-subscribed-newsgroups))
3892 (if (null (setq group (symbol-name sym)))
3894 (let ((do-sub (gnus-matches-options-n group)))
3896 ((eq do-sub 'subscribe)
3897 (gnus-sethash group group gnus-killed-hashtb)
3898 (funcall gnus-subscribe-options-newsgroup-method group))
3899 ((eq do-sub 'ignore)
3902 (setq gnus-killed-list (cons group gnus-killed-list)))))))
3905 (if (gnus-active (car groups))
3906 (gnus-group-change-level
3907 (car groups) gnus-level-default-subscribed gnus-level-killed))
3908 (setq groups (cdr groups)))
3909 (gnus-group-make-help-group)
3910 (and gnus-novice-user
3911 (gnus-message 7 "`A k' to list killed groups"))))))
3913 (defun gnus-read-newsrc-file (&optional force)
3914 "Replace function. Optionally FORCE."
3916 ;;Make sure this is defined
3917 (setq gnus-current-startup-file (gnus-make-newsrc-file gnus-startup-file))
3918 (let ((variables gnus-variable-list))
3920 (set (car variables) nil)
3921 (setq variables (cdr variables))))
3922 (let* ((newsrc-file gnus-current-startup-file)
3923 (quick-file (concat newsrc-file ".el")))
3925 ;; We always load the .newsrc.eld file. If always contains
3926 ;; much information that can not be gotten from the .newsrc
3927 ;; file (ticked articles, killed groups, foreign methods, etc.)
3928 (gnus-read-newsrc-el-file quick-file)
3929 (if (and (file-exists-p gnus-current-startup-file)
3931 (and (file-newer-than-file-p newsrc-file quick-file)
3932 (file-newer-than-file-p
3933 newsrc-file (concat quick-file "d" tinygnus-:z)))
3934 (not gnus-newsrc-alist)))
3935 ;; We read the .newsrc file. Note that if there if a
3936 ;; .newsrc.eld file exists, it has already been read, and
3937 ;; the `gnus-newsrc-hashtb' has been created. While reading
3938 ;; the .newsrc file, Gnus will only use the information it
3939 ;; can find there for changing the data already read -
3940 ;; ie. reading the .newsrc file will not trash the data
3941 ;; already read (except for read articles).
3943 (gnus-message 5 "Reading %s..." newsrc-file)
3944 (set-buffer (find-file-noselect newsrc-file))
3945 (buffer-disable-undo (current-buffer))
3946 (gnus-newsrc-to-gnus-format)
3947 (kill-buffer (current-buffer))
3948 (gnus-message 5 "Reading %s...done" newsrc-file)))
3949 ;; Read any slave files.
3951 (gnus-master-read-slave-newsrc))
3952 ;; Convert old to new.
3953 (gnus-convert-old-newsrc))))
3955 (defadvice gnus-read-newsrc-el-file (around tinygnus act)
3957 (let ((ding-file (concat file "d" tinygnus-:z)))
3958 ;; We always, always read the .eld file.
3959 (gnus-message 5 "Reading %s..." ding-file)
3960 (let (gnus-newsrc-assoc)
3962 (load ding-file t t t)
3964 (gnus-error 1 "Error in %s" ding-file)))
3965 (when gnus-newsrc-assoc
3966 (setq gnus-newsrc-alist gnus-newsrc-assoc)))
3967 (gnus-make-hashtable-from-newsrc-alist)
3968 (when (file-newer-than-file-p file ding-file)
3969 ;; Old format quick file
3970 (gnus-message 5 "Reading %s..." file)
3971 ;; The .el file is newer than the .eld file, so we read that one
3973 (gnus-read-old-newsrc-el-file file))))
3975 (defadvice gnus-make-newsrc-file (around tinygnus act)
3979 (let* ((file (expand-file-name file nil))
3980 (real-file (concat file "-" (nth 1 gnus-select-method))))
3982 ((file-exists-p (concat real-file ".el" tinygnus-:z))
3983 (concat real-file ".el" tinygnus-:z))
3984 ((file-exists-p (concat file tinygnus-:z))
3985 (concat file tinygnus-:z))
3986 ((or (file-exists-p real-file)
3987 (file-exists-p (concat real-file ".el"))
3988 (file-exists-p (concat real-file ".eld")))
3993 (defadvice gnus-save-newsrc-file (around tinygnus act)
3994 "Add compressed file support."
3995 ;; Note: We cannot save .newsrc file if all newsgroups are removed
3996 ;; from the variable gnus-newsrc-alist.
3997 (when (and (or gnus-newsrc-alist gnus-killed-list)
3998 gnus-current-startup-file)
4000 (if (and (or gnus-use-dribble-file gnus-slave)
4002 (or (not gnus-dribble-buffer)
4003 (not (buffer-name gnus-dribble-buffer))
4004 (zerop (save-excursion
4005 (set-buffer gnus-dribble-buffer)
4007 (gnus-message 4 "(No changes need to be saved)")
4008 (run-hooks 'gnus-save-newsrc-hook)
4010 (gnus-slave-save-newsrc)
4012 (when gnus-save-newsrc-file
4013 (gnus-message 5 "Saving %s..." gnus-current-startup-file)
4014 (gnus-gnus-to-newsrc-format)
4015 (gnus-message 5 "Saving %s...done" gnus-current-startup-file))
4016 ;; Save .newsrc.eld.
4017 (set-buffer (get-buffer-create " *Gnus-newsrc*"))
4018 (make-local-variable 'version-control)
4019 (setq version-control 'never)
4020 (setq buffer-file-name
4021 (concat gnus-current-startup-file ".eld" tinygnus-:z))
4022 (setq default-directory (file-name-directory buffer-file-name))
4023 (gnus-add-current-to-buffer-list)
4024 (buffer-disable-undo (current-buffer))
4026 (gnus-message 5 "Saving %s.eld..." gnus-current-startup-file)
4027 (gnus-gnus-to-quick-newsrc-format)
4028 (run-hooks 'gnus-save-quick-newsrc-hook)
4030 (kill-buffer (current-buffer))
4032 5 "Saving %s.eld...done" gnus-current-startup-file))
4033 (gnus-dribble-delete-file)
4034 (gnus-group-set-mode-line)))))
4036 ;;; --++-- --++-- --++-- --++-- --++-- --++-- --++-- --++- &advice-end --
4044 (run-hooks 'tinygnus-:load-hook)
4046 ;;; tinygnus.el ends here