gnus-5.11+v0.10.dfsg/0000755000175000017500000000000011006436031014266 5ustar tvainikatvainikagnus-5.11+v0.10.dfsg/ChangeLog0000644000175000017500000005572211002752021016047 0ustar tvainikatvainika2008-04-12 Reiner Steib * Makefile.in (release-check-settings): Clarify codename. (release-help): New target. (release-cvs-export): Add umask. Suggested by Sven Joachim. 2008-04-11 Reiner Steib * README: Bump version to 0.9. 2008-04-10 Reiner Steib * README: No Gnus v0.8 is released. 2008-03-01 Reiner Steib * Update copyright years. 2008-02-07 Katsumi Yamaoka * GNUS-NEWS: Generated. * Makefile.in (datarootdir): Define. * aclocal.m4 (AC_PATH_LISPDIR): Quote directory name that might contain whitespace. * configure: Regenerate. * mkinstalldirs: Replace it with the 2006-05-11.19 version. 2008-01-16 Katsumi Yamaoka * GNUS-NEWS: Generated. 2008-01-11 Katsumi Yamaoka * GNUS-NEWS: Generated. 2007-11-18 Reiner Steib * GNUS-NEWS: Generated. 2007-11-04 Reiner Steib * Makefile.in (RELEASE_COMMIT_FILES): Add etc/ChangeLog. (release-check-settings): Add release-add-changelog (release-bump-version): Add check for CODENAME_TO_STABLE. Split off release-add-changelog. (release-add-changelog): New target. Separate some commands from release-bump-version. Add etc/ChangeLog. (release-diff-commit-files): New target. (RELEASE_COMMIT_FILES): Reorder files. 2007-11-03 Reiner Steib * COPYING: GPLv3 from Emacs repository. 2007-10-28 Reiner Steib * Makefile.in (SED_I, CODENAME_PATTERN): New. (OLD_PATTERN): Adjust. (release-bump-version): Use new variables. Allow going from development version to release. 2007-10-27 Reiner Steib * Makefile.in (release-bump-version): Adjust version in (gnus)Troubleshooting. 2007-10-10 Katsumi Yamaoka * GNUS-NEWS: Generated. 2007-10-04 Reiner Steib * Relicense "GPLv2 or later" files to "GPLv3 or later". 2007-09-17 Alexander Solovyov (tiny change) * make.bat: Initial check didn't work if path contained spaces. 2007-07-02 Reiner Steib * Makefile.in (COMMIT_STRING): New variable. (release-bump-version): Use it. (bump-version, bump-version-commit): New targets. 2007-06-06 Andreas Seltenreich * todo: Add comment. Remove duplicate item. 2007-05-02 Reiner Steib * README: Bump version number. 2007-04-11 Didier Verna * GNUS-NEWS: Generated. 2007-04-01 Reiner Steib * GNUS-NEWS: Generated. 2007-03-23 Katsumi Yamaoka * README: Bump ngnus version. 2006-12-26 Reiner Steib * GNUS-NEWS: Generated. 2006-10-09 Romain Francoise * todo: Fix some typos. 2006-04-19 Reiner Steib * make.bat: Use "echo *" to clarify the output. (:lisp, :infotest): Avoid "not found" errors (:etc): Remove etc\gnus. Be more verbose. Add new smilies. Simplify. 2006-04-11 Reiner Steib * etc/Makefile.in (install): Install new smileys. 2006-04-11 Adam Sj,Ax(Bgren * etc/images/smilies/grayscale/*.xpm: New larger grayscale smileys. * etc/images/smilies/medium/*.xpm: New colorful smileys. 2006-04-11 Reiner Steib * README: No Gnus v0.4 is released. 2006-04-11 Reiner Steib * Makefile.in (release-sign-files): Use rm -f. (RELEASE_COMMIT_FILES): Add ./ChangeLog. (release-bump-version): Add README. (release-check-settings): OLD_TAG, not OLDTAG. (release-commit): Echo command lines before prompt. (RELEASE_COMMIT_FILES): Add README. (OLD_PATTERN): Fix. (release-bump-version): Fix gnusversionname substitution. (OLD_PATTERN): Add grouping. 2006-04-10 Reiner Steib * Makefile.in (GZIP_PROG): Use gzip -f. (release-bump-version, RELEASE_COMMIT_FILES): Add README. (release-sign-files): Remove old *.sig files. * README: Say "development version". Let sentences end with double space. 2006-04-07 Reiner Steib * Makefile.in (GZIP_PROG): New variable. (release-diff): Use it. (release-sign-files): New sign-only target. Use GPG_AGENT_INFO. 2006-04-04 Reiner Steib * Makefile.in (TAR_BALL_EXTRA, release-make-tar-ball, README): Remove; README is in CVS now. (release-files, release-files-signed, release-cvs-export) (release-make-tar-ball): Use $(VERSION) instead of $(TAG). (OLD_PATTERN): Catch stable and trunk. (CIN): New variable. (release-files, release-files-signed, release-cvs-export) (release-make-tar-ball, release-diff, release-post-clean): Add CIN. (OLD_PATTERN): Remove quotes. (release-bump-version): Fix typo. * etc/images/README: Add more Emacs 22 icons. Add suggestion on how to use those in Emacs 21. * etc/images/close.xpm, etc/images/cut.xpm, etc/images/home.xpm, etc/images/index.xpm, etc/images/jump-to.xpm, etc/images/new.xpm, etc/images/next-node.xpm, etc/images/open.xpm, etc/images/preferences.xpm, etc/images/prev-node.xpm, etc/images/saveas.xpm, etc/images/spell.xpm: New icons duplicated from Emacs 22. * README: Addition from 5.10.6 tar ball. Clarify "beta". Simplify Info directory setting. Update required Emacs and XEmacs version. Use current Gnus version in examples. 2006-03-31 Reiner Steib * GNUS-NEWS: Generated. * Makefile.in (CVS_IGNORE_FILES): Additions. (release-files-signed): New target. * etc/images/README: Update separator.xpm. 2006-03-30 Romain Francoise * GNUS-NEWS: Generated. 2006-03-30 Reiner Steib * etc/images/separator.xpm: Update from Emacs CVS. * GNUS-NEWS: Generated. 2006-03-29 Reiner Steib * Makefile.in (release-bump-version): Consider named Gnus versions in replacements. * todo: Update "tool bar icons". 2006-03-27 Reiner Steib * Makefile.in (release-revert-files): Replace release-revert-changelog. (release-diff): Remove garbage. 2006-03-07 Reiner Steib * etc/images/README: Add GIMP script. (attach.xpm): Move to top level. (sort-*.xpm) Add. * etc/images/sort-ascending.xpm, etc/images/sort-column-ascending.xpm, etc/images/sort-criteria.xpm, etc/images/sort-descending.xpm, etc/images/sort-row-ascending.xpm: New icons from GNOME 2.6. 2006-03-10 Reiner Steib * Makefile.in (release-check-settings): Add status and suggestions. (release-files): Remove duplicate release-cvs-export. (README): New target. (release-files, release-make-tar-ball, release-diff): List files. (README, release-make-tar-ball): Fix. 2006-03-06 Reiner Steib * GNUS-NEWS: Generated. * Makefile.in (release-*): New targets. 2006-02-28 Reiner Steib * todo: Remove nnweb. Add: widget for posting styles, doc string for utility functions, LIST SUBSCRIPTIONS, divide emacs-mime.texi, change servers. * etc/images/README (next-page.xpm): From Gnome, not from Emacs 22. * cancel.xpm, copy.xpm, diropen.xpm, help.xpm, left-arrow.xpm, next-page.xpm, paste.xpm, print.xpm, redo.xpm, right-arrow.xpm, save.xpm, search.xpm: New icons duplicated from Emacs 22. * etc/images/README: Add these icons. * etc/images/README: Describe the new images. * etc/gnus/gnus-setup.ast, etc/gnus/news-server.ast: Use texinfo-mode. * etc/images/mail/save.xpm, etc/images/mail/preview.xpm: Rename char*. 2006-03-03 Reiner Steib * xemacs.mak: Remove outdated file. Use make.bat instead. 2006-03-02 Reiner Steib * make.bat: Add note about "Out of environment space" on Windows 98 SE. Avoid `>' in echo. 2006-02-27 Reiner Steib * ChangeLog, texi/ChangeLog, lisp/ChangeLog: Fix "From so-and-so" and "(tiny change)" entries. 2006-02-22 Reiner Steib * etc/images/gnus/mail_send.xpm: Emacs 21 icon for message-tool-bar-retro. 2006-02-21 Reiner Steib * make.bat (:etc): Also consider images in images/mail and images/. * etc/Makefile.in (install, uninstall): Also consider images in images/mail and images/. * etc/images/connect.xpm, etc/images/contact.xpm, etc/images/delete.xpm, etc/images/describe.xpm, etc/images/disconnect.xpm, etc/images/exit.xpm, etc/images/lock-broken.xpm, etc/images/lock-ok.xpm, etc/images/lock.xpm, etc/images/refresh.xpm, etc/images/gnus/toggle-subscription.xpm, etc/images/mail/attach.xpm, etc/images/mail/compose.xpm, etc/images/mail/copy.xpm, etc/images/mail/forward.xpm, etc/images/mail/inbox.xpm, etc/images/mail/move.xpm, etc/images/mail/not-spam.xpm, etc/images/mail/outbox.xpm, etc/images/mail/reply-all.xpm, etc/images/mail/reply.xpm, etc/images/mail/save-draft.xpm, etc/images/mail/send.xpm, etc/images/mail/spam.xpm: New icons from GNOME 2.6. 2006-02-21 Miguel Frasson * etc/images/separator.xpm: Copy of sep.xpm from AUCTeX. 2006-02-21 Adam Sj,Ax(Bgren * etc/images/mail/save.xpm, etc/images/mail/preview.xpm: New icons. 2006-01-26 Katsumi Yamaoka * Makefile.in (clean): Clean all subdirectories; remove *~. (elclean): Remove lisp/auto-autoloads.el, lisp/custom-load.el, and lisp/gnus-load.el. (distclean): Don't use sub-make to run clean; use $(MAKE) instead of make. * etc/Makefile.in (clean): New rule. (distclean): Use it; remove Makefile. 2005-12-06 Katsumi Yamaoka * GNUS-NEWS: Generated. 2005-10-31 Lars Magne Ingebrigtsen * Testing CVS setup. Yes. Yes. Yes. Yes. 2005-10-04 Katsumi Yamaoka * aclocal.m4 (AC_PATH_LISPDIR): Default to .../site-lisp/gnus for Emacs. (AC_PATH_ETCDIR): Don't change the default value for Emacs. * configure: Generated. * Makefile.in (list-installed-shadows): New entry. (remove-installed-shadows): New entry. * GNUS-NEWS: Generated. 2005-09-28 Reiner Steib * todo: Remove some items that are already done. Add some new items. Add some comments. 2005-08-10 Romain Francoise * GNUS-NEWS: Generated. 2005-07-18 Romain Francoise * GNUS-NEWS: Generated. 2005-02-19 Miles Bader * etc/Makefile.in (install): Create $(etcdir)/images/gnus dir. * etc/Makefile.in (install, uninstall): Fix installed image dirs. * etc/Makefile.in (install): Put gnus-tut.txt in the right place. * Makefile.in (all): Don't do sub-make in etc. * etc/Makefile.in (all): Remove target. * make.bat: Do image copies properly. 2005-02-18 Miles Bader Move all remaining images from etc/gnus to etc/images/gnus. 2004-06-18 Reiner Steib * Makefile.in (all): Do sub-make in etc. * etc/Makefile.in (all): Link . to images. (install, uninstall): Use $(etcdir)/images for images. * make.bat: Likewise. 2005-01-02 Romain Francoise * GNUS-NEWS: Generated. 2004-12-26 Katsumi Yamaoka * GNUS-NEWS: Generated. 2004-12-06 Reiner Steib * GNUS-NEWS: Generated. 2004-09-30 Simon Josefsson * Makefile.in (GNUS-NEWS): Depend on texi/gnus-news.texi. * GNUS-NEWS: Generated. 2004-09-29 Simon Josefsson * GNUS-NEWS: Generated. * Makefile.in (GNUS-NEWS): Add. 2004-09-11 Simon Josefsson * GNUS-NEWS: Generated. 2004-09-02 Reiner Steib * etc/.cvsignore: Remove unused. 2004-06-16 Reiner Steib * make.bat: Fix line endings around arch-tag. 2004-06-03 Teodor Zlatanov * etc/gnus/gnus-setup.ast (Setting up a NNTP server) (Setting up local mail storage (nnml)): fixed some bugs, added a new screen - still testing 2004-06-01 Simon Josefsson * make.bat: Add SASL manual. 2004-05-23 Lars Magne Ingebrigtsen * etc/gnus/news-server.ast: Use library validation. 2004-03-08 Kevin Greiner * make.bat: Make sure that gnus-load.el and sieve are writable to avoid breakage. 2004-03-01 Michael Schierl (tiny change) * make.bat: Fix directory test for Windows 9x/ME. 2004-01-07 Hiroshi Fujishima (tiny change) * etc/gnus-tut.txt: `G m' instead of `G V' 2004-01-05 Jesper Harder * make.bat: Add missing parens. From Robert Marshall . 2004-01-05 Simon Josefsson * GNUS-NEWS: Mention SASL, and that sieve-manage uses it. Mention password.el. Mention NTLM. 2004-01-04 Simon Josefsson * GNUS-NEWS: Add IMAP ID (RFC 2971) support. Mention `W e' for editing all.SCORE. 2004-01-03 Reiner Steib * GNUS-NEWS: Update copyright. * etc/gnus-tut.txt (Gnus FAQ): Remove text version. Refer to info documentation and online version instead. * GNUS-NEWS: Changed "Dired integration" 2004-01-02 Reiner Steib * GNUS-NEWS: Add `gnus-group-read-ephemeral-group'. 2003-12-23 Reiner Steib * GNUS-NEWS: Mention change of `e' in draft groups. 2003-05-01 Jesper Harder * etc/gnus-tut.txt (http): Update. 2003-05-01 Simon Josefsson * GNUS-NEWS: Add prefix limit feature. 2003-04-30 Reiner Steib * GNUS-NEWS: Added Article Buttons. Added Upgrading (from Simon Josefsson). Add gnus-mime-delete-part, markup fixes and some other corrections. Mention Gnus FAQ. 2003-04-30 Jesper Harder * GNUS-NEWS: Additions. 2003-04-28 Reiner Steib * GNUS-NEWS: Fixed X-Draft-Headers entry. 2003-04-27 Simon Josefsson * GNUS-NEWS: Fix PGP entry. Doc GCC variable change. 2003-04-22 Reiner Steib * make.bat: Flag as binary to ensure DOS line terminators. Delete trailing whitespace. 2003-04-21 Reiner Steib From Frank Schmitt * etc/gnus-tut.txt: Update Gnus FAQ, delete trailing whitespace. 2003-04-17 Kevin Greiner * make.bat: Cleaned up end-of-line characters. 2003-04-17 Steve Youngs * Makefile.in (XEMACS): Use @EMACS@. * aclocal.m4 (AC_PATH_LISPDIR): Set $datadir to $prefix/lib if building with XEmacs. * aclocal.m4 (AC_SET_BUILD_FLAGS): New. So we can set XEmacs command line options to '-batch -no-autoloads...' for a cleaner build environment. * configure.in: Use it. * configure: Regenerate. 2003-04-16 Reiner Steib From Frank Schmitt * make.bat: New variable EMACS_ARGS. Changed XEmacs args. 2003-03-23 Simon Josefsson * GNUS-NEWS: Add IDNA. Add TLS. Fix USEFOR reference. 2003-03-22 Frank Schmitt * make.bat: Redone from scratch; supports both Emacs and XEmacs now; correctly generate gnus-load.el; check for errors; use makeinfo if available, infohack.el if it isn't; be less verbose when copying files; copy files from etc/gnus and etc/smilies, too 2003-03-22 Frank Schmitt * make-x.bat: Removed, make.bat does its job now. 2003-03-22 Frank Schmitt * etc/gnus-tut.txt: Include Gnus FAQ from http://my.gnus.org. 2003-02-19 Reiner Steib * GNUS-NEWS: Renamed `gnus-unsightly-citation-regexp' to `gnus-cite-unsightly-citation-regexp'. 2003-02-18 Simon Josefsson * GNUS-NEWS: Talk about canlock more. 2003-02-13 Kai Gro,A_(Bjohann * GNUS-NEWS: Add user visible changes from Michael Shields from the past couple of days. Actual text from Michael. 2003-01-24 Jesper Harder * etc/gnus-tut.txt: Update. 2003-01-15 Simon Josefsson * GNUS-NEWS: Add. Fix from Reiner Steib <4uce.02.r.steib@gmx.net>. 2003-01-10 Reiner Steib * make.bat: Removed "-no-init-file" (it's the same as "-q"). Use new variables EMACSBATCH and GNUS_INFO_DIR. Install gnus-?, message-?, sieve and pgg (in texi). Added hint for dir entries. * make-x.bat: Ditto. 2003-01-13 Simon Josefsson * GNUS-NEWS: Add smileys, Sender:, message-utils. Expand anti-spam. Fixes. 2003-01-09 Simon Josefsson * etc/gnus/preview.xpm: Add. 2003-01-06 Simon Josefsson * etc/gnus/receipt.xpm: Add. 2003-01-10 Jesper Harder * etc/gnus/preview.xbm: Add. 2003-01-05 Katsumi Yamaoka * etc/gnus/gnus.xpm (oort): Make the color replaceable. 2002-12-05 Kai Gro,A_(Bjohann * etc/smilies/*.pbm: Made them binary. 2002-11-13 Kai Gro,A_(Bjohann * etc/smilies/blink.xpm: Changed smileys and some new ones from Alex Schroeder . 2002-04-26 Steve Youngs * aclocal.m4 (AC_PATH_INFODIR): New. Defaults to '$prefix/info' for Emacs and 'site-packages/info' for XEmacs. (AC_PATH_ETCDIR): Drop 'gnus' off the end of the default directory for XEmacs. * configure.in: Use 'AC_PATH_INFO_DIR'. 2002-02-22 Steve Youngs * aclocal.m4 (AC_PATH_LISPDIR): Default to .../site-packages/lisp/gnus for XEmacs. (AC_PATH_ETCDIR): Default to .../site-packages/etc/gnus for XEmacs. 2002-02-01 ShengHuo ZHU * etc/gnus/gnus.xpm: Remove some garbages at the end of the file. 2002-01-05 Lars Magne Ingebrigtsen * etc/gnus/oort.xface (X-Face): Oort X-Face from Raymond Scholz . 2002-01-02 ShengHuo ZHU * etc/gnus/describe-group.xpm: Set pixels of first line to background color. A bug in Emacs? 2001-12-18 Josh Huber * ChangeLog, todo: (oops) changed buffer-file-coding-system back to coding. 2001-12-18 Kai Gro,A_(Bjohann * make-x.bat: Ensure nonempty variable value. Reported by Frank Haun . 2001-12-18 01:00:00 ShengHuo ZHU * ChangeLog, todo: Add `coding'. 2001-12-17 Josh Huber * ChangeLog: changed coding to buffer-file-coding-system * todo: same 2001-12-10 Kai Gro,A_(Bjohann * make-x.bat: Code cleanup. Fix a bug with "/copy". From Frank Schmitt . 2001-11-26 Kai Gro,A_(Bjohann * make-x.bat: Use parameter "/copy" rather than "copy" for increased dwimishness for old-time DOS users. From Frank Schmitt . 2001-11-15 Simon Josefsson * etc/gnus/unimportant.xpm, etc/gnus/important.xpm: New files. 2001-11-11 Simon Josefsson * make-x.bat: Don't use -nw. Suggested by Frank Haun . 2001-11-01 07:00:00 ShengHuo ZHU * etc/smilies/blink.xpm: New set of xpm. From Oliver Scholz . 2001-10-29 Per Abrahamsen * etc/smilies/sad.pbm: New bitmap. * etc/smilies/blink.pbm: Ditto. Contributed by Kim F. Storm . 2001-10-19 Kai Gro,A_(Bjohann From Frank Schmitt . * make-x.bat: Use correct directory structure for XEmacs on Windows. 2001-10-06 08:00:00 ShengHuo ZHU * Makefile.in (uninstall): Add. * etc/Makefile.in (uninstall): Add. 2001-09-27 14:00:00 ShengHuo ZHU * aclocal.m4 (GNUS_CHECK_FONTS): Typo. Use /dev/null as latex input. 2001-09-27 09:00:00 ShengHuo ZHU * aclocal.m4, configure.in: Check commercial fonts. 2001-09-24 19:00:00 ShengHuo ZHU * configure.in: Generate texi/ps/Makefile. 2001-09-21 Kai Gro,A_(Bjohann * make.bat: Use parameter "/copy" rather than "copy" for increased dwimishness for old-time DOS users. 2001-09-18 22:00:00 ShengHuo ZHU * make-x.bat: New. 2001-07-04 Yair Friedman * make.bat: Use infohack.el to create info files. 2001-05-17 Kai Gro,A_(Bjohann * etc/Makefile.in (datadir): Set this variable, like in the other Makefile.in's. Patch from Gaute B Strokkenes . 2001-02-11 18:00:00 ShengHuo ZHU * GNUS-NEWS: Copyright and others. 2001-02-09 20:00:00 ShengHuo ZHU * aclocal.m4 (AC_CHECK_URL): Add. * configure.in: Use it. 2001-01-15 Jesper Harder * make.bat: Fix doc. 2000-12-22 03:00:00 ShengHuo ZHU * configure.in: Add etc/Makefile. 2000-12-20 Jesper Harder * make.bat: set max-lisp-eval-depth. 2000-10-12 Jesper Harder * make.bat: Makes it possible to generate the Info files on windows again. 2000-08-24 Jesper Harder * make.bat: Use emacs.exe if emacs.bat does not exist. 2000-05-07 Pavel Janik * gnus.texi: direntry added. * message.texi: direntry added. * emacs-mime.texi: direntry added. 2000-07-13 10:09:52 Katsumi Yamaoka * aclocal.m4 (AC_CHECK_W3): Fix typo. 2000-07-12 15:47:06 ShengHuo ZHU * aclocal.m4: Stolen macros from w3. * configure.in: Use them. * configure: Generate it. 2000-04-22 20:25:20 Lars Magne Ingebrigtsen * GNUS-NEWS: Outline. 2000-01-06 Dave Love * aclocal.m4 (AM_PATH_LISPDIR): Check for user's EMACS setting. 1999-11-13 Adrian Aichner * xemacs.mak: New NMAKE file to support build and install on Windows NT. Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc. This file is part of GNU Emacs. GNU Emacs is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 3, or (at your option) any later version. GNU Emacs is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with GNU Emacs; see the file COPYING. If not, write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. ;; Local Variables: ;; coding: iso-2022-7bit ;; fill-column: 79 ;; add-log-time-zone-rule: t ;; End: ;;; arch-tag: 60301ba8-b152-41b3-8fb2-173bba77f2a8 gnus-5.11+v0.10.dfsg/lisp/0000755000175000017500000000000011006436031015235 5ustar tvainikatvainikagnus-5.11+v0.10.dfsg/lisp/gnus-kill.el0000644000175000017500000006055711004005110017465 0ustar tvainikatvainika;;; gnus-kill.el --- kill commands for Gnus ;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, ;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc. ;; Author: Masanobu UMEDA ;; Lars Magne Ingebrigtsen ;; Keywords: news ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 3, or (at your option) ;; any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Commentary: ;;; Code: (eval-when-compile (require 'cl)) (require 'gnus) (require 'gnus-art) (require 'gnus-range) (defcustom gnus-kill-file-mode-hook nil "Hook for Gnus kill file mode." :group 'gnus-score-kill :type 'hook) (defcustom gnus-kill-expiry-days 7 "*Number of days before expiring unused kill file entries." :group 'gnus-score-kill :group 'gnus-score-expire :type 'integer) (defcustom gnus-kill-save-kill-file nil "*If non-nil, will save kill files after processing them." :group 'gnus-score-kill :type 'boolean) (defcustom gnus-winconf-kill-file nil "What does this do, Lars? I don't know, Per." :group 'gnus-score-kill :type 'sexp) (defcustom gnus-kill-killed t "*If non-nil, Gnus will apply kill files to already killed articles. If it is nil, Gnus will never apply kill files to articles that have already been through the scoring process, which might very well save lots of time." :group 'gnus-score-kill :type 'boolean) (defmacro gnus-raise (field expression level) `(gnus-kill ,field ,expression (function (gnus-summary-raise-score ,level)) t)) (defmacro gnus-lower (field expression level) `(gnus-kill ,field ,expression (function (gnus-summary-raise-score (- ,level))) t)) ;;; ;;; Gnus Kill File Mode ;;; (defvar gnus-kill-file-mode-map nil) (unless gnus-kill-file-mode-map (gnus-define-keymap (setq gnus-kill-file-mode-map (copy-keymap emacs-lisp-mode-map)) "\C-c\C-k\C-s" gnus-kill-file-kill-by-subject "\C-c\C-k\C-a" gnus-kill-file-kill-by-author "\C-c\C-k\C-t" gnus-kill-file-kill-by-thread "\C-c\C-k\C-x" gnus-kill-file-kill-by-xref "\C-c\C-a" gnus-kill-file-apply-buffer "\C-c\C-e" gnus-kill-file-apply-last-sexp "\C-c\C-c" gnus-kill-file-exit)) (defun gnus-kill-file-mode () "Major mode for editing kill files. If you are using this mode - you probably shouldn't. Kill files perform badly and paint with a pretty broad brush. Score files, on the other hand, are vastly faster (40x speedup) and give you more control over what to do. In addition to Emacs-Lisp Mode, the following commands are available: \\{gnus-kill-file-mode-map} A kill file contains Lisp expressions to be applied to a selected newsgroup. The purpose is to mark articles as read on the basis of some set of regexps. A global kill file is applied to every newsgroup, and a local kill file is applied to a specified newsgroup. Since a global kill file is applied to every newsgroup, for better performance use a local one. A kill file can contain any kind of Emacs Lisp expressions expected to be evaluated in the Summary buffer. Writing Lisp programs for this purpose is not so easy because the internal working of Gnus must be well-known. For this reason, Gnus provides a general function which does this easily for non-Lisp programmers. The `gnus-kill' function executes commands available in Summary Mode by their key sequences. `gnus-kill' should be called with FIELD, REGEXP and optional COMMAND and ALL. FIELD is a string representing the header field or an empty string. If FIELD is an empty string, the entire article body is searched for. REGEXP is a string which is compared with FIELD value. COMMAND is a string representing a valid key sequence in Summary mode or Lisp expression. COMMAND defaults to '(gnus-summary-mark-as-read nil \"X\"). Make sure that COMMAND is executed in the Summary buffer. If the second optional argument ALL is non-nil, the COMMAND is applied to articles which are already marked as read or unread. Articles which are marked are skipped over by default. For example, if you want to mark articles of which subjects contain the string `AI' as read, a possible kill file may look like: (gnus-kill \"Subject\" \"AI\") If you want to mark articles with `D' instead of `X', you can use the following expression: (gnus-kill \"Subject\" \"AI\" \"d\") In this example it is assumed that the command `gnus-summary-mark-as-read-forward' is assigned to `d' in Summary Mode. It is possible to delete unnecessary headers which are marked with `X' in a kill file as follows: (gnus-expunge \"X\") If the Summary buffer is empty after applying kill files, Gnus will exit the selected newsgroup normally. If headers which are marked with `D' are deleted in a kill file, it is impossible to read articles which are marked as read in the previous Gnus sessions. Marks other than `D' should be used for articles which should really be deleted. Entry to this mode calls emacs-lisp-mode-hook and gnus-kill-file-mode-hook with no arguments, if that value is non-nil." (interactive) (kill-all-local-variables) (use-local-map gnus-kill-file-mode-map) (set-syntax-table emacs-lisp-mode-syntax-table) (setq major-mode 'gnus-kill-file-mode) (setq mode-name "Kill") (lisp-mode-variables nil) (gnus-run-mode-hooks 'emacs-lisp-mode-hook 'gnus-kill-file-mode-hook)) (defun gnus-kill-file-edit-file (newsgroup) "Begin editing a kill file for NEWSGROUP. If NEWSGROUP is nil, the global kill file is selected." (interactive "sNewsgroup: ") (let ((file (gnus-newsgroup-kill-file newsgroup))) (gnus-make-directory (file-name-directory file)) ;; Save current window configuration if this is first invocation. (or (and (get-file-buffer file) (get-buffer-window (get-file-buffer file))) (setq gnus-winconf-kill-file (current-window-configuration))) ;; Hack windows. (let ((buffer (find-file-noselect file))) (cond ((get-buffer-window buffer) (pop-to-buffer buffer)) ((eq major-mode 'gnus-group-mode) (gnus-configure-windows 'group) ;Take all windows. (pop-to-buffer buffer)) ((eq major-mode 'gnus-summary-mode) (gnus-configure-windows 'article) (pop-to-buffer gnus-article-buffer) (bury-buffer gnus-article-buffer) (switch-to-buffer buffer)) (t ;No good rules. (find-file-other-window file)))) (gnus-kill-file-mode))) ;; Fix by Sudish Joseph . (defun gnus-kill-set-kill-buffer () (let* ((file (gnus-newsgroup-kill-file gnus-newsgroup-name)) (buffer (find-file-noselect file))) (set-buffer buffer) (gnus-kill-file-mode) (bury-buffer buffer))) (defun gnus-kill-file-enter-kill (field regexp &optional dont-move) ;; Enter kill file entry. ;; FIELD: String containing the name of the header field to kill. ;; REGEXP: The string to kill. (save-excursion (let (string) (unless (eq major-mode 'gnus-kill-file-mode) (gnus-kill-set-kill-buffer)) (unless dont-move (goto-char (point-max))) (insert (setq string (format "(gnus-kill %S %S)\n" field regexp))) (gnus-kill-file-apply-string string)))) (defun gnus-kill-file-kill-by-subject () "Kill by subject." (interactive) (gnus-kill-file-enter-kill "Subject" (if (vectorp gnus-current-headers) (regexp-quote (gnus-simplify-subject (mail-header-subject gnus-current-headers))) "") t)) (defun gnus-kill-file-kill-by-author () "Kill by author." (interactive) (gnus-kill-file-enter-kill "From" (if (vectorp gnus-current-headers) (regexp-quote (mail-header-from gnus-current-headers)) "") t)) (defun gnus-kill-file-kill-by-thread () "Kill by author." (interactive) (gnus-kill-file-enter-kill "References" (if (vectorp gnus-current-headers) (regexp-quote (mail-header-id gnus-current-headers)) ""))) (defun gnus-kill-file-kill-by-xref () "Kill by Xref." (interactive) (let ((xref (and (vectorp gnus-current-headers) (mail-header-xref gnus-current-headers))) (start 0) group) (if xref (while (string-match " \\([^ \t]+\\):" xref start) (setq start (match-end 0)) (when (not (string= (setq group (substring xref (match-beginning 1) (match-end 1))) gnus-newsgroup-name)) (gnus-kill-file-enter-kill "Xref" (concat " " (regexp-quote group) ":") t))) (gnus-kill-file-enter-kill "Xref" "" t)))) (defun gnus-kill-file-raise-followups-to-author (level) "Raise score for all followups to the current author." (interactive "p") (let ((name (mail-header-from gnus-current-headers)) string) (save-excursion (gnus-kill-set-kill-buffer) (goto-char (point-min)) (setq name (read-string (concat "Add " level " to followup articles to: ") (regexp-quote name))) (setq string (format "(gnus-kill %S %S '(gnus-summary-temporarily-raise-by-thread %S))\n" "From" name level)) (insert string) (gnus-kill-file-apply-string string)) (gnus-message 6 "Added temporary score file entry for followups to %s." name))) (defun gnus-kill-file-apply-buffer () "Apply current buffer to current newsgroup." (interactive) (if (and gnus-current-kill-article (get-buffer gnus-summary-buffer)) ;; Assume newsgroup is selected. (gnus-kill-file-apply-string (buffer-string)) (ding) (gnus-message 2 "No newsgroup is selected."))) (defun gnus-kill-file-apply-string (string) "Apply STRING to current newsgroup." (interactive) (let ((string (concat "(progn \n" string "\n)"))) (save-excursion (save-window-excursion (pop-to-buffer gnus-summary-buffer) (eval (car (read-from-string string))))))) (defun gnus-kill-file-apply-last-sexp () "Apply sexp before point in current buffer to current newsgroup." (interactive) (if (and gnus-current-kill-article (get-buffer gnus-summary-buffer)) ;; Assume newsgroup is selected. (let ((string (buffer-substring (save-excursion (forward-sexp -1) (point)) (point)))) (save-excursion (save-window-excursion (pop-to-buffer gnus-summary-buffer) (eval (car (read-from-string string)))))) (ding) (gnus-message 2 "No newsgroup is selected."))) (defun gnus-kill-file-exit () "Save a kill file, then return to the previous buffer." (interactive) (save-buffer) (let ((killbuf (current-buffer))) ;; We don't want to return to article buffer. (when (get-buffer gnus-article-buffer) (bury-buffer gnus-article-buffer)) ;; Delete the KILL file windows. (delete-windows-on killbuf) ;; Restore last window configuration if available. (when gnus-winconf-kill-file (set-window-configuration gnus-winconf-kill-file)) (setq gnus-winconf-kill-file nil) ;; Kill the KILL file buffer. Suggested by tale@pawl.rpi.edu. (kill-buffer killbuf))) ;; For kill files (defun gnus-Newsgroup-kill-file (newsgroup) "Return the name of a kill file for NEWSGROUP. If NEWSGROUP is nil, return the global kill file instead." (cond ((or (null newsgroup) (string-equal newsgroup "")) ;; The global kill file is placed at top of the directory. (expand-file-name gnus-kill-file-name gnus-kill-files-directory)) (gnus-use-long-file-name ;; Append ".KILL" to capitalized newsgroup name. (expand-file-name (concat (gnus-capitalize-newsgroup newsgroup) "." gnus-kill-file-name) gnus-kill-files-directory)) (t ;; Place "KILL" under the hierarchical directory. (expand-file-name (concat (gnus-newsgroup-directory-form newsgroup) "/" gnus-kill-file-name) gnus-kill-files-directory)))) (defun gnus-expunge (marks) "Remove lines marked with MARKS." (save-excursion (set-buffer gnus-summary-buffer) (gnus-summary-limit-to-marks marks 'reverse))) (defun gnus-apply-kill-file-unless-scored () "Apply .KILL file, unless a .SCORE file for the same newsgroup exists." (cond ((file-exists-p (gnus-score-file-name gnus-newsgroup-name)) ;; Ignores global KILL. (when (file-exists-p (gnus-newsgroup-kill-file gnus-newsgroup-name)) (gnus-message 3 "Note: Ignoring %s.KILL; preferring .SCORE" gnus-newsgroup-name)) 0) ((or (file-exists-p (gnus-newsgroup-kill-file nil)) (file-exists-p (gnus-newsgroup-kill-file gnus-newsgroup-name))) (gnus-apply-kill-file-internal)) (t 0))) (defun gnus-apply-kill-file-internal () "Apply a kill file to the current newsgroup. Returns the number of articles marked as read." (let* ((kill-files (list (gnus-newsgroup-kill-file nil) (gnus-newsgroup-kill-file gnus-newsgroup-name))) (unreads (length gnus-newsgroup-unreads)) (gnus-summary-inhibit-highlight t) beg) (setq gnus-newsgroup-kill-headers nil) ;; If there are any previously scored articles, we remove these ;; from the `gnus-newsgroup-headers' list that the score functions ;; will see. This is probably pretty wasteful when it comes to ;; conses, but is, I think, faster than having to assq in every ;; single score function. (let ((files kill-files)) (while files (if (file-exists-p (car files)) (let ((headers gnus-newsgroup-headers)) (if gnus-kill-killed (setq gnus-newsgroup-kill-headers (mapcar (lambda (header) (mail-header-number header)) headers)) (while headers (unless (gnus-member-of-range (mail-header-number (car headers)) gnus-newsgroup-killed) (push (mail-header-number (car headers)) gnus-newsgroup-kill-headers)) (setq headers (cdr headers)))) (setq files nil)) (setq files (cdr files))))) (if (not gnus-newsgroup-kill-headers) () (save-window-excursion (save-excursion (while kill-files (if (not (file-exists-p (car kill-files))) () (gnus-message 6 "Processing kill file %s..." (car kill-files)) (find-file (car kill-files)) (goto-char (point-min)) (if (consp (ignore-errors (read (current-buffer)))) (gnus-kill-parse-gnus-kill-file) (gnus-kill-parse-rn-kill-file)) (gnus-message 6 "Processing kill file %s...done" (car kill-files))) (setq kill-files (cdr kill-files))))) (gnus-set-mode-line 'summary) (if beg (let ((nunreads (- unreads (length gnus-newsgroup-unreads)))) (or (eq nunreads 0) (gnus-message 6 "Marked %d articles as read" nunreads)) nunreads) 0)))) ;; Parse a Gnus killfile. (defun gnus-kill-parse-gnus-kill-file () (goto-char (point-min)) (gnus-kill-file-mode) (let (beg form) (while (progn (setq beg (point)) (setq form (ignore-errors (read (current-buffer))))) (unless (listp form) (error "Invalid kill entry (possibly rn kill file?): %s" form)) (if (or (eq (car form) 'gnus-kill) (eq (car form) 'gnus-raise) (eq (car form) 'gnus-lower)) (progn (delete-region beg (point)) (insert (or (eval form) ""))) (save-excursion (set-buffer gnus-summary-buffer) (ignore-errors (eval form))))) (and (buffer-modified-p) gnus-kill-save-kill-file (save-buffer)) (set-buffer-modified-p nil))) ;; Parse an rn killfile. (defun gnus-kill-parse-rn-kill-file () (goto-char (point-min)) (gnus-kill-file-mode) (let ((mod-to-header '((?a . "") (?h . "") (?f . "from") (?: . "subject"))) ;;(com-to-com ;; '((?m . " ") ;; (?j . "X"))) pattern modifier commands) (while (not (eobp)) (if (not (looking-at "[ \t]*/\\([^/]*\\)/\\([ahfcH]\\)?:\\([a-z=:]*\\)")) () (setq pattern (buffer-substring (match-beginning 1) (match-end 1))) (setq modifier (if (match-beginning 2) (char-after (match-beginning 2)) ?s)) (setq commands (buffer-substring (match-beginning 3) (match-end 3))) ;; The "f:+" command marks everything *but* the matches as read, ;; so we simply first match everything as read, and then unmark ;; PATTERN later. (when (string-match "\\+" commands) (gnus-kill "from" ".") (setq commands "m")) (gnus-kill (or (cdr (assq modifier mod-to-header)) "subject") pattern (if (string-match "m" commands) '(gnus-summary-mark-as-unread nil " ") '(gnus-summary-mark-as-read nil "X")) nil t)) (forward-line 1)))) ;; Kill changes and new format by suggested by JWZ and Sudish Joseph ;; . (defun gnus-kill (field regexp &optional exe-command all silent) "If FIELD of an article matches REGEXP, execute COMMAND. Optional 1st argument COMMAND is default to (gnus-summary-mark-as-read nil \"X\"). If optional 2nd argument ALL is non-nil, articles marked are also applied to. If FIELD is an empty string (or nil), entire article body is searched for. COMMAND must be a Lisp expression or a string representing a key sequence." ;; We don't want to change current point nor window configuration. (let ((old-buffer (current-buffer))) (save-excursion (save-window-excursion ;; Selected window must be summary buffer to execute keyboard ;; macros correctly. See command_loop_1. (switch-to-buffer gnus-summary-buffer 'norecord) (goto-char (point-min)) ;From the beginning. (let ((kill-list regexp) (date (current-time-string)) (command (or exe-command '(gnus-summary-mark-as-read nil gnus-kill-file-mark))) kill kdate prev) (if (listp kill-list) ;; It is a list. (if (not (consp (cdr kill-list))) ;; It's of the form (regexp . date). (if (zerop (gnus-execute field (car kill-list) command nil (not all))) (when (> (days-between date (cdr kill-list)) gnus-kill-expiry-days) (setq regexp nil)) (setcdr kill-list date)) (while (setq kill (car kill-list)) (if (consp kill) ;; It's a temporary kill. (progn (setq kdate (cdr kill)) (if (zerop (gnus-execute field (car kill) command nil (not all))) (when (> (days-between date kdate) gnus-kill-expiry-days) ;; Time limit has been exceeded, so we ;; remove the match. (if prev (setcdr prev (cdr kill-list)) (setq regexp (cdr regexp)))) ;; Successful kill. Set the date to today. (setcdr kill date))) ;; It's a permanent kill. (gnus-execute field kill command nil (not all))) (setq prev kill-list) (setq kill-list (cdr kill-list)))) (gnus-execute field kill-list command nil (not all)))))) (switch-to-buffer old-buffer) (when (and (eq major-mode 'gnus-kill-file-mode) regexp (not silent)) (gnus-pp-gnus-kill (nconc (list 'gnus-kill field (if (consp regexp) (list 'quote regexp) regexp)) (when (or exe-command all) (list (list 'quote exe-command))) (if all (list t) nil)))))) (defun gnus-pp-gnus-kill (object) (if (or (not (consp (nth 2 object))) (not (consp (cdr (nth 2 object)))) (and (eq 'quote (car (nth 2 object))) (not (consp (cdadr (nth 2 object)))))) (concat "\n" (gnus-prin1-to-string object)) (save-excursion (set-buffer (gnus-get-buffer-create "*Gnus PP*")) (buffer-disable-undo) (erase-buffer) (insert (format "\n(%S %S\n '(" (nth 0 object) (nth 1 object))) (let ((klist (cadr (nth 2 object))) (first t)) (while klist (insert (if first (progn (setq first nil) "") "\n ") (gnus-prin1-to-string (car klist))) (setq klist (cdr klist)))) (insert ")") (and (nth 3 object) (insert "\n " (if (and (consp (nth 3 object)) (not (eq 'quote (car (nth 3 object))))) "'" "") (gnus-prin1-to-string (nth 3 object)))) (when (nth 4 object) (insert "\n t")) (insert ")") (prog1 (buffer-string) (kill-buffer (current-buffer)))))) (defun gnus-execute-1 (function regexp form header) (save-excursion (let (did-kill) (if (null header) nil ;Nothing to do. (if function ;; Compare with header field. (let (value) (and header (progn (setq value (funcall function header)) ;; Number (Lines:) or symbol must be converted to string. (unless (stringp value) (setq value (gnus-prin1-to-string value))) (setq did-kill (string-match regexp value))) (cond ((stringp form) ;Keyboard macro. (execute-kbd-macro form)) ((functionp form) (funcall form)) (t (eval form))))) ;; Search article body. (let ((gnus-current-article nil) ;Save article pointer. (gnus-last-article nil) (gnus-break-pages nil) ;No need to break pages. (gnus-mark-article-hook nil)) ;Inhibit marking as read. (gnus-message 6 "Searching for article: %d..." (mail-header-number header)) (gnus-article-setup-buffer) (gnus-article-prepare (mail-header-number header) t) (when (save-excursion (set-buffer gnus-article-buffer) (goto-char (point-min)) (setq did-kill (re-search-forward regexp nil t))) (cond ((stringp form) ;Keyboard macro. (execute-kbd-macro form)) ((functionp form) (funcall form)) (t (eval form))))))) did-kill))) (defun gnus-execute (field regexp form &optional backward unread) "If FIELD of article header matches REGEXP, execute Lisp FORM (or a string). If FIELD is an empty string (or nil), entire article body is searched for. If optional 1st argument BACKWARD is non-nil, do backward instead. If optional 2nd argument UNREAD is non-nil, articles which are marked as read or ticked are ignored." (save-excursion (let ((killed-no 0) function article header extras) (cond ;; Search body. ((or (null field) (string-equal field "")) (setq function nil)) ;; Get access function of header field. ((cond ((fboundp (setq function (intern-soft (concat "mail-header-" (downcase field))))) (setq function `(lambda (h) (,function h)))) ((when (setq extras (member (downcase field) (mapcar (lambda (header) (downcase (symbol-name header))) gnus-extra-headers))) (setq function `(lambda (h) (gnus-extra-header (quote ,(nth (- (length gnus-extra-headers) (length extras)) gnus-extra-headers)) h))))))) ;; Signal error. (t (error "Unknown header field: \"%s\"" field))) ;; Starting from the current article. (while (or ;; First article. (and (not article) (setq article (gnus-summary-article-number))) ;; Find later articles. (setq article (gnus-summary-search-forward unread nil backward))) (and (or (null gnus-newsgroup-kill-headers) (memq article gnus-newsgroup-kill-headers)) (vectorp (setq header (gnus-summary-article-header article))) (gnus-execute-1 function regexp form header) (setq killed-no (1+ killed-no)))) ;; Return the number of killed articles. killed-no))) ;;;###autoload (defalias 'gnus-batch-kill 'gnus-batch-score) ;;;###autoload (defun gnus-batch-score () "Run batched scoring. Usage: emacs -batch -l ~/.emacs -l gnus -f gnus-batch-score" (interactive) (let* ((gnus-newsrc-options-n (gnus-newsrc-parse-options (concat "options -n " (mapconcat 'identity command-line-args-left " ")))) (gnus-expert-user t) (mail-sources nil) (gnus-use-dribble-file nil) (gnus-batch-mode t) info group newsrc unread ;; Disable verbose message. gnus-novice-user gnus-large-newsgroup gnus-options-subscribe gnus-auto-subscribed-groups gnus-options-not-subscribe) ;; Eat all arguments. (setq command-line-args-left nil) (gnus-slave) ;; Apply kills to specified newsgroups in command line arguments. (setq newsrc (cdr gnus-newsrc-alist)) (while (setq info (pop newsrc)) (setq group (gnus-info-group info) unread (gnus-group-unread group)) (when (and (<= (gnus-info-level info) gnus-level-subscribed) (and unread (or (eq unread t) (not (zerop unread))))) (ignore-errors (gnus-summary-read-group group nil t nil t)) (when (eq (current-buffer) (get-buffer gnus-summary-buffer)) (gnus-summary-exit)))) ;; Exit Emacs. (switch-to-buffer gnus-group-buffer) (gnus-group-save-newsrc))) (provide 'gnus-kill) ;; arch-tag: b30c0f53-df1a-490b-b81e-17b13474f395 ;;; gnus-kill.el ends here gnus-5.11+v0.10.dfsg/lisp/gnus-cite.el0000644000175000017500000011773111004005110017453 0ustar tvainikatvainika;;; gnus-cite.el --- parse citations in articles for Gnus ;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, ;; 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc. ;; Author: Per Abhiddenware ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 3, or (at your option) ;; any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Commentary: ;;; Code: (eval-when-compile (require 'cl)) (eval-when-compile (when (featurep 'xemacs) (require 'easy-mmode))) ; for `define-minor-mode' (require 'gnus) (require 'gnus-range) (require 'gnus-art) (require 'message) ; for message-cite-prefix-regexp ;;; Customization: (defgroup gnus-cite nil "Citation." :prefix "gnus-cite-" :link '(custom-manual "(gnus)Article Highlighting") :group 'gnus-article) (defcustom gnus-cited-opened-text-button-line-format "%(%{[-]%}%)\n" "Format of opened cited text buttons." :group 'gnus-cite :type 'string) (defcustom gnus-cited-closed-text-button-line-format "%(%{[+]%}%)\n" "Format of closed cited text buttons." :group 'gnus-cite :type 'string) (defcustom gnus-cited-lines-visible nil "The number of lines of hidden cited text to remain visible. Or a pair (cons) of numbers which are the number of lines at the top and bottom of the text, respectively, to remain visible." :group 'gnus-cite :type '(choice (const :tag "none" nil) integer (cons :tag "Top and Bottom" integer integer))) (defcustom gnus-cite-parse-max-size 25000 "Maximum article size (in bytes) where parsing citations is allowed. Set it to nil to parse all articles." :group 'gnus-cite :type '(choice (const :tag "all" nil) integer)) (defcustom gnus-cite-max-prefix 20 "Maximum possible length for a citation prefix." :group 'gnus-cite :type 'integer) (defcustom gnus-supercite-regexp (concat "^\\(" message-cite-prefix-regexp "\\)? *" ">>>>> +\"\\([^\"\n]+\\)\" +==") "*Regexp matching normal Supercite attribution lines. The first grouping must match prefixes added by other packages." :group 'gnus-cite :type 'regexp) (defcustom gnus-supercite-secondary-regexp "^.*\"\\([^\"\n]+\\)\" +==" "Regexp matching mangled Supercite attribution lines. The first regexp group should match the Supercite attribution." :group 'gnus-cite :type 'regexp) (defcustom gnus-cite-minimum-match-count 2 "Minimum number of identical prefixes before we believe it's a citation." :group 'gnus-cite :type 'integer) ;; Some Microsoft products put in a citation that extends to the ;; remainder of the message: ;; ;; -----Original Message----- ;; From: ... ;; To: ... ;; Sent: ... [date, in non-RFC-2822 format] ;; Subject: ... ;; ;; Cited message, with no prefixes ;; ;; The four headers are always the same. But note they are prone to ;; folding without additional indentation. ;; ;; Others use "----- Original Message -----" instead, and properly quote ;; the body using "> ". This style is handled without special cases. (defcustom gnus-cite-attribution-prefix "In article\\|in <\\|On \\(Mon\\|Tue\\|Wed\\|Thu\\|Fri\\|Sat\\|Sun\\),\\|----- ?Original Message ?-----" "*Regexp matching the beginning of an attribution line." :group 'gnus-cite :type 'regexp) (defcustom gnus-cite-attribution-suffix "\\(\\(wrote\\|writes\\|said\\|says\\|>\\)\\(:\\|\\.\\.\\.\\)\\|----- ?Original Message ?-----\\)[ \t]*$" "*Regexp matching the end of an attribution line. The text matching the first grouping will be used as a button." :group 'gnus-cite :type 'regexp) (defcustom gnus-cite-unsightly-citation-regexp "^-----Original Message-----\nFrom: \\(.+\n\\)+\n" "Regexp matching Microsoft-type rest-of-message citations." :version "22.1" :group 'gnus-cite :type 'regexp) (defcustom gnus-cite-ignore-quoted-from t "Non-nil means don't regard lines beginning with \">From \" as cited text. Those lines may have been quoted by MTAs in order not to mix up with the envelope From line." :version "22.1" :group 'gnus-cite :type 'boolean) (defface gnus-cite-attribution '((t (:italic t))) "Face used for attribution lines." :group 'gnus-cite) ;; backward-compatibility alias (put 'gnus-cite-attribution-face 'face-alias 'gnus-cite-attribution) (defcustom gnus-cite-attribution-face 'gnus-cite-attribution "Face used for attribution lines. It is merged with the face for the cited text belonging to the attribution." :version "22.1" :group 'gnus-cite :type 'face) (defface gnus-cite-1 '((((class color) (background dark)) (:foreground "light blue")) (((class color) (background light)) (:foreground "MidnightBlue")) (t (:italic t))) "Citation face." :group 'gnus-cite) ;; backward-compatibility alias (put 'gnus-cite-face-1 'face-alias 'gnus-cite-1) (defface gnus-cite-2 '((((class color) (background dark)) (:foreground "light cyan")) (((class color) (background light)) (:foreground "firebrick")) (t (:italic t))) "Citation face." :group 'gnus-cite) ;; backward-compatibility alias (put 'gnus-cite-face-2 'face-alias 'gnus-cite-2) (defface gnus-cite-3 '((((class color) (background dark)) (:foreground "light yellow")) (((class color) (background light)) (:foreground "dark green")) (t (:italic t))) "Citation face." :group 'gnus-cite) ;; backward-compatibility alias (put 'gnus-cite-face-3 'face-alias 'gnus-cite-3) (defface gnus-cite-4 '((((class color) (background dark)) (:foreground "light pink")) (((class color) (background light)) (:foreground "OrangeRed")) (t (:italic t))) "Citation face." :group 'gnus-cite) ;; backward-compatibility alias (put 'gnus-cite-face-4 'face-alias 'gnus-cite-4) (defface gnus-cite-5 '((((class color) (background dark)) (:foreground "pale green")) (((class color) (background light)) (:foreground "dark khaki")) (t (:italic t))) "Citation face." :group 'gnus-cite) ;; backward-compatibility alias (put 'gnus-cite-face-5 'face-alias 'gnus-cite-5) (defface gnus-cite-6 '((((class color) (background dark)) (:foreground "beige")) (((class color) (background light)) (:foreground "dark violet")) (t (:italic t))) "Citation face." :group 'gnus-cite) ;; backward-compatibility alias (put 'gnus-cite-face-6 'face-alias 'gnus-cite-6) (defface gnus-cite-7 '((((class color) (background dark)) (:foreground "orange")) (((class color) (background light)) (:foreground "SteelBlue4")) (t (:italic t))) "Citation face." :group 'gnus-cite) ;; backward-compatibility alias (put 'gnus-cite-face-7 'face-alias 'gnus-cite-7) (defface gnus-cite-8 '((((class color) (background dark)) (:foreground "magenta")) (((class color) (background light)) (:foreground "magenta")) (t (:italic t))) "Citation face." :group 'gnus-cite) ;; backward-compatibility alias (put 'gnus-cite-face-8 'face-alias 'gnus-cite-8) (defface gnus-cite-9 '((((class color) (background dark)) (:foreground "violet")) (((class color) (background light)) (:foreground "violet")) (t (:italic t))) "Citation face." :group 'gnus-cite) ;; backward-compatibility alias (put 'gnus-cite-face-9 'face-alias 'gnus-cite-9) (defface gnus-cite-10 '((((class color) (background dark)) (:foreground "plum1")) (((class color) (background light)) (:foreground "medium purple")) (t (:italic t))) "Citation face." :group 'gnus-cite) ;; backward-compatibility alias (put 'gnus-cite-face-10 'face-alias 'gnus-cite-10) (defface gnus-cite-11 '((((class color) (background dark)) (:foreground "turquoise")) (((class color) (background light)) (:foreground "turquoise")) (t (:italic t))) "Citation face." :group 'gnus-cite) ;; backward-compatibility alias (put 'gnus-cite-face-11 'face-alias 'gnus-cite-11) (defcustom gnus-cite-face-list '(gnus-cite-1 gnus-cite-2 gnus-cite-3 gnus-cite-4 gnus-cite-5 gnus-cite-6 gnus-cite-7 gnus-cite-8 gnus-cite-9 gnus-cite-10 gnus-cite-11) "*List of faces used for highlighting citations. When there are citations from multiple articles in the same message, Gnus will try to give each citation from each article its own face. This should make it easier to see who wrote what." :group 'gnus-cite :type '(repeat face) :set (lambda (symbol value) (prog1 (custom-set-default symbol value) (if (boundp 'gnus-message-max-citation-depth) (setq gnus-message-max-citation-depth (length value))) (if (boundp 'gnus-message-citation-keywords) (setq gnus-message-citation-keywords `((gnus-message-search-citation-line ,@(let ((list nil) (count 1)) (dolist (face value (nreverse list)) (push (list count (list 'quote face) 'prepend t) list) (setq count (1+ count))))))))))) (defcustom gnus-cite-hide-percentage 50 "Only hide excess citation if above this percentage of the body." :group 'gnus-cite :type 'number) (defcustom gnus-cite-hide-absolute 10 "Only hide excess citation if above this number of lines in the body." :group 'gnus-cite :type 'integer) (defcustom gnus-cite-blank-line-after-header t "If non-nil, put a blank line between the citation header and the button." :group 'gnus-cite :type 'boolean) ;; This has to go here because its default value depends on ;; gnus-cite-face-list. (defcustom gnus-article-boring-faces (cons 'gnus-signature gnus-cite-face-list) "List of faces that are not worth reading. If an article has more pages below the one you are looking at, but nothing on those pages is a word of at least three letters that is not in a boring face, then the pages will be skipped." :type '(repeat face) :group 'gnus-article-hiding) ;;; Internal Variables: (defvar gnus-cite-article nil) (defvar gnus-cite-overlay-list nil) (defvar gnus-cite-prefix-alist nil) ;; Alist of citation prefixes. ;; The cdr is a list of lines with that prefix. (defvar gnus-cite-attribution-alist nil) ;; Alist of attribution lines. ;; The car is a line number. ;; The cdr is the prefix for the citation started by that line. (defvar gnus-cite-loose-prefix-alist nil) ;; Alist of citation prefixes that have no matching attribution. ;; The cdr is a list of lines with that prefix. (defvar gnus-cite-loose-attribution-alist nil) ;; Alist of attribution lines that have no matching citation. ;; Each member has the form (WROTE IN PREFIX TAG), where ;; WROTE: is the attribution line number ;; IN: is the line number of the previous line if part of the same attribution, ;; PREFIX: Is the citation prefix of the attribution line(s), and ;; TAG: Is a Supercite tag, if any. (defvar gnus-cited-opened-text-button-line-format-alist `((?b (marker-position beg) ?d) (?e (marker-position end) ?d) (?n (count-lines beg end) ?d) (?l (- end beg) ?d))) (defvar gnus-cited-opened-text-button-line-format-spec nil) (defvar gnus-cited-closed-text-button-line-format-alist gnus-cited-opened-text-button-line-format-alist) (defvar gnus-cited-closed-text-button-line-format-spec nil) ;;; Commands: (defun gnus-article-highlight-citation (&optional force same-buffer) "Highlight cited text. Each citation in the article will be highlighted with a different face. The faces are taken from `gnus-cite-face-list'. Attribution lines are highlighted with the same face as the corresponding citation merged with the face `gnus-cite-attribution'. Text is considered cited if at least `gnus-cite-minimum-match-count' lines matches `message-cite-prefix-regexp' with the same prefix. Lines matching `gnus-cite-attribution-suffix' and perhaps `gnus-cite-attribution-prefix' are considered attribution lines." (interactive (list 'force)) (save-excursion (unless same-buffer (set-buffer gnus-article-buffer)) (gnus-cite-parse-maybe force) (let ((buffer-read-only nil) (alist gnus-cite-prefix-alist) (faces gnus-cite-face-list) (inhibit-point-motion-hooks t) face entry prefix skip numbers number face-alist) ;; Loop through citation prefixes. (while alist (setq entry (car alist) alist (cdr alist) prefix (car entry) numbers (cdr entry) face (car faces) faces (or (cdr faces) gnus-cite-face-list) face-alist (cons (cons prefix face) face-alist)) (while numbers (setq number (car numbers) numbers (cdr numbers)) (and (not (assq number gnus-cite-attribution-alist)) (not (assq number gnus-cite-loose-attribution-alist)) (gnus-cite-add-face number prefix face)))) ;; Loop through attribution lines. (setq alist gnus-cite-attribution-alist) (while alist (setq entry (car alist) alist (cdr alist) number (car entry) prefix (cdr entry) skip (gnus-cite-find-prefix number) face (cdr (assoc prefix face-alist))) ;; Add attribution button. (goto-char (point-min)) (forward-line (1- number)) (when (re-search-forward gnus-cite-attribution-suffix (point-at-eol) t) (gnus-article-add-button (match-beginning 1) (match-end 1) 'gnus-cite-toggle prefix)) ;; Highlight attribution line. (gnus-cite-add-face number skip face) (gnus-cite-add-face number skip gnus-cite-attribution-face)) ;; Loop through attribution lines. (setq alist gnus-cite-loose-attribution-alist) (while alist (setq entry (car alist) alist (cdr alist) number (car entry) skip (gnus-cite-find-prefix number)) (gnus-cite-add-face number skip gnus-cite-attribution-face))))) (defun gnus-dissect-cited-text () "Dissect the article buffer looking for cited text." (save-excursion (set-buffer gnus-article-buffer) (gnus-cite-parse-maybe nil t) (let ((alist gnus-cite-prefix-alist) prefix numbers number marks m) ;; Loop through citation prefixes. (while alist (setq numbers (pop alist) prefix (pop numbers)) (while numbers (setq number (pop numbers)) (goto-char (point-min)) (forward-line number) (push (cons (point-marker) "") marks) (while (and numbers (= (1- number) (car numbers))) (setq number (pop numbers))) (goto-char (point-min)) (forward-line (1- number)) (push (cons (point-marker) prefix) marks))) ;; Skip to the beginning of the body. (article-goto-body) (push (cons (point-marker) "") marks) ;; Find the end of the body. (goto-char (point-max)) (gnus-article-search-signature) (push (cons (point-marker) "") marks) ;; Sort the marks. (setq marks (sort marks 'car-less-than-car)) (let ((omarks marks)) (setq marks nil) (while (cdr omarks) (if (= (caar omarks) (caadr omarks)) (progn (unless (equal (cdar omarks) "") (push (car omarks) marks)) (unless (equal (cdadr omarks) "") (push (cadr omarks) marks)) (unless (and (equal (cdar omarks) "") (equal (cdadr omarks) "") (not (cddr omarks))) (setq omarks (cdr omarks)))) (push (car omarks) marks)) (setq omarks (cdr omarks))) (when (car omarks) (push (car omarks) marks)) (setq marks (setq m (nreverse marks))) (while (cddr m) (if (and (equal (cdadr m) "") (equal (cdar m) (cdaddr m)) (goto-char (caadr m)) (forward-line 1) (= (point) (caaddr m))) (setcdr m (cdddr m)) (setq m (cdr m)))) marks)))) (defun gnus-article-fill-cited-article (&optional force width) "Do word wrapping in the current article. If WIDTH (the numerical prefix), use that text width when filling." (interactive (list t current-prefix-arg)) (save-excursion (set-buffer gnus-article-buffer) (let ((buffer-read-only nil) (inhibit-point-motion-hooks t) (marks (gnus-dissect-cited-text)) (adaptive-fill-mode nil) (filladapt-mode nil) (fill-column (if width (prefix-numeric-value width) fill-column))) (save-restriction (while (cdr marks) (narrow-to-region (caar marks) (caadr marks)) (let ((adaptive-fill-regexp (concat "^" (regexp-quote (cdar marks)) " *")) (fill-prefix (if (string= (cdar marks) "") "" (concat (cdar marks) " "))) use-hard-newlines) (fill-region (point-min) (point-max))) (set-marker (caar marks) nil) (setq marks (cdr marks))) (when marks (set-marker (caar marks) nil)) ;; All this information is now incorrect. (setq gnus-cite-prefix-alist nil gnus-cite-attribution-alist nil gnus-cite-loose-prefix-alist nil gnus-cite-loose-attribution-alist nil gnus-cite-article nil))))) (defun gnus-article-hide-citation (&optional arg force) "Toggle hiding of all cited text except attribution lines. See the documentation for `gnus-article-highlight-citation'. If given a negative prefix, always show; if given a positive prefix, always hide." (interactive (append (gnus-article-hidden-arg) (list 'force))) (gnus-set-format 'cited-opened-text-button t) (gnus-set-format 'cited-closed-text-button t) (save-excursion (set-buffer gnus-article-buffer) (let ((buffer-read-only nil) marks (inhibit-point-motion-hooks t) (props (nconc (list 'article-type 'cite) gnus-hidden-properties)) (point (point-min)) found beg end start) (while (setq point (text-property-any point (point-max) 'gnus-callback 'gnus-article-toggle-cited-text)) (setq found t) (goto-char point) (gnus-article-toggle-cited-text (get-text-property point 'gnus-data) arg) (forward-line 1) (setq point (point))) (unless found (setq marks (gnus-dissect-cited-text)) (while marks (setq beg nil end nil) (while (and marks (string= (cdar marks) "")) (setq marks (cdr marks))) (when marks (setq beg (caar marks))) (while (and marks (not (string= (cdar marks) ""))) (setq marks (cdr marks))) (when marks (setq end (caar marks))) ;; Skip past lines we want to leave visible. (when (and beg end gnus-cited-lines-visible) (goto-char beg) (forward-line (if (consp gnus-cited-lines-visible) (car gnus-cited-lines-visible) gnus-cited-lines-visible)) (if (>= (point) end) (setq beg nil) (setq beg (point-marker)) (when (consp gnus-cited-lines-visible) (goto-char end) (forward-line (- (cdr gnus-cited-lines-visible))) (if (<= (point) beg) (setq beg nil) (setq end (point-marker)))))) (when (and beg end) (gnus-add-wash-type 'cite) ;; We use markers for the end-points to facilitate later ;; wrapping and mangling of text. (setq beg (set-marker (make-marker) beg) end (set-marker (make-marker) end)) (gnus-add-text-properties-when 'article-type nil beg end props) (goto-char beg) (when (and gnus-cite-blank-line-after-header (not (save-excursion (search-backward "\n\n" nil t)))) (insert "\n")) (put-text-property (setq start (point-marker)) (progn (gnus-article-add-button (point) (progn (eval gnus-cited-closed-text-button-line-format-spec) (point)) `gnus-article-toggle-cited-text (list (cons beg end) start)) (point)) 'article-type 'annotation) (set-marker beg (point)))))))) (defun gnus-article-toggle-cited-text (args &optional arg) "Toggle hiding the text in REGION. ARG can be nil or a number. Positive means hide, negative means show, nil means toggle." (let* ((region (car args)) (beg (car region)) (end (cdr region)) (start (cadr args)) (hidden (text-property-any beg (1- end) 'article-type 'cite)) (inhibit-point-motion-hooks t) buffer-read-only) (when (or (null arg) (zerop arg) (and (> arg 0) (not hidden)) (and (< arg 0) hidden)) (if hidden (progn ;; Can't remove 'cite from g-a-wash-types here because ;; multiple citations may be hidden -jas (gnus-remove-text-properties-when 'article-type 'cite beg end (cons 'article-type (cons 'cite gnus-hidden-properties)))) (gnus-add-wash-type 'cite) (gnus-add-text-properties-when 'article-type nil beg end (cons 'article-type (cons 'cite gnus-hidden-properties)))) (let ((gnus-article-mime-handle-alist-1 gnus-article-mime-handle-alist)) (gnus-set-mode-line 'article)) (save-excursion (goto-char start) (gnus-delete-line) (put-text-property (point) (progn (gnus-article-add-button (point) (progn (eval (if hidden gnus-cited-opened-text-button-line-format-spec gnus-cited-closed-text-button-line-format-spec)) (point)) `gnus-article-toggle-cited-text args) (point)) 'article-type 'annotation))))) (defun gnus-article-hide-citation-maybe (&optional arg force) "Toggle hiding of cited text that has an attribution line. If given a negative prefix, always show; if given a positive prefix, always hide. This will do nothing unless at least `gnus-cite-hide-percentage' percent and at least `gnus-cite-hide-absolute' lines of the body is cited text with attributions. When called interactively, these two variables are ignored. See also the documentation for `gnus-article-highlight-citation'." (interactive (append (gnus-article-hidden-arg) '(force))) (with-current-buffer gnus-article-buffer (gnus-delete-wash-type 'cite) (unless (gnus-article-check-hidden-text 'cite arg) (save-excursion (gnus-cite-parse-maybe force) (article-goto-body) (let ((start (point)) (atts gnus-cite-attribution-alist) (buffer-read-only nil) (inhibit-point-motion-hooks t) (hidden 0) total) (goto-char (point-max)) (gnus-article-search-signature) (setq total (count-lines start (point))) (while atts (setq hidden (+ hidden (length (cdr (assoc (cdar atts) gnus-cite-prefix-alist)))) atts (cdr atts))) (when (or force (and (> (* 100 hidden) (* gnus-cite-hide-percentage total)) (> hidden gnus-cite-hide-absolute))) (gnus-add-wash-type 'cite) (setq atts gnus-cite-attribution-alist) (while atts (setq total (cdr (assoc (cdar atts) gnus-cite-prefix-alist)) atts (cdr atts)) (while total (setq hidden (car total) total (cdr total)) (goto-char (point-min)) (forward-line (1- hidden)) (unless (assq hidden gnus-cite-attribution-alist) (gnus-add-text-properties (point) (progn (forward-line 1) (point)) (nconc (list 'article-type 'cite) gnus-hidden-properties))))))))) (gnus-set-mode-line 'article))) (defun gnus-article-hide-citation-in-followups () "Hide cited text in non-root articles." (interactive) (save-excursion (set-buffer gnus-article-buffer) (let ((article (cdr gnus-article-current))) (unless (save-excursion (set-buffer gnus-summary-buffer) (gnus-article-displayed-root-p article)) (gnus-article-hide-citation))))) ;;; Internal functions: (defun gnus-cite-parse-maybe (&optional force no-overlay) "Always parse the buffer." (gnus-cite-localize) ;;Reset parser information. (setq gnus-cite-prefix-alist nil gnus-cite-attribution-alist nil gnus-cite-loose-prefix-alist nil gnus-cite-loose-attribution-alist nil) (unless no-overlay (gnus-cite-delete-overlays)) ;; Parse if not too large. (if (and gnus-cite-parse-max-size (> (buffer-size) gnus-cite-parse-max-size)) () (setq gnus-cite-article (cons (car gnus-article-current) (cdr gnus-article-current))) (gnus-cite-parse-wrapper))) (defun gnus-cite-delete-overlays () (dolist (overlay gnus-cite-overlay-list) (ignore-errors (when (or (not (gnus-overlay-end overlay)) (and (>= (gnus-overlay-end overlay) (point-min)) (<= (gnus-overlay-end overlay) (point-max)))) (setq gnus-cite-overlay-list (delete overlay gnus-cite-overlay-list)) (ignore-errors (gnus-delete-overlay overlay)))))) (defun gnus-cite-parse-wrapper () ;; Wrap chopped gnus-cite-parse. (article-goto-body) (let ((inhibit-point-motion-hooks t)) (save-excursion (gnus-cite-parse-attributions)) (save-excursion (gnus-cite-parse)) (save-excursion (gnus-cite-connect-attributions)))) (defun gnus-cite-parse () ;; Parse and connect citation prefixes and attribution lines. ;; Parse current buffer searching for citation prefixes. (let ((line (1+ (count-lines (point-min) (point)))) (case-fold-search t) (max (save-excursion (goto-char (point-max)) (gnus-article-search-signature) (point))) (prefix-regexp (concat "^\\(" message-cite-prefix-regexp "\\)")) alist entry start begin end numbers prefix guess-limit) ;; Get all potential prefixes in `alist'. (while (< (point) max) ;; Each line. (setq begin (point) guess-limit (progn (skip-chars-forward "^> \t\r\n") (point)) end (point-at-bol 2) start end) (goto-char begin) ;; Ignore standard Supercite attribution prefix. (when (and (< guess-limit (+ begin gnus-cite-max-prefix)) (looking-at gnus-supercite-regexp)) (if (match-end 1) (setq end (1+ (match-end 1))) (setq end (1+ begin)))) ;; Ignore very long prefixes. (when (> end (+ begin gnus-cite-max-prefix)) (setq end (+ begin gnus-cite-max-prefix))) ;; Ignore quoted envelope From_. (when (and gnus-cite-ignore-quoted-from (prog2 (setq case-fold-search nil) (looking-at ">From ") (setq case-fold-search t))) (setq end (1+ begin))) (while (re-search-forward prefix-regexp (1- end) t) ;; Each prefix. (setq end (match-end 0) prefix (buffer-substring begin end)) (set-text-properties 0 (length prefix) nil prefix) (setq entry (assoc prefix alist)) (if entry (setcdr entry (cons line (cdr entry))) (push (list prefix line) alist)) (goto-char begin)) (goto-char start) (setq line (1+ line))) ;; Horrible special case for some Microsoft mailers. (goto-char (point-min)) (setq start t begin nil entry nil) (while start ;; Assume this search ends up at the beginning of a line. (if (re-search-forward gnus-cite-unsightly-citation-regexp max t) (progn (when (number-or-marker-p start) (setq begin (count-lines (point-min) start) end (count-lines (point-min) (match-beginning 0)))) (setq start (match-end 0))) (when (number-or-marker-p start) (setq begin (count-lines (point-min) start) end (count-lines (point-min) max))) (setq start nil)) (when begin (while (< begin end) ;; Need to do 1+ because we're in the bol. (push (setq begin (1+ begin)) entry)))) (when entry (push (cons "" entry) alist)) ;; We got all the potential prefixes. Now create ;; `gnus-cite-prefix-alist' containing the oldest prefix for each ;; line that appears at least `gnus-cite-minimum-match-count' ;; times. First sort them by length. Longer is older. (setq alist (sort alist (lambda (a b) (> (length (car a)) (length (car b)))))) (while alist (setq entry (car alist) prefix (car entry) numbers (cdr entry) alist (cdr alist)) (cond ((null numbers) ;; No lines with this prefix that wasn't also part of ;; a longer prefix. ) ((< (length numbers) gnus-cite-minimum-match-count) ;; Too few lines with this prefix. We keep it a bit ;; longer in case it is an exact match for an attribution ;; line, but we don't remove the line from other ;; prefixes. (push entry gnus-cite-prefix-alist)) (t (push entry gnus-cite-prefix-alist) ;; Remove articles from other prefixes. (let ((loop alist) current) (while loop (setq current (car loop) loop (cdr loop)) (setcdr current (gnus-set-difference (cdr current) numbers))))))))) (defun gnus-cite-parse-attributions () (let (al-alist) ;; Parse attributions (while (re-search-forward gnus-cite-attribution-suffix (point-max) t) (let* ((start (match-beginning 0)) (end (match-end 0)) (wrote (count-lines (point-min) end)) (prefix (gnus-cite-find-prefix wrote)) ;; Check previous line for an attribution leader. (tag (progn (beginning-of-line 1) (when (looking-at gnus-supercite-secondary-regexp) (buffer-substring (match-beginning 1) (match-end 1))))) (in (progn (goto-char start) (and (re-search-backward gnus-cite-attribution-prefix (save-excursion (beginning-of-line 0) (point)) t) (not (re-search-forward gnus-cite-attribution-suffix start t)) (count-lines (point-min) (1+ (point))))))) (when (eq wrote in) (setq in nil)) (goto-char end) ;; don't add duplicates (let ((al (buffer-substring (save-excursion (beginning-of-line 0) (1+ (point))) end))) (when (not (assoc al al-alist)) (push (list wrote in prefix tag) gnus-cite-loose-attribution-alist) (push (cons al t) al-alist))))))) (defun gnus-cite-connect-attributions () ;; Connect attributions to citations ;; No citations have been connected to attribution lines yet. (setq gnus-cite-loose-prefix-alist (append gnus-cite-prefix-alist nil)) ;; Parse current buffer searching for attribution lines. ;; Find exact supercite citations. (gnus-cite-match-attributions 'small nil (lambda (prefix tag) (when tag (concat "\\`" (regexp-quote prefix) "[ \t]*" (regexp-quote tag) ">")))) ;; Find loose supercite citations after attributions. (gnus-cite-match-attributions 'small t (lambda (prefix tag) (when tag (concat "\\<" (regexp-quote tag) "\\>")))) ;; Find loose supercite citations anywhere. (gnus-cite-match-attributions 'small nil (lambda (prefix tag) (when tag (concat "\\<" (regexp-quote tag) "\\>")))) ;; Find nested citations after attributions. (gnus-cite-match-attributions 'small-if-unique t (lambda (prefix tag) (concat "\\`" (regexp-quote prefix) ".+"))) ;; Find nested citations anywhere. (gnus-cite-match-attributions 'small nil (lambda (prefix tag) (concat "\\`" (regexp-quote prefix) ".+"))) ;; Remove loose prefixes with too few lines. (let ((alist gnus-cite-loose-prefix-alist) entry) (while alist (setq entry (car alist) alist (cdr alist)) (when (< (length (cdr entry)) gnus-cite-minimum-match-count) (setq gnus-cite-prefix-alist (delq entry gnus-cite-prefix-alist) gnus-cite-loose-prefix-alist (delq entry gnus-cite-loose-prefix-alist))))) ;; Find flat attributions. (gnus-cite-match-attributions 'first t nil) ;; Find any attributions (are we getting desperate yet?). (gnus-cite-match-attributions 'first nil nil)) (defun gnus-cite-match-attributions (sort after fun) ;; Match all loose attributions and citations (SORT AFTER FUN) . ;; ;; If SORT is `small', the citation with the shortest prefix will be ;; used, if it is `first' the first prefix will be used, if it is ;; `small-if-unique' the shortest prefix will be used if the ;; attribution line does not share its own prefix with other ;; loose attribution lines, otherwise the first prefix will be used. ;; ;; If AFTER is non-nil, only citations after the attribution line ;; will be considered. ;; ;; If FUN is non-nil, it will be called with the arguments (WROTE ;; PREFIX TAG) and expected to return a regular expression. Only ;; citations whose prefix matches the regular expression will be ;; considered. ;; ;; WROTE is the attribution line number. ;; PREFIX is the attribution line prefix. ;; TAG is the Supercite tag on the attribution line. (let ((atts gnus-cite-loose-attribution-alist) (case-fold-search t) att wrote in prefix tag regexp limit smallest best size) (while atts (setq att (car atts) atts (cdr atts) wrote (nth 0 att) in (nth 1 att) prefix (nth 2 att) tag (nth 3 att) regexp (if fun (funcall fun prefix tag) "") size (cond ((eq sort 'small) t) ((eq sort 'first) nil) (t (< (length (gnus-cite-find-loose prefix)) 2))) limit (if after wrote -1) smallest 1000000 best nil) (let ((cites gnus-cite-loose-prefix-alist) cite candidate numbers first compare) (while cites (setq cite (car cites) cites (cdr cites) candidate (car cite) numbers (cdr cite) first (apply 'min numbers) compare (if size (length candidate) first)) (and (> first limit) regexp (string-match regexp candidate) (< compare smallest) (setq best cite smallest compare)))) (if (null best) () (setq gnus-cite-loose-attribution-alist (delq att gnus-cite-loose-attribution-alist)) (push (cons wrote (car best)) gnus-cite-attribution-alist) (when in (push (cons in (car best)) gnus-cite-attribution-alist)) (when (memq best gnus-cite-loose-prefix-alist) (let ((loop gnus-cite-prefix-alist) (numbers (cdr best)) current) (setq gnus-cite-loose-prefix-alist (delq best gnus-cite-loose-prefix-alist)) (while loop (setq current (car loop) loop (cdr loop)) (if (eq current best) () (setcdr current (gnus-set-difference (cdr current) numbers)) (when (null (cdr current)) (setq gnus-cite-loose-prefix-alist (delq current gnus-cite-loose-prefix-alist) atts (delq current atts))))))))))) (defun gnus-cite-find-loose (prefix) ;; Return a list of loose attribution lines prefixed by PREFIX. (let* ((atts gnus-cite-loose-attribution-alist) att line lines) (while atts (setq att (car atts) line (car att) atts (cdr atts)) (when (string-equal (gnus-cite-find-prefix line) prefix) (push line lines))) lines)) (defun gnus-cite-add-face (number prefix face) ;; At line NUMBER, ignore PREFIX and add FACE to the rest of the line. (when face (let ((inhibit-point-motion-hooks t) from to overlay) (goto-char (point-min)) (when (zerop (forward-line (1- number))) (forward-char (length prefix)) (skip-chars-forward " \t") (setq from (point)) (end-of-line 1) (skip-chars-backward " \t") (setq to (point)) (when (< from to) (push (setq overlay (gnus-make-overlay from to)) gnus-cite-overlay-list) (gnus-overlay-put overlay 'evaporate t) (gnus-overlay-put overlay 'face face)))))) (defun gnus-cite-toggle (prefix) (save-excursion (set-buffer gnus-article-buffer) (gnus-cite-parse-maybe nil t) (let ((buffer-read-only nil) (numbers (cdr (assoc prefix gnus-cite-prefix-alist))) (inhibit-point-motion-hooks t) number) (while numbers (setq number (car numbers) numbers (cdr numbers)) (goto-char (point-min)) (forward-line (1- number)) (cond ((get-text-property (point) 'invisible) ;; Can't remove 'cite from g-a-wash-types here because ;; multiple citations may be hidden -jas (remove-text-properties (point) (progn (forward-line 1) (point)) gnus-hidden-properties)) ((assq number gnus-cite-attribution-alist)) (t (gnus-add-wash-type 'cite) (gnus-add-text-properties (point) (progn (forward-line 1) (point)) (nconc (list 'article-type 'cite) gnus-hidden-properties)))) (let ((gnus-article-mime-handle-alist-1 gnus-article-mime-handle-alist)) (gnus-set-mode-line 'article)))))) (defun gnus-cite-find-prefix (line) ;; Return citation prefix for LINE. (let ((alist gnus-cite-prefix-alist) (prefix "") entry) (while alist (setq entry (car alist) alist (cdr alist)) (when (memq line (cdr entry)) (setq prefix (car entry)))) prefix)) (defun gnus-cite-localize () "Make the citation variables local to the article buffer." (let ((vars '(gnus-cite-article gnus-cite-overlay-list gnus-cite-prefix-alist gnus-cite-attribution-alist gnus-cite-loose-prefix-alist gnus-cite-loose-attribution-alist))) (while vars (make-local-variable (pop vars))))) (defun gnus-cited-line-p () "Say whether the current line is a cited line." (save-excursion (beginning-of-line) (let ((found nil)) (dolist (prefix (mapcar 'car gnus-cite-prefix-alist)) (when (string= (buffer-substring (point) (+ (length prefix) (point))) prefix) (setq found t))) found))) ;; Highlighting of different citation levels in message-mode. ;; - message-cite-prefix will be overridden if this is enabled. (defvar gnus-message-max-citation-depth (length gnus-cite-face-list) "Maximum supported level of citation.") (defvar gnus-message-cite-prefix-regexp (concat "^\\(?:" message-cite-prefix-regexp "\\)")) (defun gnus-message-search-citation-line (limit) "Search for a cited line and set match data accordingly. Returns nil if there is no such line before LIMIT, t otherwise." (when (re-search-forward gnus-message-cite-prefix-regexp limit t) (let ((cdepth (min (length (apply 'concat (split-string (match-string-no-properties 0) "[ \t [:alnum:]]+"))) gnus-message-max-citation-depth)) (mlist (make-list (* (1+ gnus-message-max-citation-depth) 2) nil)) (start (point-at-bol)) (end (point-at-eol))) (setcar mlist start) (setcar (cdr mlist) end) (setcar (nthcdr (* cdepth 2) mlist) start) (setcar (nthcdr (1+ (* cdepth 2)) mlist) end) (set-match-data mlist)) t)) (defvar gnus-message-citation-keywords ;; eval-when-compile ;; This breaks in XEmacs `((gnus-message-search-citation-line ,@(let ((list nil) (count 1)) ;; (require 'gnus-cite) (dolist (face gnus-cite-face-list (nreverse list)) (push (list count (list 'quote face) 'prepend t) list) (setq count (1+ count)))))) ;; "Keywords for highlighting different levels of message citations.") (defvar font-lock-defaults-computed) (defvar font-lock-keywords) (defvar font-lock-set-defaults) (eval-and-compile (unless (featurep 'xemacs) (autoload 'font-lock-set-defaults "font-lock"))) (define-minor-mode gnus-message-citation-mode "Toggle `gnus-message-citation-mode' in current buffer. This buffer local minor mode provides additional font-lock support for nested citations. With prefix ARG, turn `gnus-message-citation-mode' on if and only if ARG is positive. Automatically turn `font-lock-mode' on when `gnus-message-citation-mode' is turned on." nil ;; init-value "" ;; lighter nil ;; keymap (when (eq major-mode 'message-mode) (let ((defaults (car (if (featurep 'xemacs) (get 'message-mode 'font-lock-defaults) font-lock-defaults))) default keywords) (while defaults (setq default (if (consp defaults) (pop defaults) (prog1 defaults (setq defaults nil)))) (if gnus-message-citation-mode ;; `gnus-message-citation-keywords' should be the last ;; elements of the keywords because the others are unlikely ;; to have the OVERRIDE flags -- XEmacs applies a keyword ;; having no OVERRIDE flag to matched text even if it has ;; already other faces, while Emacs doesn't. (set (make-local-variable default) (append (default-value default) gnus-message-citation-keywords)) (kill-local-variable default)))) ;; Force `font-lock-set-defaults' to update `font-lock-keywords'. (if (featurep 'xemacs) (progn (require 'font-lock) (setq font-lock-defaults-computed nil font-lock-keywords nil)) (setq font-lock-set-defaults nil)) (font-lock-set-defaults) (cond ((symbol-value 'font-lock-mode) (font-lock-fontify-buffer)) (gnus-message-citation-mode (font-lock-mode 1))))) (defun turn-on-gnus-message-citation-mode () "Turn on `gnus-message-citation-mode'." (gnus-message-citation-mode 1)) (defun turn-off-gnus-message-citation-mode () "Turn off `gnus-message-citation-mode'." (gnus-message-citation-mode -1)) (gnus-ems-redefine) (provide 'gnus-cite) ;; Local Variables: ;; coding: iso-8859-1 ;; End: ;; arch-tag: 1997b044-6067-471e-8c8f-dc903093098a ;;; gnus-cite.el ends here gnus-5.11+v0.10.dfsg/lisp/gnus-demon.el0000644000175000017500000002545011004005110017625 0ustar tvainikatvainika;;; gnus-demon.el --- daemonic Gnus behaviour ;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, ;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; Keywords: news ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 3, or (at your option) ;; any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Commentary: ;;; Code: (eval-when-compile (require 'cl)) (require 'gnus) (require 'gnus-int) (require 'nnheader) (require 'nntp) (require 'nnmail) (require 'gnus-util) (autoload 'parse-time-string "parse-time" nil nil) (defgroup gnus-demon nil "Demonic behavior." :group 'gnus) (defcustom gnus-demon-handlers nil "Alist of daemonic handlers to be run at intervals. Each handler is a list on the form \(FUNCTION TIME IDLE) FUNCTION is the function to be called. TIME is the number of `gnus-demon-timestep's between each call. If nil, never call. If t, call each `gnus-demon-timestep'. If IDLE is t, only call if Emacs has been idle for a while. If IDLE is a number, only call when Emacs has been idle more than this number of `gnus-demon-timestep's. If IDLE is nil, don't care about idleness. If IDLE is a number and TIME is nil, then call once each time Emacs has been idle for IDLE `gnus-demon-timestep's." :group 'gnus-demon :type '(repeat (list function (choice :tag "Time" (const :tag "never" nil) (const :tag "one" t) (integer :tag "steps" 1)) (choice :tag "Idle" (const :tag "don't care" nil) (const :tag "for a while" t) (integer :tag "steps" 1))))) (defcustom gnus-demon-timestep 60 "*Number of seconds in each demon timestep." :group 'gnus-demon :type 'integer) ;;; Internal variables. (defvar gnus-demon-timer nil) (defvar gnus-demon-idle-has-been-called nil) (defvar gnus-demon-idle-time 0) (defvar gnus-demon-handler-state nil) (defvar gnus-demon-last-keys nil) (defvar gnus-inhibit-demon nil "*If non-nil, no daemonic function will be run.") ;;; Functions. (defun gnus-demon-add-handler (function time idle) "Add the handler FUNCTION to be run at TIME and IDLE." ;; First remove any old handlers that use this function. (gnus-demon-remove-handler function) ;; Then add the new one. (push (list function time idle) gnus-demon-handlers) (gnus-demon-init)) (defun gnus-demon-remove-handler (function &optional no-init) "Remove the handler FUNCTION from the list of handlers." (gnus-pull function gnus-demon-handlers) (unless no-init (gnus-demon-init))) (defun gnus-demon-init () "Initialize the Gnus daemon." (interactive) (gnus-demon-cancel) (when gnus-demon-handlers ;; Set up the timer. (setq gnus-demon-timer (run-at-time gnus-demon-timestep gnus-demon-timestep 'gnus-demon)) ;; Reset control variables. (setq gnus-demon-handler-state (mapcar (lambda (handler) (list (car handler) (gnus-demon-time-to-step (nth 1 handler)) (nth 2 handler))) gnus-demon-handlers)) (setq gnus-demon-idle-time 0) (setq gnus-demon-idle-has-been-called nil))) (gnus-add-shutdown 'gnus-demon-cancel 'gnus) (defun gnus-demon-cancel () "Cancel any Gnus daemons." (interactive) (when gnus-demon-timer (nnheader-cancel-timer gnus-demon-timer)) (setq gnus-demon-timer nil gnus-demon-idle-has-been-called nil) (condition-case () (nnheader-cancel-function-timers 'gnus-demon) (error t))) (defun gnus-demon-is-idle-p () "Whether Emacs is idle or not." ;; We do this simply by comparing the 100 most recent keystrokes ;; with the ones we had last time. If they are the same, one might ;; guess that Emacs is indeed idle. This only makes sense if one ;; calls this function seldom -- like once a minute, which is what ;; we do here. (let ((keys (recent-keys))) (or (equal keys gnus-demon-last-keys) (progn (setq gnus-demon-last-keys keys) nil)))) (defun gnus-demon-time-to-step (time) "Find out how many seconds to TIME, which is on the form \"17:43\"." (if (not (stringp time)) time (let* ((now (current-time)) ;; obtain NOW as discrete components -- make a vector for speed (nowParts (decode-time now)) ;; obtain THEN as discrete components (thenParts (parse-time-string time)) (thenHour (elt thenParts 2)) (thenMin (elt thenParts 1)) ;; convert time as elements into number of seconds since EPOCH. (then (encode-time 0 thenMin thenHour ;; If THEN is earlier than NOW, make it ;; same time tomorrow. Doc for encode-time ;; says that this is OK. (+ (elt nowParts 3) (if (or (< thenHour (elt nowParts 2)) (and (= thenHour (elt nowParts 2)) (<= thenMin (elt nowParts 1)))) 1 0)) (elt nowParts 4) (elt nowParts 5) (elt nowParts 6) (elt nowParts 7) (elt nowParts 8))) ;; calculate number of seconds between NOW and THEN (diff (+ (* 65536 (- (car then) (car now))) (- (cadr then) (cadr now))))) ;; return number of timesteps in the number of seconds (round (/ diff gnus-demon-timestep))))) (defun gnus-demon () "The Gnus daemon that takes care of running all Gnus handlers." ;; Increase or reset the time Emacs has been idle. (if (gnus-demon-is-idle-p) (incf gnus-demon-idle-time) (setq gnus-demon-idle-time 0) (setq gnus-demon-idle-has-been-called nil)) ;; Disable all daemonic stuff if we're in the minibuffer (when (and (not (window-minibuffer-p (selected-window))) (not gnus-inhibit-demon)) ;; Then we go through all the handler and call those that are ;; sufficiently ripe. (let ((handlers gnus-demon-handler-state) (gnus-inhibit-demon t) ;; Try to avoid dialog boxes, e.g. by Mailcrypt. ;; Unfortunately, Emacs 20's `message-or-box...' doesn't ;; obey `use-dialog-box'. use-dialog-box (last-nonmenu-event 10) handler time idle) (while handlers (setq handler (pop handlers)) (cond ((numberp (setq time (nth 1 handler))) ;; These handlers use a regular timeout mechanism. We decrease ;; the timer if it hasn't reached zero yet. (unless (zerop time) (setcar (nthcdr 1 handler) (decf time))) (and (zerop time) ; If the timer now is zero... ;; Test for appropriate idleness (progn (setq idle (nth 2 handler)) (cond ((null idle) t) ; Don't care about idle. ((numberp idle) ; Numerical idle... (< idle gnus-demon-idle-time)) ; Idle timed out. (t (< 0 gnus-demon-idle-time)))) ; Or just need to be idle. ;; So we call the handler. (gnus-with-local-quit (ignore-errors (funcall (car handler))) ;; And reset the timer. (setcar (nthcdr 1 handler) (gnus-demon-time-to-step (nth 1 (assq (car handler) gnus-demon-handlers))))))) ;; These are only supposed to be called when Emacs is idle. ((null (setq idle (nth 2 handler))) ;; We do nothing. ) ((and (not (numberp idle)) (gnus-demon-is-idle-p)) ;; We want to call this handler each and every time that ;; Emacs is idle. (gnus-with-local-quit (ignore-errors (funcall (car handler))))) (t ;; We want to call this handler only if Emacs has been idle ;; for a specified number of timesteps. (and (not (memq (car handler) gnus-demon-idle-has-been-called)) (< idle gnus-demon-idle-time) (gnus-demon-is-idle-p) (gnus-with-local-quit (ignore-errors (funcall (car handler))) ;; Make sure the handler won't be called once more in ;; this idle-cycle. (push (car handler) gnus-demon-idle-has-been-called))))))))) (defun gnus-demon-add-nocem () "Add daemonic NoCeM handling to Gnus." (gnus-demon-add-handler 'gnus-demon-scan-nocem 60 30)) (defun gnus-demon-scan-nocem () "Scan NoCeM groups for NoCeM messages." (save-window-excursion (gnus-nocem-scan-groups))) (defun gnus-demon-add-disconnection () "Add daemonic server disconnection to Gnus." (gnus-demon-add-handler 'gnus-demon-close-connections nil 30)) (defun gnus-demon-close-connections () (save-window-excursion (gnus-close-backends))) (defun gnus-demon-add-nntp-close-connection () "Add daemonic nntp server disconnection to Gnus. If no commands have gone out via nntp during the last five minutes, the connection is closed." (gnus-demon-add-handler 'gnus-demon-nntp-close-connections 5 nil)) (defun gnus-demon-nntp-close-connection () (save-window-excursion (when (time-less-p '(0 300) (time-since nntp-last-command-time)) (nntp-close-server)))) (defun gnus-demon-add-scanmail () "Add daemonic scanning of mail from the mail backends." (gnus-demon-add-handler 'gnus-demon-scan-mail 120 60)) (defun gnus-demon-scan-mail () (save-window-excursion (let ((servers gnus-opened-servers) server (nnmail-fetched-sources (list t))) (while (setq server (car (pop servers))) (and (gnus-check-backend-function 'request-scan (car server)) (or (gnus-server-opened server) (gnus-open-server server)) (gnus-request-scan nil server)))))) (defun gnus-demon-add-rescan () "Add daemonic scanning of new articles from all backends." (gnus-demon-add-handler 'gnus-demon-scan-news 120 60)) (defun gnus-demon-scan-news () (let ((win (current-window-configuration))) (unwind-protect (save-window-excursion (save-excursion (when (gnus-alive-p) (save-excursion (set-buffer gnus-group-buffer) (gnus-group-get-new-news))))) (set-window-configuration win)))) (defun gnus-demon-add-scan-timestamps () "Add daemonic updating of timestamps in empty newgroups." (gnus-demon-add-handler 'gnus-demon-scan-timestamps nil 30)) (defun gnus-demon-scan-timestamps () "Set the timestamp on all newsgroups with no unread and no ticked articles." (when (gnus-alive-p) (let ((cur-time (current-time)) (newsrc (cdr gnus-newsrc-alist)) info group unread has-ticked) (while (setq info (pop newsrc)) (setq group (gnus-info-group info) unread (gnus-group-unread group) has-ticked (cdr (assq 'tick (gnus-info-marks info)))) (when (and (numberp unread) (= unread 0) (not has-ticked)) (gnus-group-set-parameter group 'timestamp cur-time)))))) (provide 'gnus-demon) ;; arch-tag: 8dd5cd3d-6ae4-46b4-9b15-f5fca09fd392 ;;; gnus-demon.el ends here gnus-5.11+v0.10.dfsg/lisp/ChangeLog0000644000175000017500000157550211006351432017027 0ustar tvainikatvainika2008-05-01 Lars Magne Ingebrigtsen * gnus-sum.el (gnus-summary-save-parts): Inhibit even more treatment hooks. (gnus-update-read-articles): Speed up non-marks-using users. (gnus-use-marks): Define gnus-use-marks. (gnus-propagate-marks): Rename variable to something more sensible. 2008-04-28 Teodor Zlatanov * mail-source.el (mail-source-set-1, mail-source-bind): Moved auth-source code out of the macro to clean it up and fix bugs. 2008-04-26 Teodor Zlatanov * gnus-registry.el (gnus-registry-split-fancy-with-parent): Don't split by sender if it's equal to user-mail-address, it's likely to be useless. * mail-source.el (mail-source-bind): Don't use user or password if they are not bound. Unintern them if they are nil. Don't use server unless it's bound, and default it to empty string otherwise. 2008-04-25 Teodor Zlatanov * mail-source.el: Load auth-source.el. (mail-source-bind): Add comments. Call auth-source-user-or-password to get user name or password, if auth-sources is set up. * gnus-registry.el (gnus-registry-split-strategy): New variable for strategy of splitting with parent. (gnus-registry-split-fancy-with-parent) (gnus-registry-post-process-groups): Use it and fix prior bug (returning a list as the split result). * auth-source.el (auth-sources): Remove server parameter. (auth-source-pick, auth-source-user-or-password) (auth-source-user-or-password-imap) (auth-source-user-or-password-pop3, auth-source-user-or-password-ssh) (auth-source-user-or-password-sftp) (auth-source-user-or-password-smtp): Remove server parameter. 2008-04-24 Luca Capello (tiny change) * mm-encode.el (mm-safer-encoding): Add optional argument `type'. Don't use QP for message/rfc822. (mm-content-transfer-encoding): Pass `type' to mm-safer-encoding. 2008-04-22 Juri Linkov * mailcap.el (mailcap-file-default-commands): New function. 2008-04-13 Reiner Steib * message.el (message-signature-separator, message-cite-function): Change custom version. 2008-04-13 Naohiro Aota (tiny change) * tls.el (tls-program): Add -ign_eof argument to call the openssl commands. (tls-checktrust): Ditto. 2008-04-13 Reiner Steib * mm-decode.el (mm-display-external): Make temp file read-only. 2008-04-12 Reiner Steib * gnus-diary.el (gnus-article-edit-mode-map, message-mode-map): Remove binding for `gnus-diary-version'. Bind `gnus-diary-check-message' to `C-c C-f d'. 2008-04-12 Adrian Aichner * gnus-sum.el (gnus-summary-goto-subject): Typo fix. 2008-04-11 Reiner Steib * gnus.el: Bump version to 0.9. 2008-04-10 Reiner Steib * gnus.el: No Gnus v0.8 is released. 2008-04-10 Stefan Monnier * mail-source.el (mail-source-value): Prefer fboundp to functionp so it works with macros as well. 2008-04-10 Stefan Monnier * gnus-win.el (gnus-configure-frame, gnus-all-windows-visible-p): Fix last change in case the element is not even a symbol. 2008-04-10 Stefan Monnier * gnus-win.el (gnus-configure-frame, gnus-all-windows-visible-p): Prefer fboundp to functionp so it works with macros as well. 2008-04-09 Teodor Zlatanov * auth-source.el: Added docs. (auth-sources): Modified format to support server. (auth-source-pick, auth-source-user-or-password) (auth-source-user-or-password-imap) (auth-source-user-or-password-pop3, auth-source-user-or-password-ssh) (auth-source-user-or-password-sftp) (auth-source-user-or-password-smtp): Add server parameter. 2008-04-08 Teodor Zlatanov * gnus-registry.el: Initialize the registry when gnus-registry-install is t. 2008-04-08 Katsumi Yamaoka * compface.el (uncompface): Make buffer unibyte. 2008-04-05 Glenn Morris * gnus-ems.el (mm-disable-multibyte): Autoload it. 2008-04-05 Stefan Monnier * mm-util.el (mm-with-unibyte-buffer, mm-with-multibyte-buffer): Prefer mm-(en|dis)able-multibyte to default-enable-multibyte-characters. * nnheader.el (nnheader-init-server-buffer): Change buffer's multibyteness after rather than before erasing it. * gnus-art.el (gnus-mime-replace-part): Remove unnecessary use of mm-with-multibyte. (gnus-request-article-this-buffer): Make sure the proper decoding is used if gnus-original-article-buffer happens to be unibyte. * gnus-ems.el (gnus-x-splash): Prefer mm-disable-multibyte to default-enable-multibyte-characters. * gnus-fun.el (gnus-display-x-face-in-from): Remove unnecessary use of default-enable-multibyte-characters. * mm-decode.el (mm-inline-media-tests): Add entry for x-diff. * nnweb.el (nnweb-init): Avoid nn-with-unibyte. 2008-04-02 Simon Josefsson * imap.el (imap-enable-exchange-bug-workaround): New variable. (imap-message-copyuid-1): Use it. (imap-message-appenduid-1): Likewise. Based on patch by Nathan J. Williams in . * nnimap.el (nnimap-enable-minmax-bug-workaround): Remove, replaced by imap-enable-exchange-bug-workaround. (nnimap-find-minmax-uid): Use imap-enable-exchange-bug-workaround. 2008-04-01 Simon Josefsson * nnimap.el (nnimap-find-minmax-uid): Revert last fix, the "fix" turns a 100 byte status-checks into a 2-3MB transfer for each group. (nnimap-enable-minmax-bug-workaround): New variable to toggle whether to enable bug workaround or not. (nnimap-find-minmax-uid): Only enable workaround conditionally. 2008-03-31 Glenn Morris * message.el (mml2015-use): Declare for compiler. (message-info): Require mml2015 when appropriate. 2008-03-31 Katsumi Yamaoka * Makefile.in (EMACS_COMP): Quote directory name that might contain whitespace. 2008-03-30 Stefan Monnier * nntp.el (nntp-netcat-command): Rename from nntp-via-netcat-command. (nntp-netcat-switches): Rename from nntp-via-netcat-switches. (nntp-open-telnet, nntp-open-rlogin): Use with-current-buffer. (nntp-service-to-port): New function. (nntp-open-via-rlogin-and-netcat, nntp-open-via-telnet-and-telnet) (nntp-open-telnet-stream, nntp-open-via-rlogin-and-telnet): Use it. (nntp-open-netcat-stream): New function. (nntp-open-via-rlogin-and-netcat): Don't use a pty. 2008-03-29 Sven Joachim * gnus-sum.el (gnus-summary-make-menu-bar): Add missing dots. 2008-03-29 Stefan Monnier * message.el (message-make-in-reply-to): Use mm-with-multibyte-buffer. 2008-03-28 Magnus Henoch * dns.el (dns-write): Use set-buffer-multibyte. 2008-03-28 Michael Harnois (tiny change) * nnimap.el (nnimap-find-minmax-uid): Fix Exchange 2007 IMAP problem. 2008-03-24 Reiner Steib * message.el (message-signature-separator): Change default. Improve custom type. (message-cite-function): Change default to message-cite-original-without-signature. * gnus-sum.el (gnus-summary-make-menu-bar): Add message-cite-function toggle. * message.el (message-check-news-body-syntax): Fix signature check. (message-setup-1): Mark buffer as unmodified _after_ running message-setup-hook and handling message-alternative-emails. (message-shorten-references): Be more strict when building list of valid references to comply with GNKSA. * gnus-group.el (gnus-read-ephemeral-bug-group) (gnus-read-ephemeral-debian-bug-group) (gnus-read-ephemeral-emacs-bug-group): Use the correct variable. * message.el (message-info): Don't use booleanp which isn't supported in Emacs 21 and XEmacs. 2008-03-22 Reiner Steib * gnus-group.el (gnus-gmane-group-download-format): Rename from gnus-group-gmane-group-download-format. (gnus-group-read-ephemeral-gmane-group): Rename from gnus-group-read-ephemeral-gmane-group. (gnus-read-ephemeral-gmane-group-url): Rename from gnus-group-read-ephemeral-gmane-group-url. (gnus-bug-group-download-format-alist): New variable. (gnus-read-ephemeral-bug-group, gnus-read-ephemeral-debian-bug-group) (gnus-read-ephemeral-emacs-bug-group): New commands. 2008-03-21 Reiner Steib * gnus-art.el (gnus-article-browse-html-article): Fix documentation. (gnus-visible-headers): Improve custom type. 2008-03-20 Reiner Steib * mml.el (mml-menu): Add workarounds for XEmacs. * gnus-art.el (gnus-article-browse-html-article): Inhibit display of X-Boundary header. * message.el (message-simplify-recipients): Fix previous commit. 2008-03-20 Stefan Monnier * mm-util.el (mm-set-buffer-multibyte): New function. * mm-decode.el (mm-copy-to-buffer): Use it. 2008-03-19 Glenn Morris * tls.el (open-tls-stream): Restore use of `tls-end-of-info'. Accidentally removed in the sync process with Emacs. 2008-03-19 Reiner Steib * message.el (message-alter-recipients-discard-bogus-full-name): New function. (message-alter-recipients-function): New variable. (message-get-reply-headers): Use it. (message-replace-header): New helper function. (message-recipients-without-full-name): New variable. (message-simplify-recipients): New command. * mml.el (mml-menu): Add toggle for gnus-gcc-externalize-attachments. * message.el (message-info): Handle EasyPG manual. * mml.el (mml-menu): Add entry for EasyPG. 2008-03-18 Nils Ackermann (tiny change) * nnmh.el (nnmh-request-expire-articles): Prefer expiry-target group parameter. * message.el (message-disassociate-draft): Specify drafts group name fully. 2008-03-17 Teodor Zlatanov * gnus-registry.el (gnus-registry-split-fancy-with-parent): Eliminate unnecessary duplicates from the match list. 2008-03-17 Katsumi Yamaoka * dgnushack.el: Autoload Info-index and Info-index-next for XEmacs. * lpath.el: Fbind Info-index and Info-index-next for Emacs 21, 22. * gnus-art.el (gnus-button-handle-info-keystrokes): Don't use optional args of `how-many' of which the XEmacs version doesn't take; declare Info-index-next as function. 2008-03-16 Reiner Steib * gnus-score.el (gnus-score-headers): Fix handling of gnus-inhibit-slow-scoring. * gnus-art.el (gnus-article-browse-html-article): Fix type in doc string. (gnus-button-url-regexp): Improve handling of parenthesis. (gnus-button-alist): Extend gnus-button-handle-info-keystrokes entry. (gnus-button-handle-info-keystrokes): Handle index entries. 2008-03-15 Glenn Morris * parse-time.el (parse-time-string): Simplify. 2008-03-14 Katsumi Yamaoka * mail-source.el (mail-source-delete-old-incoming) Fix regexp to find Incoming* files. 2008-03-13 Teodor Zlatanov * auth-source.el (auth-sources): Renamed from auth-source-choices. (auth-source-pick): Use it. 2008-03-12 Stefan Monnier * binhex.el (binhex-decode-region-internal): * uudecode.el (uudecode-decode-region-internal): * dns.el (dns-read-string-name, dns-read, dns-read-type, query-dns): * sha1.el (sha1-string-external): Use set-buffer-multibyte rather than setting default-enable-multibyte-characters. 2008-03-12 Teodor Zlatanov * auth-source.el (auth-source-protocols) (auth-source-protocols-customize, auth-source-choices): Added and modified variable customizations and defaults. (auth-source-pick, auth-source-user-or-password) (auth-source-protocol-defaults, auth-source-user-or-password-imap) (auth-source-user-or-password-pop3, auth-source-user-or-password-ssh) (auth-source-user-or-password-sftp) (auth-source-user-or-password-smtp): Use new variables and provide an interface to netrc.el. 2008-03-12 Katsumi Yamaoka * nntp.el (nntp-open-telnet-stream, nntp-open-via-rlogin-and-telnet) (nntp-open-via-rlogin-and-netcat, nntp-open-via-telnet-and-telnet): Make sure the nntp port to specify is a string. 2008-03-12 Stefan Monnier * nntp.el: Use with-current-buffer. (nntp-send-buffer): Just set the buffer to unibyte rather than use the dubious mm-with-unibyte-current-buffer. (nntp-with-open-group-function): New function extracted from nntp-with-open-group macro. (nntp-with-open-group): Use the function, so it's easier to debug. Add indentation and debugging info. (nntp-open-telnet-stream, nntp-open-via-rlogin-and-telnet): Recommend the use of the netcat alternatives. * rfc2047.el (rfc2047-decode-string): Don't use `m'. Avoid mm-string-as-multibyte as well. * nnweb.el (nnweb-insert-html): Remove use of nnheader-string-as-multibyte. * nnheader.el (nnheader-init-server-buffer): Use with-current-buffer. (nnheader-string-as-multibyte): Remove. * mm-view.el: Use inhibit-read-only. (mm-inline-text-html-render-with-w3, mm-inline-message): Use dolist. (mm-pkcs7-signed-magic, mm-pkcs7-enveloped-magic): Use just string or unibyte-string. * mm-uu.el (mm-uu-copy-to-buffer): Preserve (uni/multi)byteness. (mm-uu-yenc-extract): Use with-current-buffer. * gnus-soup.el (gnus-soup-send-packet): Don't use mm-with-unibyte-current-buffer since the buffer is unibyte anyway. * nnmh.el: Use with-current-buffer. (nnmh-request-list-1): Use mm-string-to-multibyte rather than mm-string-as-multibyte on the output of mm-encode-coding-string. * nnimap.el (nnimap-retrieve-headers-progress): Use a unibyte buffer. (nnimap-request-move-article): Use with-current-buffer. * mm-decode.el (mm-with-part): Set the buffer to unibyte before inserting the handle-buffer's text, so the implicit multibyte->unibyte conversion uses string-make-unibyte rather than string-as-unibyte. * gnus-msg.el: Use with-current-buffer. * message.el (message-ignored-resent-headers): Add "Delivered-To". 2008-03-10 Daiki Ueno * mml2015.el (mml2015-epg-passphrase-callback): Type cast KEY-ID to a string for caching if it is 'PIN. 2008-03-10 Katsumi Yamaoka * lpath.el: Consider the case without Emacs/W3. 2008-03-08 Glenn Morris * time-date.el (date-to-time, time-subtract, time-add) (safe-date-to-time): Doc fixes. 2008-03-08 Reiner Steib * mail-source.el (mail-source-delete-old-incoming-confirm): Change default to nil. (mail-source-delete-old-incoming): Make confirmation prompt more clear. 2008-03-07 Katsumi Yamaoka * lpath.el: Rearrange. * gnus-art.el (gnus-narrow-to-page): Position point properly. (gnus-article-goto-prev-page): Work for articles having ^L's. * gnus-sum.el (gnus-summary-end-of-article): Remove needless narrowing. * mm-view.el (mm-w3m-standalone-supports-m17n-p): Fix typo. 2008-03-07 Karl Fogel * gnus-bookmark.el: Adjust for renames in bookmark.el. (gnus-bookmark-make-record): Was `gnus-bookmark-make-cell'. (gnus-bookmark-jump): Adjust some variable names. 2008-03-06 Teodor Zlatanov * auth-source.el: New package. (auth-source-choices): Add customization entry point variable. * gnus-registry.el (gnus-registry-user-format-function-M): Fix concat bug. 2008-03-05 Teodor Zlatanov * gnus-registry.el (gnus-registry-install): Allow 'ask as an option. (gnus-registry-initialize, gnus-registry-install-p): Use it. (gnus-registry-install-shortcuts): Rename from gnus-registry-install-shortcuts-and-menus. Installs the shortcuts in the `gnus-registry-mark-map' keymap dynamically from `gnus-registry-marks'. The generated functions update the summary line when a registry mark is added or deleted, and will call `gnus-registry-install-p' (see the comments in the code). (gnus-registry-user-format-function-M): Use concat intelligently. * gnus-sum.el (gnus-summary-make-menu-bar): Add menu entries for all the registry mark functions. 2008-03-05 Glenn Morris * gnus-art.el (gnus-article-mode-line-format-alist): Move to gnus-sum. * gnus-sum.el (gnus-article-mode-line-format-alist): Move here from gnus-art. (top-level): No need to load own source when compiling. 2008-03-04 Reiner Steib * gnus-sum.el (gnus-print-buffer): Honor ps-print-color-p. Suggested by . 2008-03-04 Glenn Morris * gnus-sum.el (top-level): No need to require gnus when compiling, since unconditionally required near start of file. (gnus-summary-display-while-building): Move definition before use. 2008-03-04 Teodor Zlatanov * gnus-registry.el (gnus-registry-user-format-function-M): Add formatting function. 2008-03-03 Teodor Zlatanov * gnus-registry.el (gnus-registry-marks): Changed format to be nicer with plists. (gnus-registry-do-marks, gnus-registry-install-shortcuts-and-menus): Use new format. 2008-03-03 Katsumi Yamaoka * gnus-art.el (gnus-article-describe-bindings): Work for the version of `where-is-internal' that returns a range of key sequences. 2008-03-03 Stefan Monnier * mm-bodies.el (mm-decode-content-transfer-encoding): Simplify. * gnus-sum.el: Use inhibit-read-only and with-current-buffer. (gnus-summary-jump-to-group): Consider windows on other displayed frames as well. Similar changes might be needed elsewhere, but that's the one I've bumped into during my use. * nndoc.el (nndoc-oe-dbx-type-p): * gnus-msg.el (gnus-debug): * gnus-group.el (gnus-update-group-mark-positions): Use mm-string-to-multibyte. 2008-03-02 Reiner Steib * mml2015.el (mml2015-extract-cleartext-signature): Explain that it doesn't handle NotDashEscaped. * mml.el (mml-menu): Improve help entries. Move Sign/Encrypt Part. (mml-dnd-attach-options): Fix typo in custom choice. * gnus-group.el (gnus-group-read-ephemeral-gmane-group): Change nndoc-article-type to mbox. (gnus-group-read-ephemeral-gmane-group-url): Support permalink. * mm-decode.el (mm-text-html-renderer): Prefer w3m over w3. Fall back to nil, instead of html2text. * imap.el (imap-debug): Add `imap-ping-server'. * gnus-bookmark.el: Add FIXMEs. * message.el (message-form-letter-separator) (message-send-form-letter-delay): New variables. (message-send-form-letter): Use them. New command to send form letters. Requested by Uwe Siart. (message-send-mail-function): Doc fix. Add "Other" custom option. 2008-03-01 Reiner Steib * Update copyright years. 2008-03-01 Reiner Steib Sync from EMACS_22_BASE. * parse-time.el: Rename elt->parse-time-elt and val->parse-time-val. 2008-02-29 Andreas Seltenreich * nnweb.el (nnweb-google-parse-1): Fix date parsing on articles with empty author. 2008-02-29 Teodor Zlatanov * gnus-registry.el (gnus-registry-marks): Add variable for customization of marks and their appearance. (gnus-registry-read-mark): Use it. (gnus-registry-do-marks): Add utility function to loop through `gnus-registry-marks'. (gnus-registry-install-shortcuts-and-menus): Add function to install shortcuts and menus. (gnus-registry-initialize): Use it. (gnus-registry-default-mark): Clarify documentation. 2008-02-29 Glenn Morris * gnus-art.el, gnus-bookmark.el, gnus-dired.el, gnus-draft.el: * gnus-group.el, gnus-msg.el, gnus-score.el, gnus-sum.el, gnus-util.el: * gnus.el, mail-source.el, message.el, mm-decode.el, mm-uu.el, mml.el: * nnmail.el, pop3.el, smiley.el, smime.el, spam-report.el: Change defcustom :version from 23.0 to 23.1. 2008-02-28 Teodor Zlatanov * gnus-registry.el (gnus-registry-follow-group-p) (gnus-registry-post-process-groups): Add functions to aid registry splitting and improve logging. Clarify behavior in function documentation. (gnus-registry-split-fancy-with-parent): Use them. 2008-02-28 Stefan Monnier * gnus-art.el: Use with-current-buffer. 2008-02-27 David Engster * nnmairix.el (nnmairix-request-group-with-article-number-correction): Express real group name in the response. 2008-02-27 Katsumi Yamaoka * nnmairix.el (nnmairix-group-regexp, nnmairix-valid-backends) (nnmairix-last-server, nnmairix-current-server): Defvar them. (nnmairix-goto-original-article): Defvar gnus-registry-install and autoload gnus-registry-fetch-group when compiling. (nnmairix-request-group-with-article-number-correction): remove unreferenced argument passed to nnmairix-call-backend. 2008-02-27 Reiner Steib * mm-uu.el (mm-uu-type-alist): Fix message-marks non-hide arguments. (mm-uu-extract): Improve face for low color ttys. Reported by Sascha Wilde. 2008-02-27 Glenn Morris * nnmairix.el: Change defcustom :version from 23.0 to 23.1. (nnmairix-group-regexp, nnmairix-valid-backends): Convert from free variables to defconsts. Convert comments to doc-strings. (nnmairix-last-server, nnmairix-current-server): Convert from free variables to defvars. Convert comments to doc-strings. (gnus-registry-fetch-group): Autoload. (nnmairix-replace-group-and-numbers): Use mapc rather than mapcar. (nnmairix-widget-get-values, nnmairix-widget-make-query-from-widgets) (nnmairix-widget-build-editable-fields): Use car cddr rather than caddr. (nnmairix-request-group): Bind nnmairix-fast and nnmairix-group around nnmairix-request-group-with-article-number-correction call. (nnmairix-fast, nnmairix-group): New, less general names, for free variables passed from nnmairix-request-group to nnmairix-request-group-with-article-number-correction. Declare. (nnmairix-request-group-with-article-number-correction): Use nnmairix-fast, nnmairix-group rather than fast, group. 2008-02-26 David Engster * nnmairix.el: New file. Mairix back end for Gnus. Initial import of version 0.5. 2008-02-26 Teodor Zlatanov * gnus-registry.el (gnus-registry-register-message-ids): Use `id' instead of making an extra function call. Don't add the current group to articles only when they have the group. Use `gnus-registry-fetch-groups' instead of `gnus-registry-fetch-group'. Reported by David . 2008-02-20 Katsumi Yamaoka * lpath.el: Fbind pgg-display-output-buffer for systems in which EasyPG has been installed; bind pgg-parse-crc24 for only non-Mule XEmacs. 2008-02-16 Reiner Steib * mail-source.el (mail-source-delete-incoming): Change default. Supplement doc string. * gnus-util.el (gnus-y-or-n-p, gnus-y-or-n-p): Update comments. 2008-02-14 Glenn Morris * time-date.el (format-seconds): New function. 2008-02-14 Reiner Steib * nnmail.el (nnmail-message-id-cache-file): Derive from `gnus-home-directory'. 2008-02-11 Reiner Steib * gnus-topic.el (gnus-topic-select-group, gnus-topic-read-group): Document negative prefix. * gnus-group.el (gnus-group-read-group): Document negative prefix. 2008-02-10 Lars Magne Ingebrigtsen * message.el (message-unsent-separator): Add the Exim bounce separator. 2008-02-10 Daiki Ueno * mml2015.el (mml2015-epg-sign): Remove skipped signers from the signer list. (mml2015-epg-encrypt): Remove skipped recipients/signers from the recipient/signer list. 2008-02-07 Katsumi Yamaoka * Makefile.in (datarootdir): Define. (EMACS_COMP, install-el, install-elc, install-el-elc): Quote directory name that might contain whitespace. 2008-02-10 Reiner Steib * mm-util.el (mm-codepage-setup): If cp-supported-codepages isn't fbound (Emacs 23 unicode), signal an error. 2008-02-08 Glenn Morris * gnus-art.el (pgg-display-output-buffer): Declare as function. 2008-02-07 Tassilo Horn * nnimap.el (nnimap-open-connection): Add "143" and "993" as default ports to the calls to `netrc-machine-user-or-password' in addition to "imap" and "imaps". 2008-02-01 Zhang Wei * rfc2047.el (rfc2047-charset-encoding-alist): Add gbk and GB18030. * mm-util.el (mm-mime-mule-charset-alist): Add gbk and GB18030. 2008-02-01 Kenichi Handa * rfc2104.el (rfc2104-hexstring-to-byte-list): Renamed from rfc2104-hexstring-to-bitstring and changed to return a byte list. (rfc2104-hash): Convert the result of concat to unibyte string. 2008-02-01 Dave Love * gnus-start.el (gnus-read-newsrc-el-file): Don't bind coding-system-for-read. (gnus-gnus-to-quick-newsrc-format): Insert coding cookie. 2008-02-03 Reiner Steib * gnus.el (gnus-group-startup-message): Add `find-image' call before image-load-path is let-bound. Reported by Harald Hanche-Olsen . 2008-02-01 Katsumi Yamaoka * gnus-art.el (gnus-article-describe-bindings): Work for draft group. * gnus-xmas.el (gnus-xmas-article-describe-bindings): Ditto. 2008-01-28 Dan Nicolaescu * sieve.el (sieve-make-overlay, sieve-overlay-put, sieve-overlays-at): * message.el (message-beginning-of-line): Use featurep instead of bound tests in order to resolve conditionals at compile time. 2008-01-24 Michael Sperber * mail-source.el (mail-sources): Add `group' choice. * nnmail.el (nnmail-get-new-mail-1): Abstract this out to add another parameter `in-group' to control into which group the articles go. Add treatment of `group' mail-source. 2008-01-23 Katsumi Yamaoka * gnus-art.el (gnus-insert-mime-button): Don't decode description. * mm-decode.el (mm-dissect-buffer): Decode description. * mml.el (mml-to-mime): Encode message header first. 2008-01-18 Katsumi Yamaoka * gnus-art.el (gnus-article-describe-bindings): Make it possible to use xrefs, i.e. [back] and [forward] buttons, in *Help* buffer. * lpath.el: Fbind help-buffer for Emacs 21 and XEmacs; bind help-xref-stack-item for Emacs 21, Emacs 22.1, and XEmacs. 2008-01-18 Teodor Zlatanov * gnus-registry.el (gnus-registry-trim): Use append, not concat. 2008-01-17 Katsumi Yamaoka * gnus-art.el (gnus-article-read-summary-keys): Work for some `A' prefix keys. (gnus-article-read-summary-send-keys): Use gnus-character-to-event. (gnus-article-describe-bindings): Simplify; move XEmacs stuff to gnus-xmas.el. * gnus-xmas.el: Bind gnus-agent-summary-mode when compiling. (gnus-xmas-article-describe-bindings): New function. (gnus-xmas-redefine): Make gnus-article-describe-bindings alias to gnus-xmas-article-describe-bindings. * lpath.el: Don't fbind character-to-event and map-keymap for Emacs 21. 2008-01-16 Teodor Zlatanov * gnus-registry.el (gnus-registry-marks, gnus-registry-default-mark): Add new variables for article mark management. (gnus-registry-extra-entries-precious, gnus-registry-trim): Define a list of extra data entries which, when present, will indicate that the article ID should not be trimmed from the registry. (gnus-registry-mark-article, gnus-registry-article-marks): Remove these functions. (gnus-registry-read-mark): New function to read a mark name from the user. (gnus-registry-set-article-mark, gnus-registry-remove-article-mark) (gnus-registry-set-article-mark-internal): New functions to add and remove marks. (gnus-registry-get-article-marks): New function to show the marks for an article, or retrieve them for further use. 2008-01-16 Katsumi Yamaoka * gnus-art.el (gnus-article-describe-bindings): Show all `S' prefix keys when no argument is given. 2008-01-14 Reiner Steib * imap.el (imap-ping-server): New variable. (imap-opened): On add extra ping if imap-ping-server is non-nil. (imap-ping-server): Minor doc string fixes. 2008-01-14 Knut Anders Hatlen (tiny change) * imap.el (imap-ping-server): New function. (imap-opened): Call imap-ping-server. 2008-01-12 Reiner Steib * gnus-sum.el (gnus-article-sort-by-random) (gnus-thread-sort-by-random): Fix doc strings. Reported by jidanni@jidanni.org. 2008-01-11 Katsumi Yamaoka * gnus-art.el (gnus-article-describe-bindings): New function. (gnus-article-read-summary-keys): Use it. (gnus-article-mode-map): Bind `C-h b' to it. 2008-01-10 Katsumi Yamaoka * gnus-art.el (gnus-article-read-summary-keys): Work for `C-h' on XEmacs. (gnus-article-describe-key, gnus-article-describe-key-briefly): Protect against non-character events. * lpath.el: Fbind map-keymap for Emacs 21. 2008-01-09 Reiner Steib * gnus-group.el (gnus-group-read-ephemeral-gmane-group-url): New command. (gnus-group-read-ephemeral-gmane-group): Use optional argument RANGE instead of END. Change name of the temp file. (gnus-group-gmane-group-download-format): Add doc string. Make it customizable. 2008-01-09 Katsumi Yamaoka * gnus-art.el (gnus-article-send-map): New keymap for `S' prefix keys; bind `S W' to gnus-article-wide-reply-with-original; set default binding to gnus-article-read-summary-send-keys. (gnus-article-read-summary-keys): Fix the order of keys; display continuation keys correctly in the echo area; describe bindings correctly when keys end with `C-h'. (gnus-article-read-summary-send-keys): New function. (gnus-article-describe-key, gnus-article-describe-key-briefly): Work for gnus-article-read-summary-send-keys; display continuation keys correctly in the echo area. (gnus-article-reply-with-original): Ignore prefix argument. (gnus-article-wide-reply-with-original): New function. * lpath.el: Fbind character-to-event and set-keymap-default-binding for Emacs 21. 2008-01-08 Katsumi Yamaoka * gnus-bookmark.el (gnus-bookmark-mouse-available-p): Don't test for display-color-p. Reported by Reiner Steib . 2008-01-06 Reiner Steib * gnus-group.el (gnus-group-gmane-group-download-format): New variable. (gnus-group-read-ephemeral-gmane-group): New command. 2008-01-06 Dan Nicolaescu * gnus.el (gnus-use-long-file-name): Remove reference to xenix. 2007-12-28 Reiner Steib * message.el (message-send-mail-function): Increase custom version. * mml-sec.el, sieve-manage.el, smime.el: Simplify loading of password-cache or password. Suggested by Glenn Morris . 2007-12-21 Teodor Zlatanov * imap.el (imap-authenticate): Use current-buffer instead of buffer, for the cases where imap-authenticate is called with a nil buffer parameter. 2007-12-19 Katsumi Yamaoka * gnus-art.el (gnus-article-browse-html-parts): Work for two or more html parts correctly; support forwarded messages. (gnus-article-browse-html-article): Remove work buffers. * netrc.el: Bind encrypt-file-alist for Emacs 21 and XEmacs when compiling. (netrc-bound-and-true-p): New macro. (netrc-parse): Use it instead of bound-and-true-p that is not available in XEmacs 21.4. 2007-12-19 Teodor Zlatanov * gnus-registry.el (gnus-registry-mark-article) (gnus-registry-article-marks): Add functionality to mark articles through the Gnus registry. * encrypt.el: Clarify documentation for the new pgg method. (encrypt-file-alist): Add PGG option. (encrypt-insert-file-contents, encrypt-write-file-contents): Use PGG functionality. Abstract password key and messaging to external functions. (encrypt-password-key, encrypt-get-passphrase-if-needed) (encrypt-message-method-and-cipher): Add new convenience external functions. (encrypt-pgg-encode-buffer, encrypt-pgg-decode-buffer) (encrypt-pgg-process-buffer): Add PGG functionality glue. * netrc.el: Autoload encrypt when encrypt-file-alist is set. (netrc-parse): Use encrypt-file-alist to determine if encrypt-find-model or encrypt-insert-file-contents should be used. * encrypt.el: Clarify documentation. Load password-cache or password, whichever one is found first, instead of autoloading. 2007-12-19 Glenn Morris * mml.el (message-options-set, message-narrow-to-head) (message-in-body-p, message-mail-p, message-encode-message-body): Autoload. (message-remove-header, message-narrow-to-headers-or-head) (message-subscribed-p, message-make-mail-followup-to) (message-position-on-field, message-news-p) (message-options-set-recipient, message-generate-headers) (message-sort-headers): Declare as functions. 2007-12-18 Reiner Steib * gnus-draft.el (gnus-draft-send-message): Mention process/prefix convention in doc string. 2007-12-17 Katsumi Yamaoka * gnus-art.el (gnus-article-browse-html-parts): Add message header and title to html parts. (gnus-article-browse-html-article): Pass message header to it. * mm-decode.el (mm-display-external): Use mm-add-meta-html-tag. 2007-12-16 Reiner Steib * mml-sec.el, sieve-manage.el, smime.el: Make loading of password-cache or password compatible with XEmacs. 2007-12-15 Reiner Steib * gnus-art.el (article-verify-x-pgp-sig): Add reference to X-PGP-Sig format document. (gnus-mime-delete-part): Don't write description line if empty. (gnus-article-encrypt-body): Add confirmation for gnus-novice-user. 2007-12-14 Johan Bockgård * gnus-sum.el (gnus-summary-mark-unread-as-read) (gnus-summary-mark-read-and-unread-as-read) (gnus-summary-mark-current-read-and-unread-as-read) (gnus-summary-mark-unread-as-ticked): Doc fix. `gnus-mark-article-hook', not `gnus-summary-mark-article-hook'. 2007-12-14 Reiner Steib * gnus-sum.el (gnus-summary-prev-article): Fix doc string. Reported by Christoph Conrad . 2007-12-14 Reiner Steib * gnus-util.el (gnus-y-or-n-p, gnus-yes-or-no-p): Alias to y-or-n-p and yes-or-no-p. 2007-12-11 Katsumi Yamaoka * mm-decode.el (mm-add-meta-html-tag): New function. (mm-save-part-to-file, mm-pipe-part): Use it. * gnus-art.el (gnus-article-browse-delete-temp-files): Use gnus-y-or-n-p instead of y-or-n-p. (gnus-article-browse-html-parts): Work with message/external-body; use mm-add-meta-html-tag. 2007-12-11 Glenn Morris * gnus-cache.el: Require gnus-sum not just when compiling. * gnus-fun.el (gnus-display-x-face-in-from): Require gnus-art. * gnus-int.el (gnus-server-opened, gnus-status-message): Move definitions before use. * mm-decode.el: Require gnus-util. (mm-remove-part): Only call delete-annotation on XEmacs. * mm-uu.el (gnus-original-article-buffer): Define for compiler. * nnmail.el: Require gnus-int. * spam.el: Move `require's before `eval-when-compile's. * gnus-ems.el (gnus-alive-p): * gnus-fun.el (message-goto-eoh): * gnus-util.el (gnus-group-name-decode): * mail-source.el (gnus-compress-sequence): * message.el (Info-goto-node, format-spec): * mm-bodies.el (message-options-get): * mm-decode.el (mm-view-pkcs7): * mm-util.el (gmm-write-region): * mml-smime.el (mml-compute-boundary) (gnus-completing-read-with-default): * mml.el (widget-button-press, gnus-make-hashtable): * mml1991.el (mm-decode-content-transfer-encoding) (mm-encode-content-transfer-encoding) (message-options-get, message-options-set): * mml2015.el (gnus-buffer-live-p, gnus-get-buffer-create): * nnfolder.el (gnus-request-group): * nnheader.el (ietf-drums-unfold-fws): * rfc1843.el (mail-header-parse-content-type, message-narrow-to-head): * smime.el (gnus-run-mode-hooks): * spam-stat.el (gnus-message): Autoload. * gnus-cache.el, gnus-fun.el, gnus-group.el, gnus.el, mail-source.el: * mm-bodies.el, mm-decode.el, mm-extern.el, mm-util.el: * mml-smime.el, mml.el, mml1991.el, mml2015.el, nndb.el, nnfolder.el: * nnmail.el, nnmaildir.el, nnrss.el, rfc1843.el, spam.el: Add declare-function compatibility definition. * gnus-cache.el (nnvirtual-find-group-art): * gnus-fun.el (article-narrow-to-head, gnus-article-goto-header) (gnus-add-image, gnus-add-wash-type): * gnus-group.el (nnkiboze-score-file): * gnus-sum.el (turn-on-gnus-mailing-list-mode) (gnus-cache-write-active, mm-uu-dissect, idna-to-unicode): * gnus-util.el (gnus-find-method-for-group, gnus-group-name-charset) (message-tokenize-header, gnus-get-buffer-create) (mm-enable-multibyte, gnus-put-text-property, gnus-overlay-put) (gnus-make-overlay, mm-disable-multibyte, gnus-add-text-properties): * gnus.el (gnus-group-decoded-name): * mail-source.el (imap-capability): * mm-bodies.el (message-options-set): * mm-decode.el (gnus-configure-windows): * mm-extern.el (message-goto-body): * mm-util.el (mm-delete-duplicates, mm-detect-coding-region): * mml-smime.el (epg-key-sub-key-list, epg-sub-key-capability) (epg-sub-key-validity, message-options-set): * mml.el (widget-event-point, gnus-configure-windows): * mml1991.el (mc-encrypt-generic, gpg-sign-encrypt, gpg-encrypt): * mml2015.el (epg-check-configuration, epg-configuration) (message-options-set): * nndb.el (nndb-request-article): * nnfolder.el (gnus-request-create-group): * nnmail.el (gnus-activate-group, gnus-group-mark-article-read): * nnmaildir.el (gnus-group-mark-article-read): * nnrss.el (w3-parse-buffer, gnus-group-make-rss-group): * rfc1843.el (message-fetch-field): * spam.el (gnus-extract-address-components): Declare as functions. 2007-12-10 Katsumi Yamaoka * gnus-art.el (gnus-article-browse-html-parts): Decode CTE. * pgg.el (pgg-run-at-time, pgg-cancel-timer): Use eval-and-compile. * lpath.el: Fbind run-mode-hooks for Emacs 21; bind show-trailing-whitespace for XEmacs. 2007-12-09 Reiner Steib * hashcash.el, imap.el, pgg.el, pgg-parse.el (declare-function): Add new no-op macro for backward compatibility. * imap.el (imap-string-to-integer): New function. 2007-12-09 Glenn Morris * gnus-uu.el (gnus-uu-yenc-article): Use insert-buffer-substring. * gnus-art.el, gnus-spec.el, gnus-sum.el, gnus-util.el: * message.el, mm-view.el, sieve-manage, smime.el: Add declare-function compatibility definition. * gnus-art.el (w3-region, w3m-region, Info-menu): * gnus-spec.el (gnus-summary-from-or-to-or-newsgroups): * gnus-sum.el (gnus-get-predicate): * gnus-util.el (mm-append-to-file, w32-focus-frame): * message.el (mail-abbrev-in-expansion-header-p): * mm-view.el (w3-do-setup, w3-region, w3-prepare-buffer) (w3m-detect-meta-charset, w3m-region): * sieve-manage.el (password-read, password-cache-add) (password-cache-remove): * smime.el (password-read-and-add): Declare as functions. 2007-12-08 David Kastrup * gnus-sum.el (gnus-summary-simplify-subject-query): * ecomplete.el (ecomplete-display-matches): Fix buggy call to `message'. 2007-12-07 Katsumi Yamaoka * dgnushack.el (dgnushack-emacs-compile-defcustom-p): New function; use it to bind idna-program, installation-directory, defined-colors, and face-attribute for XEmacs of the version that compiles defcustom forms. 2007-12-07 Glenn Morris * gnus-art.el (article-make-date-line): Revert previous change. 2007-12-06 Reiner Steib * gnus-start.el (gnus-load): Rename local variable to avoid confusion. 2007-12-06 Christian Plate (tiny change) * nnmaildir.el (nnmaildir-request-update-info): Improved performance. Call gnus-add-to-range ranges only once with a prepared article-list. 2007-12-06 Paul Jarc * nnmaildir.el (nnmaildir-request-list, nnmaildir-retrieve-groups, nnmaildir-request-group, nnmaildir-retrieve-headers): Escape spaces in group names with backslashes. Reported by Tassilo Horn . 2007-12-06 D. Goel * gnus-art.el (article-make-date-line): * gnus-start.el (gnus-load): * pop3.el (pop3-read-response): Fix buggy call to `error'. 2007-12-05 Katsumi Yamaoka * gnus-art.el (gnus-use-idna) * gnus-start.el (gnus-site-init-file) * message.el (message-use-idna) * mm-uu.el (mm-uu-hide-markers) * smiley.el (smiley-style): Revert changes that suppress warnings. 2007-12-05 Katsumi Yamaoka * gnus-art.el (gnus-article-browse-html-parts): Add meta html tag to specify charset to html source. Reported by Christoph Conrad . 2007-12-05 Katsumi Yamaoka * gnus-art.el (gnus-use-idna): Don't directly refer to the value of idna-program in order to suppress byte compile warning issued by XEmacs that came to byte compile the default value section of defcustom forms recently. * gnus-start.el (gnus-site-init-file): Don't directly refer to the value of installation-directory. * message.el (message-use-idna): Don't directly refer to the value of idna-program. * mm-uu.el (mm-uu-hide-markers): Don't directly call defined-colors. * smiley.el (smiley-style): Don't directly call face-attribute. 2007-12-04 Reiner Steib * gnus-group.el (gnus-group-highlight-line): Add FIXME. * gnus-dired.el: Reduce Gnus dependencies. (gnus-ems, gnus-msg, gnus-util, message, mm-decode, mml): Don't require. Use autoloads instead. (mml-attach-file, mm-default-file-encoding, mailcap-extension-to-mime) (mailcap-mime-info, mm-mailcap-command, ps-print-preprint) (message-buffers, gnus-setup-message, gnus-print-buffer): Autoload. (gnus-dired-mode): Adjust doc string. (gnus-dired-mail-mode): New variable. (gnus-dired-mode-map): Avoid using `gnus-define-keys'. (gnus-dired-mode): Avoid using `gnus-run-hooks'. (gnus-dired-mail-buffers): New function. Return mail or message composition buffers. (gnus-dired-attach): Use it. (gnus-dired-find-file-mailcap): Call `mailcap-mime-info' with NO-DECODE. (gnus-dired-print): Use `gnus-print-buffer' depending on `gnus-dired-mail-mode'. 2007-12-04 Katsumi Yamaoka * rfc2047.el (rfc2047-encoded-word-regexp) (rfc2047-encoded-word-regexp-loose): Move forward; add comments explaining what regexp patterns are for. 2007-12-04 Glenn Morris * password.el: Move to password-cache.el. * mml1991.el (password-read, password-cache-add, password-cache-remove): * mml2015.el (password-read, password-cache-add, password-cache-remove): * mml-smime.el (password-read, password-cache-add) (password-cache-remove): No need to autoload, since mml-sec requires password. * gnus.el (gnus-spam-resend-to, gnus-ham-resend-to): * message.el (gnus-extract-address-components): * mml-smime.el (gnus-extract-address-components): Define for compiler. * mml-sec.el, sieve-manage.el, smime.el: Require password-cache or password. 2007-12-03 Reiner Steib * mailcap.el: Reduce dependencies. (mail-header-parse-content-type): Autoload. (mailcap-delete-duplicates): New alias. (mailcap-mime-info): Add optional argument NO-DECODE. (mailcap-mime-types): Use mailcap-delete-duplicates. * message.el (message-ignored-supersedes-headers): Add "X-ID". 2007-12-03 Nathan J. Williams (tiny change) * imap.el (imap-mailbox-status-asynch): Upcase STATUS items. (imap-parse-status): Upcase status-att for servers that sends them lower-case (e.g., MS Exchange 2007). 2007-12-03 Lars Magne Ingebrigtsen * gnus-sum.el (gnus-uu-extract-map): Add a command for the yenc function. * gnus-uu.el (gnus-uu-decode-yenc): New command. (gnus-uu-yenc-article): New function. * yenc.el (yenc-first-part-p, yenc-last-part-p): New functions. * mm-uu.el (mm-uu-yenc-extract): Get the data from the original buffer. 2007-12-02 Glenn Morris * binhex.el (binhex): New custom group. (binhex-decoder-program, binhex-decoder-switches) (binhex-use-external): Move to the binhex custom group. * uudecode.el (uudecode): New custom group. (uudecode-decoder-program, uudecode-decoder-switches) (uudecode-use-external): Move to the uudecode custom group. * netrc.el (top-level): Don't load `encrypt' features. (netrc-parse): Don't use encrypt. (netrc-find-service-name, netrc-find-service-number): Don't use caddr. * encrypt.el: Remove file. 2007-12-01 Reiner Steib * message.el (message-cite-prefix-regexp): Remove `-' and `+' to avoid matches on patches. * gnus-art.el (gnus-article-browse-html-article): Mention `mm-text-html-renderer' in the doc string. * rfc2047.el (rfc2047-encode-max-chars): Refer to RFC 2047 in doc string. Add comments. * message.el (message-idna-to-ascii-rhs-1): Don't call `idna-to-ascii' if rhs is ASCII. 2007-12-01 Glenn Morris * mail-source.el (top-level): Require format-spec before eval-when-compile. 2007-11-30 Glenn Morris * encrypt.el: Require password, rather than autoloading password-read. 2007-11-29 Glenn Morris * imap.el (sasl-find-mechanism, sasl-mechanism-name) (sasl-make-client, sasl-next-step, sasl-step-data) (sasl-step-set-data): Declare as functions. 2007-11-28 Reiner Steib * tls.el (tls-hostmismatch, open-tls-stream): Checkdoc cleanup. 2007-11-28 Elias Oltmanns * tls.el (open-tls-stream): Actually consult tls-checktrust to see if certs should be verified and what is to be done in the event of a verification failure. * gnus.el (gnus-method-to-server): Add an optional parameter so the caller can indicate whether the cache should be disregarded for this call. This way the result of the call is reproducible at all times and can be considered a canonical server name for the supplied method. (gnus-agent-method-p): Canonicalize server names by pushing their method through `gnus-method-to-server' using the no-cache argument. * gnus-srvr.el (gnus-server-insert-server-line): Call `gnus-method-to-server' with `no-cache' argument. * gnus-agent.el (gnus-agent-toggle-plugged): Don't call gnus-agent-possibly-synchronize-flags as this should be called when the server is actually being opened. (gnus-agent-possibly-synchronize-flags) (gnus-agent-possibly-synchronize-flags-server): Move check for the flags file of an agentized server to the latter function. * gnus-int.el (gnus-agent-possibly-synchronize-flags-server): Autoload. (gnus-open-server): Call gnus-agent-possibly-synchronize-flags-server after a connection has been established successfully. 2007-11-28 Katsumi Yamaoka * gnus-art.el (article-display-face): Force to display face if called interactively; check if gnus-article-x-face-too-ugly matches author. (article-display-x-face): Display face even if From header is missing as article-display-face does. 2007-11-27 Dan Nicolaescu * hashcash.el (message-narrow-to-headers-or-head) (message-fetch-field, message-goto-eoh) (message-narrow-to-headers): Declare as functions. 2007-11-27 Reiner Steib * mail-source.el (mail-sources): Default to fetch from file for compatibility with default of nnmail-spool-file. 2007-11-27 Katsumi Yamaoka * rfc2047.el (rfc2047-allow-irregular-q-encoded-words): New variable. (rfc2047-encodable-p): Use rfc2047-encoded-word-regexp instead of "=?" to look for encoded word that should be encoded again. (rfc2047-encoded-word-regexp): Make B encoding pattern strict. (rfc2047-encoded-word-regexp-loose): New constant that has loose Q encoding pattern. (rfc2047-decode-region): Switch strict regexp and loose one according to rfc2047-allow-irregular-q-encoded-words. 2007-11-25 Romain Francoise * gnus-msg.el (gnus-summary-reply): Delete extra paren. 2007-11-25 Reiner Steib * tls.el (tls-program): Provide more custom choices from `tls-checktrust'. Refer to `tls-checktrust' in doc string. (tls-process-connection-type, tls-success): Remove "*" in doc string. 2007-11-24 Reiner Steib * nnmail.el (nnmail-spool-file): Remove obsolete variable. (nnmail-get-new-mail): Remove code using `nnmail-spool-file'. * gnus-start.el (defvar, gnus-get-unread-articles): Remove code using `nnmail-spool-file'. * nnkiboze.el (nnkiboze-generate-groups): Don't bind obsolete `nnmail-spool-file'. * gnus-move.el (gnus-change-server): Ditto. * gnus-kill.el (gnus-batch-score): Ditto. * gnus-cache.el (gnus-jog-cache): Ditto. * gnus-msg.el (gnus-summary-reply): Ignore gnus-confirm-mail-reply-to-news for wide and very wide replies. 2007-11-24 Reiner Steib * tls.el (tls-checktrust, tls-hostmismatch, tls-untrusted): Add custom version. Minor improvement to doc strings. (tls-program): Add comment. 2007-11-24 Elias Oltmanns * tls.el (tls-certtool-program, tls-hostmismatch): New variables. (tls-checktrust): New variable. Check if GNU TLS complained about a mismatch between the hostname provided in the certificate and the name of the host connnecting to. (open-tls-stream): Use them. Check certificates against trusted root certificates. 2007-11-24 Reiner Steib * gnus-cache.el (gnus-cache-generate-nov-databases): Use nnml-generate-nov-databases-directory instead of nnml-generate-nov-databases-1. 2007-11-24 Glenn Morris * message.el (message-tool-bar-retro): Update for rename mail_send.xpm->mail-send.xpm. 2007-11-22 Reiner Steib * smime.el (smime-cert-by-ldap-1): Use `ldap-search' instead of `smime-ldap-search' for Emacs 22 and up. 2007-11-22 Stefan Monnier * gnus-art.el (gnus-article-truncate-lines): Use `truncate-lines'. * message.el (message-send-mail-function): Fix error convention. (message-mailer-swallows-blank-line, message-send-mail-with-sendmail) (message-widen-reply, message-send-mail, message-talkative-question) (message-with-reply-buffer, message-generate-new-buffer-clone-locals) (message-clone-locals, message-send-news): Use with-current-buffer. (message-insert-or-toggle-importance): Remove unused var `valid'. (message-make-references): Remove unused var `new-references'. (message-make-mail-followup-to): Remove unused var `subscribed-lists'. 2007-11-22 Juanma Barranquero * spam.el (spam-find-spam, spam-enter-list): Doc fixes. (spam-split-symbolic-return-positive): Reflow docstring. (spam-backends, spam-summary-exit-behavior) (spam-mark-ham-unread-before-move-from-spam-group) (spam-summary-score-preferred-header, spam-sa-learn-spam-switch) (spam-sa-learn-ham-switch, spam-sa-learn-unregister-switch) (spam-clear-cache, spam-backend-check, spam-install-backend) (spam-install-statistical-backend, spam-list-of-processors) (spam-group-processor-p, spam-split, spam-bogofilter-score) (spam-bsfilter-score, spam-check-bsfilter, spam-crm114-score) (spam-check-crm114, spam-initialize, spam-unload-hook): Fix typos in docstrings. 2007-11-21 Katsumi Yamaoka * gnus-start.el (gnus-get-unread-articles): Mark groups as having never been checked if they have never been read and those group levels are higher than the one that a user specified. 2007-11-21 Katsumi Yamaoka * gnus-start.el (gnus-get-unread-articles): Don't prevent from checking foreign groups unless a group level is specified by a user. Reported by Dan Nicolaescu . 2007-11-21 Reiner Steib * message.el (message-send-mail-function): Require sendmail. 2007-11-20 Reiner Steib * message.el (message-send-mail-function): Check for smtpmail too. * utf7.el (utf7-encode, utf7-decode): Use coding system `utf-7'/`utf-7-imap' from utf-7.el' if available. * message.el (message-send-mail-function): New function. (message-send-mail-function): Set default using message-send-mail-function. Adjust doc string. (message-send-mail-with-mailclient): New function. 2007-11-17 Richard Stallman * assistant.el: Remove file. 2007-11-16 Dan Nicolaescu * smime.el (from): * rfc2047.el (message-posting-charset): * qp.el (mm-use-ultra-safe-encoding): * pop3.el (parse-time-months): * nnrss.el (mm-text-html-renderer, mm-text-html-washer-alist): * nnml.el (files): * nnheader.el (gnus-newsgroup-name, nnheader-file-coding-system) (jka-compr-compression-info-list, ange-ftp-path-format) (efs-path-regexp): * nndiary.el (files): * mml2015.el (mc-default-scheme, mc-schemes, pgg-default-user-id) (pgg-errors-buffer, pgg-output-buffer, epg-user-id-alist) (epg-digest-algorithm-alist, inhibit-redisplay) (password-cache-expiry): * mml1991.el (pgg-default-user-id, pgg-errors-buffer) (pgg-output-buffer, password-cache-expiry): * mml.el (mml-dnd-protocol-alist, ange-ftp-name-format) (efs-path-regexp): * mml-smime.el (epg-user-id-alist, epg-digest-algorithm-alist) (inhibit-redisplay): * mm-uu.el (file-name, start-point, end-point, entry) (gnus-newsgroup-name, gnus-newsgroup-charset): * mm-util.el (mm-mime-mule-charset-alist, latin-unity-coding-systems) (latin-unity-ucs-list): * mm-bodies.el (mm-uu-yenc-decode-function, mm-uu-decode-function) (mm-uu-binhex-decode-function): * message.el (gnus-message-group-art, gnus-list-identifiers, ) (rmail-enable-mime-composing, gnus-local-organization) (gnus-post-method, gnus-select-method, gnus-active-hashtb) (gnus-read-active-file, facemenu-add-face-function) (facemenu-remove-face-function, gnus-article-decoded-p) (tool-bar-mode): * mail-source.el (display-time-mail-function): * gnus-util.el (nnmail-pathname-coding-system) (nnmail-active-file-coding-system, gnus-emphasize-whitespace-regexp) (gnus-original-article-buffer, gnus-user-agent) (rmail-default-rmail-file, mm-text-coding-system, tool-bar-mode) (xemacs-codename, sxemacs-codename, emacs-program-version): * gnus-sum.el (tool-bar-mode, gnus-tmp-header, number): * gnus-start.el (gnus-agent-covered-methods) (gnus-agent-file-loading-local, gnus-agent-file-loading-cache) (gnus-current-headers, gnus-thread-indent-array, gnus-newsgroup-name) (gnus-newsgroup-headers, gnus-group-list-mode) (gnus-group-mark-positions, gnus-newsgroup-data) (gnus-newsgroup-unreads, nnoo-state-alist) (gnus-current-select-method, mail-sources) (nnmail-scan-directory-mail-source-once, nnmail-split-history) (nnmail-spool-file, gnus-cache-active-hashtb): * gnus-mh.el (mh-lib-progs): * gnus-ems.el (gnus-tmp-unread, gnus-tmp-replied) (gnus-tmp-score-char, gnus-tmp-indentation, gnus-tmp-opening-bracket) (gnus-tmp-lines, gnus-tmp-name, gnus-tmp-closing-bracket) (gnus-tmp-subject-or-nil, gnus-check-before-posting, gnus-mouse-face) (gnus-group-buffer): * gnus-cite.el (font-lock-defaults-computed, font-lock-keywords) (font-lock-set-defaults): * gnus-art.el (tool-bar-map, w3m-minor-mode-map) (gnus-face-properties-alist, charset, gnus-summary-article-menu) (gnus-summary-post-menu, total-parts, type, condition, length): * gnus-agent.el (gnus-agent-read-agentview): * flow-fill.el (show-trailing-whitespace): * gnus-group.el (tool-bar-mode, nnrss-group-alist): Remove unnecessary eval-and-compile wrappers for byte compiler pacifiers. * mm-view.el (mm-inline-image-xemacs): Only do something for XEmacs. (mm-display-inline-fontify): Check for featurep 'xemacs not extent-list. * mm-decode.el (mm-display-external): Check for featurep 'xemacs not itimer-list. (mm-create-image-xemacs): Only do something for XEmacs. (mm-image-fit-p): Check for featurep 'xemacs not glyph-width. * mm-util.el (mm-find-buffer-file-coding-system): Add check for XEmacs. * gnus-registry.el (gnus-adaptive-word-syntax-table): * gnus-fun.el (gnus-face-properties-alist): Pacify byte compiler. 2007-11-15 Juanma Barranquero * nnimap.el (nnimap-split-download-body): * gnus-demon.el (gnus-demon): * gnus-uu.el (gnus-uu-default-view-rules): Fix typos in docstrings. 2007-11-15 Katsumi Yamaoka * nntp.el (nntp-insert-buffer-substring, nntp-copy-to-buffer): New macros. (nntp-wait-for, nntp-retrieve-articles, nntp-async-trigger) (nntp-retrieve-headers-with-xover): Use nntp-insert-buffer-substring to copy data from unibyte buffer to multibyte current buffer. (nntp-retrieve-headers, nntp-retrieve-groups); Use nntp-copy-to-buffer to copy data from unibyte current buffer to multibyte buffer. (nntp-make-process-buffer): Make process buffer unibyte. * pop3.el (pop3-open-server): Fix typo in Lisp code. 2007-11-14 Denys Duchier (tiny change) * pop3.el (pop3-open-server): Accept and process data more robustly at connexion start to avoid spurious "POP SSL connexion failed" errors. 2007-11-14 Katsumi Yamaoka * gnus-start.el (gnus-active-to-gnus-format): Use unibyte buffer to read group names. 2007-11-12 Reiner Steib * gnus-msg.el (gnus-confirm-mail-reply-to-news): Adjust :version. 2007-11-12 Katsumi Yamaoka * nnmail.el (nnmail-parse-active): Make group names unibyte. (nnmail-save-active): Use a unibyte buffer when saving active file, which may contain non-ASCII group names. * nnml.el (nnml-request-group): Decode group names in messages. 2007-11-05 Reiner Steib * message.el (message-citation-line-function) (message-insert-formatted-citation-line): Fix spelling of `message-insert-formated-citation-line'. 2007-11-03 Reiner Steib * gnus-sum.el (gnus-summary-highlight): Mark as risky local variable. 2007-11-02 Katsumi Yamaoka * nnml.el (nnml-request-rename-group): Bind file-name-coding-system to nnmail-pathname-coding-system. * gnus-group.el (gnus-group-rename-group): Encode non-ASCII group name that a user enters; decode group names in messages. * gnus-msg.el (gnus-inews-do-gcc): Encode non-ASCII group names. 2007-11-01 Reiner Steib * mm-util.el (mm-charset-eval-alist): Mark as risky local variable. * gnus.el (gnus-group-charter-alist): Mark as risky local variable. * gnus-art.el (gnus-button-alist, gnus-header-button-alist): Mark as risky local variable. * gnus-group.el (gnus-group-icon-list): Mark as risky local variable. 2007-11-01 Teodor Zlatanov * encrypt.el: Improve documentation to fix function name typo. Reported by Daiki Ueno . 2007-11-01 Katsumi Yamaoka * gnus-art.el (gnus-article-next-page): Honor gnus-article-over-scroll even if the point is not in the last page of an article. (gnus-article-prev-page): Honor gnus-article-over-scroll when moving back to the previous page. 2007-10-30 Reiner Steib * qp.el (quoted-printable-decode-string): Fix typo in doc string. 2007-10-30 Katsumi Yamaoka * gnus-ems.el (gnus-x-splash): Work even if there's no scroll bar. 2007-10-29 Stefan Monnier * message.el (message-check-news-body-syntax): Avoid mm-string-as-multibyte. (message-hide-headers): Don't assume (point-min)==1. 2007-10-28 Reiner Steib * message.el (message-remove-blank-cited-lines): Fix if remove is given. (message-bogus-address-regexp): New variable. (message-bogus-recipient-p): New function. (message-check-recipients): New command. (message-syntax-checks): Add `bogus-recipient'. (message-fix-before-sending): Add `bogus-recipient'. * gnus-art.el (gnus-button-mid-or-mail-heuristic-alist): Add "alpine". (gnus-treat-body-boundary): Don't test window-system. 2007-10-28 Leo (tiny change) * gnus-art.el (gnus-treat-emphasize): Don't test window-system. 2007-10-28 Miles Bader * nnheader.el (nnheader-uniquify-message-id): Make sure this is defined at compile-time too. 2007-10-27 Reiner Steib * gnus-msg.el (gnus-message-setup-hook): Add `message-remove-blank-cited-lines' to options. 2007-10-26 Reiner Steib * message.el (message-remove-blank-cited-lines): New function. Suggested by Karl Plästerer. 2007-10-25 Katsumi Yamaoka * hashcash.el (mail-add-payment): Replace mapcar called for effect with mapc. * imap.el (imap-open): Replace mapcar called for effect with mapc. (top-level): Use mapc to set functions to be traced for debugging. * legacy-gnus-agent.el (gnus-agent-convert-agentview): Replace mapcar called for effect with while loop. * message.el (message-talkative-question): Replace mapcar called for effect with mapc. * mm-util.el: Use mapc instead of mapcar to make compatible functions. (mm-find-mime-charset-region, mm-find-charset-region): Replace mapcar called for effect with dolist. * mml.el (mml-insert-mime): Replace mapcar called for effect with mapc. * nndiary.el: Use dolist instead of mapcar to add diary headers to gnus-extra-headers and nnmail-extra-headers. * nnimap.el (nnimap-request-update-info-internal): Replace mapcar called for effect with dolist. (top-level): Use mapc to set functions to be traced for debugging. * nnmail.el (nnmail-read-incoming-hook): Doc fix. (nnmail-split-fancy-with-parent): Replace mapcar called for effect with dolist. * nnmaildir.el (nnmaildir--delete-dir-files, nnmaildir-request-close): Replace mapcar called for effect with mapc. (nnmaildir--scan, nnmaildir-request-scan, nnmaildir-retrieve-groups) (nnmaildir-request-update-info, nnmaildir-request-delete-group) (nnmaildir-retrieve-headers, nnmaildir-request-set-mark) (nnmaildir-close-group): Replace mapcar called for effect with dolist. * nnrss.el (nnrss-make-hash-index): Use gnus-remove-if instead of remove-if that's a cl function. * webmail.el (webmail-debug): Replace mapcar called for effect with dolist. * gnus-xmas.el (gnus-group-add-icon): Replace mapcar called for effect with mapc. 2007-10-24 Katsumi Yamaoka * gnus-agent.el (gnus-agent-read-agentview, gnus-agent-save-alist) (gnus-agent-expire-unagentized-dirs): Replace mapcar called for effect with while loop. * gnus-art.el: Use mapc instead of mapcar to make gnus-article-* functions from article-* functions. (gnus-multi-decode-header): Replace mapcar called for effect with dolist. * gnus-bookmark.el (gnus-bookmark-bmenu-list) (gnus-bookmark-show-details): Replace mapcar called for effect with while loop. * gnus-diary.el (gnus-diary-update-group-parameters): Replace mapcar called for effect with while loop. * gnus-group.el (gnus-group-suspend): Replace mapcar called for effect with dolist. * gnus-registry.el (gnus-registry-split-fancy-with-parent): Replace mapcar called for effect with dolist. * gnus-spec.el (gnus-correct-length): Make it simple and fast. * gnus-sum.el (gnus-multi-decode-encoded-word-string) (gnus-build-sparse-threads, gnus-summary-limit-include-expunged): Replace mapcar called for effect with dolist. (gnus-simplify-buffer-fuzzy): Replace mapcar called for effect with mapc. * gnus-topic.el (gnus-topic-find-groups, gnus-topic-move-group): Replace mapcar called for effect with dolist. (gnus-topic-list): Replace mapcar called for effect with mapc. * gnus.el: Use mapc instead of mapcar to add autoloads. 2007-10-23 Richard Stallman * gnus-group.el (gnus-group-highlight): Mark as risky. 2007-10-23 Katsumi Yamaoka * gnus.el (gnus-server-to-method): Return method found first in gnus-newsrc-alist. * gnus-art.el (gnus-article-highlight-signature) (gnus-insert-prev-page-button, gnus-insert-next-page-button): Make a button overlay without the front stickiness. 2007-10-22 Kevin Greiner * gnus-agent.el (gnus-agent-expire-group-1): The check for an unsorted overview buffer needed a catch to receive its throw. (gnus-agent-flush-cache): Declared as interactive to make this function easier to use. 2007-10-20 Reiner Steib * html2text.el (html2text-fix-paragraph): Use `forward-line' instead of `next-line'. 2007-10-18 Katsumi Yamaoka * nnmail.el (nnmail-fancy-expiry-target): Use rmail-dont-reply-to to exclude address matching message-dont-reply-to-names. 2007-10-15 Katsumi Yamaoka * gnus-util.el (gnus-string<): New function. * gnus-sum.el (gnus-article-sort-by-author) (gnus-article-sort-by-recipient, gnus-article-sort-by-subject): Use it. 2007-10-15 Katsumi Yamaoka * gnus-win.el (gnus-configure-windows): Focus on the frame for which the frame-focus tag is set in gnus-buffer-configuration. 2007-10-12 Katsumi Yamaoka * gnus-art.el (gnus-article-add-button): Make a button overlay without the front stickiness. 2007-10-11 Katsumi Yamaoka * gnus-art.el (gnus-button-alist): Exclude newline in RFC2396-compliant url pattern; remove duplicate one. (gnus-article-extend-url-button): New function. (gnus-article-add-buttons): Use it. (gnus-button-push): Use concatenated url that it makes. 2007-10-04 Juanma Barranquero * sieve-manage.el (sieve-manage-interactive-login): Doc fix. 2007-10-02 Stefan Monnier * gnus-uu.el (gnus-uu-reginize-string, gnus-uu-expand-numbers): Don't hardcode point-min==1. 2007-10-08 Reiner Steib * mm-util.el (mm-charset-synonym-alist): Alias gbk to cp936. Fix comment about "iso8859-1". 2007-10-08 Daiki Ueno * mm-decode.el (mm-possibly-verify-or-decrypt): Replace PARTS with the ones returned from the verify-function. * mm-uu.el (mm-uu-pgp-signed-extract-1): Call mml2015-extract-cleartext-signature if extraction failed. 2007-10-07 Daiki Ueno * mm-uu.el (mm-uu-pgp-signed-extract-1): Delete the first line beginning with "-----BEGIN PGP SIGNED MESSAGE-----" if extraction failed. 2007-10-04 Reiner Steib * Relicense "GPLv2 or later" files to "GPLv3 or later". 2007-10-03 Reiner Steib * pgg.el, pgg-def.el, pgg-gpg.el: Revert to the version in v5-10. The trunk version of PGG was unmaintained. The author of PGG, Daiki Ueno, recommends to use EasyPG instead of PGG. * pgg.el: Revert to revision 6.23.2.16 * pgg-def.el: Revert to revision 6.6.2.14. * pgg-gpg.el: Revert to revision 6.23.2.34. 2007-09-27 Teodor Zlatanov * gnus-sum.el (gnus-summary-kill-thread): Allow universal prefix zero to mark a thread as expirable. Add variable `hide' to handle hiding of thread for both the null and zero (kill/expire thread) universal prefix cases. (gnus-summary-expire-thread): Add new function to expire a thread, using gnus-summary-kill-thread. (gnus-summary-mode-map, gnus-summary-thread-map): Add 'M-C-e' and 'T e' shortcuts for gnus-summary-expire-thread. (gnus-summary-mode-map, gnus-summary-thread-map): Remove `M-C-e' and `T e' bindings for gnus-summary-expire-thread. Add `T E' binding. 2007-09-25 Teodor Zlatanov * gnus-registry.el (gnus-registry-store-extra-entry): Allow for nil extras value, so an extras entry can be deleted. (gnus-registry-delete-extra-entry): Use it. (gnus-registry-fetch-extra-flags, gnus-registry-has-extra-flag) (gnus-registry-store-extra-flags, gnus-registry-delete-extra-flags) (gnus-registry-delete-all-extra-flags): Allow for arbitrary flag symbol storage through the gnus-registry, and provide an appropriate API for it. 2007-09-13 Katsumi Yamaoka * gnus-sum.el (gnus-newsgroup-maximum-articles): Move from gnus.el. Suggested by Leo . * gnus.el: Do. 2007-09-13 Katsumi Yamaoka * gnus.el (gnus-newsgroup-maximum-articles): Rename from gnus-maximum-newsgroup. Suggested by Leo . * gnus-agent.el (gnus-agent-fetch-headers): Do. * gnus-sum.el (gnus-articles-to-read, gnus-list-of-unread-articles) (gnus-list-of-read-articles, gnus-sequence-of-unread-articles): Do. 2007-09-13 Katsumi Yamaoka * nnmbox.el (nnmbox-request-article): Don't assume delim regexp matches newline. (nnmbox-request-accept-article): Don't change article in source buffer; narrow to header to use message-fetch-field rather than nnmail-fetch-field; use with-current-buffer instead of save-excursion. (nnmbox-request-replace-article): Quote lines that'll be misidentified as delimiters; make sure article ends with newline. (nnmbox-delete-mail): Correct last position of article to be deleted; ignore X-Gnus-Newsgroup header in article body. (nnmbox-save-mail): Quote lines looking like delimiters at the right positions; make sure article ends with newline. * message.el (message-display-abbrev): Don't infloop when a user inserts SPC in the beginning of header. * lpath.el: Don't bind define-ccl-program for non-Mule XEmacs; bind coding-system-for-read and coding-system-for-write for XEmacs having no file-coding feature. * dgnushack.el: Bind or autoload define-ccl-program for XEmacs. 2007-09-12 Teodor Zlatanov * gnus-registry.el (gnus-registry-unfollowed-groups): Add INBOX to the list of groups not followed by default. Fix type to be regexp. (gnus-registry-grep-in-list): Fix inverted parameters to string-match. 2007-09-06 Tassilo Horn * hmac-def.el (define-hmac-function): Switch from old-style to new-style backquotes. * md4.el (md4-make-step): Likewise. 2007-09-06 Katsumi Yamaoka * gnus-start.el (gnus-gnus-to-newsrc-format): Use a unibyte buffer and raw-text coding system when saving .newsrc file, which may contain non-ASCII group names. 2007-09-05 Katsumi Yamaoka * gnus-cus.el (gnus-score-extra): New widget. (gnus-score-extra-convert): New function. (gnus-score-customize): Use it for Extra. 2007-08-31 Daiki Ueno * mml2015.el (mml2015-extract-cleartext-signature): New function. (mml2015-mailcrypt-clear-verify): Use it. (mml2015-gpg-clear-verify): Use it. (mml2015-pgg-clear-verify): Use it. (mml2015-epg-clear-verify): Replace the current part with the output from GnuPG; don't extract the plaintext by itself. * mm-uu.el (mm-uu-pgp-beginning-signature): Abolish. (mm-uu-pgp-signed-extract-1): Bind coding-system-for-read when calling mml2015-clear-verify-function; don't touch the armor headers or dash-escaped text here. 2007-08-24 Katsumi Yamaoka * gnus-art.el (gnus-article-edit-part): Don't jump to nonexistent part. (gnus-mime-view-part-as-type-internal): Default to text/plain for text parts, or application/octet-stream as a last resort. (gnus-mime-view-part-as-type): Don't toggle display. (gnus-mime-view-part-as-charset): Don't turn off display before querying charset. * mm-view.el (mm-inline-text-html-render-with-w3): Don't add XEmacs stuff to undisplayer function in Emacs. (mm-inline-text-html-render-with-w3m): Remove Emacs/W3 stuff. * mml.el (mml-generate-mime-1): Prefer utf-8 when encoding text/calendar parts. 2007-08-23 Katsumi Yamaoka * gnus-art.el (gnus-mime-display-single): Use utf-8 by default for decoding text/calendar parts. * message.el (message-forward-make-body-mime): Always mark body as having no illegible text; remove signed-or-encrypted argument. (message-forward-make-body): Don't pass signed-or-encrypted arg to it. * mml.el (mml-generate-mime): Make sure it uses multibyte temp buffer. (mml-generate-mime-1): Don't encode body if it is specified to be in raw form; don't make buffer be unibyte when inserting multibyte string. 2007-08-23 Stefan Monnier * sha1.el: Fix up comment style. (sha1-F0, sha1-F1, sha1-F2, sha1-F3, sha1-S1, sha1-S5, sha1-S30) (sha1-OP, sha1-add-to-H): Use new-style backquotes. * hex-util.el: Fix up comment style. (hex-char-to-num, num-to-hex-char): Use new-style backquotes. * gnus-salt.el: Use with-current-buffer. (gnus-pick-setup-message): Fix long-standing typo. 2007-08-17 Katsumi Yamaoka * imap.el (imap-logout-timeout): New variable. (imap-logout, imap-logout-wait): New functions. (imap-kerberos4-open, imap-gssapi-open, imap-close): Use them. * nnimap.el (nnimap-logout-timeout): New server variable. (nnimap-open-server, nnimap-close-server): Bind imap-logout-timeout to nnimap-logout-timeout. * gnus-art.el (gnus-article-summary-command-nosave) (gnus-article-read-summary-keys): Don't use 3rd arg of pop-to-buffer. 2007-08-14 Katsumi Yamaoka * gnus.el (gnus-maximum-newsgroup): New variable. * gnus-agent.el (gnus-agent-fetch-headers): Limit the range of articles according to gnus-maximum-newsgroup. * gnus-sum.el (gnus-articles-to-read, gnus-list-of-unread-articles) (gnus-list-of-read-articles, gnus-sequence-of-unread-articles): Limit the range of articles according to gnus-maximum-newsgroup. 2007-08-14 Tassilo Horn * gnus-art.el (gnus-sticky-article): Fixed problems described in on ding. Thanks to Katsumi. Don't perform gnus-configure-windows here; reuse existing sticky article buffer. * gnus-sum.el (gnus-summary-display-article): Setup article buffer if it doesn't exist in gnus-article-mode. 2007-08-13 Katsumi Yamaoka * gnus-agent.el (gnus-agent-decoded-group-names): New variable. (gnus-agent-decoded-group-name): New function. (gnus-agent-group-path, gnus-agent-group-pathname): Use it. (gnus-agent-expire-group-1): Use it; decode group name in messages. 2007-08-12 Tassilo Horn * gnus-sum.el (gnus-summary-article-map, gnus-summary-make-menu-bar): Add binding for gnus-sticky-article. (gnus-summary-exit): Don't kill sticky article buffers. * gnus-art.el (gnus-sticky-article-mode): New mode to generate a sticky article buffer. (gnus-sticky-article, gnus-kill-sticky-article-buffer) (gnus-kill-sticky-article-buffers): New commands. 2007-08-10 Katsumi Yamaoka * nntp.el (nntp-xref-number-is-evil): New server variable. (nntp-find-group-and-number): If it is non-nil, don't trust article numbers in the Xref header. 2007-08-09 Katsumi Yamaoka * gnus-agent.el (gnus-agent-read-group): New function. (gnus-agent-flush-group, gnus-agent-expire-group) (gnus-agent-regenerate-group): Use it. (gnus-agent-expire-unagentized-dirs): Bind file-name-coding-system to nnmail-pathname-coding-system. 2007-08-06 Katsumi Yamaoka * gnus-ems.el (gnus-x-splash): Bind inhibit-read-only to t. * gnus-sum.el (gnus-summary-insert-articles): Mark inserted articles that are unread as unread, and also as selected so that information of marks having been changed by a user may be updated when exiting group. 2007-08-03 Katsumi Yamaoka * gnus-art.el (gnus-mime-display-single): Pass part number that is calculated ignoring signature parts to gnus-treat-article. 2007-08-02 Katsumi Yamaoka * gnus-art.el (gnus-mime-security-verify-or-decrypt): Don't narrow to a point here in order to keep the window start. (gnus-insert-mime-security-button): Make a button overlay without the front stickiness. (gnus-mime-display-security): Goto the end of a button. * gnus-group.el (gnus-group-name-at-point): Fix regexps. 2007-08-01 Katsumi Yamaoka * gnus-group.el (gnus-group-name-at-point): Rewrite; rename from group-name-at-point. (gnus-group-completing-read): New function that offers decoded non-ASCII group names for completion. (gnus-fetch-group, gnus-group-read-ephemeral-group) (gnus-group-jump-to-group, gnus-group-make-group-simple) (gnus-group-unsubscribe-group, gnus-group-fetch-charter) (gnus-group-fetch-control): Use it. (gnus-fetch-group): Use group-name-at-point for the initial value rather than the default value; use gnus-alive-p. * gnus-msg.el (gnus-group-mail, gnus-group-news, gnus-group-post-news) (gnus-summary-mail-other-window, gnus-summary-news-other-window) (gnus-summary-post-news): Use gnus-group-completing-read. * gnus-sum.el (gnus-select-newsgroup): Decode group name in error msg. (gnus-read-move-group-name): Decode group name for completion. 2007-07-31 Ted Zlatanov * gnus-srvr.el (gnus-server-close-all-servers): Close servers not only in gnus-inserted-opened-servers but also in gnus-server-alist (Katsumi Yamaoka slightly modified the code). 2007-07-24 Katsumi Yamaoka * nnmail.el (nnmail-group-names-not-encoded-p): New variable. (nnmail-split-incoming): Bind it. * nnml.el (nnml-group-name-charset): New function. (nnml-decoded-group-name): Use it; don't decode group name if nnmail-group-names-not-encoded-p is non-nil. (nnml-encoded-group-name): New function. (nnml-group-pathname): Inline nnml-decoded-group-name. (nnml-request-expire-articles): Decode group name in message. (nnml-request-delete-group): Ditto; bind file-name-coding-system to nnmail-pathname-coding-system. (nnml-save-mail, nnml-active-number): Work with decoded group names and not decoded ones according to nnmail-group-names-not-encoded-p. (nnml-generate-active-info): Use nnml-encoded-group-name. 2007-08-08 Glenn Morris * gmm-utils.el, gnus-async.el, gnus-msg.el, gnus-score.el * gnus-util.el, imap.el, mailcap.el, nnimap.el: Replace `iff' in doc-strings and comments. 2007-07-25 Glenn Morris * Relicense all FSF files to GPLv3 or later. 2007-07-23 Katsumi Yamaoka * gnus-sum.el (gnus-summary-move-article): Make gnus-summary-respool-article work. 2007-07-21 Reiner Steib * mm-uu.el (mm-uu-type-alist): Refer to mm-uu-configure-list in doc string. 2007-07-20 Michaël Cadilhac * nnrss.el (nnrss-ignore-article-fields): New variable. List of fields that should be ignored when comparing distant RSS articles with local ones. (nnrss-make-hash-index): New function. Create a hash index according to the ignored fields. (nnrss-check-group): Use it. 2007-07-20 Katsumi Yamaoka * gnus-agent.el (gnus-agent-group-pathname): Take notice of the method. * gnus-art.el (article-decode-group-name): Decode Xref header too. * gnus-group.el (gnus-group-make-group): Encode group name here unless the new optional argument ENCODED is non-nil. (gnus-group-make-doc-group): Use gnus-group-name-charset to determine coding system for encoding group name. (gnus-group-make-rss-group): Pass un-encoded group name to gnus-group-make-group. (gnus-group-set-info): Tell gnus-group-make-group that group name is encoded. * gnus-sum.el (gnus-summary-move-article, gnus-read-move-group-name): Encode group name to which articles are moved or copied. (gnus-summary-edit-article): Use gnus-group-name-charset to determine coding system for encoding Newsgroup, Followup-To and Xref headers. * nnagent.el (nnagent-request-set-mark): Use unibyte buffer to compose marks; use nnheader-file-coding-system to write a file. (nnagent-retrieve-headers): Bind file-name-coding-system to nnmail-pathname-coding-system. * nnmail.el (nnmail-insert-xref): Don't break non-ASCII group name. * nnml.el (nnml-decoded-group-name, nnml-group-pathname): New functions. (nnml-request-article, nnml-request-create-group) (nnml-request-rename-group, nnml-find-id) (nnml-possibly-change-directory, nnml-possibly-create-directory) (nnml-save-mail, nnml-active-number, nnml-marks-changed-p) (nnml-save-marks): Use nnml-group-pathname instead of nnmail-group-pathname. (nnml-request-create-group, nnml-request-expire-articles) (nnml-request-move-article, nnml-request-delete-group) (nnml-deletable-article-p, nnml-possibly-create-directory) (nnml-get-nov-buffer, nnml-generate-nov-databases-directory) (nnml-open-marks): Bind file-name-coding-system to nnmail-pathname-coding-system. (nnml-request-article): Pass server argument to nnml-find-group-number. (nnml-request-create-group, nnml-active-number, nnml-save-marks): Pass server argument to nnml-possibly-create-directory. (nnml-request-accept-article): Pass server argument to nnml-active-number and nnml-save-mail. (nnml-find-group-number): Pass server argument to nnml-find-id. (nnml-request-update-info): Pass server argument to nnml-marks-changed-p. (nnml-find-id, nnml-find-group-number, nnml-possibly-create-directory) (nnml-save-mail, nnml-active-number): Add server argument. (nnml-request-delete-group): Warn if group is missing. (nnml-get-nov-buffer): Decode group name. (nnml-generate-active-info): Encode group name. (nnml-open-marks): Decode group name in messages. 2007-07-19 Katsumi Yamaoka * gnus-art.el (gnus-article-part-wrapper): Work with the nearest part if it is not specified. (gnus-article-pipe-part, gnus-article-save-part) (gnus-article-interactively-view-part, gnus-article-copy-part) (gnus-article-view-part-as-charset, gnus-article-view-part-externally) (gnus-article-inline-part, gnus-article-save-part-and-strip) (gnus-article-replace-part, gnus-article-delete-part) (gnus-article-view-part-as-type): Pass raw prefix argument to gnus-article-part-wrapper. 2007-07-18 Katsumi Yamaoka * gnus-agent.el (gnus-agent-save-active): Bind nnheader-file-coding-system to gnus-agent-file-coding-system. * gnus-cache.el (gnus-cache-save-buffers) (gnus-cache-possibly-enter-article, gnus-cache-request-article) (gnus-cache-retrieve-headers, gnus-cache-change-buffer) (gnus-cache-possibly-remove-article, gnus-cache-articles-in-group) (gnus-cache-braid-nov, gnus-cache-braid-heads) (gnus-cache-generate-active, gnus-cache-rename-group) (gnus-cache-delete-group, gnus-cache-update-file-total-fetched-for) (gnus-cache-update-overview-total-fetched-for): Bind file-name-coding-system to nnmail-pathname-coding-system. (gnus-cache-decoded-group-names, gnus-cache-unified-group-names): New variables. (gnus-cache-decoded-group-name): New function. (gnus-cache-file-name): Use it. (gnus-cache-generate-active): Use non-decoded group name for active. * gnus-util.el (gnus-write-buffer): Bind file-name-coding-system at the right place. (gnus-write-active-file): Don't break non-ASCII group names. * nntp.el (nntp-marks-changed-p): Bind file-name-coding-system to nnmail-pathname-coding-system. * lpath.el: Bind default-file-name-coding-system, file-name-coding-system and language-info-alist for XEmacs. * gnus-uu.el (gnus-uu-decode-save): Typo. 2007-07-16 Katsumi Yamaoka * gnus-srvr.el (gnus-server-font-lock-keywords): Quote faces. 2007-07-13 Katsumi Yamaoka * gnus-agent.el (gnus-agent-rename-group, gnus-agent-delete-group) (gnus-agent-fetch-articles, gnus-agent-unfetch-articles) (gnus-agent-crosspost, gnus-agent-backup-overview-buffer) (gnus-agent-flush-group, gnus-agent-flush-cache) (gnus-agent-fetch-headers, gnus-agent-load-alist) (gnus-agent-read-agentview, gnus-agent-expire-group-1) (gnus-agent-retrieve-headers, gnus-agent-request-article) (gnus-agent-regenerate-group) (gnus-agent-update-files-total-fetched-for) (gnus-agent-update-view-total-fetched-for): Bind file-name-coding-system to nnmail-pathname-coding-system. (gnus-agent-group-pathname): Don't encode file names by nnmail-pathname-coding-system. (gnus-agent-save-local): Bind file-name-coding-system correctly; bind coding-system-for-write instead of buffer-file-coding-system to gnus-agent-file-coding-system. * gnus-msg.el (gnus-inews-make-draft, gnus-inews-insert-archive-gcc): Decode group name. * gnus-srvr.el (gnus-browse-foreign-server): Make group names unibyte. * gnus-start.el (gnus-update-active-hashtb-from-killed) (gnus-read-newsrc-el-file): Make group names unibyte. * nnmail.el (nnmail-group-pathname): Don't encode file names by nnmail-pathname-coding-system. * nnrss.el (nnrss-file-coding-system): Doc fix; make it begin with *. (nnrss-request-delete-group): Bind file-name-coding-system to nnmail-pathname-coding-system. (nnrss-read-server-data, nnrss-read-group-data): Bind file-name-coding-system correctly. (nnrss-check-group): Pass nnrss-file-coding-system to md5. * nntp.el: Require gnus-group for the function gnus-group-name-charset. (nntp-server-to-method-cache): New variable. (nntp-group-pathname): New function that decodes non-ASCII group names. (nntp-possibly-create-directory, nntp-marks-changed-p) (nntp-save-marks, nntp-open-marks): Use it. (nntp-possibly-create-directory, nntp-open-marks): Bind file-name-coding-system to nnmail-pathname-coding-system. (nntp-open-marks): Decode group names when bootstrapping marks. * rfc2047.el (rfc2047-encode-message-header): Make XEmacs decode Newsgroups and Folowup-To headers. 2007-07-13 Katsumi Yamaoka * gnus-srvr.el (gnus-server-agent-face, gnus-server-opened-face) (gnus-server-closed-face, gnus-server-denied-face) (gnus-server-offline-face): Remove variable. (gnus-server-font-lock-keywords): Use faces that are not aliases. * gnus-util.el (gnus-message-with-timestamp-1): Use log-message instead of modifying message-stack directly for XEmacs. * mm-util.el (mm-decode-coding-string, mm-encode-coding-string) (mm-decode-coding-region, mm-encode-coding-region): Don't modify string if the coding-system argument is nil for XEmacs. * nnrss.el (nnrss-compatible-encoding-alist): Inherit the value of mm-charset-override-alist. * rfc2047.el: Don't require base64; require rfc2045 for the function rfc2045-encode-string. (rfc2047-encode-parameter): Use rfc2045-encode-string to quote or not to quote the parameter value. 2007-07-06 Katsumi Yamaoka * gnus-group.el (gnus-group-name-charset): Allow a method of the short form in gnus-group-name-charset-method-alist. * gnus-eform.el (gnus-edit-form): Add optional argument layout which overrides the default layout edit-form. * gnus-win.el (gnus-buffer-configuration): Add edit-server. * gnus-srvr.el (gnus-server-edit-server): Use edit-server layout. 2007-07-04 Katsumi Yamaoka * gnus-sum.el (gnus-summary-catchup): Don't recognize cached articles as unfetched articles. 2007-07-02 Reiner Steib * gnus-start.el (gnus-level-unsubscribed): Improve doc string. 2007-07-02 Katsumi Yamaoka * nnagent.el (nnagent-request-set-mark): Also set the marks for the original back end that keeps marks in the local system. 2007-06-26 Katsumi Yamaoka * gnus-art.el (gnus-article-summary-command-nosave): Don't set the 3rd arg of pop-to-buffer for XEmacs. (gnus-article-read-summary-keys): Ditto; don't restore window configuration if summary command ends up with neither article buffer nor summary buffer; describe bindings if summary keys end with C-h. 2007-06-22 Katsumi Yamaoka * message.el (message-fix-before-sending): Skip raw message part to be forwarded while checking illegible text. (message-forward-make-body-mime, message-forward-make-body): Mark signed or encrypted raw message as having no illegible text. 2007-06-19 Katsumi Yamaoka * gnus-util.el (gnus-add-timestamp-to-message): New user option. (gnus-message-with-timestamp-1): New macro. (gnus-message-with-timestamp): New function. (gnus-message): Use them. * nnheader.el (nnheader-message): Use them. 2007-06-16 Reiner Steib * gnus-start.el (gnus-gnus-to-quick-newsrc-format): Add newlines to .newsrc.eld file. 2007-06-14 Katsumi Yamaoka * gnus-agent.el (gnus-agent-fetch-headers) (gnus-agent-retrieve-headers): Bind gnus-decode-encoded-address-function to identity. * nntp.el (nntp-send-xover-command): Recognize an xover command is available also when the server returns simply a dot. * gnus-ems.el (gnus-x-splash): Redisplay window before measuring it. 2007-06-08 Katsumi Yamaoka * gnus-ems.el (gnus-x-splash): Fix calculation; error in tty. 2007-06-07 Katsumi Yamaoka * gnus-ems.el (gnus-x-splash): Make it work. * gnus-start.el (gnus-1): Relax restrictions that prevent gnus-x-splash from being used. * lpath.el: Bind line-spacing and tool-bar-mode for XEmacs. 2007-06-05 Katsumi Yamaoka * gnus-xmas.el (gnus-xmas-define): Make gnus-make-overlay ignore the 4th and the 5th arguments. * gnus-art.el (gnus-insert-mime-button): Make a button overlay without the front stickiness. (gnus-article-summary-command-nosave): Correct the order of the arguments passed to pop-to-buffer. (gnus-article-read-summary-keys): Ditto; make it work properly when the summary command ends up with the article buffer. * mm-decode.el (mm-insert-part): Separate the extracted parts that have the same faces. 2007-06-07 Juanma Barranquero * gnus-art.el (gnus-split-methods): Fix typo in docstring. 2007-06-06 Juanma Barranquero * gnus-diary.el (gnus-diary-time-format, gnus-summary-sort-by-schedule): * gnus-sum.el (gnus-summary-highlight): * pgg.el (pgg-sign-region, pgg-sign): * mail-source.el (mail-source-delete-old-incoming-confirm): * nndiary.el (nndiary-reminders): Fix typos in docstrings. 2007-06-04 Katsumi Yamaoka * gnus-art.el (gnus-mime-view-part-externally) (gnus-mime-view-part-internally): Fix predicate function passed to completing-read. * mm-decode.el (mm-image-fit-p): Return t if argument is not an image. * gnus.el (gnus-update-message-archive-method): Add :version. 2007-06-01 Katsumi Yamaoka * gnus.el (gnus-update-message-archive-method): New variable. * gnus-start.el (gnus-setup-news): Update saved "archive" method according to gnus-message-archive-method if gnus-update-message-archive-method is non-nil. 2007-05-29 Katsumi Yamaoka * gnus-sum.el (gnus-summary-limit-to-address): New function. Suggested by Loic Dachary . (gnus-summary-limit-map, gnus-summary-make-menu-bar): Add it. 2007-05-28 Katsumi Yamaoka * message.el (message-pop-to-buffer): Add switch-function argument. (message-mail): Pass switch-function argument to it. 2007-05-25 Reiner Steib * mm-decode.el (mm-file-name-rewrite-functions): Make it customizable. Improve doc string. 2007-05-25 Katsumi Yamaoka * gnus-art.el (gnus-header-from, gnus-header-subject, gnus-header-name) (gnus-header-content) * gnus-cite.el (gnus-cite-10) * gnus-srvr.el (gnus-server-closed) * gnus.el (gnus-group-mail-1, gnus-group-mail-1-empty) (gnus-group-mail-2, gnus-group-mail-2-empty, gnus-group-mail-3) (gnus-group-mail-3-empty, gnus-group-mail-low) (gnus-group-mail-low-empty, gnus-splash) * message.el (message-header-to, message-header-cc) (message-header-subject, message-header-other, message-header-name) (message-header-xheader, message-separator, message-cited-text) (message-mml): Lighten colors of faces used for dark background. 2007-05-24 Simon Josefsson * nnimap.el (nnimap-need-unselect-to-notice-new-mail): Change default to t as an experiment. Suggested by Greg Troxel . 2007-05-24 Katsumi Yamaoka * message.el (message-narrow-to-headers-or-head): Ignore mail-header-separator in the body. 2007-05-23 Katsumi Yamaoka * mm-decode.el (mm-image-fit-p): Return t if image size is just the same as window size. 2007-05-22 Kevin Ryde * message.el (message-font-lock-keywords): Use message-header-xheader face for "X-Foo", its apparent intended purpose. Move "X-" pattern ahead of the anything pattern, to get it recognised. 2007-05-22 Katsumi Yamaoka * dgnushack.el: Autoload ad-add-advice for XEmacs. bbdb-com.el that spam.el loads uses it in the compiled defadvice form. 2007-05-12 Michaël Cadilhac * gnus-sum.el (gnus-articles-to-read) (gnus-summary-insert-old-articles): Don't truncate group name for `read-string'. * gnus-util.el (gnus-limit-string): Delete this function. * gnus-sum.el (gnus-simplify-subject-fully): Use `truncate-string-to-width' instead. 2007-05-11 Michaël Cadilhac * gnus-sum.el (gnus-summary-next-group-on-exit): New variable. Tell if, on summary exit, the next group has to be selected. (gnus-summary-exit): Use it. 2007-05-10 Reiner Steib * gnus-art.el (gnus-article-mode): Fix comment about displaying non-break space. 2007-05-10 Katsumi Yamaoka * nnfolder.el (nnfolder-request-group, nnfolder-request-create-group): Check if group is not a directory. (nnfolder-request-expire-articles): Don't delete articles if the target group is not available. * nnml.el (nnml-request-create-group): Properly check if group is not a file. (nnml-request-expire-articles): Don't delete articles if the target group is not available. * rfc2047.el (rfc2047-quote-special-characters-in-quoted-strings): Don't quote characters that are within parentheses. 2007-05-09 Katsumi Yamaoka * gnus-sum.el (gnus-auto-select-on-ephemeral-exit): New variable. (gnus-handle-ephemeral-exit): Select article according to it. 2007-05-08 Reiner Steib * message.el (message-insert-formated-citation-line): Remove newline. (message-citation-line-format): Add final \n here so that the user can avoid a blank line. 2007-05-03 Dan Christensen * nndoc.el (nndoc-type-alist, nndoc-lanl-gov-announce-type-p) (nndoc-transform-lanl-gov-announce, nndoc-generate-lanl-gov-head): Update lanl/arXiv support. 2007-05-02 Reiner Steib * gnus.el: Bump version number. 2007-05-01 Lars Magne Ingebrigtsen * gnus.el (gnus-version-number): Bump version. 2007-05-01 Lars Magne Ingebrigtsen * gnus.el: No Gnus v0.6 is released. 2007-04-27 Didier Verna * gnus-util.el (gnus-orify-regexp): Moved and renamed to ... * gmm-utils.el (gmm-regexp-concat): here. * message.el: Don't require 'gnus-util. (message-dont-reply-to-names): Handle name change above. * gnus-sum.el (gnus-ignored-from-addresses): Ditto. 2007-04-26 Katsumi Yamaoka * mm-util.el (mm-charset-synonym-alist): Don't make it a user option since the initial value varies according to the system. 2007-04-25 Katsumi Yamaoka * mm-util.el (mm-charset-synonym-alist): Defcustom. 2007-04-25 NAKAJI Hiroyuki (tiny change) * mm-util.el (mm-charset-synonym-alist): Map iso8859-1 to iso-8859-1. 2007-04-24 Didier Verna Improve the type of gnus-ignored-from-addresses. * gnus-util.el (gnus-orify-regexp): New function. * message.el (gnus-util): Require it. * message.el (message-dont-reply-to-names): Use gnus-orify-regexp. * gnus-sum.el (gnus-ignored-from-addresses): New function. * gnus-sum.el (gnus-summary-from-or-to-or-newsgroups): Use it. 2007-04-24 Didier Verna * gnus-sum.el: * gnus-utils.el: Fix some trailing whitespaces. 2007-04-23 Katsumi Yamaoka * gnus-msg.el (gnus-summary-resend-message-edit): Add Gcc header. (gnus-summary-resend-bounced-mail): Ditto; search whole body for parent article's Message-ID; refer parent article in summary buffer. * message.el (message-bounce): Call mime-to-mml. * dgnushack.el (byte-optimize-form-code-walker): Fix the form which was not helpful to Emacs 21.1 and 21.2 for detecting a bug that does not optimize and/or forms properly. 2007-04-22 Reiner Steib * dgnushack.el (with-syntax-table): XEmacs bug has been fixed. Add URL. 2007-04-20 Katsumi Yamaoka * gnus-msg.el (gnus-summary-supersede-article): Add Gcc header. 2007-04-19 Katsumi Yamaoka * gnus-art.el (gnus-mime-strip-charset-parameters): New function. (gnus-mime-view-part-as-charset): Use it; redisplay subpart currently displayed of multipart/alternative part if it is invoked from summary buffer. * mm-view.el (mm-inline-text-html-render-with-w3m) (mm-inline-text-html-render-with-w3m-standalone) (mm-inline-render-with-function): Use mail-parse-charset by default. 2007-04-18 Levin Du (tiny change) * parse-time.el (parse-time-string-chars): Check if CHAR is less than the length of parse-time-syntax. 2007-04-17 Katsumi Yamaoka * gnus-uu.el (gnus-uu-digest-mail-forward): Pull articles processed from gnus-newsgroup-processable. 2007-04-16 Didier Verna * gnus-msg.el (gnus-configure-posting-styles): Handle message-signature-directory properly with :file syntax. Reported by "Leo". 2007-04-11 Didier Verna New user option: message-signature-directory. * gnus-msg.el (gnus-configure-posting-styles): Support it. * message.el (message-insert-signature): Ditto. * message.el (message-signature-file): Doc update. * message.el (message-signature-directory): New. 2007-04-10 Katsumi Yamaoka * gnus-msg.el (gnus-inews-yank-articles): Use message-exchange-point-and-mark instead of exchange-point-and-mark. 2007-04-09 Katsumi Yamaoka * message.el (message-yank-original): Make sure cited text ends with newline; don't exchange point and mark. 2007-04-07 Chong Yidong * tls.el (open-tls-stream): Properly handle case where there is no associated buffer. 2007-04-03 Thien-Thi Nguyen * gnus-msg.el (gnus-inews-yank-articles): Fix bug: After message-yank-original, make sure (< mark TEXT point). 2007-03-31 Reiner Steib * message.el (message-fill-column): New variable. (message-mode): Use it. Add comment on a possible new hook. * nnmail.el (nnmail-spool-file): Mark as obsolete. (nnmail-get-new-mail): Reformat. * gnus-registry.el (gnus-registry-cache-save): Add FIXME comment. * gmm-utils.el: Fix Commentary. (gmm-tool-bar-from-list): Fix typo in doc string. 2007-03-27 Thien-Thi Nguyen * message.el (message-yank-original): Don't switch point and mark unnecessarily to put point and mark as documented. 2007-03-27 Lars Magne Ingebrigtsen * message.el (message-put-addresses-in-ecomplete): Only fetch headers from the message heads. 2007-03-25 Kevin Greiner * gnus-art.el (gnus-article-set-window-start): Do nothing when the article buffer does not have a window. This may not be the best solution but is certainly better than setting the start of the null, that is the current, window. 2007-03-24 Reiner Steib * gnus-draft.el (gnus-draft-setup-hook): New hook. (gnus-draft-setup): Run it. * gnus-score.el (gnus-inhibit-slow-scoring): New variable, renamed from gnus-score-fast-scoring. Allow regexp. (gnus-score-headers): Use it. * gnus-util.el (gnus-emacs-version): Include "no MULE" in no-MULE XEmacs. * gnus-art.el (gnus-article-browse-html-article): Fix typo in doc string. (gnus-button-alist): Also catch ` k ...'. (gnus-treat-display-x-face): Fix doc string. 2007-03-25 Andreas Seltenreich * gnus-msg.el (gnus-setup-message, gnus-inews-add-send-actions): Move evaluation of gnus-extended-version to ensure correct generation of the User-Agent header when message-generate-headers-first is used. 2007-03-24 Simon Josefsson * hashcash.el (hashcash-generate-payment-async): Don't crash if hashcash-path is nil. Don't call callback with incorrect number of parameters if val is 0. 2007-03-20 Andreas Seltenreich * message.el (message-required-news-headers): * gnus-util.el (gnus-intern-safe): Fix typo in docstring. 2007-03-18 Thien-Thi Nguyen * tls.el (open-tls-stream): In handshake-waiting loop, don't wait more if there is output available to process. 2007-03-17 Thien-Thi Nguyen * tls.el (tls-program): Doc fix. 2007-03-15 Katsumi Yamaoka * message.el (message-generate-new-buffers): Change the meaning of the nil value; add `standard' to the choices; treat t as `unique'; improve doc string. (gnus-select-frame-set-input-focus): Autoload. (message-buffer-name): Search for the existing message buffer if message-generate-new-buffers is nil or `standard'; treat the value t of message-generate-new-buffers as `unique'. (message-pop-to-buffer): Raise the frame already displaying the message buffer; clear the echo area after querying. (message-setup): Pass the `continue' argument to compose-mail. (message-mail): Prefer `switch-function' if it is given; search for the existing message buffer if the `continue' argument is non-nil; pass continue and switch-function arguments to compose-mail by way of message-setup. (message-mail-other-window): Adjust argument of message-setup. (message-mail-other-frame): Ditto. 2007-03-13 Katsumi Yamaoka * gnus-cite.el (font-lock-set-defaults): Autoload it for Emacs. (gnus-message-citation-mode): Require font-lock for XEmacs; make sure to turn font-lock on when turning gnus-message-citation-mode on. 2007-03-06 Daiki Ueno * mml-smime.el (mml-smime-use): New variable; default to use openssl. (mml-smime-function-alist): New variable; add epg as the backend. * mml-sec.el (mml-smime-sign): Don't require mml-smime, autoload mml-smime- functions instead. * mm-view.el: Require smime. 2007-03-05 Didier Verna * gnus-topic.el (gnus-topic-hierarchical-parameters): Perform merging instead of just inheritance for posting styles. * gnus.el (gnus-group-fast-parameter): Fix typo in comment. 2007-02-24 Chris Moore * pgg-pgp5.el (pgg-pgp5-encrypt-region): * pgg-pgp.el (pgg-pgp-encrypt-region): * pgg-gpg.el (pgg-gpg-encrypt-region): Check pgg-encrypt-for-me if no other recipients. 2007-02-24 John Paul Wallington * tls.el (tls-certtool-program): Fix custom type. 2007-02-28 Katsumi Yamaoka * gnus-cite.el (gnus-message-search-citation-line): Use point-at-bol and point-at-eol instead of line-(beginning|end)-position. * assistant.el (assistant-parse-buffer): Ditto. * netrc.el (netrc-parse-services): Ditto. 2007-02-28 Daiki Ueno * mml2015.el (mml2015-epg-find-usable-key): New function. (mml2015-epg-sign): Use it. (mml2015-epg-encrypt): Use it. 2007-02-28 Katsumi Yamaoka * message.el (message-make-in-reply-to): Quote name containing non-ASCII characters. It will make the RFC2047 encoder cause an error if there are special characters. Reported by NAKAJI Hiroyuki . 2007-02-27 Didier Verna Include the group parameters as well as the topic ones in the inheritance filter process. * gnus-topic.el (gnus-topic-hierarchical-parameters): New optional argument GROUP-PARAMS-LIST. * gnus-topic.el (gnus-group-topic-parameters): Use it. 2007-02-27 Katsumi Yamaoka * nntp.el (nntp-never-echoes-commands) (nntp-open-connection-functions-never-echo-commands): New variables. (nntp-send-command): Use them. 2007-02-20 Daiki Ueno * mml2015.el (mml2015-epg-verify): Simplified. 2007-02-19 Katsumi Yamaoka * mml.el (mml-content-disposition-alist): New user option. (mml-content-disposition): New function. (mml-insert-mime-headers, mml-minibuffer-read-disposition): Use it. (mml-attach-file, mml-dnd-attach-file): Pass file name to it. 2007-02-19 Daiki Ueno * mml2015.el (mml2015-epg-verify): Convert LF to CRLF before signature verification. 2007-02-15 Andreas Seltenreich * nnweb.el (nnweb-google-parse-1): Fix date parsing to also match on articles posted in the last 24 hours. 2007-02-14 Chong Yidong * smiley.el (smiley-regexp-alist): Add "dead" smiley. 2007-02-14 Michaël Cadilhac * nntp.el (nntp-send-command): Don't wait for echoes when nntp-open-ssl-stream is used. 2007-02-13 Katsumi Yamaoka * gnus-cite.el (gnus-test-font-lock-add-keywords) (gnus-message-add-citation-keywords) (gnus-message-remove-citation-keywords): Remove. (gnus-message-citation-mode): Instead of modifying font-lock-keywords directly, make the variables in font-lock-defaults buffer-local, add gnus-message-citation-keywords to them and then update the value of font-lock-keywords. 2007-02-09 Katsumi Yamaoka * message.el (message-cite-original-1): Don't call gnus-article-highlight-citation. * gnus-cite.el (gnus-cite-parse): Work with two or more MS-type citations; fix line count. 2007-02-08 Katsumi Yamaoka * gnus-cite.el (gnus-test-font-lock-add-keywords): New function. (gnus-message-add-citation-keywords) (gnus-message-remove-citation-keywords): Use it; fix the emulating versions of font-lock-add-keywords and font-lock-remove-keywords to work with XEmacs correctly. 2007-02-07 Katsumi Yamaoka * gnus-cite.el (gnus-cite-face-list): Set the values of gnus-message-max-citation-depth and gnus-message-citation-keywords. (gnus-message-max-citation-depth): Use defvar rather than defconst. (gnus-message-cite-prefix-regexp): New variable. (gnus-message-search-citation-line): Use it; protect against long citation prefix; fill match data with nil rather than 0 for XEmacs; set the 0th match data for Emacs. (gnus-message-citation-keywords): Set LAXMATCH flag in every HIGHLIGHT. (gnus-message-add-citation-keywords): Append keywords rather than prepending; emulate font-lock-add-keywords if it is not available. (gnus-message-remove-citation-keywords): Emulate font-lock-remove-keywords if it is not available. * gnus-msg.el (gnus-message-highlight-citation): Default to t. * message.el (message-cite-prefix-regexp): Set the value of gnus-message-cite-prefix-regexp. 2007-02-01 Andreas Seltenreich * nnweb.el (nnweb-google-parse-1): Update parser. 2007-01-29 Juanma Barranquero * gnus-art.el (gnus-button-prefer-mid-or-mail): Fix typo in docstring. 2007-01-28 Andreas Seltenreich * nnslashdot.el (nnslashdot-request-article): Update end-of-article regexp. 2007-01-24 Katsumi Yamaoka * uudecode.el (uudecode-string-to-multibyte): New function emulating string-to-multibyte. (uudecode-decode-region-internal): Use it. * lpath.el: Fbind string-as-multibyte for XEmacs. 2007-01-23 Reiner Steib * gnus-score.el (gnus-home-score-file, gnus-home-adapt-file): Fix custom choice. * gnus-art.el (gnus-signature-limit): Fix custom choice. 2007-01-22 Daiki Ueno * mm-util.el (mm-inhibit-file-name-handlers): Add epa-file-handler. * mm-decode.el (mm-save-part-to-file): Use `mm-write-region' instead of `write-region' to respect `mm-inhibit-file-name-handlers'. 2007-01-19 Reiner Steib * nnsoup.el (nnsoup-directory, nnsoup-packer, nnsoup-packet-directory): Use gnus-home-directory instead of "~/" or "$HOME". 2007-01-17 Teodor Zlatanov * encrypt.el (encrypt-insert-file-contents): Add better prompt to mention filename. Add comments at beginning regarding usage. (encrypt-write-file-contents): Change interactive so a string is acceptable. If the file has no associated model, show an error instead of a nonsense prompt. 2007-01-16 TSUCHIYA Masatoshi * spam.el (spam-bsfilter-ham-switch): Fix typo. Thanks to Yoshihiko Yamada for kind notification of this typo. 2007-01-12 Kenichi Handa * uudecode.el (uudecode-decode-region-internal): Make it work in a multibyte buffer. 2007-01-14 Reiner Steib * gnus-score.el (gnus-score-fast-scoring): New variable. (gnus-score-headers): Use it. * gnus-sum.el (gnus-auto-select-first): Improve doc string. * message.el (message-cite-original-1): Call gnus-article-highlight-citation if requested. (message-make-from): Allow name and address as optional arguments. * gnus-cite.el (gnus-article-highlight-citation): Add SAME-BUFFER arg. * gnus-art.el (gnus-article-browse-html-article): Add warning about web bugs to doc string. (gnus-button-alist): Add mid\\|message-id. (gnus-button-fetch-group): Extend for use in `browse-url-browser-function'. (gnus-button-url-regexp): Try to catch paired parentheses like in Wikipedia URLs. * gnus-sum.el (gnus-summary-reparent-children): Another doc string fix. Suggested by Simon Krahnke . 2007-01-13 Romain Francoise * nnml.el (nnml-use-compressed-files): Fix typo in docstring. Update copyright. 2007-01-13 Patric Mueller (tiny change) * gnus-sum.el (gnus-summary-reparent-children): Fix typo in doc string. 2007-01-09 Teodor Zlatanov * gnus-registry.el (gnus-registry-unfollowed-groups) (gnus-registry-split-fancy-with-parent): Fix documentation. 2007-01-08 Lars Magne Ingebrigtsen * spam-report.el (spam-report-gmane-internal): Speed up spam reporting from nnweb groups. 2006-12-31 Lars Magne Ingebrigtsen * spam-report.el (spam-report-gmane-internal): Add necessary "/" to Xref urls. Erase buffer before requesting head. 2007-01-07 Reiner Steib * gnus-soup.el (gnus-soup): New custom group. Make user variables customizable. 2007-01-05 Daiki Ueno * mml2015.el (mml2015-epg-sign): Ask user whether to skip or abort if no signing key is found. (mml2015-epg-encrypt): Ask user whether to skip or abort if no encrypting and/or signing key is found. 2007-01-03 Reiner Steib * spam-report.el (spam-report-gmane-spam): Remove redundant message. 2007-01-01 Andreas Seltenreich * nnweb.el (nnweb-gmane-create-mapping): Put back code to merge the headers read from disk with the ones newly found in the current search. This should no longer cause problems, because the article numbers in Gmane's `nov.php' output are ignored since the previous change. 2007-01-02 Andreas Seltenreich * gmm-utils.el (gmm-tool-bar-style): Fix custom type. 2007-01-01 Katsumi Yamaoka * lpath.el: Fbind clear-string and cp-supported-codepages; don't fbind replace-regexp-in-string; bind url-version; fbind display-images-p and timer-set-function for XEmacs; bind timer-list for XEmacs; fbind find-face and set-itimer-function for Emacs; bind itimer-list for Emacs. * mm-decode.el (mm-display-external): Use itimer function for XEmacs. 2007-01-01 Romain Francoise * gnus-sum.el (gnus-summary-make-menu-bar): Fix typo. 2006-12-31 Steve Youngs * gnus-cite.el: Load easy-mmode at compile time for (S)XEmacs to get `define-minor-mode' macro definition expanded properly. (gnus-message-citation-mode): This is now OK for (S)XEmacs so don't exclude it there. * gnus-msg.el (gnus-message-highlight-citation): Revert Reiner's patch of 2006-12-30. The default is nil on (S)XEmacs already because of the `fboundp' test. (gnus-message-citation-mode): Revert Reiner's patch of 2006-12-30. This is OK to autoload in (S)XEmacs now. 2006-12-30 Lars Magne Ingebrigtsen * gnus-sum.el (gnus-summary-limit-to-singletons): New command and keystroke. (gnus-summary-limit-to-singletons): Fix typo. * spam-report.el (spam-report-gmane-internal): Fall back on Xref if all else fails. 2006-12-30 Andreas Seltenreich * gnus-cite.el (turn-off-gnus-message-citation-mode): Fix typo in docstring. * gnus-sum.el (gnus-summary-insert-ticked-articles): New command. (gnus-summary-make-menu-bar, gnus-summary-buffer-map): Bind it. (gnus-summary-insert-dormant-articles): Fix typo in message. 2006-12-30 Reiner Steib * gnus-msg.el (gnus-message-highlight-citation): Ensure default to be nil for XEmacs. (gnus-message-citation-mode): Don't autoload in XEmacs. * gnus-cite.el (gnus-message-citation-mode): Don't define in XEmacs. 2006-12-29 Jouni K. Seppänen * nnimap.el (nnimap-expunge-search-string): Mention nnimap-search-uids-not-since-is-evil in docstring. 2006-12-28 Reiner Steib * spam.el: Revert to make-obsolete-variable because define-obsolete-variable-alias is not supported in Emacs 21. * spam.el (spam-ifile-path, spam-ifile-database-path) (spam-bogofilter-path): Use define-obsolete-variable-alias instead of make-obsolete-variable. (spam-bsfilter-path, spam-bsfilter-program) (spam-spamassassin-path, spam-spamassassin-program) (spam-sa-learn-path, spam-sa-learn-program): Rename variables. Don't use "path" inappropriately. (spam-check-spamassassin, spam-spamassassin-register-with-sa-learn) (spam-check-bsfilter, spam-bsfilter-register-with-bsfilter): Use new variable names. 2006-12-28 Daiki Ueno * gnus-sum.el (gnus-summary-next-article): Make sure we are in the summary buffer. * password.el (password-cache-remove): Use clear-string to burn password, if available. 2006-12-26 Reiner Steib * gnus-msg.el (gnus-message-citation-mode): Fix autoload. * gnus-cite.el (gnus-message-highlight-citation): Move to gnus-msg.el. * gnus-msg.el (gnus-setup-message): Add gnus-message-citation-mode. (gnus-message-highlight-citation): Move defcustom here from gnus-cite.el. (gnus-message-citation-mode): Autoload. * gnus-cite.el: Adjust Oliver's code to Gnus namespace. Add some checks to make it compile with XEmacs. (gnus-message-citation-mode): New minor mode. (gnus-message-max-citation-depth, gnus-message-citation-keywords) (gnus-message-highlight-citation): New variables. (gnus-message-search-citation-line) (gnus-message-add-citation-keywords) (gnus-message-remove-citation-keywords) (turn-on-gnus-message-citation-mode) (turn-off-gnus-message-citation-mode): New functions. 2006-12-26 Oliver Scholz * gnus-cite.el: Enable highlighting of different citation levels in message-mode. 2006-12-26 Reiner Steib * message.el (message-make-fqdn): Fix comment. (message-bogus-system-names): Add ".local". * spam.el (spam-ifile-path, spam-ifile-program) (spam-ifile-database-path, spam-ifile-database) (spam-bogofilter-path, spam-bogofilter-program): Rename variables. Don't use "path" inappropriately. (spam-spamoracle-database, spam-get-ifile-database-parameter): Fix doc strings. (spam-check-ifile, spam-ifile-register-with-ifile) (spam-check-bogofilter, spam-bogofilter-register-with-bogofilter): Use new variable names. * gnus-art.el (gnus-treat-display-x-face, gnus-treat-display-face) (gnus-treat-display-smileys): Simplify using gnus-image-type-available-p. * gnus-ems.el (gnus-image-type-available-p): Use display-images-p if available. * gnus-xmas.el (gnus-xmas-image-type-available-p): Use `display-images-p' if available. 2006-12-22 Katsumi Yamaoka * nnrss.el (nnrss-fetch): Replace buffer's contents with the decoded one after turning on the buffer's multibyteness instead of decoding them directly in the unibyte buffer that causes unexpected conversion in Emacs 23 (unicode). 2006-12-21 Andreas Seltenreich * message.el (message-generate-hashcash): Fix custom type. 2006-12-20 Reiner Steib * gnus-sum.el (gnus-summary-recenter): Remove debug messages. 2006-12-20 Reiner Steib * gnus-group.el (gnus-group-tool-bar-gnome): Exchange connect and disconnect icons. Add help text. 2006-12-20 Teodor Zlatanov * spam.el (spam-extra-header-to-number): CRM114 spam score is negated to be consistent with the others we handle. 2006-12-19 Lars Magne Ingebrigtsen * gnus-art.el (gnus-article-setup-buffer): Actually set the local version of gnus-summary-buffer to something, so that we can use two article buffers at the same time. 2006-12-18 Teodor Zlatanov * spam.el (spam-necessary-extra-headers): Make spam-use-regex-headers trigger all the extra headers. (spam-extra-header-to-number): Don't require spam-use-crm114 for header sorting. 2006-12-14 Andreas Seltenreich * nnweb.el (nnweb-gmane-create-mapping): Keep the mapping stable for solid groups. 2006-12-17 Chong Yidong * pgg-gpg.el (pgg-gpg-use-agent): Default to t. 2006-12-13 Reiner Steib * legacy-gnus-agent.el: Add Copyright notice. 2006-12-12 Chong Yidong * gnus-sum.el (gnus-make-thread-indent-array): Fix last change. 2006-12-10 Lars Magne Ingebrigtsen * nnweb.el (nnweb-gmane-search): Placeholder TOPDOC setting. * gnus-sum.el (gnus-summary-recenter): Force setting the window start to make it work reliably in CVS Emacs. (gnus-summary-limit-strange-charsets-predicate) (gnus-summary-limit-to-predicate): New functions. 2006-12-08 Chong Yidong * gnus-sum.el (gnus-make-thread-indent-array): New optional arg specifying array size. (gnus-summary-insert-line, gnus-summary-prepare-threads): Regrow indent array if it is too small. (gnus-sort-threads-recursive): Renamed from gnus-sort-thread-1. (gnus-sort-threads-loop): New function. 2006-12-06 Chris Moore * gnus-sum.el (gnus-sort-threads, gnus-summary-limit-children): Use `max' to avoid the value of `max-lisp-eval-depth' decreasing. 2006-12-04 Jouni K. Seppänen * mm-url.el (mm-url-predefined-programs): Call curl with correct options. 2006-12-01 Lars Magne Ingebrigtsen * spam-report.el (spam-report-url-ping-plain): Wait for output to avoid DOS-ing the recipient. * nnweb.el (nnweb-gmane-create-mapping): Use the article number from the headers when creating the mapping to avoid mismappings. (nnweb-gmane-create-mapping): Always nix out old mapping. 2006-11-30 Katsumi Yamaoka * message.el (message-signed-or-encrypted-p): Bind mm-decrypt-option and mm-verify-option to never. 2006-11-30 Katsumi Yamaoka * message.el (message-signed-or-encrypted-p): New function. (message-forward-make-body): Use it. * mml2015.el (mml2015-pgg-clear-verify, mml2015-epg-clear-verify): Replace encode-coding-string with mm-encode-coding-string. 2006-11-29 Katsumi Yamaoka * nneething.el (nneething-decode-file-name): Replace decode-coding-string with mm-decode-coding-string. * gnus-int.el (gnus-open-server): Say failed server's name. 2006-11-24 Stefan Monnier * pgg-pgp.el (pgg-pgp-process-region): Change `args' from a list of strings to a single string. Quote `errors-file-name'. (pgg-pgp-encrypt-region, pgg-pgp-decrypt-region, pgg-pgp-sign-region) (pgg-pgp-verify-region, pgg-pgp-insert-key, pgg-pgp-snarf-keys-region): Adjust calls. Use `shell-quote-argument'. 2006-11-24 Juanma Barranquero * gnus-agent.el (gnus-agent-expire-unagentized-dirs) (gnus-agent-regenerate-group): Fix space/tab mixup in messages. * gnus-art.el (gnus-article-x-face-command, gnus-numeric-save-name): * gnus-group.el (gnus-group-sort-function, gnus-group-line-format) (gnus-group-mode, gnus-group-read-group, gnus-group-delete-group) (gnus-group-make-directory-group, gnus-group-transpose-groups): * gnus-start.el (gnus-options-subscribe, gnus-options-not-subscribe) (gnus-subscribe-newsgroup, gnus-1): * gnus-sum.el (gnus-summary-make-false-root, gnus-make-threads): * gnus.el (gnus-nntp-server, gnus-use-cross-reference) (gnus-valid-select-methods, total-expire, gnus-summary-line-format) (gnus-group-read-only-p): Fix space/tab mixup in docstrings. 2006-11-24 Lars Magne Ingebrigtsen * gnus-sum.el (gnus-summary-limit-to-headers): New command and keystroke. (gnus-summary-limit-to-bodies): Implement headersp. 2006-11-23 Lars Magne Ingebrigtsen * dns.el (query-dns): Protect against "Process dns deleted" strings. 2006-11-21 Katsumi Yamaoka * mm-util.el (mm-string-to-multibyte): Alias to identity in XEmacs. 2006-11-21 Lars Magne Ingebrigtsen * message.el (message-generate-hashcash): Expand range of values to include `opportunistic'. (message-send-mail): Use it. 2006-11-18 Andreas Seltenreich * mm-uu.el (mm-uu-pgp-signed-extract-1): Make last fix more thorough and comment it. * nnslashdot.el (nnslashdot-retrieve-headers-1): Update regexp. 2006-11-15 Reiner Steib * gnus-util.el (gnus-extract-address-components): Improve comment. 2006-11-14 Katsumi Yamaoka * gnus-util.el (gnus-extract-address-components): Work with address in which the name portion contains @. * lpath.el: Fbind custom-autoload. 2006-11-14 Reiner Steib * gnus.el (gnus-start): Move custom group up. (gnus-select-method): Don't autoload, but make it available for `customize-variable'. (gnus-getenv-nntpserver): Don't autoload. 2006-11-14 Teodor Zlatanov * spam.el: Revert to 7.82 (removed changes since 2006-10-16). 2006-11-14 Reiner Steib * message.el (message-sendmail-extra-arguments): New variable. (message-send-mail-with-sendmail): Use it. 2006-11-14 Katsumi Yamaoka * mml.el (mml-generate-mime-1): Use mm-string-as-unibyte instead of mm-with-unibyte-current-buffer to make string unibyte. * mm-decode.el (mm-insert-part): Use mm-string-to-multibyte instead of mm-string-as-multibyte. 2006-11-14 Daiki Ueno * mml2015.el (mml2015-epg-sign): Prefix "pgp-" to a micalg value. Reported by Werner Koch . 2006-11-14 Daiki Ueno * mml2015.el: Autoload epa-select-keys when compiling. 2006-11-13 Daiki Ueno * mml2015.el (mml2015-epg-sign): Save the signing keys in message-options. (mml2015-epg-encrypt): Save the recipient keys in message-options. 2006-11-13 Daiki Ueno * mml2015.el (mml2015-epg-encrypt): Removed backward compatibility for EasyPG (< 0.0.6). (mml2015-always-trust): New user option. (mml2015-epg-passphrase-callback): Display key ID on the passphrase prompt. 2006-11-10 Katsumi Yamaoka * nntp.el (nntp-authinfo-force): New variable. (nntp-send-authinfo): Use it. 2006-11-09 Reiner Steib * message.el (message-strip-subject-encoded-words): Allow _not_ to decode encoded words. Improve prompt. Add comment about forwarding. (message-replacement-char): Move up. 2006-11-08 Wolfgang Jenkner (tiny change) * gnus-sum.el (gnus-summary-catchup): Use gnus-sorted-intersection instead of gnus-intersection because arguments of gnus-sorted-nunion must be sorted. This avoids corruption of gnus-newsgroup-unreads. 2006-11-07 Reiner Steib * message.el (message-strip-subject-encoded-words): Reformat prompt. (message-simplify-subject-functions): Enable message-strip-subject-encoded-words by default. 2006-11-06 Reiner Steib * message.el (message-strip-subject-encoded-words): New function (message-simplify-subject-functions): New variable. (message-simplify-subject): Use it. Fix typo in doc string. Support message-strip-subject-encoded-words. 2006-11-03 Juanma Barranquero * gnus-diary.el (gnus-diary-delay-format-function): * nndiary.el (nndiary-reminders): * nnsoup.el (nnsoup-always-save): Use "non-nil" in docstrings. 2006-11-01 Reiner Steib * gnus-art.el (article-hide-boring-headers): Fetch date from gnus-original-article-buffer to avoid problems with localized date strings. 2006-10-30 Katsumi Yamaoka * html2text.el (html2text-format-tags): Avoid infloop on open tags. 2006-10-29 Reiner Steib * mm-util.el (mm-codepage-iso-8859-list, mm-codepage-ibm-list): New variables. (mm-setup-codepage-iso-8859, mm-setup-codepage-ibm): New functions. (mm-charset-synonym-alist): Move some entries to mm-codepage-iso-8859-list. (mm-charset-synonym-alist, mm-charset-override-alist): Add iso-8859-8/windows-1255 and iso-8859-9/windows-1254. 2006-10-29 Katsumi Yamaoka * gnus-sum.el (gnus-set-mode-line): Quote % in group name. 2006-10-28 Reiner Steib * gnus-agent.el (gnus-agent-make-mode-line-string): Make it compatible with Emacs 21 and XEmacs. 2006-10-27 Teodor Zlatanov * spam.el (spam-parse-address): New function for better parsing, catching errors, etc. (spam-check-BBDB, spam-enter-ham-BBDB, spam-parse-list): Use it. 2006-10-26 Reiner Steib * mm-view.el: Add interactive arg to html2text autoload. 2006-10-25 Katsumi Yamaoka * gnus-sum.el (gnus-summary-move-article): Use no-encode for `B B'. 2006-10-24 Reiner Steib * mm-util.el (mm-codepage-iso-8859-list, mm-codepage-ibm-list): New variables. (mm-setup-codepage-iso-8859, mm-setup-codepage-ibm): New functions. (mm-charset-synonym-alist): Move some entries to mm-codepage-iso-8859-list. * gnus.el (gnus-getenv-nntpserver, gnus-select-method): Autoload. 2006-10-23 Reiner Steib * message.el (message-citation-line-format) (message-insert-formated-citation-line): Fix implementation of %E, %N and %n according to the doc string. 2006-10-20 Teodor Zlatanov * spam.el (spam-check-BBDB, spam-enter-ham-BBDB, spam-parse-list): Use car-safe to avoid bad parses. 2006-10-20 Katsumi Yamaoka * gnus-group.el (gnus-group-make-doc-group): Work for non-ASCII group names. * gnus-sum.el (gnus-select-newsgroup): Decode group name. 2006-10-19 Katsumi Yamaoka * gnus-draft.el (gnus-draft-edit-message): Make sure to remove Date header. * message.el (message-draft-headers): Add Date. (message-headers-to-generate): Fix typo in docstring. * nndraft.el (nndraft-required-headers): New variable. (nndraft-generate-headers): Use it. * gnus-registry.el (gnus-registry-wash-for-keywords): Bind `word'. 2006-10-16 Teodor Zlatanov * gnus-registry.el (gnus-registry-wash-for-keywords) (gnus-registry-find-keywords): New functions to allow easy searching of articles that are in the registry. 2006-10-16 Teodor Zlatanov * spam.el (spam-check-BBDB, spam-enter-ham-BBDB, spam-parse-list): Use ietf-drums-parse-address instead of gnus-extract-address-components. Reported by Damien Elmes . 2006-10-19 Reiner Steib * gnus.el (gnus-mime): Remove unused custom group. 2006-10-13 Andreas Seltenreich * mm-uu.el (mm-uu-pgp-signed-extract-1): Use RFC 2440 definition of "blank line" when searching for end of armor headers. 2006-10-11 Katsumi Yamaoka * gmm-utils.el (gmm-write-region): Fix variable name. 2006-10-10 Reiner Steib * gmm-utils.el (gmm-write-region): New function based on compatibility code from `mm-make-temp-file'. * mm-util.el (mm-make-temp-file): Use `gmm-write-region'. * nnmaildir.el (nnmaildir--update-nov) (nnmaildir-request-replace-article, nnmaildir-request-accept-article): Use `gmm-write-region'. 2006-10-04 Reiner Steib * mm-util.el (mm-charset-synonym-alist, mm-charset-override-alist): Add iso-8859-8/windows-1255 and iso-8859-9/windows-1254. * nnheader.el (nnheader-find-file-noselect): Inhibit version-control. * message.el (message-replacement-char): New variable. (message-fix-before-sending): Use it. (message-simplify-subject): New function to remove duplicate code. (message-reply, message-followup): Use it. * gnus-sum.el (gnus-summary-make-menu-bar): Clarify gnus-summary-limit-to-articles. 2006-10-03 Katsumi Yamaoka * gnus-util.el (gnus-with-local-quit): New macro. * gnus-demon.el (gnus-demon): Replace with-local-quit with it. 2006-10-02 Teodor Zlatanov * gnus-util.el (gnus-string-remove-all-properties): Another fix to ignore non-string data. 2006-09-29 Teodor Zlatanov * gnus-util.el (gnus-string-remove-all-properties): Fix to ignore non-string data (needs to be done in the registry too). 2006-09-28 Teodor Zlatanov * gnus-registry.el (gnus-registry-save, gnus-registry-cache-save) (gnus-registry-remove-alist-text-properties, gnus-registry-action) (gnus-registry-split-fancy-with-parent) (gnus-registry-fetch-simplified-message-subject-fast) (gnus-registry-fetch-sender-fast, gnus-registry-store-extra-entry): Remove text properties on ingress into the registry and when it's saved. (gnus-registry-clean-empty-function): Fix bug with cleaning the registry from entries with no groups. 2006-09-28 Teodor Zlatanov * gnus-util.el (gnus-string-remove-all-properties): Add utility function to remove string properties. 2006-09-28 Reiner Steib * gmm-utils.el (gmm): Adjust custom version. * mm-util.el (mm-charset-override-alist, mm-charset-eval-alist): Adjust custom version. * gnus-draft.el (gnus-draft-mode): Don't call `mml-mode'. 2006-09-27 Reiner Steib * gnus-art.el (gnus-insert-prev-page-button) (gnus-insert-next-page-button): Simplify. Reformat. 2006-09-27 Maxime Edouard Robert Froumentin * gnus-art.el (gnus-insert-prev-page-button) (gnus-insert-next-page-button): Apply gnus-article-button-face. 2006-09-25 Chong Yidong * gnus-demon.el (gnus-demon): Use with-local-quit to avoid hangs. 2006-09-20 Maxime Edouard Robert Froumentin (gnus-insert-mime-button, gnus-insert-mime-security-button): Apply gnus-article-button-face to MIME and security buttons. 2006-09-20 Reiner Steib * gnus-art.el (gnus-button-url-regexp): Try to make the value more readable. 2006-09-20 Katsumi Yamaoka * dgnushack.el: Autoload browse-url-of-file for XEmacs. 2006-09-20 Steve Youngs * gnus-art.el (gnus-article-browse-html-parts): They're files, so use `browse-url-of-file' instead of `browse-url'. 2006-09-19 Andreas Seltenreich * nnslashdot.el (nnslashdot-request-article): Update end-of-article regexp. Articles containing quotation were cut prematurely. 2006-09-16 Katsumi Yamaoka * message.el (message-cite-original-1): Use nobody by default for the value of From header. (message-reply): Ditto. 2006-09-11 Daiki Ueno * mml2015.el (mml2015-epg-clear-decrypt): Don't append verify results to the gnus-info. This fixes a bug of inline-PGP message verification. Reported by Michael Piotrowski . 2006-09-09 Reiner Steib * pop3.el (pop3-leave-mail-on-server): Mention problem of duplicate mails in the doc string. Add some URLs in comment. (pop3-movemail): Warn about pop3-leave-mail-on-server. 2006-09-07 Katsumi Yamaoka * rfc2047.el (rfc2047-quote-special-characters-in-quoted-strings): Fix backslashes handling and the way to find boundaries of quoted strings. 2006-09-07 Daiki Ueno * mml1991.el (mml1991-epg-encrypt): Simply throw an error if mml1991-encrypt-to-self is set and mml1991-signers is not set. * mml2015.el (mml2015-epg-encrypt): Simply throw an error if mml2015-encrypt-to-self is set and mml2015-signers is not set. 2006-09-06 Reiner Steib * gnus-art.el (gnus-button-marker-list): Move up. Convert comment into doc string. (gnus-button-regexp, gnus-button-last): Remove unused variables. 2006-09-06 Katsumi Yamaoka * lpath.el: Fbind epg-check-configuration. 2006-09-06 Simon Josefsson * mml2015.el (mml2015-use): Doc fix, mention epg. 2006-09-06 Daiki Ueno * mml2015.el (mml2015-use): Default to epg, if available. 2006-09-06 Daiki Ueno * mml1991.el (mml1991-epg-sign): Don't lookup a private key by message-sender. (mml1991-epg-encrypt): Ditto. * mml2015.el (mml2015-epg-sign): Don't lookup a private key by message-sender. (mml2015-epg-encrypt): Ditto. 2006-09-04 Chong Yidong * message.el (message-send-mail-with-sendmail): Look for sendmail in several common directories. 2006-09-05 Daiki Ueno * mml2015.el (mml2015-epg-encrypt): Expand group configuration. * mml1991.el (mml1991-epg-encrypt): Expand group configuration. 2006-09-04 Katsumi Yamaoka * gnus-art.el (article-decode-encoded-words): Make it fast. 2006-09-04 Katsumi Yamaoka * gnus-art.el (article-decode-encoded-words): Don't infloop in XEmacs. * rfc2047.el (rfc2047-strip-backslashes-in-quoted-strings): Decode `\\' in quoted string into `\'. 2006-09-01 Katsumi Yamaoka * rfc2047.el (rfc2047-quote-special-characters-in-quoted-strings): Use standard-syntax-table. 2006-09-01 Katsumi Yamaoka * gnus-art.el (gnus-decode-address-function): New variable. (article-decode-encoded-words): Use it to decode headers which are assumed to contain addresses. (gnus-mime-delete-part): Remove useless `or'. * gnus-sum.el (gnus-decode-encoded-address-function): New variable. (gnus-summary-from-or-to-or-newsgroups): Use it to decode To header. (gnus-nov-parse-line): Use it to decode From header. (gnus-get-newsgroup-headers): Ditto. (gnus-summary-enter-digest-group): Use it to decode `to-address'. * mail-parse.el (mail-decode-encoded-address-region): New alias. (mail-decode-encoded-address-string): New alias. * rfc2047.el (rfc2047-quote-special-characters-in-quoted-strings): New function. (rfc2047-encode-message-header, rfc2047-encode-region): Use it. (rfc2047-strip-backslashes-in-quoted-strings): New fnction. (rfc2047-decode-region): Use it; add optional argument `address-mime'. (rfc2047-decode-string): Ditto. (rfc2047-decode-address-region): New function. (rfc2047-decode-address-string): New function. 2006-08-31 Reiner Steib * message.el (message-caesar-buffer-body): Allow rotating headers. * gnus-sum.el (gnus-summary-caesar-message): Allow rotating headers. * message.el (message-insert-formated-citation-line): Fix %f. Reported by Torsten Bronger . 2006-08-18 Katsumi Yamaoka * gnus-bookmark.el (gnus-bookmark-file-coding-system): New variable. (gnus-bookmark-mouse-available-p): New macro. (gnus-bookmark-bmenu-list): Use it; use gnus-mouse-2. (gnus-bookmark-bmenu-show-infos): Use it. (gnus-bookmark-insert-details): Use it; use gnus-mouse-2. (gnus-bookmark-bmenu-hide-infos): Ditto. (gnus-bookmark-remove-properties): New function. (gnus-bookmark-set, gnus-bookmark-make-cell): Use it. (gnus-bookmark-set-bookmark-name): Don't use 2nd arg of split-string. (gnus-bookmark-write-file): Bind coding-system-for-write. (gnus-bookmark-insert-file-format-version-stamp): Add coding cookie. (gnus-bookmark-jump): Make completing-read work with XEmacs; activate group before selecting it. (gnus-bookmark-get-bookmark): Use assoc instead of assoc-string. (gnus-bookmark-bmenu-mode-map): Bind `q' to bury-buffer instead of quit-window if it is not available; use gnus-mouse-2 and bind it to gnus-bookmark-bmenu-select-by-mouse. (gnus-bookmark-show-details): Remove unused variable `details-list'. (gnus-bookmark-bmenu-select-by-mouse): New function. 2006-08-13 Romain Francoise * mm-extern.el (mm-extern-mail-server): End `y-or-n-p' prompt with a space. 2006-08-09 Katsumi Yamaoka * compface.el (uncompface): Use binary rather than raw-text-unix. 2006-08-09 Katsumi Yamaoka * compface.el (uncompface): Make sure the eol conversion doesn't take place when communicating with the external programs. Reported by ARISAWA Akihiro . 2006-07-31 Katsumi Yamaoka * nnheader.el (nnheader-insert-head): Fix typo in comment. 2006-07-31 Andreas Seltenreich * nnweb.el (nnweb-google-parse-1): Update regexp for author and date. Make it more robust by parsing author and date independently. 2006-07-28 Katsumi Yamaoka * nnheader.el (nnheader-insert-head): Make it work with Mac as well. 2006-07-28 Daiki Ueno * mml2015.el (mml2015-epg-sign): If mml2015-signers is not set, use the first matching secret key. (mml2015-epg-encrypt): Ditto. * mml1991.el (mml1991-epg-sign): If mml1991-signers is not set, use the first matching secret key. (mml1991-epg-encrypt): Ditto. * mml2015.el (mml2015-encrypt-to-self): New user option. (mml2015-epg-encrypt): Append mml2015-signers to recipients list if mml2015-epg-encrypt-to-self is set. * mml1991.el (mml1991-encrypt-to-self): New variable. (mml1991-epg-encrypt): Append mml1991-signers to recipients list if mml1991-epg-encrypt-to-self is set. * mml2015.el (mml2015-signers): New user option. (mml2015-epg-sign): Reflect the value of mml2015-signers. (mml2015-epg-encrypt): Allow to select signing keys. * mml1991.el (mml1991-signers): New variable. (mml1991-epg-sign): Reflect the value of mml1991-signers. (mml1991-epg-encrypt): Allow to select signing keys. 2006-07-27 Katsumi Yamaoka * nnheader.el (nnheader-insert-head): Make it work even if the file uses CRLF for the line-break code. 2006-07-25 Daiki Ueno * mml2015.el: Require mml-sec instead of password. (mml2015-verbose): Inherit the default value from mml-secure-verbose. (mml2015-cache-passphrase): Inherit the default value from mml-secure-cache-passphrase. (mml2015-passphrase-cache-expiry): Inherit the default value from mml-secure-passphrase-cache-expiry. * mml1991.el: Require mml-sec instead of password. (mml1991-verbose): Inherit the default value from mml-secure-verbose. (mml1991-cache-passphrase): Inherit the default value from mml-secure-cache-passphrase. (mml1991-passphrase-cache-expiry): Inherit the default value from mml-secure-passphrase-cache-expiry. * mml-sec.el: Require password. (mml-secure-verbose): New user option. (mml-secure-cache-passphrase): New user option. (mml-secure-passphrase-cache-expiry): New user option. 2006-07-24 Daiki Ueno * pgg-def.el (pgg-truncate-key-identifier): Truncate the key ID to 8 letters from the end. Thanks to "David Smith" and andreas@altroot.de (Andreas Vögele). FIXME: Use `tiny change'? 2006-07-19 Andreas Seltenreich * mm-url.el (mm-url-insert-file-contents): Inhibit Connection: close workaround for the url package included with Emacs. * nnweb.el (nnweb-google-create-mapping): Update regexp. 2006-07-19 Katsumi Yamaoka * gnus-sum.el (gnus-select-newsgroup): Setup the article buffer correctly. This fixes a bug caused by the 2006-05-12 change. 2006-07-18 Karl Fogel * nnmail.el (nnmail-article-group): If splitting raises an error, give some information about the error when saying that the `bogus' mail group will be used. 2006-07-17 Reiner Steib * gnus-sum.el (gnus-summary-delete-article): Don't use TAB in doc string. 2006-07-16 NAKAJI Hiroyuki (tiny change) * mm-util.el (mm-charset-synonym-alist): Map windows-31j to cp932. 2006-07-14 Andreas Seltenreich * gnus-start.el (gnus-subscribe-options-newsgroup-method): Doc fix. 2006-07-10 Daiki Ueno * mml1991.el (mml1991-function-alist): Add epg. (mml1991-epg-passphrase-callback, mml1991-epg-sign) (mml1991-epg-encrypt): New functions. 2006-07-10 Daiki Ueno * mml2015.el (mml2015-verbose): New variable. (mml2015-cache-passphrase): Ditto. (mml2015-passphrase-cache-expiry): Ditto. (mml2015-function-alist): Add epg. (mml2015-epg-passphrase-callback, mml2015-epg-decrypt) (mml2015-epg-clear-decrypt, mml2015-epg-verify) (mml2015-epg-clear-verify, mml2015-epg-sign, mml2015-epg-encrypt): New functions. 2006-07-08 Andreas Seltenreich * message.el (message-cite-original-1): Preserve region when removing quoted text due to X-No-Archive in order to avoid bogus attribution when citing multiple messages. 2006-06-27 Andreas Seltenreich * gnus-group.el (gnus-group-sort-by-unread): Fix typo. Reported by Kenneth Jacker . 2006-06-26 Reiner Steib * gnus-diary.el (gnus-user-format-function-d) (gnus-user-format-function-D): Autoload. * imap.el (Commentary): Fix typo. * gnus-util.el (kill-empty-logs, gnus-byte-compile): Remove anonymous 2006-04-22 contribution. 2006-06-26 Andreas Seltenreich * gnus.el (gnus-valid-select-methods): Revert last change for nnweb. It didn't really fix the bogosity I'm seeing with solid web groups. 2006-06-26 Andreas Seltenreich * gnus.el (gnus-valid-select-methods): Declare nnweb with 'address. Since revision 6.95 (2003-01-05) of gnus-group.el, solid web groups are created using server names. If we use the feature without declaring it, Gnus does not properly manage server and group state. * nnweb.el (nnweb-google-search): Respect nnweb-max-hits as upper bound. 2006-06-25 Andreas Seltenreich * gnus.el (gnus-find-method-for-group): On killed/unknown groups, try looking up the method using GROUP's prefix before inventing a new one. It is used on killed/unknown groups in various places where returning an all-new method isn't expected by the caller. * gnus-util.el (gnus-group-server): Fix for empty virtual server names and match semantics of gnus-group-real-prefix. 2006-06-22 Reiner Steib * nnmail.el (nnmail-broken-references-mailers): New variable. (nnmail-ignore-broken-references): New function generalizing nnmail-fix-eudora-headers. (nnmail-fix-eudora-headers): Now obsolete. * gnus-art.el (gnus-button-handle-custom): Support `customize-apropos*'. 2006-06-21 Lars Magne Ingebrigtsen * gnus-art.el (article-hide-headers): Inhibit read-only stuff. * gnus-group.el (gnus-fetch-group): Document ARTICLES and select those articles. 2006-06-21 Reiner Steib * message.el (message-cite-reply-above): New variable. (message-yank-original): Use it. 2006-06-20 Katsumi Yamaoka * rfc2231.el (rfc2231-parse-string): Allow `*'s in parameter values. 2006-06-20 Reiner Steib * gnus-bookmark.el (gnus-bookmark-jump): Don't mark unrelated articles as read. * gnus-group.el (gnus-group-quick-select-group): Add GROUP argument. 2006-06-19 Reiner Steib * gnus-bookmark.el: Fix Copyright, keywords, whitespace, etc. (gnus-bookmark-default-file): Use gnus-directory. (gnus-bookmark-bmenu-file-column, gnus-bookmark-use-annotations): Remove "*" in doc string. (gnus-bookmark-write-file): Simplify. (gnus-bookmark-maybe-sort-alist): Use `when'. (gnus-bookmark-get-bookmark): Fix typo in doc string. (gnus-bookmark-set-bookmark-name, gnus-bookmark-get-bookmark): Add FIXME about Emacs 21 and XEmacs compatibility. (gnus-bookmark-set-bookmark-name): Use `gnus-replace-in-string' for compatibility. (gnus-bookmark-bmenu-mode): Use `gnus-run-mode-hooks' for compatibility. (gnus-bookmark-menu-heading): Fix version. 2006-06-19 Bastien Guerry * gnus-bookmark.el: New file. 2006-06-19 Katsumi Yamaoka * message.el (message-syntax-checks): Doc fix. 2006-06-17 Andreas Seltenreich * gnus-srvr.el (gnus-browse-unsubscribe-group): Don't subscribe unsubscribed groups as if they were killed ones. It causes duplicate entries in gnus-newsrc-alist. 2006-06-16 Katsumi Yamaoka * message.el (message-syntax-checks): Doc fix. (message-send-mail): Add check for continuation headers. (message-check-news-header-syntax): Fix regexp used to check for continuation headers. 2006-06-14 Katsumi Yamaoka * gnus-art.el (gnus-display-mime): Make sure body ends with newline. 2006-06-11 Reiner Steib * gnus-art.el (gnus-article-toggle-truncate-lines): Fix code. 2006-06-11 Katsumi Yamaoka * gnus-art.el (gnus-article-truncate-lines): Default to the value of default-truncate-lines. 2006-06-06 Katsumi Yamaoka * mm-util.el (mm-mime-mule-charset-alist): Use unicode-precedence-list to fill the utf-8 entry. * lpath.el: Fbind unicode-precedence-list. 2006-06-01 Andreas Seltenreich * nnweb.el (nnweb-google-parse-1): Update regexp for author and date. 2006-05-30 Kevin Greiner * gnus-agent.el (directory-files-and-attributes): Move all the way forward (the third and final move). (gnus-agent-read-agentview): Trap reconstruction errors due to nonexistant directory. Handle by returning nil. 2006-05-30 Didier Verna * message.el (message-dont-reply-to-names): Update the custom type. * message.el (message-dont-reply-to-names): New defsubst: potentially convert a list of regexps into a single one. * message.el (message-get-reply-headers): Use it. * nnmail.el (nnmail-fancy-expiry-target): Ditto. 2006-05-30 Katsumi Yamaoka * gnus-agent.el (directory-files-and-attributes): Move forward. 2006-05-29 Reiner Steib * gnus-ml.el (gnus-mailing-list-subscribe) (gnus-mailing-list-unsubscribe, gnus-mailing-list-owner) (gnus-mailing-list-message): Fix doc strings. 2006-05-29 Andreas Seltenreich * gnus-ml.el (gnus-mailing-list-message): Use gnus-url-mailto instead of doing it manually. 2006-05-29 Reiner Steib * gnus-art.el (gnus-article-toggle-truncate-lines): Fix typo in comment. 2006-05-29 Kevin Greiner * gnus-agent.el: Added gnus-agent-flush* to purge agent info. (gnus-agent-read-agentview): Fixed handling of end-of-file error. (gnus-agent-read-local): All symbols allocated in my-obarray (gnus-agent-set-local): Skip invalid entries (min and/or max is nil). (gnus-agent-regenerate-group): Check numeric names to see if they are messages or groups. (gnus-agent-total-fetched-for): Ignore 'dummy.group' (there should be a better way of do this...) * gnus-cache.el (gnus-agent-total-fetched-for): Ignore 'dummy.group' (there should be a better way of do this...) 2006-05-29 Katsumi Yamaoka * gnus-art.el (gnus-save-all-headers): Mention it might be overridden. (gnus-saved-headers): Ditto. (gnus-default-article-saver): Mention functions may have properties. (gnus-article-save): Override gnus-save-all-headers and gnus-saved-headers by :headers property which saver function may have. (gnus-summary-save-in-file): Add :headers property. (gnus-summary-write-to-file): Ditto. * gnus-sum.el (gnus-summary-save-article): Bind gnus-prompt-before-saving to t when saving many articles in a file; always show all headers. * dgnushack.el: Autoload toggle-truncate-lines for XEmacs. 2006-05-26 Reiner Steib * deuglify.el (gnus-outlook-rearrange-article): Add missing citation marks. * message.el (message-indent-citation): Add optional arguments to allow using it outside of message buffers. * gnus-art.el (gnus-article-unfold-long-headers): New variable. (gnus-article-treat-unfold-headers): Use it. (gnus-article-truncate-lines): New variable. (gnus-article-mode): Use it. (gnus-article-toggle-truncate-lines): New function. * gnus-sum.el (gnus-summary-wash-map, gnus-summary-make-menu-bar): Add gnus-article-toggle-truncate-lines. * uudecode.el (uudecode-decode-region-external): nil isn't a valid coding system in XEmacs, use binary. 2006-05-26 Katsumi Yamaoka * mm-util.el (mm-enrich-utf-8-by-mule-ucs): Don't edit after-load-alist. * gnus-art.el (gnus-summary-save-in-file): Use property to specify this function should save decoded articles. (gnus-summary-write-to-file): Use property to specify this function should save decoded articles and specify gnus-summary-save-in-file should be used to save articles other than the first one when saving many articles. (gnus-summary-save-body-in-file): Use property to specify this function should save decoded articles. (gnus-summary-write-body-to-file): Use property to specify this function should save decoded articles and specify gnus-summary-save-body-in-file should be used to save articles other than the first one when saving many articles. * gnus-sum.el (gnus-summary-save-article): Simplify. 2006-05-25 Katsumi Yamaoka * gnus-art.el (gnus-default-article-saver): Add gnus-summary-write-body-to-file. (gnus-article-save-coding-system): Don't use coding system object in XEmacs. (gnus-read-save-file-name): Add optional `dir-var' argument which specifies directory in which files are saved; work even if optional `variable' argument is not specified. (gnus-summary-write-to-file): Read file name. (gnus-summary-save-body-in-file): Add optional `overwrite' argument. (gnus-summary-write-body-to-file): New function. * gnus-sum.el (gnus-newsgroup-last-directory): New variable. (gnus-summary-local-variables): Add it. (gnus-summary-save-map): Add gnus-summary-write-article-body-file. (gnus-summary-save-article): Remove optional `decode' argument; determine whether to decode articles by the value of gnus-default-article-saver; when saving many files using gnus-summary-write-to-file or gnus-summary-write-body-to-file, use it first and use gnus-summary-save-in-file or gnus-summary-save-body-in-file thereafter unless gnus-prompt-before-saving is always; move point to article which will be saved. (gnus-summary-save-article-file): Revert. (gnus-summary-write-article-file): Revert. (gnus-summary-save-article-body-file): Revert. (gnus-summary-write-article-body-file): New function. 2006-05-24 Katsumi Yamaoka * gnus-art.el (gnus-default-article-saver): Doc fix. (gnus-article-save-coding-system): Move from gnus-sum.el, rename from gnus-summary-save-article-coding-system, and default to a certain coding system. (gnus-output-to-file): Add coding cookie and encode text according to gnus-article-save-coding-system; don't use mm-append-to-file. * gnus-sum.el (gnus-summary-save-article-coding-system): Move to gnus-art.el and rename to gnus-article-save-coding-system. (gnus-summary-save-article): Require gnus-art; don't show all headers if it decodes articles; don't add coding cookie here; don't bind mm-text-coding-system-for-write. (gnus-summary-save-article-file): Save decoded articles. (gnus-summary-write-article-file): When saving many files, use gnus-summary-write-to-file first and gnus-summary-save-in-file thereafter unless gnus-prompt-before-saving is always. (gnus-summary-save-article-body-file): Save decoded articles. * lpath.el: Fbind select-safe-coding-system for XEmacs. 2006-05-23 Reiner Steib * nnrss.el (nnrss-check-group): Bind hash-index. 2006-05-23 Michaël Cadilhac * nnrss.el (nnrss-check-group): Use the md5sum of the whole RSS item as its hash index. Store this hash in `nnrss-group-data'. (nnrss-read-group-data): Update accordingly. 2006-05-23 Reiner Steib * gnus-art.el (gnus-button-alist): Improve gnus-button-handle-symbol entry. * gnus-sum.el (gnus-summary-make-menu-bar): Add gnus-article-browse-html-article. 2006-05-23 Hynek Schlawack * gnus-sum.el (gnus-summary-mime-map): Add gnus-article-browse-html-article. * gnus-art.el (gnus-article-browse-html-article): Remove comment. 2006-05-23 Reiner Steib * gnus-sum.el (gnus-summary-save-article-coding-system): Offer some suitable coding systems in customize. 2006-05-22 Reiner Steib * mail-source.el (mail-sources): Fix custom type. 2006-05-18 Reiner Steib * gnus-sum.el (gnus-summary-save-article-mail): Clarify doc string. (gnus-summary-expire-articles-now): Shorten prompt. * gmm-utils.el (wid-edit): Require. (defun-gmm): Renamed from `gmm-defun-compat'. (gmm-image-search-load-path): Use it. (gmm-image-load-path-for-library): Use it. Sync with `mh-compat.el'. 2006-05-17 Katsumi Yamaoka * gnus-sum.el (gnus-summary-save-article-coding-system): New variable. (gnus-summary-save-article): Add optional `decode' argument. If it is set and gnus-summary-save-article-coding-system is non-nil, save decoded article. (gnus-summary-write-article-file): Save decoded article if gnus-summary-save-article-coding-system is non-nil. * ecomplete.el (ecomplete-database-file-coding-system): Fix custom type. 2006-05-16 Katsumi Yamaoka * gnus-art.el (easy-menu-define): Use :active instead of :enable. 2006-05-12 Katsumi Yamaoka * gnus-art.el (gnus-article-setup-buffer): Go to summary buffer first to test gnus-single-article-buffer which may be buffer-local. * gnus-sum.el (gnus-summary-setup-buffer): Make gnus-single-article-buffer buffer-local and nil in ephemeral group; make gnus-article-buffer, gnus-article-current, and gnus-original-article-buffer always buffer-local. (gnus-summary-exit): Kill article buffer belonging to ephemeral group. (gnus-handle-ephemeral-exit): Don't move to next summary line. 2006-05-08 Reiner Steib * nnml.el (nnml-request-compact-group): Compressed files might not have .gz extension. 2006-05-04 Stefan Monnier * mm-decode.el (mm-dissect-buffer): Remove spurious double assignment. (mm-copy-to-buffer): Use with-current-buffer. (mm-display-part): Simplify. (mm-inlinable-p): Add optional arg `type'. 2006-05-03 Stefan Monnier * gnus-art.el (gnus-mime-view-part-as-type): Add optional PRED arg. (gnus-mime-view-part-externally, gnus-mime-view-part-internally): Try harder to show the attachment internally or externally using gnus-mime-view-part-as-type. 2006-05-02 Reiner Steib * message.el (message-from-style, message-signature-separator) (message-user-organization-file, message-send-mail-function) (message-citation-line-function, message-yank-prefix) (message-indent-citation-function, message-signature) (message-signature-file, message-signature-insert-empty-line): Remove autoloads. * gnus-art.el (gnus-buttonized-mime-types): Remove "multipart/signed". Revert 2006-04-26 change. 2006-05-01 Lars Magne Ingebrigtsen * gnus.el (gnus-version-number): Bump version. 2006-05-01 Lars Magne Ingebrigtsen * gnus.el: No Gnus v0.5 is released. 2006-04-30 Andreas Seltenreich * nnweb.el (nnweb-request-article): Do proper xwfu encoding when fetching articles by message-id. 2006-04-30 Lars Magne Ingebrigtsen * message.el (hashcash): Require hashcash as normal. * ecomplete.el (ecomplete-highlight-match-line): Use point-at-eol. (ecomplete-highlight-match-line): Use `highlight', because that face exists in both Emacs and XEmacs. * message.el (message-display-abbrev): Use point-at-bol. * mail-source.el: Don't require timer/timer-funcs. * gnus-async.el: Ditto. * password.el: Ditto. * nnheaderxm.el (nnheader-cancel-timer): Ditto. * mm-url.el: Ditto. * gnus-xmas.el: Don't require timer-funcs. * mm-util.el: Require timer/timer-funcs. 2006-04-23 Andreas Seltenreich * mm-url.el (mm-url-insert-file-contents): Don't set Connection: Close. 2006-04-28 Katsumi Yamaoka * mm-uu.el (mm-uu-pgp-encrypted-extract-1): Assume buffer is made unibyte after clear-decrypt function runs. * mml2015.el (mml2015-pgg-clear-decrypt): Treat data which pgg returns as a unibyte string. 2006-04-27 Katsumi Yamaoka * lpath.el: Revert. * pgg-gpg.el (pgg-string-to-multibyte): Remove. (pgg-gpg-process-sentinel): Revert. * pgg-pgp.el (pgg-pgp-process-region): Revert. (pgg-pgp-lookup-key): Revert. * pgg-pgp5.el (pgg-pgp5-process-region): Revert. (pgg-pgp5-lookup-key): Revert. * pgg.el (pgg-fetch-key): Revert. 2006-04-27 Katsumi Yamaoka * lpath.el: Fbind string-as-multibyte for XEmacs. * mml1991.el (mml1991-pgg-sign): No need to load pgg.el, which is always loaded by way of gnus-art.el -> mm-uu.el -> mml2015.el. (mml1991-pgg-encrypt): Ditto. * pgg-gpg.el (pgg-string-to-multibyte): New function. (pgg-gpg-process-sentinel): Make sure pgg-output-buffer is always a multibyte buffer. * pgg-pgp.el (pgg-pgp-process-region): Ditto. (pgg-pgp-lookup-key): Ditto. * pgg-pgp5.el (pgg-pgp5-process-region): Ditto. (pgg-pgp5-lookup-key): Ditto. * pgg.el (pgg-fetch-key): Ditto. 2006-04-26 Reiner Steib * message.el (message-user-organization-file): Check several locations of the organization file. * gnus-sum.el (gnus-summary-mime-map, gnus-summary-make-menu-bar): Add gnus-article-view-part-as-type. * gnus-art.el (gnus-article-view-part-as-type): New function. * message.el (message-valid-fqdn-regexp): Add TLDs .cat, jobs, .mobi and .travel. Remove .nato, .bitnet and .uucp. * mml.el: Simplify autoload. (mml-mode): defvar dnd-protocol-alist instead of using symbol-value. (mml-default-directory): New variable. (mml-minibuffer-read-file): Use it. (mml-dnd-protocol-alist, mml-dnd-attach-options): Adjust :version. * message.el (message-citation-line-format): New variable. (message-insert-formated-citation-line): New function. (message-citation-line-function): Add `message-insert-formated-citation-line' to custom type. * mm-decode.el (mm-verify-option): Add gnus-buttonized-mime-types to doc string. * gnus-art.el (gnus-buttonized-mime-types): Add "multipart/signed" depending on mm-verify-option. 2006-04-26 Katsumi Yamaoka * mml1991.el (mml1991-pgg-sign): Make sure to load pgg.el before binding pgg-* variables; reimplement the section which prevents MIME header from being signed. (mml1991-pgg-encrypt): Make sure to load pgg.el before binding pgg-text-mode; remove a blank line at the top of body. * mm-uu.el (mm-uu-pgp-encrypted-extract-1): Don't remove blank lines at the top of body; use gnus-newsgroup-charset if there's no Charset header. 2006-04-25 Katsumi Yamaoka * message.el (message-self-insert-commands): Doc fix. * mm-uu.el (mm-uu-pgp-signed-test): Erase prompt. (mm-uu-pgp-encrypted-test): Ditto. (mm-uu-pgp-encrypted-extract-1): Make sure there's a blank line between header and body; return application/pgp-encrypted handle if decryption failed; decode decrypted body by charset. * mm-decode.el (mm-automatic-display): Don't make application/pgp element match to application/pgp-*. 2006-04-23 Andreas Seltenreich * nnweb.el (nnweb-google-wash-article): Sync up to new Google HTML. 2006-04-23 Lars Magne Ingebrigtsen * mail-source.el (mail-source-call-script): Message the error string. 2006-04-22 Lars Magne Ingebrigtsen * gnus-util.el (gnus-byte-compile): Use it. 2006-04-22 xyblor (tiny change) * gnus-util.el (kill-empty-logs): New function. 2006-04-22 Lars Magne Ingebrigtsen * message.el (message-mail-alias-type): Doc fix. (message-mail-alias-type-p): New function. (message-send): Use it. (message-mode): Ditto. (message-strip-forbidden-properties): Ditto. * ecomplete.el (ecomplete-database-file-coding-system): New variable. (ecomplete-save): Use it. (ecomplete-setup): Use it. 2006-04-22 Katsumi Yamaoka * message.el (message-self-insert-commands): New variable. (message-strip-forbidden-properties): Use it. 2006-04-22 Lars Magne Ingebrigtsen * message.el (message-put-addresses-in-ecomplete): Use a regexp that doesn't make XEmacs choke. 2006-04-20 Reiner Steib * gnus-util.el (gnus-replace-in-string): Prefer replace-regexp-in-string over of replace-in-string. 2006-04-20 Katsumi Yamaoka * gnus-util.el (gnus-select-frame-set-input-focus): Use select-frame-set-input-focus if it is available in XEmacs; use definition defined in Emacs 22 for old Emacsen. * dgnushack.el: Autoload unmorse-region for XEmacs. * lpath.el: Bind cursor-in-non-selected-windows and select-frame-set-input-focus for XEmacs. 2006-04-19 Katsumi Yamaoka * mm-view.el (mm-inline-text): Use equal instead of equalp. 2006-04-18 Teodor Zlatanov * gnus-registry.el (gnus-registry-cache-save): Remove text properties when saving via the temp buffer. 2006-04-18 Reiner Steib * message.el (message-generate-hashcash): Honor custom type. 2006-04-18 Lars Magne Ingebrigtsen * message.el (message-generate-hashcash): Default to non-nil when hashcash is found. * gnus-sum.el (gnus-summary-expire-articles-now): Clarify prompt. (gnus-refer-thread-limit): Increase default to 500. * mm-view.el (mm-inline-text): Supply delsp to flow-fill. * flow-fill.el (fill-flowed): Allow delete-space. 2006-04-18 Reiner Steib * deuglify.el (gnus-outlook-deuglify-unwrap-min) (gnus-outlook-deuglify-unwrap-max, gnus-outlook-display-hook): Remove autoloads. 2006-04-18 Simon Josefsson * message.el (message-generate-hashcash): Default to. 2006-04-18 Katsumi Yamaoka * rfc2231.el (rfc2231-parse-string): Decode encoded value after concatenating segments rather than before concatenating them. 2006-04-17 Reiner Steib * gnus-group.el: Move comment to gnus-group-update-tool-bar. 2006-04-17 Lars Magne Ingebrigtsen * rfc2231.el (rfc2231-parse-string): Sort the parameters first. * message.el (message-forward-make-body-plain): Allow message-forward-ignored-headers to be a list. (message-remove-ignored-headers): Factor out into function. (message-forward-make-body-mml): Use it. * imap.el (imap-quote-specials): New function. (imap-login-auth): Quote specials. * rfc2231.el (rfc2231-parse-string): Remove dead code. (rfc2231-parse-string): Allow concatanation of parameters that aren't contiguous. The test case is (mail-header-parse-content-type "message/external-body; name*0*=us-ascii''~%2ffoo%2fbar%2fbaz%2fxyzzy%2f; access-type=LOCAL-FILE; name*1*=plugh%2fhello-sailor%2fbing.pdf") 2006-04-17 Stefan Monnier * nntp.el (nntp-accept-process-output): Return the value of `nnheader-accept-process-output'. 2006-04-17 Lars Magne Ingebrigtsen * gnus-art.el (gnus-article-treat-types): Add text/x-patch. (gnus-button-alist): Recognize more diff formats. (gnus-button-patch): Strip directory. 2006-04-17 Reiner Steib * gnus-util.el (gnus-select-frame-set-input-focus): Check for Emacs 22 when setting focus. 2006-04-17 Lars Magne Ingebrigtsen * gnus-art.el (gnus-article-treat-types): Do treatment of text/x-verbatim parts. (gnus-button-patch): New command. * ietf-drums.el (ietf-drums-parse-address): Attempt parsing addresses that contain invalid characters. 2006-04-16 Lars Magne Ingebrigtsen * message.el (message-put-addresses-in-ecomplete): Use gnus-replace-in-string. (message-is-yours-p): Use the more correct mail-header-parse-address instead of mail-extract-address-components. (message-put-addresses-in-ecomplete): Fix typo. * gnus-sum.el (gnus-summary-limit-to-bodies): New command and keystroke. * gnus-art.el (gnus-treatment-function-alist): Change order of newsgroups/generic header folding to avoid double-folding. * message.el (message-hidden-headers): Add X-Draft-From. * gnus-sum.el (gnus-summary-repeat-search-article-forward): New command. (gnus-summary-repeat-search-article-backward): New command. * gnus-topic.el (gnus-topic-display-missing-topic): Skip past groups in the parent topic. 2006-04-16 João Cachopo (tiny change) * spam.el (spam-necessary-extra-headers): Add X-CRM114-Status. (spam-extra-header-to-number): Return the CRM114 number as a number instead of a string. 2006-04-16 Lars Magne Ingebrigtsen * gnus-art.el (gnus-face-properties-alist): Moved here from gnus-fun. * gnus-fun.el (gnus-face-properties-alist): Move to gnus-art. 2006-04-15 Lars Magne Ingebrigtsen * message.el (message-strip-forbidden-properties): Only display on self-insert-command. * hashcash.el (hashcash-insert-payment-async): Remove dead code; reindent. (hashcash-insert-payment-async-2): Make sure the buffer is alive. 2006-04-15 NAKAJI Hiroyuki (tiny change) * smiley.el (smiley-style): Fix typo. 2006-04-15 Lars Magne Ingebrigtsen * hashcash.el (hashcash-insert-payment-async-2): Use message-goto-eoh instead of doing it manually. (mail-add-payment): Use message-narrow-to-header instead of trying to do the same itself. * message.el (message-hidden-headers): Add Face. * gnus-sum.el (gnus-summary-reparent-thread): Factor out reparenting code. (gnus-summary-reparent-children): Refactored out code. (gnus-summary-thread-map): New keystroke. (gnus-summary-reparent-children): Make into command. * smiley.el (smiley-style): Default to `medium' if using a large font. * gnus-sum.el (unmorse-region): Remove autoload, because morse.el does it itself. * message.el (message-point-in-header-p): Simplify definition. 2006-04-14 Lars Magne Ingebrigtsen * nnagent.el (nnagent-request-set-mark): Silence log file writing. (nnagent-request-set-mark): Use write-region instead of append-to-file. * gnus-sum.el (gnus-read-header): Fudge article number if using a strange select method. * ecomplete.el (ecomplete-display-matches): Get highlightling right. (ecomplete-display-matches): Use literals. (ecomplete-display-matches): Disable message logging. * message.el (message-display-abbrev): Small optimization. * ecomplete.el (ecomplete-display-matches): Allow automatic display. * message.el (message-strip-forbidden-properties): Display abbrevs. (message-display-abbrev): Get automatic display right. * ecomplete.el (ecomplete-display-matches): Use M-n/M-p keystrokes. 2006-04-13 Romain Francoise TODO: Backport to v5-10! * gnus-util.el (gnus-alist-to-hashtable, gnus-hashtable-to-alist): Moved here (and renamed) from gnus-registry.el. * gnus-registry.el: Require gnus-util. Use `gnus-alist-to-hashtable' and `gnus-hashtable-to-alist'. 2006-04-13 Lars Magne Ingebrigtsen * gnus-group.el (gnus-group-catchup-current): Change if-then-else-if-then-else into cond. (gnus-group-catchup): Indent. (group-name-at-point): New function. (gnus-fetch-group): Provide default from thing at point. 2006-04-12 Lars Magne Ingebrigtsen * message.el (message-display-abbrev): Fix regexp. * ecomplete.el (ecomplete-highlight-match-line): Reimplement choosing. (ecomplete-highlight-match-line): Fix up code rewrite, remove dead variables. * message.el (message-newline-and-indent): Remove debugging. (message-display-abbrev): Use new implementation. 2006-04-12 Reiner Steib * gnus-art.el (gnus-article-mode): Set cursor-in-non-selected-windows to nil. * smiley.el: Revert previous change. (smiley-data-directory): defvar it before using it in the defcustom of `smiley-style'. 2006-04-12 Lars Magne Ingebrigtsen * message.el (message-newline-and-indent): New function. * ecomplete.el: Implement more bits. * message.el (message-put-addresses-in-ecomplete): Clean up the string. * ecomplete.el (ecomplete-add-item): Chop off decimals. * gnus-sum.el (gnus-summary-save-parts): Bind gnus-summary-save-parts-counter and use it to make unique file names. * gnus-art.el (gnus-ignored-headers): Add some more headers. * ietf-drums.el (ietf-drums-parse-addresses): Take a RAWP parameter to say whether to actually parse the individual addresses. * message.el (message-put-addresses-in-ecomplete): New function. (ecomplete): Require. (message-mail-alias-type): Add ecomplete as an option. 2006-04-12 Ralf Angeli * flow-fill.el (fill-flowed): Remove trailing space from blank quoted lines. 2006-04-12 Lars Magne Ingebrigtsen * smiley.el (smiley-style): Move definition later to avoid a compilation warning. 2006-04-12 Kenichi Handa * rfc2231.el (rfc2231-decode-encoded-string): Work on unibyte buffer and then decode the buffer text if necessary. (rfc2231-encode-string): Be sure to work on multibyte buffer at first, and after mm-encode-body, change the buffer to unibyte. Use mm-disable-multibyte instead of set-buffer-multibyte. 2006-04-12 Katsumi Yamaoka * gnus-art.el (gnus-mime-copy-part): Find name parameter in Content-Type header instead of Content-Disposition header. (gnus-mime-inline-part): Ditto. (gnus-mime-view-part-as-charset): Ignore charset that the part specifies. * mm-decode.el (mm-display-part): Work with external parts and usual parts similarly. * mm-extern.el (mm-inline-external-body): Use mm-display-part instead of gnus-display-mime. * mm-util.el (mm-decompress-buffer): Use mm-with-unibyte-buffer instead of with-temp-buffer. * gnus-uu.el (gnus-uu-save-article): Put mml tags instead of part tag to summarized topics part in order to encode non-ASCII text. 2006-04-11 Reiner Steib * smiley.el (smiley-style): New variable. (smiley-directory): New function. (smiley-data-directory): Derive from `smiley-style' using `smiley-directory'. (smiley-regexp-alist): Add new entries. * gnus-art.el (gnus-button-valid-localpart-regexp): Exclude `@'. (gnus-article-browse-delete-temp): Add :version. 2006-04-11 Arne Jørgensen * gnus-sieve.el (gnus-sieve-generate): Delete from the start of the sieve region. 2006-04-11 Lars Magne Ingebrigtsen * gnus.el (gnus-version-number): Bump version. 2006-04-11 Reiner Steib * gnus.el: No Gnus v0.4 is released. 2006-04-11 Lars Magne Ingebrigtsen * nnslashdot.el (nnslashdot-retrieve-headers-1): Fix up to new layout. * rfc2047.el (rfc2047-decode-encoded-words): Don't message about unknown charset. * message.el (message-header-synonyms): Add Original-To to the default. * gnus-sum.el (gnus-get-newsgroup-headers-xover): group is an optional parameter. 2006-04-06 Reiner Steib * gnus-fun.el (gnus): Require it for gnus-directory. 2006-04-06 Katsumi Yamaoka * gnus-fun.el (gnus-face-properties-alist): Add :version. 2006-04-05 Daiki Ueno * pgg-gpg.el (pgg-gpg-process-filter): Fix. 2006-04-05 Simon Josefsson * password.el (password-reset): New function. 2006-04-05 Daiki Ueno * pgg-gpg.el (pgg-gpg-encrypt-region, pgg-gpg-sign-region): Wait for BEGIN_SIGNING too, new in GnuPG 1.4.3. 2006-04-04 Andreas Seltenreich * nnweb.el (nnweb-google-create-mapping): Update regexp. Some whitespace was matched into the url, which broke browsing hits > 100 when mm-url-use-external was nil. 2006-04-04 Reiner Steib * gnus-sum.el (gnus-summary-from-or-to-or-newsgroups): Check gnus-extra-headers for 'Newsgroups. * message.el (message-tool-bar-gnome): Check if `flyspell-mode' is bound. 2006-04-04 Daiki Ueno * pgg-gpg.el: Clean up process buffers every time gpg processes complete. 2006-04-03 Reiner Steib * gnus-fun.el (gnus-convert-image-to-face-command): Fix typo in doc string. 2006-04-03 Daiki Ueno * pgg-gpg.el (pgg-gpg-process-filter) (pgg-gpg-wait-for-completion): Check if buffer is alive. * pgg-gpg.el (pgg-gpg-process-sentinel): Don't remove GNUPG: lines, temporary fix. 2006-03-31 Reiner Steib * gnus-group.el (gnus-group-update-tool-bar): Add :initialize and :set. 2006-03-29 Daiki Ueno * pgg-gpg.el (pgg-gpg-start-process): Don't bind default-enable-multibyte-characters. This reverts the change from revision 6.17 which is no longer necessary because the passphrase is sent separately now. GnuPG messages are unreadable under multibyte locales with default-enable-multibyte-characters set to nil. 2006-03-28 Reiner Steib * message.el (message-tool-bar-gnome): Move "spell". 2006-03-27 Reiner Steib * gnus-sum.el (gnus-summary-from-or-to-or-newsgroups): Don't use XEmacs-only `replace-in-string'. Use `gnus-group-real-name' instead. 2006-03-27 Karl Kleinpaste * gnus-sum.el (gnus-summary-from-or-to-or-newsgroups): Improve newsgroups handling for NNTP overviews which don't include Newsgroups. 2006-03-26 Andreas Seltenreich * message.el (message-resend): Bind message-generate-hashcash to nil. 2006-03-26 Andreas Seltenreich * hashcash.el (hashcash-already-paid-p): Bind case-fold-search when searching for already-paid recipients. 2006-03-27 Daiki Ueno * pgg-gpg.el: Invoke gpg asynchronous, to avoid querying for passphrases when it is not needed. (pgg-gpg-use-agent): Add, to hard code that pgg shouldn't wait for passphrase stuff from gpg, should only be necessary when you use gpg with a smartcard. 2006-03-23 Katsumi Yamaoka * mml.el (mml-insert-mime): Ignore cached contents of message/external-body part. * mm-decode.el (mm-get-part): Add optional 'no-cache' argument. (mm-insert-part): Ditto. 2006-03-23 Simon Josefsson * pgg-gpg.el (pgg-gpg-update-agent): Add again, with fixes from Reiner. (pgg-gpg-use-agent-p): Use it again. 2006-03-23 Simon Josefsson * pgg-gpg.el (pgg-gpg-update-agent): Remove, doesn't work with older emacsen. (pgg-gpg-use-agent-p): Don't use it. 2006-03-23 Reiner Steib * pgg-gpg.el (pgg-gpg-update-agent): Only use make-network-process if we can. 2006-03-22 Sascha Wilde * pgg-gpg.el (pgg-gpg-use-agent): Disable by default. (pgg-gpg-update-agent): New function. (pgg-gpg-use-agent-p): New function. (pgg-gpg-process-region, pgg-gpg-encrypt-region) (pgg-gpg-encrypt-symmetric-region, pgg-gpg-decrypt-region) (pgg-gpg-sign-region): Use it. 2006-03-22 Katsumi Yamaoka * gnus-sum.el (gnus-map-articles): Don't funcall symbol macro. Reported by Ralf Wachinger . 2006-03-21 Simon Josefsson * pgg-gpg.el: Ideas below based on patch from Sascha Wilde . (pgg-gpg-use-agent): New variable. (pgg-gpg-process-region): Use it. (pgg-gpg-encrypt-region): Likewise. (pgg-gpg-encrypt-symmetric-region): Likewise. (pgg-gpg-decrypt-region): Likewise. (pgg-gpg-sign-region): Likewise. (pgg-gpg-possibly-cache-passphrase): Don't cache a nil password. 2006-03-21 Reiner Steib * gnus-agent.el (gnus-agent-queue-mail): Fix custom tag for `t'. * spam.el (spam-mark-new-messages-in-spam-group-as-spam): Add comment on version. 2006-03-20 Reiner Steib * smiley.el: Add missing test smiley. 2006-03-17 Katsumi Yamaoka * mm-decode.el (mm-with-part): New macro. (mm-get-part): Use it; work with message/external-body as well. (mm-save-part): Treat name and filename equally. * mm-extern.el (mm-extern-cache-contents): New function. (mm-inline-external-body): Use it; force the part to be displayed; move undisplayer added to the cached handle to the parent. * gnus-art.el (gnus-mime-save-part-and-strip): Add name parameter. (gnus-mime-view-part-as-type): Work with message/external-body. * gnus-util.el (gnus-tool-bar-update): Bind tool-bar-mode. 2006-03-16 Reiner Steib * gmm-utils.el (gmm-image-load-path-for-library): Prefer user's images in image-load-path. [Sync with image.el, revision 1.60, in Emacs.] 2006-03-15 Reiner Steib * gmm-utils.el (gmm-image-load-path-for-library): Pass value of path rather than symbol. Always return list of directories. Guarantee that image directory comes first. [Sync with image.el, revision 1.59, in Emacs.] * message.el (message-make-tool-bar): Adjust to new API of `gmm-image-load-path-for-library'. * gnus-sum.el (gnus-summary-make-tool-bar): Ditto. * gnus-group.el (gnus-group-make-tool-bar): Ditto. 2006-03-15 Andreas Seltenreich * gnus-art.el (gnus-article-only-boring-p): Bind inhibit-point-motion-hooks to avoid infinite loop when entering intangible text. Reported by Ralf Wachinger . 2006-03-14 Reiner Steib * gmm-utils.el (gmm-image-load-path-for-library): Fix typo. Use `defun' instead of `gmm-defun-compat'. 2006-03-14 Simon Josefsson * message.el (message-unique-id): Don't use message-number-base36 if (user-uid) is a float. Reported by Bjorn Solberg . 2006-03-13 Katsumi Yamaoka * mm-uu.el (mm-uu-dissect): Dissect all parts correctly. * gnus-art.el (gnus-mime-display-single): Make sure there is an empty line between a part and a message part. 2006-03-10 Reiner Steib * smiley.el: Add more test smileys. (smiley-data-directory, smiley-regexp-alist) (gnus-smiley-file-types): Fix doc strings. (smiley-update-cache): Clear smiley-cached-regexp-alist before adding new elements. (smiley-mouse-map): Unused code. Make it a comment. 2006-03-10 Katsumi Yamaoka * gnus-nocem.el (gnus-nocem-scan-groups): Add autoload cookie; scan latest NoCeM messages instead of old ones. (gnus-nocem-check-article): Fix regexps so as to match to PGP delimiters that are recently used. (gnus-nocem-load-cache): Add autoload cookie. * gnus.el (gnus-use-nocem): Enable it to be set to also a number. * gnus-start.el (gnus-setup-news): Scan NoCeM messages if a group level which is larger than gnus-use-nocem is specified. * gnus-group.el (gnus-group-get-new-news): Ditto. 2006-03-08 Reiner Steib * gnus-util.el (gnus-tool-bar-update): New function. * gnus-group.el (gnus-group-update-tool-bar): New variable. (gnus-group-insert-group-line): Add gnus-tool-bar-update. * gnus-topic.el (gnus-topic-prepare-topic): Add gnus-tool-bar-update. * gnus-group.el (gnus-group-redraw-when-idle) (gnus-group-redraw-check): Remove. (gnus-group-make-tool-bar): Remove gnus-group-redraw-check. 2006-03-08 Katsumi Yamaoka * nnmail.el (nnmail-split-it): Invert match-partial-words behavior if optional last element is specified in splits (FIELD VALUE...). 2006-03-07 Reiner Steib * message.el (message-make-tool-bar): Rename gmm-image-load-path to gmm-image-load-path-for-library. Call with no-error argument. (message-tool-bar-gnome): Rename "mail/attach" to "attach". * gnus-sum.el (gnus-summary-make-tool-bar): Ditto. * gnus-group.el (gnus-group-make-tool-bar): Ditto. * gmm-utils.el (gmm-image-load-path): Remove alias. 2006-03-06 Reiner Steib * gmm-utils.el (gmm-image-load-path): Add alias. * nnml.el (nnml-generate-nov-databases-directory): Rename from nnml-generate-nov-databases-1. (nnml-generate-nov-databases): Use it. (nnml-generate-nov-databases-directory): Document no-active argument. * gmm-utils.el (gmm-image-load-path-for-library): Return single directory if path is t. Add no-error. * gnus-group.el (gnus-group-make-tool-bar): Use add-hook. Suggested by Stefan Monnier . * gnus-art.el (gnus-article-browse-delete-temp-files): Simplify resetting gnus-article-browse-html-temp-list. * gmm-utils.el (gmm-image-load-path-for-library): Sync with mh-compat.el revision 1.9 in Emacs. Rename `gmm-image-load-path'. Add example to docstring. Rename local variables. Move error checks to default case in cond and simplify. 2006-03-06 Katsumi Yamaoka * mm-view.el (mm-w3m-cid-retrieve-1): Check carefully whether handle is multipart when calling it recursively. (mm-w3m-cid-retrieve): Display warning if retrieving fails. 2006-03-03 Daniel Pittman * nnimap.el (nnimap-request-update-info-internal): Optimize. Don't `gnus-uncompress-range' to avoid excessive memory usage. 2006-03-03 Katsumi Yamaoka * gnus-group.el (gnus-group-tool-bar-gnome): Check if gnus-topic.el is loaded. * gnus-sum.el (gnus-summary-tool-bar-gnome): Check if spam.el is loaded. 2006-03-03 Reiner Steib * mm-util.el (mm-with-unibyte-current-buffer): Change "Emacs 23" to "Emacs 23 (unicode)" in doc string. * gnus-sum.el (gnus-summary-set-display-table): Change "Emacs 23" to "Emacs 23 (unicode)" in comment. 2006-03-03 Katsumi Yamaoka * mm-decode.el (mm-get-part): Don't use mm-with-unibyte-current-buffer. * gnus-sum.el (gnus-summary-set-display-table): Don't nix out characters 160 through 255 in Emacs 23. 2006-03-02 Reiner Steib * gnus-art.el (gnus-article-browse-html-temp-list): Rename from gnus-article-browse-html-temp. (gnus-article-browse-delete-temp): Make it customizable. Add `file'. Adjust doc string. (gnus-article-browse-delete-temp-files): Add argument. Allow query for each file. Adjust doc string. (gnus-article-browse-html-parts): Add `gnus-article-browse-delete-temp-files' to `gnus-summary-prepare-exit-hook' and `gnus-exit-gnus-hook'. 2006-03-02 Hynek Schlawack * gnus-art.el (gnus-article-browse-html-temp) (gnus-article-browse-delete-temp): New variables. (gnus-article-browse-delete-temp-files): New function. (gnus-article-browse-html-parts): Use it. 2006-03-02 Reiner Steib * gnus-group.el (gnus-group-redraw-check): Remove redundant tests. * gmm-utils.el (gmm-image-load-path): Mention ../etc search in doc string. * gnus-sum.el (gnus-summary-tool-bar-gnome): Don't use gnus-summary-insert-new-articles when unplugged. Remove gnus-summary-search-article-forward. * gmm-utils.el (gmm-tool-bar-style): Test tool-bar-mode and display-visual-class instead of display-color-cells. 2006-03-02 Katsumi Yamaoka * dgnushack.el: Autoload customize-group for XEmacs. * mml.el (mml-generate-mime-1): Encode parts other than text/* or message/* containing non-ASCII text properly. 2006-03-01 Reiner Steib * message.el: Require gmm-utils, remove autoloads. (message-tool-bar): Set default based on gmm-tool-bar-style. (message-tool-bar-gnome): Add gmm-customize-mode. * gnus-sum.el (gnus-summary-tool-bar): Set default based on gmm-tool-bar-style. (gnus-summary-tool-bar-gnome): Add gmm-customize-mode. * gnus-group.el (gnus-group-tool-bar): Set default based on gmm-tool-bar-style. (gnus-group-tool-bar-gnome): Add gmm-customize-mode. * gmm-utils.el (gmm-image-directory): Rename variable from gmm-image-load-path. (gmm-image-load-path): Use gmm-image-directory. (gmm-customize-mode): New function. (gmm-tool-bar-style): New variable. * gnus-group.el (gnus-group-redraw-when-idle): Rename from gnus-group-redraw-line-number. (gnus-group-redraw-check): Simplify. (gnus-group-tool-bar-update): Remove redraw check. (gnus-group-make-tool-bar): Add redraw check. 2006-03-01 Michael Piotrowski (tiny change) * gnus-art.el (gnus-button): Add missing parentheses. 2006-03-01 Katsumi Yamaoka * lpath.el: Fbind line-number-at-pos. 2006-02-28 Katsumi Yamaoka * mm-util.el (mm-with-unibyte-current-buffer): Add note. 2006-02-28 Reiner Steib * gnus-art.el (gnus-button): New face. (gnus-article-button-face): Use it. * gnus-sum.el (gnus-summary-tool-bar-gnome): Add gnus-summary-next-page. Re-order. * gnus-group.el (gnus-group-tool-bar-gnome): prev-node and next-node are now included. (gnus-group-redraw-line-number): New internal variable. (gnus-group-redraw-check): Helper function for updating the tool bar. (gnus-group-tool-bar-update): Add gnus-group-redraw-check. * gmm-utils.el (gmm-tool-bar-item): Add TODO about modifiers. * spam.el (spam-spamassassin-score-regexp): New internal variable. (spam-extra-header-to-number, spam-check-spamassassin-headers): Use it to match format of Spamassassin 3.0 and later. Reported by IRIE Tetsuya . (spam-check-bogofilter) (spam-bogofilter-register-with-bogofilter): Fix args of `gnus-error' calls. 2006-02-28 Reiner Steib * gnus-draft.el (gnus-draft-send): Bind message-signature to avoid unnecessary interaction when sending queued mails. Reported by TAKAHASHI Yoshio . 2006-02-27 Reiner Steib * gnus-sum.el (gnus-sequence-of-unread-articles): Return nil if first or last are nil. 2006-02-24 Andreas Seltenreich * nnweb.el (nnweb-gmane-create-mapping): Don't choke on ^M. 2006-02-24 Lars Magne Ingebrigtsen * gnus-int.el (gnus-open-server): Respect gnus-batch-mode. 2006-02-24 Lars Magne Ingebrigtsen * dns.el (query-dns): Protect more against buggy tcp output. 2006-02-24 Reiner Steib * nnweb.el (nnweb-type-definition, nnweb-gmane-search): Use new nov.php. 2006-02-24 Andreas Seltenreich * nnweb.el (nnweb-type-definition, nnweb-gmane-create-mapping) (nnweb-gmane-wash-article, nnweb-gmane-search): Fix Gmane web groups. Kudos to Olly Betts for providing NOV output on the server side. (nnweb-google-create-mapping): Update regexps and add some progress indication. 2006-02-23 Reiner Steib * gnus-group.el (gnus-group-tool-bar-gnome): Fix gnus-agent-toggle-plugged. Re-order icons. (gnus-group-tool-bar-gnome): Add gnus-group-{prev,next}-unread-group. (gnus-group-tool-bar-gnome): Re-order icons. * gnus-sum.el (gnus-summary-tool-bar-gnome): Move gnus-summary-insert-new-articles. * message.el (message-tool-bar-gnome, message-tool-bar-retro): Fix comments. * utf7.el (utf7-utf-16-coding-system): Fix comment. utf-16-be is also available in Emacs 21.3. * message.el (message-fix-before-sending): Change "Emacs 22" to "Emacs 23 (unicode)" in comment. * qp.el (quoted-printable-encode-region): Change "Emacs 22" to "Emacs 23 (unicode)" in comment. * mm-util.el: Change "Emacs 22" to "Emacs 23 (unicode)" in comment. (mm-coding-system-p): Add comment about no-MULE XEmacs. * mm-view.el (mm-fill-flowed): Add :version. 2006-02-23 Katsumi Yamaoka * gmm-utils.el (gmm-image-load-path): Don't modify image-load-path and load-path. 2006-02-22 Reiner Steib * message.el: Autoload gmm-image-load-path. (message-tool-bar-retro): Prepend "gnus/" subdirectory to some icon file names. Use old Emacs 21 "mail_send.xpm" icon for consitency. * gmm-utils.el (gmm-image-load-path): Also search in "../etc/images". Don't set gmm-image-load-path if we don't find the image. 2006-02-22 Katsumi Yamaoka * gmm-utils.el (gmm-image-load-path): Don't make `gmm-image-load-path' include subdirectories which the second arg `image' might specify. * gnus-group.el (gnus-group-tool-bar-retro): Prepend the "gnus/" subdirectory to icon file names. * gnus-sum.el (gnus-summary-tool-bar-retro): Ditto. 2006-02-21 Reiner Steib * gnus-group.el (gnus-group-make-tool-bar): Add IMAGE argument to gmm-image-load-path calls. * gnus-sum.el (gnus-summary-make-tool-bar): Ditto. * message.el (message-make-tool-bar): Ditto. * mml.el (mml-preview): Added comment concerning tool bar icons. * gnus-group.el (gnus-group-tool-bar-gnome): Use new icon names. (gnus-group-make-tool-bar): Use `gmm-image-load-path'. * gnus-sum.el (gnus-summary-tool-bar-gnome): Use new icon names. (gnus-summary-make-tool-bar): Use `gmm-image-load-path'. * message.el (message-tool-bar-gnome): Use new icon names. (message-make-tool-bar): Use `gmm-image-load-path'. * gmm-utils.el (gmm-defun-compat, gmm-image-search-load-path): New functions from MH-E. (gmm-image-load-path): New variable from MH-E. (gmm-image-load-path): New function from MH-E. Added arguments LIBRARY, IMAGE and PATH. Don't modify paths. Don't use *-image-load-path-called-flag. 2006-02-21 Milan Zamazal * mm-view.el (mm-view-pkcs7-verify): Implement using smime.el. 2006-02-21 Wolfram Fenske (tiny change) * nnimap.el (nnimap-request-move-article): Change folder back to source group before deleting. 2006-02-20 Reiner Steib * mm-util.el (mm-charset-override-alist): Fix type in doc string. * gnus-art.el (mm-url-insert-file-contents-external): Autoload mm-url. * mm-uu.el (mm-uu-type-alist): Improve `LaTeX'. 2006-02-20 Katsumi Yamaoka * rfc2047.el (rfc2047-charset-to-coding-system): Don't check the coding system which mm-charset-to-coding-system returns for a given charset is valid. 2006-02-16 Juanma Barranquero * html2text.el (html2text-remove-tag-list): * spam-stat.el (spam-stat-buffer-words): Fix typo in docstring. 2006-02-14 Chong Yidong * gnus-cus.el: Revert 2005-10-17 change. 2006-02-17 Katsumi Yamaoka * gnus-art.el (article-strip-banner): Call article-really-strip-banner only when the regexp match is made. 2006-02-16 Katsumi Yamaoka * gnus-art.el (article-strip-banner): Use gnus-extract-address-components instead of mail-header-parse-addresses to make it work with non-ASCII text; remove mail-encode-encoded-word-string. * rfc2231.el (rfc2231-parse-string): Attempt to parse parameter values which are surrounded with \"...\"; make it never cause a Lisp error; give up parsing of parameters if it failed in extracting type. 2006-02-14 Arne Jørgensen * smime.el (smime-cert-by-ldap-1): Fix bug where `smime-ldap-search' returns results without userCertificates. 2006-02-15 Katsumi Yamaoka * mm-util.el (mm-make-temp-file): Don't catch file-error in Emacs. 2006-02-14 Reiner Steib * spam.el (spam-check-spamassassin-headers): Adapt format for Spamassassin 3.0 or later. Reported by ARISAWA Akihiro . (spam-list-of-processors): Add spam-use-gmane. 2006-02-14 Katsumi Yamaoka * mm-util.el (mm-make-temp-file): Import the Emacs 22 version of make-temp-file; make it work with XEmacs as well. * gnus-art.el (gnus-article-browse-html-parts): Use the 3rd arg of mm-make-temp-file. * mm-decode.el (mm-display-external): Use the 3rd arg of mm-make-temp-file. (mm-create-image-xemacs): Ditto. 2006-02-14 Katsumi Yamaoka * gnus-draft.el (gnus-draft-send): Replace message-narrow-to-head with message-narrow-to-headers. (gnus-draft-setup): Narrow to header to run message-fetch-field. (gnus-draft-check-draft-articles): New function. (gnus-draft-edit-message, gnus-draft-send-message): Use it. 2006-02-13 Reiner Steib * gnus-art.el (gnus-article-browse-html-parts): `hs-show-html-list' should read `gnus-article-browse-html-parts'. Don't use suffix argument for mm-make-temp-file for Emacs 21 compatibility. Remove useless `format'. 2006-02-13 Andreas Seltenreich * nnweb.el (nnweb-google-wash-article): Update regexps. (nnweb-group-alist): Use defvoo instead of defvar. 2006-02-13 Katsumi Yamaoka * nnoo.el (nnoo-declare): Don't generate duplicate entries when re-loading nn* modules. 2006-02-10 Reiner Steib * gnus-group.el (gnus-group-make-tool-bar): Remove duplicate check for `tool-bar-mode' and don't check it's default-value. * gnus-sum.el (gnus-summary-make-tool-bar): Ditto. * message.el (message-make-tool-bar): Ditto. * gnus-art.el (gnus-article-browse-html-parts): Remove useless `substring'. Shorten tmp-file name. * gnus.el: Remove bogus comment. 2006-02-10 Hynek Schlawack * gnus-art.el (gnus-article-browse-html-parts): New function. (gnus-article-browse-html-article): New function for viewing html articles with a browser. 2006-02-09 Daiki Ueno * pgg-gpg.el (pgg-gpg-encrypt-region): Don't convert line-endings in elisp. (pgg-gpg-encrypt-symmetric-region): Ditto. (pgg-gpg-sign-region): Ditto. * pgg-def.el (pgg-text-mode): New variable. * mml2015.el (mml2015-pgg-sign): Enable pgg-text-mode. (mml2015-pgg-encrypt): Ditto. * mml1991.el (mml1991-pgg-sign): Enable pgg-text-mode. (mml1991-pgg-encrypt): Ditto. 2006-02-08 Katsumi Yamaoka * nnfolder.el (nnfolder-insert-newsgroup-line): Use message-make-date instead of current-time-string. * mm-view.el (mm-inline-message): Don't set gnus-newsgroup-charset to gnus-decoded which mm-uu might set. 2006-02-08 Katsumi Yamaoka * rfc2231.el (rfc2231-parse-string): Sort segmented parameters; don't decode quoted parameters; remove misimported Emacs code. Suggested by ARISAWA Akihiro . (rfc2231-decode-encoded-string): Don't use split-string which behaves differently according to Emacs version; use mm-decode-coding-region to convert charset to coding-system. Suggested by ARISAWA Akihiro . (rfc2231-encode-string): Remove misimported Emacs code. 2006-02-07 Katsumi Yamaoka * gnus-art.el (article-decode-charset): Don't use ignore-errors when calling mail-header-parse-content-type. (article-de-quoted-unreadable): Ditto. (article-de-base64-unreadable): Ditto. (article-wash-html): Ditto. * mm-decode.el (mm-dissect-buffer): Don't use ignore-errors when calling mail-header-parse-content-type and mail-header-parse-content-disposition. (mm-find-raw-part-by-type): Don't use ignore-errors when calling mail-header-parse-content-type. * mml.el (mml-insert-mime-headers): Use mml-insert-parameter to insert charset and format parameters; encode description after inserting it to buffer. (mml-insert-parameter): Fold lines properly even if a parameter is segmented into two or more lines; change the max column to 76. * rfc1843.el (rfc1843-decode-article-body): Don't use ignore-errors when calling mail-header-parse-content-type. * rfc2231.el (rfc2231-parse-string): Return at least type if possible; don't cause an error even if it fails in parsing of parameters. Suggested by ARISAWA Akihiro . (rfc2231-encode-string): Don't break lines at the beginning, leave it to mml-insert-parameter. * webmail.el (webmail-yahoo-article): Don't use ignore-errors when calling mail-header-parse-content-type. 2006-02-06 Reiner Steib * spam-report.el (spam-report-gmane-use-article-number): Improve doc string. (spam-report-gmane-internal): Check if a suitable header was found in the article. 2006-02-04 Katsumi Yamaoka * rfc2231.el (rfc2231-parse-string): Revert 2006-02-03 change. (rfc2231-encode-string): Make param*=value always begin with LWSP. 2006-02-05 Romain Francoise Update copyright notices of all files in the gnus directory. 2006-02-03 Andreas Seltenreich * nnweb.el (nnweb-request-group): Avoid growing overview files. 2006-02-03 Katsumi Yamaoka * rfc2231.el (rfc2231-parse-string): Add missing semicolons to segmented lines of parameter value to cope with Thunderbird 1.5 bug (cf. https://bugzilla.mozilla.org/show_bug.cgi?id=323318). Suggested by ARISAWA Akihiro . (rfc2231-encode-string): Don't make lines exceeding 76 column. 2006-02-01 Max Froumentin (tiny change) * mml.el (mml-generate-mime-1): Correct the order of inline signed parts. 2006-01-31 Andreas Seltenreich * nnweb.el (nnweb-group-alist): Use defvar instead of defvoo, there's only one active file for all servers. (nnweb-request-scan): Make sure nnweb-articles is initialized on solid groups. Gnus might have used a FAST request to select the group. (nnweb-request-group, nnweb-google-parse-1): Don't keep nnweb-type and nnweb-search redundantly in the active file. (nnweb-request-list): Don't list bogus groups. There can only be one. (nnweb-request-create-group): Don't use ARGS. (nnweb-possibly-change-server, nnweb-request-group): Remove some initialisations. Let nnoo do the work. 2006-01-31 Katsumi Yamaoka * mm-uu.el (mm-uu-emacs-sources-extract, mm-uu-diff-extract): Say the part has been decoded. * mm-view.el (mm-display-inline-fontify): Get decoded part rightly. 2006-01-31 Kevin Ryde * mailcap.el (mailcap-viewer-passes-test): Don't put "(nil t)" into mailcap-viewer-test-cache when there's no 'test clause, since that will invert the meaning of a "nil" test previously determined by mailcap-mailcap-entry-passes-test. 2006-01-30 Katsumi Yamaoka * gnus-group.el: Bind tool-bar-mode instead of tool-bar-map when compiling. * gnus-sum.el: Ditto. * message.el: Don't bind tool-bar-map when compiling. 2006-01-30 Reiner Steib * nnweb.el (nnweb-google-parse-1): Clarify some comments. 2006-01-30 Andreas Seltenreich * nnweb.el (nnweb-type-definition, nnweb-google-parse-1) (nnweb-google-create-mapping, nnweb-google-search): Adapt to current Google Groups. 2006-01-26 Reiner Steib * gnus-sum.el (gnus-summary-make-tool-bar): Add checks for XEmacs and tool-bar-mode. * gnus-group.el (gnus-group-make-tool-bar): Add checks for XEmacs and tool-bar-mode. * message.el (message-tool-bar-update): Simplify. (message-make-tool-bar): Add checks for XEmacs and tool-bar-mode. * gnus-sum.el (gnus-summary-tool-bar-update): Check for gnus-summary-buffer. (gnus-summary-tool-bar-gnome): Use "reply-author" icon for gnus-summary-reply. * gmm-utils.el (gmm): Add :version. 2006-01-26 Katsumi Yamaoka * Makefile.in (clean): New rule. (distclean): Use it. 2006-01-26 Steve Youngs * gmm-utils.el (gmm-tool-bar-item, gmm-tool-bar-zap-list): Don't autoload. 2006-01-26 Katsumi Yamaoka * gmm-utils.el (gmm-verbose): Add :group. 2006-01-25 Reiner Steib * message.el: Change some comments WRT tool-bars. * gnus-sum.el (gnus-summary-tool-bar) (gnus-summary-tool-bar-gnome, gnus-summary-tool-bar-retro) (gnus-summary-tool-bar-zap-list): New variables. (gnus-summary-make-tool-bar): Complete rewrite using `gmm-tool-bar-from-list'. * gnus-group.el (gnus-group-tool-bar, gnus-group-tool-bar-gnome) (gnus-group-tool-bar-retro, gnus-group-tool-bar-zap-list): New variables. (gnus-group-make-tool-bar): Complete rewrite using `gmm-tool-bar-from-list'. (gnus-group-tool-bar-update): New function. * message.el (message-mode-field-menu): Add "Show hidden Headers". 2006-01-25 Katsumi Yamaoka * mm-uu.el (mm-uu-dissect-text-parts): Ignore it if a given part is dissected into a single part of which the type is the same as the given one; decode charset. 2006-01-21 Kevin Ryde * mailcap.el (mailcap-parse-mailcap-extras): "test" key must go into alists as symbol not string, since that's what mailcap-viewer-passes-test and mailcap-mailcap-entry-passes-test look for. 2006-01-24 Reiner Steib * gmm-utils.el (gmm-tool-bar-item): Add "Separator". (gmm-tool-bar-from-list): Suppress tooltip for `gmm-ignore'. * message.el (message-tool-bar-gnome): Use gmm-ignore. 2006-01-24 Katsumi Yamaoka * gnus-xmas.el (gnus-mime-security-button-menu): New alias. (gnus-xmas-mime-security-button-menu): New function. * gnus-art.el (gnus-mime-security-button-commands): New variable. (gnus-mime-security-button-menu): New definition. (gnus-mime-security-button-map): Use them. (gnus-mime-security-button-menu): New function. (gnus-insert-mime-security-button): Addition to help echo. (gnus-mime-security-run-function, gnus-mime-security-save-part) (gnus-mime-security-pipe-part): New functions. * mm-uu.el (mm-uu-buttonize-original-text-parts): Remove. (mm-uu-dissect-text-parts): Revert a part of 2006-01-23 change. * mm-decode.el (mm-handle-set-disposition): Remove. (mm-handle-set-description): Remove. 2006-01-24 Katsumi Yamaoka * mm-view.el (mm-w3m-standalone-supports-m17n-p): New variable. (mm-w3m-standalone-supports-m17n-p): New function. (mm-inline-text-html-render-with-w3m-standalone): Use it to alter w3m usage. * gnus-art.el (gnus-article-wash-html-with-w3m-standalone): Use mm-w3m-standalone-supports-m17n-p to alter w3m usage. 2006-01-23 Reiner Steib * message.el (message-tool-bar-zap-list): Use gmm-tool-bar-zap-list as custom type. (message-tool-bar-update): New function. (message-tool-bar, message-tool-bar-gnome) (message-tool-bar-retro): Add message-tool-bar-update. (message-tool-bar-gnome): Add flyspell-buffer. * gnus-util.el (gnus-error): Describe `args'. * gmm-utils.el (gmm-error): Describe `args'. (gmm-tool-bar-zap-list): New widget. (gmm-tool-bar-from-list): Improve description of `zap-list'. 2006-01-23 Katsumi Yamaoka * mm-uu.el (mm-uu-buttonize-original-text-parts): New variable. (mm-uu-dissect-text-parts): Buttonize original text parts; reduce the number of recursive calls. * mm-decode.el (mm-handle-set-disposition): New macro. (mm-handle-set-description): New macro. 2006-01-23 Katsumi Yamaoka * mm-uu.el (mm-uu-dissect-text-parts): Decode content transfer encoding. 2006-01-20 Reiner Steib * message.el (message-tool-bar-zap-list, message-tool-bar) (message-tool-bar-gnome, message-tool-bar-retro): New variables. (message-tool-bar-local-item-from-menu): Remove. (message-tool-bar-map): Replace by `message-make-tool-bar'. (message-make-tool-bar): New function. (message-mode): Use `message-make-tool-bar'. * gmm-utils.el: New file. (gmm-verbose, gmm-message, gmm-error): From gnus-utils.el. (gmm-lazy): New widget copied from `nnmail.el'. (gmm-tool-bar-from-list): New function for creating customizable tool bars. (gmm-tool-bar-from-list): Fix typos in doc string. Remove debug output. (gmm): Add :prefix to defgroup. 2006-01-20 Per Abrahamsen * gmm-utils.el (gmm-widget-p): New function. 2006-01-20 Reiner Steib * mml.el (mml-attach-file): Describe `description' in doc string. (mml-menu): Add Emacs MIME manual and PGG manual. 2006-01-20 Richard M. Stallman * mm-url.el (mm-url-load-url): Require url-parse and url-vars. 2006-01-20 Kevin Greiner * nntp.el (nntp-end-of-line): Doc fix. 2006-01-20 Chong Yidong * imap.el (imap-open): Handle case where buffer is a buffer object. 2005-01-20 Stefan Monnier * gnus-delay.el (gnus-delay): Don't autoload. It's useless and could trigger a bug in cus-dep.el causing ldefs-boot to be re-loaded when customizing the `gnus-delay' group. 2005-01-20 Chong Yidong * message.el (message-insert-citation-line): Use newlines. 2006-01-19 Ken Manheimer * pgg-pgp.el (pgg-pgp-encrypt-region, pgg-pgp-decrypt-region) (pgg-pgp-sign-region): Add optional 'passphrase' argument to all these routines, so the passphrase can be managed externally and passed in to the system. (pgg-pgp-decrypt-region, pgg-pgp-sign-region): Use new name for pgg-add-passphrase-to-cache function. * pgg-pgp5.el (pgg-pgp5-encrypt-region, pgg-pgp5-decrypt-region) (pgg-pgp5-sign-region): Add optional 'passphrase' argument to all these routines, so the passphrase can be managed externally and passed in to the system. (pgg-pgp5-sign-region): Use new name of pgg-add-passphrase-to-cache function. 2006-01-19 Ken Manheimer * pgg-gpg.el (pgg-gpg-select-matching-key): Fix: look at the right part of the decoded armor to find the key-identifier. (pgg-gpg-lookup-key-owner): New function to return the human-readable identifier of a key owner. (pgg-gpg-key-id-from-key-owner): Make it easy to identify the key itself. (pgg-gpg-decrypt-region): Prompt with the key owner (rather than the key value) if we have a key and can match it against a secret key. Also, added a note pointing out fact that the prompt only indicates the first matching key. * pgg.el (pgg-decrypt): Passing along 'passphrase' in call to pgg-decrypt-region. (pgg-add-passphrase-to-cache): Rename from `pgg-add-passphrase-cache' to reduce confusion (all callers changed). (pgg-remove-passphrase-from-cache): Rename from `pgg-remove-passphrase-cache' to reduce confusion (all callers changed). (pgg-read-passphrase, pgg-add-passphrase-cache) (pgg-remove-passphrase-cache): Add informative docstrings. (pgg-decrypt): Convey provided passphrase in subordinate call to pgg-decrypt-region. 2006-01-19 Ken Manheimer * pgg.el (pgg-encrypt-region, pgg-encrypt-symmetric-region) (pgg-encrypt-symmetric, pgg-encrypt, pgg-decrypt-region) (pgg-decrypt, pgg-sign-region, pgg-sign): Add optional 'passphrase' argument, so the passphrase can be managed externally and then passed in to the system. * pgg.el (pgg-read-passphrase, pgg-add-passphrase-cache) (pgg-remove-passphrase-cache): Add optional 'notruncate' argument, so the passphrase cache can be used reliably with identifiers besides a pgp packet's key id. * pgg-gpg.el (pgg-gpg-encrypt-region) (pgg-gpg-encrypt-symmetric-region, pgg-gpg-decrypt-region) (pgg-gpg-sign-region): Add optional 'passphrase' argument to all these routines, so the passphrase can be managed externally and passed in to the system. * pgg-gpg.el (pgg-gpg-possibly-cache-passphrase): Add optional 'notruncate' argument, so the passphrase cache can be used reliably with identifiers besides a pgp packet's key id. 2006-01-19 Sascha Wilde * pgg-gpg.el (pgg-gpg-encrypt-symmetric-region): New function for symmetric encryption. (pgg-gpg-symmetric-key-p): New function to check for an symmetric encrypted session key. (pgg-gpg-decrypt-region): When decrypting a symmetric encrypted message ask for the passphrase in a proper way. * pgg.el (pgg-encrypt-symmetric, pgg-encrypt-symmetric-region): New user commands for symmetric encryption. 2006-01-19 Katsumi Yamaoka * mm-bodies.el (mm-decode-body): Don't decode decoded body. * mm-uu.el (mm-uu-dissect-text-parts): Dissect dissected parts. 2006-01-19 Mark D. Baushke * pgg-gpg.el (pgg-gpg-encrypt-region): Add --textmode to gpg args. 2006-01-17 Katsumi Yamaoka * mm-decode.el (mm-inlined-types): Add application/pgp. (mm-automatic-display): Ditto. * mm-uu.el (mm-uu-dissect-text-parts): Recognize application/pgp part as text. 2006-01-16 Katsumi Yamaoka * nnrss.el: Update copyright. (nnrss-opml-import): Query whether to subscribe to each entry. * gnus-art.el: * gnus-sum.el: * gnus-xmas.el: * messagexmas.el: * mm-uu.el: * mm-view.el: Update copyright. 2006-01-16 Reiner Steib * message.el (message-info): New function. (message-mode-menu): Add it. Update copyright. * ChangeLog: Fix and update copyright. 2006-01-13 Romain Francoise * message.el (message-forward-subject-name-subject): Prefer the address to 'nowhere' if the sender has no name. Fix typo. Update copyright year. 2006-01-13 Katsumi Yamaoka * gnus-art.el (article-wash-html): Use gnus-summary-show-article-charset-alist if a numeric arg is given. (gnus-article-wash-html-with-w3m-standalone): New function. * mm-view.el (mm-text-html-renderer-alist): Map w3m-standalone to mm-inline-text-html-render-with-w3m-standalone. (mm-text-html-washer-alist): Map w3m-standalone to gnus-article-wash-html-with-w3m-standalone. (mm-inline-text-html-render-with-w3m-standalone): New function. 2006-01-12 Reiner Steib * mm-uu.el (mm-uu-type-alist): Fix previous message-marks commit. Improve LaTeX. 2006-01-10 Katsumi Yamaoka * nnrss.el (nnrss-wash-html-in-text-plain-parts): New variable. (nnrss-request-article): Render text/plain parts as HTML. * gnus-art.el (gnus-article-wash-html-with-w3m): No need to narrow the buffer. 2006-01-08 Reiner Steib * gnus-cus.el (gnus-group-parameters): Sync posting-style with custom definition of `gnus-posting-styles'. * gnus-start.el (gnus-gnus-to-quick-newsrc-format): Bind print-circle. Suggested by Kalle Olavi Niemitalo . 2006-01-05 Reiner Steib * gnus-group.el (gnus-useful-groups): Use Gmane for ding. Use nntp for bug archive. 2006-01-05 Katsumi Yamaoka * nnrss.el (nnrss-request-article): Fix the way to fill text/plain parts. (nnrss-normalize-date): New function converts ISO 8601 date into RFC822 style. Suggested by Mark Plaksin . (nnrss-check-group): Use it. 2006-01-01 Katsumi Yamaoka * gnus-sum.el (gnus-summary-work-articles): Remove useless `min'. * nnrss.el (nnrss-fetch): Make it fail gracefully when it can't fetch a feed. Suggested by Mark Plaksin . (nnrss-insert-w3): Ditto. 2005-12-22 Katsumi Yamaoka * gnus-uu.el (gnus-uu-digest-mail-forward): Reverse the order of the articles to be forwarded including the case where neither a number of articles nor a region is specified. 2005-12-21 Katsumi Yamaoka * nnrss.el (nnrss-request-article): Fix last change; fill text/plain parts. 2005-12-20 Katsumi Yamaoka * nnrss.el (nnrss-request-article): Replace
s with newlines in text/plain part. (nnrss-check-group): Don't add excessive newline to dc:subject. 2005-12-19 Mark Plaksin (tiny change) * nnrss.el (nnrss-check-group): Put the RSS dc:subject in the article. 2005-12-18 Reiner Steib * nnml.el: Don't require gnus-bcklg. Autoload it. (nnml-use-compressed-files, nnml-save-mail): Support other comression programs such as bzip2. 2005-12-17 Lars Magne Ingebrigtsen * dns.el (query-dns): Make sure we check the buffer size before removing tcp headers. 2005-12-16 Katsumi Yamaoka * gnus-art.el (gnus-article-delete-text-of-type): Enable it to remove MIME buttons associated with multipart/alternative parts. (gnus-mime-display-alternative): Tag buttons using `article-type' text property. * gnus-msg.el (gnus-copy-article-buffer): Remove MIME buttons associated with multipart/alternative parts. * gnus-art.el (gnus-signature-separator): Fix custom type. * mm-decode.el (mm-inlined-types): Fix custom type. (mm-keep-viewer-alive-types): Ditto. (mm-automatic-display): Ditto. (mm-attachment-override-types): Ditto. (mm-inline-override-types): Ditto. (mm-automatic-external-display): Ditto. 2005-12-15 Reiner Steib * spam-report.el (spam-report-user-mail-address) (spam-report-user-agent): New variables. (spam-report-url-ping-plain): Use spam-report-user-agent. 2005-12-14 Ralf Angeli * gnus-art.el (gnus-button-handle-custom): Do not just use `customize-apropos' for any "M-x customize-*" button but the function called for. Accept both the function name and its argument in order to achieve this. (gnus-button-alist): Remove support for "custom:" URL's. Pass function name to `gnus-button-handle-custom' in case of "M-x customize-*" buttons. 2005-12-12 Katsumi Yamaoka * gnus-art.el (gnus-buttonized-mime-types): Mention addition of multipart/alternative and add xref to mm-discouraged-alternatives in doc string. * mm-decode.el (mm-discouraged-alternatives): Add xref to gnus-buttonized-mime-types in doc string. 2005-12-08 Reiner Steib * mm-decode.el (mm-discouraged-alternatives): Fix custom type. Suggest image/.* in the doc string. 2005-12-12 Reiner Steib * mm-uu.el (mm-uu-type-alist): Don't depend on message.el for message-marks (Debian bug #342521). 2005-12-12 Simon Josefsson * password.el (password-read-from-cache): Add. (password-read): Use it. 2005-12-12 Katsumi Yamaoka * rfc2047.el (rfc2047-charset-to-coding-system): Recognize us-ascii as a MIME charset. * mm-bodies.el (mm-decode-content-transfer-encoding): Protect against the case where the 2nd arg TYPE is nil. 2005-12-09 Reiner Steib * pop3.el (pop3-stream-type): Fix custom version. * mm-uu.el (mm-uu-type-alist): Simplify uu regexp. 2005-12-09 ARISAWA Akihiro (tiny change) * mm-decode.el (mm-display-external): Add missing cdr. 2005-12-07 Katsumi Yamaoka * mm-decode.el (mm-display-external): Use nametemplate (defined in RFC1524) if it is in mailcap or add a suffix according to mailcap-mime-extensions when generating a temp filename; postpone deleting a temp file for 2 seconds for some wrappers, shell scripts, and so on, which might exit right after having started a viewer command as a background job. 2005-12-06 Reiner Steib * nntp.el (nntp-marks-directory): Fix custom group. * gnus-fun.el (gnus-face-from-file): Decrease quant in smaller steps when < 10. * gnus-start.el (gnus-no-server-1): Mention `gnus-level-default-subscribed' in doc string. 2005-12-02 ARISAWA Akihiro (tiny change) * mm-view.el (mm-inline-text-html-render-with-w3m): Fix misplaced parens. 2005-12-01 Katsumi Yamaoka * gnus-xmas.el (gnus-use-toolbar): Revert. (gnus-xmas-setup-toolbar): Use global default-toolbar if gnus-use-toolbar is default. * messagexmas.el (message-use-toolbar): Revert. (message-setup-toolbar): Use global default-toolbar if message-use-toolbar is default. 2005-11-30 Katsumi Yamaoka * gnus-xmas.el (gnus-use-toolbar): Determine the default value according to default-toolbar-visible-p. * messagexmas.el (message-use-toolbar): Ditto. 2005-11-26 Dave Love * tls.el (open-tls-stream): Rename arg SERVICE to PORT. (tls-program, tls-success): Provide openssl alternative. * starttls.el: Doc fixes. (starttls-open-stream-gnutls, starttls-open-stream): Rename arg SERVICE to PORT. * pop3.el (pop3-open-server) : Clarify a loop. Deal with port null or service name. (starttls-negotiate): Autoload. 2005-11-25 Katsumi Yamaoka * message.el (message-kill-to-signature): Fix interactive spec. 2005-11-24 Katsumi Yamaoka * pop3.el (pop3-open-server): Recognize a string as a service name. 2005-11-24 Pascal Rigaux (tiny change) * rfc2231.el (rfc2231-parse-string): Support non-ascii chars. 2005-11-23 Dave Love Add pop3s, pop3/starttls. * pop3.el (pop3-authentication-scheme): Clarify doc. (open-tls-stream, starttls-open-stream): Autoload. (pop3-stream-type): New. (pop3-open-server): Use it. * mail-source.el (mail-sources): Fix some :types. Add stream type for POP. (mail-source-keyword-map): Add :stream for POP. (mail-source-fetch-pop): Use pop3-stream-type. 2005-11-22 Katsumi Yamaoka * nnmail.el (nnmail-fancy-expiry-target): Use current-time instead of current-time-string. 2005-11-20 Stefan Schimanski (tiny change) * nnmail.el (nnmail-fancy-expiry-target): Protect against invalid date header. 2005-11-19 Kevin Greiner * gnus-sum.el (gnus-fetch-old-headers): Updated docs to warn that it can seriously impact performance as it bypasses the agent's local caches. 2005-11-19 Kevin Greiner * gnus-agent.el (gnus-agent-possibly-synchronize-flags): A server must be explicitly online rather than "not explicitly offline" for its flags to be synchronized. * gnus-sum.el (gnus-summary-remove-process-mark): Always return t so that gnus-uu-unmark-thread will function correctly. * gnus-group.el (gnus-total-fetched-for): Reduced cutoff so that 1024K is instead displayed as 1M. 2005-11-17 Lars Magne Ingebrigtsen * flow-fill.el (fill-flowed): Bind adaptive-fill-mode to nil. 2005-11-16 Boris Samorodov (tiny change) * imap.el (imap-kerberos4-open): Ignore SSL stuff. 2005-11-13 Kevin Greiner * gnus-agent.el (gnus-agent-read-local): Trivial fix to format of error message to display actual error condition. (gnus-agent-save-local): Avoid saving symbols that are bound to nil as they simply result in a warning message in gnus-agent-read-local. 2005-11-13 Katsumi Yamaoka * gnus-start.el (gnus-dribble-read-file): Use make-local-variable rather than make-variable-buffer-local for file-precious-flag. 2005-11-12 Kevin Greiner * gnus-agent.el (gnus-agent-braid-nov): Now tests new nov entries for duplicates which are removed. The invalid sort check then triggers a rescan after the sort as sorting may have moved duplicate entries such that they can be cheaply detected. 2005-11-13 Katsumi Yamaoka * gnus-start.el (gnus-dribble-read-file): Quote file-precious-flag. 2005-11-12 Kevin Greiner * gnus-agent.el (gnus-agent-article-alist-save-format): Changed internal variable to a custom variable. Changed default value from compressed(2) to uncompressed(1). (gnus-agent-read-agentview): Reversed revision 7.8 to restore support for uncompressed agentview files. Taken together, reading the agentview file should now be 6-7 times faster. 2005-11-11 Jan Nieuwenhuizen * gnus-start.el (gnus-dribble-read-file): Set file-precious-flag, as a buffer-local variable. This avoids creating truncated dribble files as a result of a hang up, eg. 2006-01-03 Rodrigo Ventura (tiny change) * gnus-xmas.el (gnus-xmas-group-startup-message): Typo gnus-splash-face -> gnus-splash. Fixes starting from a TTY in XEmacs. 2005-12-09 Reiner Steib * gnus-start.el (gnus-start-draft-setup): Enforce `gnus-draft-mode' for nndraft:drafts at startup. * gnus.el (gnus-splash): Change custom group. (gnus-group-get-parameter, gnus-group-parameter-value): Describe allow-list argument. * gnus-agent.el (gnus-agent-article-alist-save-format): Format doc string. 2005-12-06 Reiner Steib * gnus-art.el (gnus-default-article-saver): Add user-defined `function' to custom type. 2005-10-30 Chong Yidong * imap.el (imap-open): Handle case where buffer is a buffer object. 2005-11-29 Reiner Steib * gnus-cache.el (gnus-cache-rename-group): Wrap doc strings and long lines. (gnus-cache-delete-group): Wrap doc strings. * gnus-agent.el (gnus-agent-rename-group) (gnus-agent-delete-group): Wrap doc strings. 2005-11-10 Katsumi Yamaoka * messagexmas.el (message-use-toolbar): Change the valid values into default, top, bottom, left, and right. (message-toolbar-thickness): New variable. (message-xmas-setup-toolbar): Locate gnus-xmas-glyph-directory as well. (message-setup-toolbar): Make it work. * gnus-xmas.el (gnus-xmas-update-toolbars): New function. (gnus-use-toolbar): Change the valid values into default, top, bottom, left, and right. (gnus-toolbar-thickness): New variable. (gnus-xmas-setup-toolbar): New function. (gnus-xmas-setup-group-toolbar): Use it. (gnus-xmas-setup-summary-toolbar): Use it. 2005-11-10 Lars Magne Ingebrigtsen * gnus-start.el (gnus-1): Add "native" to gnus-predefined-server-alist. * gnus.el (gnus-method-to-server): Don't add "native" to the lists here, because that leads to problems when gnus-select-method is bound. 2005-11-09 Simon Josefsson * gnus-sum.el (gnus-article-sort-by-date-reverse): Remove, use (not sort-by-date) instead. 2005-11-30 Stefan Monnier * gnus-delay.el (gnus-delay-group): Don't autoload. It's useless and could trigger a bug in cus-dep.el causing ldefs-boot to be re-loaded when customizing the `gnus-delay' group. 2005-11-19 Chong Yidong * message.el: Revert last changes. (message-insert-citation-line): Use newlines. 2005-11-17 Chong Yidong * message.el (message-courtesy-message) (message-mark-insert-begin, message-mark-insert-end) (message-elide-ellipsis, message-cancel-message) (message-add-header, message-change-subject) (message-cross-post-followup-to-header) (message-cross-post-insert-note, message-reduce-to-to-cc) (message-widen-reply, message-delete-not-region) (message-kill-to-signature, message-insert-signature) (message-insert-importance-high, message-insert-importance-low) (message-insert-or-toggle-importance) (message-insert-disposition-notification-to) (message-indent-citation, message-yank-original) (message-cite-original-without-signature, message-cite-original) (message-insert-citation-line, message-position-on-field) (message-fix-before-sending, message-send-mail-partially) (message-send-mail, message-send-mail-with-sendmail) (message-send-mail-with-qmail, message-send-news) (message-check-news-header-syntax, message-generate-headers) (message-insert-courtesy-copy, message-fill-address) (message-fill-header, message-shorten-references) (message-setup-1, message-cancel-news) (message-forward-make-body-plain, message-forward-make-body-mime) (message-forward-make-body-mml, message-encode-message-body) (message-forward-make-body-digest-plain) (message-forward-make-body-digest-mime) (message-use-alternative-email-as-from): Insert `hard-newline' instead of ordinary newlines. 2005-11-09 Katsumi Yamaoka * message.el (message-generate-headers): Downcase the argument given to message-check-element. 2005-11-08 Kevin Greiner * nntp.el (nntp-authinfo-rejected): New error condition. (nntp-wait-for): Use new error condition to signal authentication error. (nntp-retrieve-data): Rethrow new error condition to break out of recursive call to nntp-send-authinfo. 2005-11-08 Romain Francoise * gnus-sum.el (gnus-summary-catchup-and-goto-prev-group): New function. (gnus-summary-exit-map): Bind to `Z p'. (gnus-summary-make-menu-bar): Add menu item. 2005-11-02 Reiner Steib * gnus-art.el (gnus-article-treat-custom): Add `first'. (gnus-treat-*): Add `first' in all doc strings. * gnus-group.el (gnus-group-compact-group): Fix typo. 2005-11-01 Katsumi Yamaoka * gnus.el (gnus-parameters-case-fold-search): New variable. (gnus-parameters-get-parameter): Use it. * gnus-score.el (gnus-home-score-file): Doc fix. 2005-11-01 Xavier Maillard (tiny change) * gnus-score.el (gnus-update-score-entry-dates): Doc fix. 2005-10-31 Katsumi Yamaoka * mm-util.el (mm-special-display-p): New function. * mml.el (mml-preview): Use it; doc fix. 2005-10-30 Chong Yidong * imap.el (imap-open): Handle case where buffer is a buffer object. 2005-10-29 Romain Francoise * message.el (message-fix-before-sending): Fix comment. 2005-10-29 Jari Aalto * gnus-sum.el (gnus-article-sort-by-date-reverse): New function. 2005-10-29 Jari Aalto * score-mode.el (gnus-score-edit-done-hook): Introduce variable. Used in gnus-score.el. 2005-10-28 Reiner Steib * mm-util.el (mm-codepage-setup): Remove bogus alias test. 2005-10-27 Reiner Steib * flow-fill.el (fill-flowed-encode-tests): Restore trailing whitespace removed in revision 7.8. Use concatenated string to protect trailing whitespace. 2005-10-27 Jouni K. Seppänen * nnimap.el (nnimap-search-uids-not-since-is-evil): Add variable. (nnimap-request-expire-articles): Use it to avoid sending 'UID SEARCH UID ... NOT SINCE' queries, for inefficient servers like Courier IMAP ("some version from 2004"). Mostly based on similar code in the same function. 2005-10-26 Didier Verna * gnus-group.el (gnus-group-compact-group): Invalidate original article buffer. * gnus-srvr.el (gnus-server-compact-server): Ditto. * nnml.el (nnml-request-compact-group): Handle self Xref: field in NOV database and in article itself. Invalidate article backlog. 2005-10-26 Reiner Steib * mm-uu.el (mm-uu-hide-markers): Fix XEmacs case. 2005-10-26 Simon Josefsson * flow-fill.el (fill-flowed): Flow-fill unquoted lines too, revert part of 2004-07-25 change. 2005-10-26 Katsumi Yamaoka * message.el (message-display-completion-list): New function. (message-expand-group): Use it; make sure the Completions buffer is modifiable. 2005-10-23 Chong Yidong * gnus-sum.el (gnus-ignored-from-addresses): Handle case where user-mail-name is an empty string. 2005-10-25 Reiner Steib * gnus-score.el (gnus-default-adaptive-score-alist): Set defaults depending on gnus-score-decay-constant. * encrypt.el (encrypt-insert-file-contents) (encrypt-write-file-contents): Don't use `gnus-message'. * mm-uu.el (mm-uu-verbatim-marks-extract): Add four start and end arguments. (mm-uu-type-alist): Add message-marks and insert-marks. Pass arguments to mm-uu-verbatim-marks-extract. (mm-uu-hide-markers): New variable. (mm-uu-extract): Use face similar to `gnus-cite-3'. * gnus-fun.el (gnus-convert-image-to-x-face-command) (gnus-convert-image-to-face-command): Use "convert" by default to allow other input image formats. (gnus-x-face-from-file, gnus-face-from-file): Adjust doc strings accordingly. 2005-10-23 Simon Josefsson * imap.el (imap-gssapi-program): Align command line parameters with latest GNU SASL. (imap-gssapi-open): Ignore 'Trying ...' messages from GNU SASL. 2005-10-21 Lars Magne Ingebrigtsen * nnslashdot.el (nnslashdot-retrieve-headers-1): Update to new HTML. (nnslashdot-request-article): Ditto. * lpath.el (featurep): Add nobreak-char-display. 2005-10-20 Hiroshi Fujishima (tiny change) * mail-source.el (mail-source-fetch-pop): Require pop3. (mail-source-check-pop): Ditto. 2005-10-20 Katsumi Yamaoka * rfc2047.el (rfc2047-decode-encoded-words): Fix the handling of errors. 2005-10-19 Reiner Steib * gnus-art.el (gnus-treat-strip-trailing-blank-lines) (gnus-treat-strip-leading-blank-lines): Improve doc string. * message.el (message-tool-bar-local-item-from-menu): Fix comment. * mm-bodies.el (mm-decode-string): Call `mm-charset-to-coding-system' with allow-override argument. 2005-10-19 Katsumi Yamaoka * rfc2047.el (rfc2047-allow-incomplete-encoded-text): New variable. (rfc2047-charset-to-coding-system): New function. (rfc2047-decode-encoded-words): New function. (rfc2047-decode-region): Use them. (rfc2047-decode-cte): Remove. (rfc2047-parse-and-decode): Remove. (rfc2047-decode): Remove. 2005-10-15 Kenichi Handa * rfc2047.el (rfc2047-decode-cte): New function. (rfc2047-decode-region): Change the way to decode successive encoded-words: decode B- or Q-encoding in each encoded-word, concatenate them, and decode it as charset. 2005-10-14 Katsumi Yamaoka * lpath.el: Fbind codepage-setup for XEmacs. 2005-10-17 Chong Yidong * gnus-cus.el (gnus-custom-map): New variable. Bind mouse-1 to widget-move-and-invoke. (gnus-custom-mode): Use gnus-custom-map. 2005-10-15 Bill Wohler * message.el (message-tool-bar-map): Renamed image file from mail_send to mail/send. 2005-10-16 Masatake YAMATO * message.el (message-expand-group): Pass the common prefix substring of completion to `display-completion-list'. 2005-10-13 Reiner Steib * mml-sec.el (mml-secure-method): New internal variable. (mml-secure-sign, mml-secure-encrypt, mml-secure-message-sign) (mml-secure-message-sign-encrypt, mml-secure-message-encrypt): New functions using mml-secure-method. * mml.el (mml-mode-map): Add key bindings for those functions. (mml-menu): Simplify security menu entries. Suggested by Jesper Harder . (mml-attach-file, mml-attach-buffer, mml-attach-external): Goto end of message if point is the headers of the message. * message.el (message-in-body-p): New function. * assistant.el: Autoload gnus-util and netrc. * mm-util.el (mm-charset-to-coding-system): Add allow-override. Use `mm-charset-override-alist' only when decoding. * mm-bodies.el (mm-decode-body): Call `mm-charset-to-coding-system' with allow-override argument. * gnus-art.el (gnus-mime-view-part-as-type-internal): Try to fetch `filename' from Content-Disposition if Content-Type doesn't provide `name'. (gnus-mime-view-part-as-type): Set default instead of initial-input. 2005-10-09 Daniel Brockman * format-spec.el (format-spec): Propagate text properties of % spec. 2005-10-12 Reiner Steib * gnus-art.el (gnus-treat-predicate): Add `first'. 2005-10-11 Reiner Steib * mm-util.el (mm-charset-synonym-alist): Improve doc string. (mm-charset-override-alist): New variable. (mm-charset-to-coding-system): Use it. (mm-codepage-setup): New helper function. (mm-charset-eval-alist): New variable. (mm-charset-to-coding-system): Use mm-charset-eval-alist. Warn about unknown charsets. * dgnushack.el (with-syntax-table): Add some URLs WRT the XEmacs bug. 2005-10-04 David Hansen * nnrss.el (nnrss-request-article): Add support for the comments tag. (nnrss-check-group): Ditto. 2005-10-04 Reiner Steib * mm-uu.el (mm-uu-verbatim-marks-extract, mm-uu-latex-extract): Rename x-gnus-verbatim to x-verbatim. (mm-uu-type-alist): Fix regexp for verbatim-marks. * mm-decode.el (mm-automatic-display): Rename x-gnus-verbatim to x-verbatim. * mm-url.el (mm-url-predefined-programs): Add switches for curl. * gnus-util.el (gnus-remove-duplicates): Remove. * nnmail.el (nnmail-article-group): Use mm-delete-duplicates instead of gnus-remove-duplicates. * message.el (message-remove-duplicates): Remove. (message-idna-to-ascii-rhs-1): Use mm-delete-duplicates instead of message-remove-duplicates. * mm-util.el (mm-delete-duplicates): Use `delete-dups' if available, else use implementation from `delete-dups'. * message.el (message-insert-expires): New function. (message-mode-map): Add key binding. (message-mode-field-menu): Add menu entry. (message-mode): Document it. (message-make-expires-date): Use `message-make-date'. 2005-10-04 Josh Huber * message.el (message-make-expires-date): New function. 2005-10-04 Katsumi Yamaoka * Makefile.in (list-installed-shadows): New entry. (install): Use it. (remove-installed-shadows): New entry. * dgnushack.el (dgnushack-default-load-path): New variable. (dgnushack-find-lisp-shadows): New function. (dgnushack-remove-lisp-shadows): New function. 2005-10-02 Katsumi Yamaoka * Makefile.in (install-el-elc): New entry. (install): Use it so that .el files are necessarily installed. 2005-09-30 Katsumi Yamaoka * time-date.el: Autoload parse-time-string, XEmacs needs it. 2005-09-30 Stefan Monnier * mm-decode.el (mm-inline-media-tests): Check presence of the diff-mode function rather than the diff-mode.el package. (mm-display-external): Use with-current-buffer. (mm-viewer-completion-map, mm-viewer-completion-map): Move initialization inside declaration. 2005-09-29 Simon Josefsson * spam.el: Load hashcash when compiling, to avoid warnings. Don't autoload mail-check-payment. (spam-check-hashcash): Define unconditionally, since hashcash.el is part of Gnus now. Ignore errors from payment checking. 2005-09-28 Reiner Steib * message.el (message-bold-region, message-unbold-region): Rename from `bold-region' and `unbold-region'. * message.el: Remove useless autoloads. 2005-09-28 Simon Josefsson * message.el (message-use-idna): Default to t. (message-use-idna): Test whether encoding works too. Doc fix. 2005-09-28 Katsumi Yamaoka * nntp.el (nntp-warn-about-losing-connection): Remove. 2005-09-27 Reiner Steib * mm-uu.el (mm-uu-emacs-sources-regexp): Make variable customizable. Change default value. (mm-uu-diff-groups-regexp): Change default value. (mm-uu-type-alist): Add doc string. (mm-uu-configure): Add doc string. Make it interactive. (mm-uu-tex-groups-regexp): New variable. (mm-uu-latex-extract, mm-uu-latex-test): New functions. (mm-uu-type-alist): Add LaTeX documents. (mm-uu-verbatim-marks-extract): Use "text/x-gnus-verbatim" instead of "text/verbatim". (mm-uu-diff-groups-regexp): Fix missing quotes from previous commit. * mm-decode.el (mm-automatic-display): Use "text/x-gnus-verbatim" instead of "text/verbatim". * message.el (message-mark-inserted-region) (message-mark-insert-file): Use slrn style marks when called with prefix argument. 2005-09-27 Simon Josefsson * message.el (message-idna-to-ascii-rhs-1): Reformat. 2005-09-27 Arne Jørgensen * message.el (message-remove-duplicates): New function. Implementation borrowed from `gnus-remove-duplicates'. (message-idna-to-ascii-rhs): Also encode idna addresses in Reply-To:, Mail-Reply-To: and Mail-Followup-To:. (message-idna-to-ascii-rhs-1): When `message-use-idna' is 'ask only ask about the same idna domain once per header and also tell in what header to replace the idna domain. * gnus-art.el (article-decode-idna-rhs): Also decode idna addresses in Reply-To:, Mail-Reply-To: and Mail-Followup-To:. (article-decode-idna-rhs): Fix regexp so that all idna-address in a header is decoded and not just the last one. 2005-09-27 Katsumi Yamaoka * gnus-art.el (gnus-mime-display-single): Don't modify text if it has been decoded. * mm-decode.el (mm-automatic-display): Add text/verbatim. (mm-insert-part): Don't modify text if it has been decoded. * mm-uu.el (mm-uu-verbatim-marks-extract): Say text has been decoded. * mm-view.el (mm-inline-text): Don't strip text props unless decoding enriched or richtext parts. 2005-09-25 Romain Francoise * gnus-agent.el (gnus-agent-expire-group, gnus-agent-expire): * gnus-start.el (gnus-subscribe-interactively): * gnus-uu.el (gnus-uu-grab-articles): End `yes-or-no-p' and `y-or-n-p' prompts with question mark and space. 2005-09-24 Emilio C. Lopes * smime.el (smime-sign-buffer, smime-decrypt-buffer): * mm-view.el (mm-view-pkcs7-decrypt): * gnus-sum.el (gnus-summary-limit-to-extra) (gnus-summary-respool-article, gnus-read-move-group-name): * gnus-score.el (gnus-summary-increase-score): * gnus-util.el (gnus-completing-read-with-default): * gnus-art.el (gnus-read-save-file-name) (gnus-summary-save-in-rmail, gnus-summary-save-in-mail) (gnus-summary-save-in-file, gnus-summary-save-body-in-file): * message.el (message-check-news-header-syntax): Follow convention for reading with the minibuffer. 2005-09-22 Reiner Steib * spam-report.el (spam-report-url-ping-plain): Use gnus-extended-version as User-Agent. * gnus-agent.el (gnus-agent-synchronize-flags): Explain why the default value is nil. * mm-uu.el (mm-uu-type-alist): Added slrn style verbatim-marks. (mm-uu-verbatim-marks-extract): New function. (mm-uu-extract): New face. (mm-uu-copy-to-buffer): Use it. * spam-report.el (spam-report-gmane-ham): Renamed from `spam-report-gmane-unspam'. (spam-report-gmane-internal): Renamed from `spam-report-gmane'. Simplify use of UNSPAM argument. Fetch "X-Report-Unspam" header. * spam.el (spam-report-gmane-spam, spam-report-gmane-ham): Autoload. (spam-report-gmane-unregister-routine): Renamed `spam-report-gmane-unspam' to `spam-report-gmane-ham'. 2005-09-21 Teodor Zlatanov * spam.el (spam-use-gmane, spam-report-gmane-register-routine) (spam-report-gmane-unregister-routine): Add support for gmane unregistration. * spam-report.el (spam-report-gmane-unspam) (spam-report-gmane-spam): Add new wrappers around spam-report-gmane. (spam-report-gmane): Change to take a single article and do unspam registration. 2005-09-19 Reiner Steib * mm-url.el (mm-url-decode-entities): Fix regexp. 2005-09-20 Lars Magne Ingebrigtsen * gnus-agent.el (gnus-agent-synchronize-flags): Switch the default to nil, to be able to use Gnus at all. If the default switches to something else, then the function should be fixed not be exceedingly slow. 2005-09-20 Teodor Zlatanov * gnus-start.el (gnus-activate-group): If the server is nil, don't fail hard. * spam-report.el: Add better Keywords line. * spam.el: Add Maintainer and better Keywords line. 2005-09-19 Reiner Steib * gnus-art.el (gnus-article-replace-part) (gnus-mime-replace-part): New functions. (gnus-mime-action-alist, gnus-mime-button-commands) (gnus-mime-save-part-and-strip): Added file argument. (gnus-article-part-wrapper): Added interactive argument. * gnus-sum.el (gnus-summary-mime-map): Add `gnus-article-replace-part'. 2005-09-19 Didier Verna The nnml compaction feature: * nnml.el (nnml-request-compact-group): New function. * nnml.el (nnml-request-compact): New function. * gnus-int.el (gnus-request-compact-group): New function. * gnus-int.el (gnus-request-compact): New function. * gnus-group.el (gnus-group-compact-group): New function. * gnus-group.el (gnus-group-group-map): Bind it to 'G z'. * gnus-group.el (gnus-group-make-menu-bar): Add an entry for it. * gnus-srvr.el (gnus-server-compact-server): New function. * gnus-srvr.el (gnus-server-mode-map): Bind it to 'z'. * gnus-srvr.el (gnus-server-make-menu-bar): Add an entry for it. 2005-09-18 Deepak Goel * sieve.el (sieve-help): Fix `message' call: first arg should be a format spec. 2005-09-16 Katsumi Yamaoka * gnus.el (gnus-group-startup-message): Bind image-load-path. 2005-09-15 Romain Francoise * message.el (message-fill-paragraph): Clarify docstring. 2005-09-14 Katsumi Yamaoka * gnus-art.el (gnus-mime-display-part): Protect against broken MIME messages. 2005-09-13 Katsumi Yamaoka * gnus-sum.el (gnus-summary-edit-article-done): Remove text props before parsing header. 2005-09-11 Jari Aalto * html2text.el (html2text-replace-list): Add new entities. 2005-09-11 Romain Francoise * message.el (message-alternative-emails): Improve docstring. (message-setup-1): Call `message-use-alternative-email-as-from' after `message-setup-hook' to give it precedence over posting styles, etc. (message-use-alternative-email-as-from): Add docstring. Remove the original From header if present. * nnml.el (nnml-compressed-files-size-threshold): New variable. (nnml-save-mail): Use it. * gnus-uu.el (gnus-uu-mark-series): Return number of marked articles. Add new argument `silent'. (gnus-uu-mark-all): Report the total number of marked articles. 2005-09-10 Romain Francoise * gnus-uu.el (gnus-message-process-mark): Use gnus-message. (gnus-uu-mark-series): Likewise. 2005-09-10 Reiner Steib * spam-report.el (spam-report-gmane): Fix generation of spam report URL. 2005-09-10 Simon Josefsson * gnus-agent.el (gnus-agent-synchronize-flags): Make the default t, based on discussion on the ding list with Robert Epprecht . 2005-09-07 Reiner Steib * spam-report.el (spam-report-gmane): Make it work without X-Report-Spam header. Gmane now only provides Archived-At. This is only used if `spam-report-gmane-use-article-number' is nil. (spam-report-gmane-spam-header): Remove. Not used anymore. * gnus-sum.el (gnus-thread-sort-by-recipient): New function to make `gnus-summary-sort-by-recipient' work with threading. * nnweb.el (nnweb-google-wash-article): Print a message if article is not available. 2005-09-07 TSUCHIYA Masatoshi * gnus-art.el (gnus-mime-display-single): Revert 2004-10-07 change. Decode text/* parts content before displaying. 2005-09-06 Reiner Steib * mml-smime.el: Remove defvar of gnus-extract-address-components. 2005-09-06 Katsumi Yamaoka * mm-view.el (mm-display-inline-fontify): Disable support modes. * lpath.el: Don't bind mc-pgp-always-sign, url-current-object, url-package-name, url-package-version, w3m-cid-retrieve-function-alist, w3m-current-buffer, w3m-display-inline-images, and w3m-minor-mode-map. 2005-09-05 Reiner Steib * message.el (message-tab-body-function): Fix mismatched custom type. * gnus.el (gnus-group-change-level-function): Ditto. * gnus-msg.el (gnus-outgoing-message-group): Ditto. * gnus-art.el (gnus-signature-limit) (gnus-article-mime-part-function): Ditto. 2005-09-05 Katsumi Yamaoka * mml.el (mml-mode): Silence the byte compiler. * gnus-art.el (gnus-article-jump-to-part): Redisplay the article using `(sit-for 0)' before moving the point to the specified part; skip unbuttonized parts. (gnus-article-part-wrapper): Don't use save-window-excursion; don't return to the summary window if gnus-auto-select-part is non-nil. 2005-09-04 Reiner Steib * mml.el (mml-dnd-protocol-alist, mml-dnd-attach-options): New variables. (mml-dnd-attach-file, mml-mode): Use them. * nnweb.el (nnweb-type-definition, nnweb-google-wash-article): Make fetching article by MID work again for Google Groups. Added FIXME concerning gnus-group-make-web-group. * mml-smime.el (mml-smime-sign-query, mml-smime-get-dns-cert): Don't depend on Gnus by using mail-extract-address-components if gnus-extract-address-components is not bound. 2005-09-04 Lars Magne Ingebrigtsen * gnus-art.el (gnus-mime-display-security): Don't display the signature, but only the signed part. 2005-09-02 Katsumi Yamaoka * gnus-sum.el (gnus-thread-hide-subtree): Doc fix. * gnus-msg.el (gnus-inews-insert-gcc): Fix the mistake of using list, not listp. 2005-09-02 Hrvoje Niksic * mm-encode.el (mm-encode-content-transfer-encoding): Likewise when encoding. * mm-bodies.el (mm-decode-content-transfer-encoding): De-canonicalize CRLF for all text content types, not just text/plain. 2005-09-01 Katsumi Yamaoka * gnus-art.el (gnus-article-part-wrapper): Error if there's no valid article; point arrow and cursor at the MIME button. 2005-08-30 Katsumi Yamaoka * gnus-art.el (gnus-mime-save-part-and-strip): Clarify prompt. Suggested by Dan Christensen . * mm-decode.el (mm-save-part): Enable change of prompt. 2005-08-29 Jari Aalto * gnus-msg.el (gnus-inews-add-send-actions): Made `message-post-method' lambda parameter ARG `&optional'. 2005-08-29 Reiner Steib * gnus-sum.el (gnus-summary-mime-map): Added gnus-article-save-part-and-strip, gnus-article-delete-part and gnus-article-jump-to-part. * gnus-art.el (gnus-article-edit-article): Added quiet argument. (gnus-article-edit-part): Use it. (gnus-article-part-wrapper): Added no-handle argument. (gnus-article-save-part-and-strip, gnus-article-delete-part): New functions. 2005-08-29 Romain Francoise * gnus-fun.el (gnus-convert-image-to-face-command): Fix typo in docstring. (gnus-face-from-file): Likewise. 2005-08-29 Reiner Steib * gnus-art.el (gnus-mime-save-part-and-strip): Don't prompt. (gnus-mime-delete-part): Don't prompt if `gnus-expert-user' is non-nil. (gnus-auto-select-part): New variable. (gnus-article-jump-to-part): New function. (gnus-article-edit-part, gnus-mime-save-part-and-strip) (gnus-mime-delete-part): Allow selecting specified part after deleting or stripping parts. (gnus-article-jump-to-part): Don't use `read-number'. Use last part if argument is bogus. 2005-08-31 Juanma Barranquero * gnus-art.el (w3m-minor-mode-map): * gnus-spec.el (gnus-newsrc-file-version): * gnus-util.el (nnmail-active-file-coding-system) (gnus-original-article-buffer, gnus-user-agent): * gnus.el (gnus-ham-process-destinations) (gnus-parameter-ham-marks-alist) (gnus-parameter-spam-marks-alist, gnus-spam-autodetect) (gnus-spam-autodetect-methods, gnus-spam-newsgroup-contents) (gnus-spam-process-destinations, gnus-spam-process-newsgroups): * mm-decode.el (gnus-current-window-configuration): * mm-extern.el (gnus-article-mime-handles): * mm-url.el (url-current-object, url-package-name) (url-package-version): * mm-view.el (gnus-article-mime-handles, gnus-newsgroup-charset) (smime-keys, w3m-cid-retrieve-function-alist) (w3m-current-buffer, w3m-display-inline-images) (w3m-minor-mode-map): * mml-smime.el (gnus-extract-address-components): * mml.el (gnus-article-mime-handles, gnus-mouse-2) (gnus-newsrc-hashtb, message-default-charset) (message-deletable-headers, message-options) (message-posting-charset, message-required-mail-headers) (message-required-news-headers): * mml1991.el (mc-pgp-always-sign): * mml2015.el (mc-pgp-always-sign): * nnheader.el (nnmail-extra-headers): * rfc1843.el (gnus-decode-encoded-word-function) (gnus-decode-header-function, gnus-newsgroup-name): * spam-stat.el (gnus-original-article-buffer): Add defvars. 2005-08-22 Karl Chen * gnus-art.el (gnus-treatment-function-alist): Move date-lapsed to the end of the date treatments. 2005-08-15 Simon Josefsson * pgg.el (url-insert-file-contents): Don't autoload it, Emacs has it in url-handlers.el and XEmacs in url.el. Reported by Luca Capello and Romain Francoise. (pgg-fetch-key-function): Removed, not used? (pgg-insert-url-with-w3): Require url, to get url-insert-file-contents regardless of where it is defined. 2005-08-13 Romain Francoise * message.el (message-cite-original-1): New function. (message-cite-original): Use it. (message-cite-original-without-signature): Ditto. 2005-08-08 Romain Francoise * message.el (message-yank-empty-prefix): New variable. (message-indent-citation): Use it. (message-cite-original-without-signature): Respect X-No-Archive. 2005-08-08 Simon Josefsson * pgg.el: Autoload url-insert-file-contents instead of loading w3/url. (pgg-insert-url-with-w3): Don't load url here. 2005-08-07 Jesper Harder * message.el (message-kill-to-signature): Don't insert newline at bol. (message-newline-and-reformat): Bind fill-paragraph-function to nil. 2005-08-06 Romain Francoise * message.el (message-user-fqdn): Fix typo in docstring. 2005-08-05 Daiki Ueno * mml2015.el (mml2015-pgg-sign): Make sure micalg is correct. * pgg-parse.el (pgg-parse-hash-algorithm-alist): Add SHA-2. 2005-08-05 Katsumi Yamaoka * mm-bodies.el (mm-encode-body): Use coding system rather than charset to encode text. * mm-util.el (mm-find-mime-charset-region): Attempt to reduce the number of charsets if utf-8 is available (XEmacs). 2005-08-04 Reiner Steib * gnus-art.el (gnus-button-valid-localpart-regexp): New variable taken from `gnus-button-mid-or-mail-regexp'. (gnus-button-mid-or-mail-regexp, gnus-button-alist): Use it. (gnus-button-alist): Improve regexp for domain part of the MIDs for news:localpart@domain buttons. (gnus-button-ctan-directory-regexp): Update. 2005-08-02 Katsumi Yamaoka * sieve-manage.el (sieve-manage-interactive-login): Use make-local-variable rather than make-variable-buffer-local. (sieve-manage-open): Ditto. (sieve-manage-authenticate): Ditto. * mml.el (mml-generate-mime-1): Make the content type default to text/plain if the filename is not specified. 2005-08-01 Katsumi Yamaoka * gnus-uu.el (gnus-uu-save-article): Use insert-buffer-substring instead of insert-buffer. * message.el (message-yank-original): Ditto; set the mark at the end of the yanked message. 2005-07-29 Katsumi Yamaoka * gnus-art.el (gnus-article-next-page-1): Reduce the number of lines to scroll rather than to stop it. * mml.el (mml-generate-default-type): Add doc string. (mml-generate-mime-1): Use mm-default-file-encoding or make it default to application/octet-stream when determining the content type if it is not specified for the part or the mml contents; add a comment about mml-generate-default-type. 2005-07-29 Reiner Steib * mml.el (mml-generate-mime-1): Use mm-default-file-encoding or make it default to application/octet-stream when determining the content type if it is not specified for the external contents. 2005-07-28 Katsumi Yamaoka * rfc2231.el (rfc2231-parse-string): Take care that not only a segmented parameter but also other parameters might be there. 2005-07-27 Katsumi Yamaoka * mm-decode.el (mm-display-external): Delete temp file, directory and buffer immediately if the external process is exited. 2005-07-26 Katsumi Yamaoka * gnus-art.el (gnus-article-next-page-1): Don't scroll if there're fewer lines than that of scroll-margin. (gnus-article-prev-page): Narrow the range to bind scroll-in-place. 2005-07-25 Katsumi Yamaoka * gnus-art.el (gnus-article-next-page): Revert. (gnus-article-beginning-of-window): New macro. (gnus-article-next-page-1): Use it. (gnus-article-prev-page): Ditto. (gnus-article-edit-part): Use insert-buffer-substring instead of insert-buffer. (gnus-article-edit-exit): Ditto. * gnus-util.el (gnus-beginning-of-window): Remove. (gnus-end-of-window): Remove. * lpath.el: Don't bind header-line-format and scroll-margin. 2005-07-25 Simon Josefsson * pgg.el (pgg-insert-url-with-w3): Don't load w3, it is possible to have the url package without w3. Reported by Daiki Ueno and Luigi Panzeri . 2005-07-20 Didier Verna * gnus-diary.el: Remove the description comment (nndiary is now properly documented in the Gnus manual). Fix the spelling of "Back End". * nndiary.el: Ditto. Fix the copyright notice. 2005-07-18 Romain Francoise * gnus-sum.el (gnus-summary-to-prefix, gnus-summary-newsgroup-prefix): New variables. (gnus-summary-from-or-to-or-newsgroups): Use them. 2005-07-17 Romain Francoise * mml2015.el (mml2015-clean-buffer): Prefix buffer name with a space as it's generally not especially interesting to the user. 2005-07-16 Romain Francoise * nnfolder.el (nnfolder-save-buffer): Bind `copyright-update' to nil to avoid prompting and file modification if one of the messages at the top of the nnfolder file contains a copyright notice. Update copyright notice. * gnus-uu.el (gnus-uu-save-article): Use `message-make-date' instead of `current-time-string' as the latter creates a time string that is not RFC 2822 compliant (it lacks the zone). Update copyright notice. 2005-07-21 Stefan Monnier * mml.el (mml-minibuffer-read-disposition): Don't use inline by default for text/rtf. Display default in prompt. Pass default for M-n. * mm-uu.el (mm-uu-copy-to-buffer): Use with-current-buffer. 2005-07-16 Lars Magne Ingebrigtsen * gnus-msg.el (gnus-button-mailto): Remove save-selected-window-window hackery because it relies on save-selected-window internals. 2005-07-15 Katsumi Yamaoka * gnus-art.el (gnus-article-next-page): Use gnus-end-of-window. (gnus-article-next-page-1): Use gnus-beginning-of-window. (gnus-article-prev-page): Ditto. * gnus-util.el (gnus-beginning-of-window): New function. (gnus-end-of-window): New function. * lpath.el: Bind header-line-format and scroll-margin for XEmacs. 2005-07-14 Hiroshi Fujishima (tiny change) * gnus-score.el (gnus-score-edit-all-score): Set gnus-score-edit-exit-function to gnus-score-edit-done and call gnus-message. 2005-07-14 Lars Magne Ingebrigtsen * gnus-msg.el (gnus-button-mailto): Remove save-selected-window-window hackery because it relies on save-selected-window internals. 2005-07-13 Katsumi Yamaoka * gnus-salt.el (gnus-pick-mode): Remove the 5th arg of add-minor-mode. (gnus-binary-mode): Ditto. * gnus-topic.el (gnus-topic-mode): Ditto. 2005-07-08 Ralf Angeli * gnus-art.el (gnus-article-next-page, gnus-article-next-page-1) (gnus-article-prev-page): Take scroll-margin into consideration. 2005-07-04 Lute Kamstra Update FSF's address in GPL notices. 2005-07-04 Juanma Barranquero * gnus.el (gnus-exit): * gnus-group.el (gnus-group-icons): * nnmail.el (nnmail-prepare): Fix typos in docstrings. * gnus-nocem.el (gnus-nocem): * message.el (message-various, message-buffers, message-sending) (message-interface, message-forwarding, message-insertion) (message-headers, message-news, message-mail): * pgg-gpg.el (pgg-gpg): * pgg-parse.el (pgg-parse): * pgg-pgp.el (pgg-pgp): * pgg-pgp5.el (pgg-pgp5): * pop3.el (pop3): Finish `defgroup' description with period. 2005-07-01 Katsumi Yamaoka * gnus-art.el (article-display-face): Improve the efficiency. (article-display-x-face): Ditto; remove grey x-face stuff. 2005-06-30 Katsumi Yamaoka * gnus-art.el (article-display-face): Correct the position in which Faces are inserted. 2005-06-29 Didier Verna * gnus-art.el (article-display-face): Display faces in correct order. 2005-06-29 Katsumi Yamaoka * gnus-nocem.el (gnus-nocem-verifyer): Default to pgg-verify. (gnus-fill-real-hashtb): Use hash table instead of obarray. (gnus-nocem-check-article): Fetch the Type header. (gnus-nocem-message-wanted-p): Fix the way to examine types. (gnus-nocem-verify-issuer): Use functionp instead of fboundp. (gnus-nocem-enter-article): Use hash tables rather than obarrays; make sure gnus-nocem-hashtb is initialized. (gnus-nocem-alist-to-hashtb): Use hash table instead of obarray. (gnus-nocem-unwanted-article-p): Ditto. * pgg.el (pgg-verify): Return the verification result. 2005-06-27 Lars Magne Ingebrigtsen * gnus-art.el (gnus-mime-copy-part): Check whether coding-system is ascii. 2005-06-24 Juanma Barranquero * gnus-art.el (gnus-article-mode): Set `nobreak-char-display', not `show-nonbreak-escape'. 2005-06-23 Lute Kamstra * gnus-art.el (gnus-article-mode): Use kill-all-local-variables. * dig.el (dig-mode): * smime.el (smime-mode): Use gnus-run-mode-hooks. 2005-06-21 Juanma Barranquero * nnimap.el (nnimap-split-download-body): Fix spellings. 2005-06-16 Juanma Barranquero * gnus-art.el (gnus-article-encrypt-body): * gnus-cus.el (gnus-score-customize): * mm-extern.el (mm-extern-local-file, mm-inline-external-body): * pop3.el (pop3-user): Don't use `format' on `error' arguments. 2005-06-16 Arne Jørgensen * smime.el (smime-cert-by-ldap-1): Detect PEM format without header by looking for magic "MII" at the beginnig. 2005-06-16 Miles Bader * gnus-xmas.el (gnus-xmas-group-startup-message): Use renamed gnus-splash face. * assistant.el (assistant-field): Remove "-face" suffix from face name. (assistant-field-face): New backward-compatibility alias for renamed face. (assistant-render-text): Use renamed assistant-field face. * spam.el (spam): Remove "-face" suffix from face name. (spam-face): New backward-compatibility alias for renamed face. (spam-face, spam-initialize): Use renamed spam face. * message.el (message-header-to, message-header-cc) (message-header-subject, message-header-newsgroups) (message-header-other, message-header-name) (message-header-xheader, message-separator, message-cited-text) (message-mml): Remove "-face" suffix from face names. (message-header-to-face, message-header-cc-face) (message-header-subject-face, message-header-newsgroups-face) (message-header-other-face, message-header-name-face) (message-header-xheader-face, message-separator-face) (message-cited-text-face, message-mml-face): New backward-compatibility aliases for renamed faces. (message-font-lock-keywords): Use renamed message faces. * sieve-mode.el (sieve-control-commands, sieve-action-commands) (sieve-test-commands, sieve-tagged-arguments): Remove "-face" suffix from face names. (sieve-control-commands-face, sieve-action-commands-face) (sieve-test-commands-face, sieve-tagged-arguments-face): New backward-compatibility aliases for renamed faces. (sieve-control-commands-face, sieve-action-commands-face) (sieve-test-commands-face, sieve-tagged-arguments-face): Use renamed sieve faces. * gnus.el (gnus-group-news-1, gnus-group-news-1-empty) (gnus-group-news-2, gnus-group-news-2-empty, gnus-group-news-3) (gnus-group-news-3-empty, gnus-group-news-4) (gnus-group-news-4-empty, gnus-group-news-5) (gnus-group-news-5-empty, gnus-group-news-6) (gnus-group-news-6-empty, gnus-group-news-low) (gnus-group-news-low-empty, gnus-group-mail-1) (gnus-group-mail-1-empty, gnus-group-mail-2) (gnus-group-mail-2-empty, gnus-group-mail-3) (gnus-group-mail-3-empty, gnus-group-mail-low) (gnus-group-mail-low-empty, gnus-summary-selected) (gnus-summary-cancelled, gnus-summary-high-ticked) (gnus-summary-low-ticked, gnus-summary-normal-ticked) (gnus-summary-high-ancient, gnus-summary-low-ancient) (gnus-summary-normal-ancient, gnus-summary-high-undownloaded) (gnus-summary-low-undownloaded) (gnus-summary-normal-undownloaded, gnus-summary-high-unread) (gnus-summary-low-unread, gnus-summary-normal-unread) (gnus-summary-high-read, gnus-summary-low-read) (gnus-summary-normal-read, gnus-splash): Remove "-face" suffix from face names. (gnus-group-news-1-face, gnus-group-news-1-empty-face) (gnus-group-news-2-face, gnus-group-news-2-empty-face) (gnus-group-news-3-face, gnus-group-news-3-empty-face) (gnus-group-news-4-face, gnus-group-news-4-empty-face) (gnus-group-news-5-face, gnus-group-news-5-empty-face) (gnus-group-news-6-face, gnus-group-news-6-empty-face) (gnus-group-news-low-face, gnus-group-news-low-empty-face) (gnus-group-mail-1-face, gnus-group-mail-1-empty-face) (gnus-group-mail-2-face, gnus-group-mail-2-empty-face) (gnus-group-mail-3-face, gnus-group-mail-3-empty-face) (gnus-group-mail-low-face, gnus-group-mail-low-empty-face) (gnus-summary-selected-face, gnus-summary-cancelled-face) (gnus-summary-high-ticked-face, gnus-summary-low-ticked-face) (gnus-summary-normal-ticked-face) (gnus-summary-high-ancient-face, gnus-summary-low-ancient-face) (gnus-summary-normal-ancient-face) (gnus-summary-high-undownloaded-face) (gnus-summary-low-undownloaded-face) (gnus-summary-normal-undownloaded-face) (gnus-summary-high-unread-face, gnus-summary-low-unread-face) (gnus-summary-normal-unread-face, gnus-summary-high-read-face) (gnus-summary-low-read-face, gnus-summary-normal-read-face) (gnus-splash-face): New backward-compatibility aliases for renamed faces. (gnus-group-startup-message): Use renamed gnus faces. * gnus-srvr.el (gnus-server-agent, gnus-server-opened) (gnus-server-closed, gnus-server-denied, gnus-server-offline) (gnus-server-agent): Remove "-face" suffix from face names. (gnus-server-agent-face, gnus-server-opened-face) (gnus-server-closed-face, gnus-server-denied-face) (gnus-server-offline-face): New backward-compatibility aliases for renamed faces. (gnus-server-agent-face, gnus-server-opened-face) (gnus-server-closed-face, gnus-server-denied-face) (gnus-server-offline-face): Use renamed gnus faces. * gnus-picon.el (gnus-picon-xbm, gnus-picon): Remove "-face" suffix from face names. (gnus-picon-xbm-face, gnus-picon-face): New backward-compatibility aliases for renamed faces. * gnus-cite.el (gnus-cite-attribution, gnus-cite-1, gnus-cite-2) (gnus-cite-3, gnus-cite-4, gnus-cite-5, gnus-cite-6) (gnus-cite-7, gnus-cite-8, gnus-cite-9, gnus-cite-10) (gnus-cite-11): Remove "-face" suffix from face names. (gnus-cite-attribution-face, gnus-cite-face-1, gnus-cite-face-2) (gnus-cite-face-3, gnus-cite-face-4, gnus-cite-face-5) (gnus-cite-face-6, gnus-cite-face-7, gnus-cite-face-8) (gnus-cite-face-9, gnus-cite-face-10, gnus-cite-face-11): New backward-compatibility aliases for renamed faces. (gnus-cite-attribution-face, gnus-cite-face-list) (gnus-article-boring-faces): Use renamed gnus faces. * gnus-art.el (gnus-signature, gnus-header-from) (gnus-header-subject, gnus-header-newsgroups, gnus-header-name) (gnus-header-content): Remove "-face" suffix from face names. (gnus-signature-face, gnus-header-from-face) (gnus-header-subject-face, gnus-header-newsgroups-face) (gnus-header-name-face, gnus-header-content-face): New backward-compatibility aliases for renamed faces. (gnus-signature-face, gnus-header-face-alist): Use renamed gnus faces. * gnus-sum.el (gnus-summary-selected-face) (gnus-summary-highlight): Use renamed gnus faces. * gnus-group.el (gnus-group-highlight): Likewise. 2005-06-14 Juanma Barranquero * gnus-sieve.el (gnus-sieve-article-add-rule): * legacy-gnus-agent.el (gnus-agent-unlist-expire-days): * spam-stat.el (spam-stat-buffer-change-to-spam) (spam-stat-buffer-change-to-non-spam): Follow error conventions. * message.el (message-is-yours-p): * gnus-sum.el (gnus-auto-select-subject): Fix quoting in docstring. 2005-06-14 Katsumi Yamaoka * mm-view.el (mm-inline-text): Withdraw the last change. 2005-06-09 Katsumi Yamaoka * mm-view.el (mm-inline-text): Turn off adaptive-fill-mode while executing enriched-decode. 2005-06-07 Katsumi Yamaoka * mm-util.el (mm-find-buffer-file-coding-system): Don't examine charset of tar files. 2005-06-04 Luc Teirlinck * gnus-art.el (article-update-date-lapsed): Use `save-match-data'. 2005-06-04 Lute Kamstra * nnfolder.el (nnfolder-read-folder): Make sure that undo information is never recorded. 2005-06-03 Stefan Monnier * gnus-art.el (gnus-emphasis-alist): Disable the strikethru thingy. 2005-06-02 Katsumi Yamaoka * pop3.el (pop3-apop): Run md5 in the binary mode. * starttls.el (starttls-set-process-query-on-exit-flag): Use eval-and-compile. 2005-05-31 Simon Josefsson * smime.el (smime-replace-in-string): Define. (smime-cert-by-ldap-1): Use it. 2005-05-31 Katsumi Yamaoka * gnus-art.el (article-display-x-face): Replace process-kill-without-query by gnus-set-process-query-on-exit-flag. * gnus-util.el (gnus-set-process-query-on-exit-flag): Alias to set-process-query-on-exit-flag or process-kill-without-query. * html2text.el (html2text-fix-paragraphs): Use `while - re-search' loop instead of replace-regexp. * imap.el (imap-ssl-open): Use set-process-query-on-exit-flag instead of process-kill-without-query if it is available. * lpath.el: Fbind ldap-search-entries. * mm-util.el (mm-insert-file-contents): Bind find-file-hook instead of find-file-hooks if it is available. * mml1991.el: Bind pgg-default-user-id when compiling. * mml2015.el: Bind pgg-default-user-id when compiling. * nndraft.el (nndraft-request-associate-buffer): Use write-contents-functions instead of write-contents-hooks if it is available. * nnheader.el (nnheader-find-file-noselect): Bind find-file-hook instead of find-file-hooks if it is available. * nntp.el (nntp-open-connection): Replace process-kill-without-query by gnus-set-process-query-on-exit-flag. (nntp-open-ssl-stream): Ditto. (nntp-open-tls-stream): Ditto. * starttls.el (starttls-set-process-query-on-exit-flag): Alias to set-process-query-on-exit-flag or process-kill-without-query. (starttls-open-stream-gnutls): Use it instead of process-kill-without-query. (starttls-open-stream): Ditto. 2005-05-31 Ulf Stegemann (tiny change) * smime.el (smime-cert-by-ldap-1): Don't use replace-regexp-in-string. 2005-05-31 Arne Jørgensen * smime-ldap.el (smime-ldap-search): Add compatibility for XEmacs. * smime.el (smime-cert-by-ldap-1): Handle certificates distributed in PEM format. Adjust to the XEmacs compability. 2005-05-30 Reiner Steib * encrypt.el (encrypt-xor-process-buffer): Replace `string-to-int' by `string-to-number'. * gnus-agent.el (gnus-agent-regenerate-group) (gnus-agent-fetch-articles): Ditto. * gnus-art.el (gnus-button-fetch-group): Ditto. * gnus-cache.el (gnus-cache-generate-active) (gnus-cache-articles-in-group): Ditto. * gnus-group.el (gnus-group-set-current-level) (gnus-group-insert-group-line): Ditto. * gnus-score.el (gnus-score-set-expunge-below) (gnus-score-set-mark-below, gnus-summary-score-effect) (gnus-summary-score-entry): Ditto. * gnus-soup.el (gnus-soup-send-packet, gnus-soup-parse-areas) (gnus-soup-pack): Ditto. * gnus-spec.el (gnus-xmas-format): Ditto. * gnus-start.el (gnus-newsrc-to-gnus-format): Ditto. * gnus-sum.el (gnus-create-xref-hashtb): Ditto. * gnus-uu.el (gnus-uu-expand-numbers): Ditto. * nnbabyl.el (nnbabyl-article-group-number): Ditto. * nndb.el (nndb-get-remote-expire-response): Ditto. * nndiary.el (nndiary-parse-schedule-value) (nndiary-string-to-number, nndiary-request-replace-article) (nndiary-request-article): Ditto. * nndoc.el (nndoc-rnews-body-end, nndoc-mbox-body-end): Ditto. * nndraft.el (nndraft-articles, nndraft-request-group): Ditto. * nneething.el (nneething-make-head): Ditto. * nnfolder.el (nnfolder-request-article) (nnfolder-retrieve-headers): Ditto. * nnheader.el (nnheader-file-to-number): Ditto. * nnkiboze.el (nnkiboze-request-article): Ditto. * nnmail.el (nnmail-process-unix-mail-format) (nnmail-process-babyl-mail-format): Ditto. * nnmbox.el (nnmbox-read-mbox, nnmbox-article-group-number): Ditto. * nnmh.el (nnmh-update-gnus-unreads, nnmh-active-number) (nnmh-request-create-group, nnmh-request-list-1) (nnmh-request-group, nnmh-request-article): Ditto. * nnml.el (nnml-request-replace-article, nnml-request-article): Ditto. * nnrss.el (nnrss-find-rss-via-syndic8): Ditto. * nnsoup.el (nnsoup-make-active): Ditto. * nnspool.el (nnspool-find-id, nnspool-request-group): Ditto. * nntp.el (nntp-find-group-and-number) (nntp-retrieve-headers-with-xover): Ditto. * pgg-gpg.el (pgg-gpg-snarf-keys-region): Ditto. * pgg-parse.el (pgg-read-body, pgg-read-bytes) (pgg-format-key-identifier): Ditto. * pop3.el (pop3-last, pop3-stat): Ditto. * qp.el (quoted-printable-decode-region): Ditto. * spam-report.el (spam-report-url-ping-mm-url): Use format instead of concat. 2005-05-30 Katsumi Yamaoka * gnus-agent.el (gnus-category-mode): Use gnus-run-mode-hooks. * gnus-art.el (gnus-article-mode): Use gnus-run-mode-hooks. * gnus-cus.el (gnus-custom-mode): Use gnus-run-mode-hooks. * gnus-eform.el (gnus-edit-form-mode): Use gnus-run-mode-hooks. * gnus-group.el (gnus-group-mode): Use gnus-run-mode-hooks. * gnus-kill.el (gnus-kill-file-mode): Use gnus-run-mode-hooks. * gnus-salt.el (gnus-tree-mode): Use gnus-run-mode-hooks. (gnus-carpal-mode): Ditto. * gnus-srvr.el (gnus-server-mode): Use gnus-run-mode-hooks. (gnus-browse-mode): Ditto. * gnus-sum.el (gnus-summary-mode): Use gnus-run-mode-hooks. * gnus-util.el (gnus-run-mode-hooks): Save current buffer. 2005-05-29 Richard M. Stallman * gnus-cite.el (gnus-cite-add-face): Set overlay's evaporate property. 2005-05-27 Katsumi Yamaoka * gnus-util.el (gnus-run-mode-hooks): New function. * score-mode.el (gnus-score-mode): Use gnus-run-mode-hooks. * dgnushack.el: Advise byte-optimize-form-code-walker to avoid the ``...called for effect'' warnings for Emacs 21.4 as well as 21.3. 2005-05-26 Luc Teirlinck * gnus-agent.el (gnus-agent-make-mode-line-string): Use mode-line-highlight as mouse-face. 2005-05-17 Katsumi Yamaoka * canlock.el (canlock): Change the parent group to news. * deuglify.el (gnus-outlook-deuglify): Add :group. * dig.el (dig): Add :group. * dns-mode.el (dns-mode): Add :group. * encrypt.el (encrypt): Add :group. * gnus-cite.el (gnus-cite-attribution-face): Add :group. (gnus-cite-face-1, gnus-cite-face-2, gnus-cite-face-3): Ditto. (gnus-cite-face-4, gnus-cite-face-5, gnus-cite-face-6): Ditto. (gnus-cite-face-7, gnus-cite-face-8, gnus-cite-face-9): Ditto. (gnus-cite-face-10, gnus-cite-face-11): Ditto. * gnus-diary.el (gnus-diary): Add :group. * gnus.el (gnus-group-news-1-face): Add :group. (gnus-group-news-1-empty-face): Ditto. (gnus-group-news-2-face, gnus-group-news-2-empty-face): Ditto. (gnus-group-news-3-face, gnus-group-news-3-empty-face): Ditto. (gnus-group-news-4-face, gnus-group-news-4-empty-face): Ditto. (gnus-group-news-5-face, gnus-group-news-5-empty-face): Ditto. (gnus-group-news-6-face, gnus-group-news-6-empty-face): Ditto. (gnus-group-news-low-face, gnus-group-news-low-empty-face): Ditto. (gnus-group-mail-1-face, gnus-group-mail-1-empty-face): Ditto. (gnus-group-mail-2-face, gnus-group-mail-2-empty-face): Ditto. (gnus-group-mail-3-face, gnus-group-mail-3-empty-face): Ditto. (gnus-group-mail-low-face, gnus-group-mail-low-empty-face): Ditto. (gnus-summary-selected-face, gnus-summary-cancelled-face): Ditto. (gnus-summary-high-ticked-face): Ditto. (gnus-summary-low-ticked-face): Ditto. (gnus-summary-normal-ticked-face): Ditto. (gnus-summary-high-ancient-face): Ditto. (gnus-summary-low-ancient-face): Ditto. (gnus-summary-normal-ancient-face): Ditto. (gnus-summary-high-undownloaded-face): Ditto. (gnus-summary-low-undownloaded-face): Ditto. (gnus-summary-normal-undownloaded-face): Ditto. (gnus-summary-high-unread-face): Ditto. (gnus-summary-low-unread-face): Ditto. (gnus-summary-normal-unread-face): Ditto. (gnus-summary-high-read-face, gnus-summary-low-read-face): Ditto. (gnus-summary-normal-read-face, gnus-splash-face): Ditto. * hashcash.el (hashcash): New custom group. (hashcash-default-payment): Add :group. (hashcash-payment-alist): Ditto. (hashcash-default-accept-payment): Ditto. (hashcash-accept-resources): Ditto. (hashcash-path): Ditto. (hashcash-extra-generate-parameters): Ditto. (hashcash-double-spend-database): Ditto. (hashcash-in-news): Ditto. * message.el (message-minibuffer-local-map): Add :group. * netrc.el (netrc): Add :group. * sieve-manage.el (sieve-manage-log): Add :group. (sieve-manage-default-user): Diito. (sieve-manage-server-eol, sieve-manage-client-eol): Ditto. (sieve-manage-streams, sieve-manage-stream-alist): Ditto. (sieve-manage-authenticators): Ditto. (sieve-manage-authenticator-alist): Ditto. (sieve-manage-default-port): Ditto. * sieve-mode.el (sieve-control-commands-face): Add :group. (sieve-action-commands-face): Ditto. (sieve-test-commands-face): Ditto. (sieve-tagged-arguments-face): Ditto. * smime.el (smime): Add :group. * spam-report.el (spam-report): Add :group. * spam.el (spam, spam-face): Add :group. 2005-05-16 Lars Magne Ingebrigtsen * nntp.el (nntp-next-result-arrived-p): Some news servers may return \n.\n.\n at the end of articles. Protect against that. (nntp-with-open-group): Allow debugging. * nnheader.el (mail-header-set-extra): Make into a function because I just could't understand how to quote the list properly. * dns.el (query-dns-cached): New function. 2005-05-26 Lute Kamstra * score-mode.el (gnus-score-mode): Use run-mode-hooks. 2005-05-16 Katsumi Yamaoka * dgnushack.el: Autoload mail-extract-address-components for XEmacs. * gnus-art.el: Don't autoload mail-extract-address-components. * gnus.el: Remove duplicated autoload for message-y-or-n-p; use eval-and-compile to evaluate it. * hashcash.el: Don't autoload executable-find. * nndb.el: Don't declare the nndb back end two or more times; don't autoload news-reply-mode, news-setup, cancel-timer and telnet. * nntp.el: Autoload format-spec instead of format; use eval-and-compile to evaluate autoload forms. 2005-05-09 Georg C. F. Greve (tiny change) * pgg-gpg.el (pgg-gpg-possibly-cache-passphrase): Fix PIN caching. 2005-05-01 Lars Magne Ingebrigtsen * gnus.el (gnus-version-number): Bump version. 2005-05-01 Lars Magne Ingebrigtsen * gnus.el: No Gnus v0.3 is released. 2005-05-01 Lars Magne Ingebrigtsen * lpath.el (featurep): Bind show-nonbreak-escape. 2005-04-28 Katsumi Yamaoka * gnus-art.el (gnus-article-edit-part): Disable undo. 2005-04-25 Katsumi Yamaoka * gnus-art.el (article-date-ut): Don't delete X-Sent header when gnus-article-date-lapsed-new-header is t if date timer is active; skip headers in which the original date value is empty. (gnus-article-save-original-date): Redefine it as a macro. (gnus-display-mime): Use it. 2005-04-22 Katsumi Yamaoka * gnus-art.el (article-date-ut): Support converting date in forwarded parts as well. (gnus-article-save-original-date): New function. (gnus-display-mime): Use it. 2005-04-22 David Hansen * nnrss.el (nnrss-check-group, nnrss-request-article): Support the enclosure element of . 2005-04-21 Reiner Steib * message.el (message-kill-buffer-query): Renamed from `message-kill-buffer-query-if-modified'. Added :version. 2005-04-19 Katsumi Yamaoka * mml.el (mml-preview): Bind gnus-message-buffer while setting the window layout. 2005-04-18 Katsumi Yamaoka * mml.el: Autoload dnd when compiling. 2005-04-18 Reiner Steib * mml.el (mml-mode, mml-dnd-attach-file): Use dnd-* instead of x-dnd-*. 2005-04-18 Katsumi Yamaoka * qp.el (quoted-printable-encode-region): Save excursion. 2005-04-14 Teodor Zlatanov * message.el (message-kill-buffer-query-if-modified): Add new variable so the user can kill a modified message buffer quickly. (message-kill-buffer): Use it. 2005-04-13 Katsumi Yamaoka * lpath.el: Fbind display-time-event-handler; don't fbind string-to-multibyte. * qp.el (quoted-printable-encode-region): Use mm-string-to-multibyte. 2005-04-12 Katsumi Yamaoka * nnrss.el (nnrss-node-text): Replace CRLFs (which might be contained in text because xml.el decodes entities) with LFs. 2005-04-11 Lute Kamstra * nnimap.el (nnimap-date-days-ago): Handle byte-compiler warnings differently. 2005-04-10 Stefan Monnier * mm-util.el (mm-detect-coding-region): Typo. 2005-04-11 Katsumi Yamaoka * gnus-art.el (gnus-article-read-summary-keys): Fix misplaced parens. 2005-04-06 D Goel * spam-stat.el (spam-stat-score-buffer): Add a call to a user-function allow user modifications of the scores. (spam-stat-score-buffer-user): New function, to allow user-computed modifications to the score. (spam-stat-score-buffer-user-functions): List of additional scoring functions. (spam-stat-error-holder): Global temporary error holder. (spam-stat-split-fancy): Use the new `spam-stat-error-holder' variable. 2005-04-06 Teodor Zlatanov * gnus-registry.el (gnus-registry-clean-empty-function) (gnus-registry-trim, gnus-registry-fetch-groups) (gnus-registry-delete-group): Groups that match `gnus-registry-ignored-groups' are removed from the registry entries, not just ignored for splitting. This helps clean up the registry. Also, `gnus-registry-fetch-groups' is a convenient way to get all the groups a message ID is in. * spam-stat.el (spam-stat-split-fancy-spam-threshold) (spam-stat-split-fancy): Change "threshhold" to "threshold" (spam-stat-score-buffer-user-functions): Add :number custom type. 2005-04-06 Katsumi Yamaoka * mm-util.el (mm-coding-system-p): Don't return binary for the nil argument in XEmacs. * nnrss.el (nnrss-compatible-encoding-alist): New variable. (nnrss-request-group): Decode group name first. (nnrss-request-article): Make a text/plain article if mml-to-mime failed. (nnrss-get-encoding): Return a compatible encoding according to nnrss-compatible-encoding-alist. (nnrss-find-el): Use consp instead of listp. (nnrss-opml-export, nnrss-order-hrefs, nnrss-find-el): Use dolist. 2005-04-06 Katsumi Yamaoka * time-date.el (time-to-seconds): Don't use the #xhhhh syntax which Emacs 20 doesn't support. (seconds-to-time, days-to-time, time-subtract, time-add): Ditto. 2005-04-04 Reiner Steib * nnimap.el (nnimap-date-days-ago): Add defvars in order to silence the byte compiler inside the defun. * gnus-demon.el (parse-time-string): Add autoload. * gnus-delay.el (parse-time-string): Add autoload. * gnus-art.el (parse-time-string): Add autoload. * nnultimate.el (parse-time): Require for `parse-time-string'. 2005-03-31 Reiner Steib * gnus-art.el (gnus-copy-article-ignored-headers): Update :version. * gnus-score.el (gnus-adaptive-pretty-print): Ditto. * smime.el (smime-ldap-host-list): Add :version. 2005-03-21 Reiner Steib * gnus-srvr.el (gnus-browse-select-group): Add NUMBER argument and pass it to `gnus-browse-read-group'. (gnus-browse-read-group): Add NUMBER argument and pass it to `gnus-group-read-ephemeral-group'. * gnus-group.el (gnus-group-read-ephemeral-group): Add NUMBER argument and pass it to `gnus-group-read-group'. 2005-03-19 Aidan Kehoe * mm-util.el (mm-xemacs-find-mime-charset): Only call mm-xemacs-find-mime-charset-1 if we have the mule feature available at runtime. 2005-03-25 Werner Lemberg * nnmaildir.el: Replace `illegal' with `invalid'. 2005-03-23 Lute Kamstra * time-date.el: Add comment on time value formats. Don't require parse-time. (with-decoded-time-value): New macro. (encode-time-value): New function. (time-to-seconds, time-less-p, time-subtract, time-add): Use them. (days-to-time): Return a valid time value when arg is huge. (time-since): Use time-subtract. (time-to-number-of-days): Use time-to-seconds. 2005-03-22 Stefan Monnier * gnus-start.el (gnus-display-time-event-handler): Check display-time-timer at runtime rather than only at load time in case display-time-mode is turned off in the mean time. 2005-03-16 Reiner Steib * nnimap.el (nnimap-open-connection): Print which authinfo file is used. * nneething.el (nneething-map-file-directory): Derive from `gnus-directory'. * gnus-art.el (gnus-header-button-alist): Use `gnus-msg-mail' for the To/Cc button. 2005-03-15 Reiner Steib * nnmaildir.el (nnmaildir-request-accept-article): Use `nnheader-cancel-timer' for compatibility with current XEmacs. 2005-03-13 Andrey Slusar (tiny change) * gnus-async.el: Require timer-funcs at compile time when in XEmacs for `run-with-idle-timer'. 2005-03-13 Andrey Slusar (tiny change) * gnus.el: Don't try and mark `gnus-agent-save-groups' as an autoloaded function. 2005-03-10 Stefan Monnier * nnimap.el (nnimap-retrieve-headers-from-server): Fix last change. 2005-03-10 Arne Jørgensen (tiny change) * nnimap.el (nnimap-retrieve-headers-from-server): Fix off-by-one flaw. 2005-03-09 Lars Magne Ingebrigtsen * gnus-msg.el (gnus-confirm-mail-reply-to-news): Add gnus-expert-user to default. 2005-03-08 Juergen Kreileder (tiny change) * nnimap.el (nnimap-open-server): Ditto. * imap.el (imap-authenticate): Fix typo. 2005-03-08 Bjorn Solberg (tiny change) * nnimap.el (nnimap-retrieve-headers-from-server): Sort NOV buffer (since IMAP server might return FETCH response out of order, and the nntp buffer must be sorted). 2005-03-06 Kevin Greiner * gnus-start.el (gnus-convert-old-newsrc): Fixed numeric comparison on string. * gnus-agent.el (gnus-agent-long-article, gnus-agent-short-article, gnus-agent-score): Renamed category keywords to match gnus-cus. (gnus-agent-summary-fetch-series): Modified to protect against gnus-agent-summary-fetch-group clearing processable flags. (gnus-agent-synchronize-group-flags): Update live group buffer as synchronization may occur due to the user toggle the plugged status. (gnus-agent-fetch-group-1): Clear downloadable flag when article successfully downloaded. (gnus-agent-expire-group-1): Avoid using markers when the overview is in ascending order; greatly improves performance. (gnus-agent-regenerate-group): Use gnus-agent-synchronize-group-flags to reset read status in both gnus and server. (gnus-agent-update-files-total-fetched-for): Fixed initial size. 2005-03-04 Reiner Steib * message.el: Don't autoload former message-utils variables. (message-strip-subject-trailing-was): Change doc string. * nnweb.el: Fixes for `gnus-group-make-web-group'. (nnweb-type-definition): Don't add "hl=en" in `address'. Add `base'. (nnweb-google-search): Add "hl=en" here. (nnweb-google-parse-1, nnweb-google-create-mapping): Don't hardcode URL. 2005-03-03 Reiner Steib * message.el (message-get-reply-headers, message-followup): Mention related variables `message-use-followup-to' and `message-use-mail-followup-to', in the information buffer. * nnweb.el (nnweb-type-definition): Use groups.google.de instead of broken groups(-beta).google.com. 2005-03-03 Teodor Zlatanov * gnus-sum.el (gnus-summary-move-article): Pass move-is-internal parameter to invoked gnus-request-move-article; remove the redundant gnus-sum-hint-move-is-internal variable; apply the marks all at once instead of once per article. (gnus-summary-remove-process-mark): Accept a list of articles as well as a single article for processing. * gnus-int.el (gnus-request-move-article): Add move-is-internal parameter. * nnml.el (nnml-request-move-article): Add move-is-internal parameter. * nnmh.el (nnmh-request-move-article): Add move-is-internal parameter. * nnmbox.el (nnmbox-request-move-article): Add move-is-internal parameter. * nnmaildir.el (nnmaildir-request-move-article): Add move-is-internal parameter. * nnimap.el (nnimap-request-move-article): Add move-is-internal parameter and remove the gnus-sum-hint-move-is-internal variable. * nnfolder.el (nnfolder-request-move-article): Add move-is-internal parameter. * nndraft.el (nndraft-request-move-article): Add move-is-internal parameter. * nndiary.el (nndiary-request-move-article): Add move-is-internal parameter. * nndb.el (nndb-request-move-article): Add move-is-internal parameter. * nnbabyl.el (nnbabyl-request-move-article): Add move-is-internal parameter. * nnagent.el (nnagent-request-move-article): Add move-is-internal parameter. 2005-03-01 Stefan Monnier * gnus-sum.el (gnus-summary-exit): Undo last change and fix it in a more conservative way. 2005-02-26 Stefan Monnier * gnus-sum.el (gnus-summary-exit): Move point after displaying the buffer, so it moves the window's cursor. 2005-02-26 Arne Jørgensen * mm-decode.el (mm-dissect-buffer): Pass the from field on to `mm-dissect-multipart' and receive the from field as an (optional) argument from `mm-dissect-multipart'. (mm-dissect-multipart): Receive the from field as an argument and pass it on when we call `mm-dissect-buffer' on MIME parts. Fixes verification/decryption of signed/encrypted MIME parts. 2005-02-25 Teodor Zlatanov * gnus-sum.el (gnus-summary-move-article): Set gnus-sum-hint-move-is-internal for gnus-request-move-article and whatever it calls (right now, only nnimap-request-move article respects it). * nnimap.el (nnimap-request-move-article): When gnus-sum-hint-move-is-internal is set, don't do the extra nnimap-request-article. 2005-02-24 Reiner Steib * nnheader.el (nnheader-find-file-noselect): Add doc string. * nnfolder.el (nnfolder-read-folder): Use RAWFILE for `nnheader-find-file-noselect' to avoid `large-file-warning-threshold'. * gnus-sum.el (gnus-summary-caesar-message): Apply `gnus-treat-article' after rotation. * gnus-group.el (gnus-group-clear-data): Mention process/prefix in doc string. 2005-02-22 Simon Josefsson * encrypt.el (encrypt-password-cache-expiry): Remove (use `password-cache-expiry' instead). Reported by Arne Jørgensen . (encrypt): Add password-cache and password-cache-expiry as group members. 2005-02-22 Arne Jørgensen * smime.el (smime-ldap-host-list): Doc fix. (smime-ask-passphrase): Use `password-read-and-add' to read (and cache) password. (smime-sign-region): Use it. (smime-decrypt-region): Use it. (smime-sign-buffer): Signal an error if `smime-sign-region' fails. (smime-encrypt-buffer): Signal an error if `smime-encrypt-region' fails. (smime-cert-by-ldap-1): Use `base64-encode-string' to convert certificate from DER to PEM format rather than calling openssl. * mml-smime.el (mml-smime-encrypt-query): Remove obsolete comment. * mml-sec.el (mml-secure-message): Insert keyfile/certfile tags for signing/encryption. * mml.el (mml-parse-1): Use them. 2005-02-21 Arne Jørgensen * nnrss.el (nnrss-verbose): Removed. (nnrss-request-group): Use `nnheader-message' instead. 2005-02-19 Mark Plaksin (tiny change) * nnrss.el (nnrss-verbose): New variable. (nnrss-request-group): Make it say nnrss is requesting a group. 2005-02-21 Reiner Steib * gnus-art.el (gnus-parse-news-url, gnus-button-handle-news): Handle news URL with given port correctly. 2005-02-19 Katsumi Yamaoka * gnus-msg.el (gnus-copy-article-buffer): Quote decoded words containing special characters. * gnus-sum.el (gnus-summary-edit-article): Ditto. * mml.el (mime-to-mml): Ditto. * rfc2047.el (rfc2047-encode-parameter): Use ietf-drums-tspecials. (rfc2047-quote-decoded-words-containing-tspecials): New variable. (rfc2047-decode-region): Quote decoded words containing special characters when rfc2047-quote-decoded-words-containing-tspecials is non-nil. 2005-02-16 Teodor Zlatanov * gnus-registry.el (gnus-registry-delete-group): Add minor bug fix. * gnus.el (gnus-install-group-spam-parameters): Add minor doc fix. 2005-02-15 Simon Josefsson * nnimap.el (nnimap-debug): Doc fix. * imap.el (imap-debug): Doc fix. 2005-02-15 Katsumi Yamaoka * gnus-art.el: Avoid "Recursive load suspected" error in Emacs 21.1. 2005-02-14 Teodor Zlatanov * gnus.el (spam-contents): Improve docs for spam-contents parameter in its variable incarnation. 2005-02-14 Simon Josefsson * smime-ldap.el: Use require instead of load-library for ldap. (smime-ldap-search): Indent. (smime-ldap-search-internal): Shorten line. * smime.el (smime-cert-by-dns): Add doc-string. (smime-cert-by-ldap-1): Indent. * mml-smime.el (mml-smime-get-ldap-cert): Renamed from mml-smime-get-dns-ldap. (mml-smime-encrypt-query): Use new function. Default to ldap. 2005-02-14 Arne Jørgensen * smime.el: Require smime-ldap. (smime-ldap-host-list): New variable. (smime-cert-by-ldap, smime-cert-by-ldap-1): New functions. * mml-smime.el (mml-smime-encrypt-query): New function. (mml-smime-encrypt-query): Use it. * smime-ldap.el: New file. 2005-02-13 Katsumi Yamaoka * gnus-agent.el: Remove garbage made while merging the Emacs trunk. 2005-02-14 Reiner Steib * gnus-group.el (gnus-group-make-doc-group): Mention prefix argument in doc string. Make query for type more clear. 2005-02-13 Reiner Steib * gnus.el (gnus-group-startup-message): Search for gnus images in etc/images/gnus. * mm-util.el (mm-image-load-path): Likewise. * smiley.el (smiley-data-directory): Search for smilies in etc/images/smilies. 2005-02-09 Kim F. Storm Change Emacs release version from 21.4 to 22.1 throughout. Change Emacs development version from 21.3.50 to 22.0.50. 2005-02-12 Katsumi Yamaoka * gnus-art.el (gnus-mime-copy-part): Don't decode compressed parts. * mm-util.el (mm-coding-system-to-mime-charset): Make it work with non-Mule XEmacs as well. (mm-decompress-buffer): Signal an error intentionally if it does not decompress compressed data because auto-compression-mode is disabled. 2005-02-11 Teodor Zlatanov * gnus-registry.el (gnus-registry-delete-group): Fix bug: leaves an ID in the registry even if it has no groups. 2005-02-10 Katsumi Yamaoka * gnus-art.el (gnus-mime-jka-compr-maybe-uncompress): Remove; merge it into mm-decompress-buffer. (gnus-mime-copy-part): Use the MIME part charset, the value which a user specified or gnus-newsgroup-charset for decoding, like gnus-mime-inline-part does; set buffer-file-coding-system to tell save-buffer what was used. Suggested by Kevin Ryde . (gnus-mime-inline-part): Allow the name parameter as well as the filename parameter; force decompressing of compressed data; always display contents being not decoded as unibyte. * mm-view.el (mm-display-inline-fontify): Allow the name parameter as well as the filename parameter. * mm-util.el (mm-decompress-buffer): Merge gnus-mime-jka-compr-maybe-uncompress. (mm-find-buffer-file-coding-system): Doc fix; force decompressing of compressed data. 2005-02-08 Simon Josefsson * imap.el (imap-log): Doc fix. 2005-02-07 Katsumi Yamaoka * gnus-art.el (gnus-mime-inline-part): Decode parts according to the coding cookies; decompress compressed parts. * mml.el (mml-generate-mime-1): Add the charaset parameter according to the value which a user specified manually or the coding cookie. * mm-util.el (mm-string-to-multibyte): New function. (mm-detect-mime-charset-region): Work with Emacs 22 as well. (mm-coding-system-to-mime-charset): New function. (mm-decompress-buffer): New function. (mm-find-buffer-file-coding-system): New function. * mm-view.el (mm-insert-inline): Make sure a part ends with a newline. (mm-display-inline-fontify): Rewrite for decoding and decompressing parts. 2005-02-07 TSUCHIYA Masatoshi * mm-view.el (mm-display-inline-fontify): Decode a part according to the charset parameter. 2005-02-03 Katsumi Yamaoka * gnus-art.el (gnus-mime-inline-part): Show the raw contents if a prefix arg is neither nil nor a number, as info specifies. 2005-02-02 Katsumi Yamaoka * nntp.el (nntp-marks-changed-p): Use time-less-p to compare the timestamps. 2005-02-02 Jari Aalto * gnus-sum.el (gnus-list-of-unread-articles): Improve active groups error checking and notify user. 2005-02-02 Jari Aalto * message.el (message-send-mail-function): Check existence of sendmail-program first before using default value `message-send-mail-with-sendmail'. Otherwise use more generic `smtpmail-send-it'. 2005-02-01 Katsumi Yamaoka * nntp.el (nntp-request-update-info): Always return nil. 2005-01-30 Stefan Monnier * gnus-art.el (gnus-article-mode): Turn off the "\ " non-break space. 2005-01-28 Stefan Monnier * message.el (message-beginning-of-line): Change the behavior when invoked between BOL and : so that it first moves backward. 2005-01-28 Katsumi Yamaoka * gnus-art.el (gnus-article-setup-buffer): Kill and re-create the article buffer when editing of the article is discarded. (gnus-article-prepare): Revert. 2005-01-28 Katsumi Yamaoka * gnus-art.el (gnus-article-prepare): Remove message-strip-forbidden-properties from the local hook. 2005-01-27 Simon Josefsson * password.el (password-cache-add): Only start one timer per key. Reported by Derek Atkins . 2005-01-26 Steve Youngs * run-at-time.el: Removed. It is no longer needed as timer-funcs.el in the xemacs-base package has a working version of `run-at-time'. * gnus-xmas.el: Require timer-funcs instead of run-at-time. * password.el: Require timer-funcs instead of run-at-time in XEmacs. Remove `password-run-at-time' macro. (password-cache-add): Use `run-at-time' instead of `password-run-at-time'. * nnheaderxm.el: Require timer-funcs instead of run-at-time. Remove `nnheader-cancel-function-timers' alias, `cancel-function-timers' exists in XEmacs in timer-funcs. * mail-source.el: Require timer-funcs instead of itimer in XEmacs for `run-with-idle-timer'. * gnus-demon.el: Require timer-funcs instead of itimer in XEmacs for `run-at-time'. * mm-url.el: Require timer-funcs at compile time when in XEmacs for `with-timeout'. * dgnushack.el: Autoload the correct `setenv' for SXEmacs which is the same as for XEmacs 21.4. No need to ignore `run-with-idle-timer', this function exists in XEmacs now in timer-funcs.el in the xemacs-base package. (dgnushack-compile): No need to delete run-at-time.el from the list of files to compile because it doesn't exist anymore. 2005-01-24 Katsumi Yamaoka * mml.el (mml-generate-mime-1): Convert string into unibyte when inserting " *mml*" buffer's contents into a unibyte temp buffer. 2005-01-24 Harald Meland (tiny change) * mail-source.el (mail-source-fetch-imap): Search for ^From case sensitively. 2005-01-21 Derek Atkins (tiny change) * pgg-pgp.el (pgg-pgp-decrypt-region): Use passphrase cache. 2005-01-20 Katsumi Yamaoka * mm-decode.el (mm-insert-part): Switch the multibyteness of data which will be inserted according to the multibyteness of a buffer rather than the type of contents. Suggested by ARISAWA Akihiro . * nnrss.el (nnrss-find-el): Check carefully whether there's a list of string which old xml.el may return rather than a string. 2005-01-17 Katsumi Yamaoka * gnus-sum.el (gnus-summary-idna-message): Silence byte compiler. 2005-01-16 Simon Josefsson * gnus-sum.el (gnus-summary-idna-message): Fail gracefully if idn/idna.el isn't available. (gnus-summary-idna-message): Doc fix. Suggested by Michael Cook . * hashcash.el: Remove non-FSF copyright header. * hashcash.el (hashcash-extra-generate-parameters): New variable. (hashcash-generate-payment): Use it. (hashcash-generate-payment-async): Use it. 2005-01-15 Simon Josefsson * message.el (message-idna-to-ascii-rhs): Decode Reply-To too. Suggested by Raymond Scholz . * gnus-sum.el (gnus-summary-wash-map): Bind "W i" to gnus-summary-idna-message. (gnus-summary-make-menu-bar): Add De-IDNA menu entry. (gnus-summary-idna-message): New function. 2005-01-13 Reiner Steib * gnus-msg.el (gnus-confirm-mail-reply-to-news): Change default to gnus-novice-user. 2005-01-12 Katsumi Yamaoka * nnrss.el (nnrss-request-delete-group): Delete entries in nnrss-group-alist as well. (nnrss-save-server-data): Insert newline. 2005-01-10 Reiner Steib * gnus.el (gnus-user-agent): Use list of symbols instead of symbols. Display full version number for (S)XEmacs. Optionally display (S)XEmacs codename. * gnus-util.el (gnus-emacs-version): Update for new `gnus-user-agent'. * gnus-msg.el (gnus-extended-version): Make it possible to omit Gnus version. 2005-01-05 Reiner Steib * spam.el (spam-face): New face. Don't use `gnus-splash-face' which is unreadable in some setups. 2005-01-06 Katsumi Yamaoka * gnus-spec.el (gnus-update-format-specifications): Flush the group format spec cache if it doesn't support decoded group names. 2005-01-03 Reiner Steib * gnus-score.el (gnus-decay-scores, gnus-score-load-file): Allow to apply decay on score files matching a regexp. 2004-12-30 Katsumi Yamaoka * gnus-group.el (gnus-group-line-format-alist): Keep the forward compatibility in %g and %c. 2004-12-29 Katsumi Yamaoka * gnus-group.el (gnus-group-line-format-alist): Use decoded group name for only %g and %c. (gnus-group-insert-group-line): Bind gnus-tmp-decoded-group instead of gnus-tmp-group to decoded group name. (gnus-group-make-rss-group): Exclude `/'s from group names. 2004-12-28 Katsumi Yamaoka * nnrss.el (nnrss-get-encoding): Fix regexp. 2004-12-27 Simon Josefsson * mm-bodies.el (mm-body-encoding): Don't permit 7-bit to be used when mm-use-ultra-safe-encoding is enabled (e.g., for PGP/MIME) and we have trailing white space. Reported by Werner Koch . 2004-12-17 Kim F. Storm * gnus-group.el (gnus-group-mode-map): Map follow-link to mouse-face. * gnus-sum.el (gnus-summary-mode-map): Likewise. 2004-12-26 Tsuyoshi AKIHO * gnus-sum.el (gnus-summary-walk-group-buffer): Decode group name. 2004-12-26 Katsumi Yamaoka * nnrss.el: Require rfc2047 and mml. (nnrss-file-coding-system): New variable. (nnrss-format-string): Redefine it as an inline function. (nnrss-decode-group-name): New function. (nnrss-string-as-multibyte): Remove. (nnrss-retrieve-headers): Decode group name; don't use nnrss-format-string. (nnrss-request-group): Decode group name. (nnrss-request-article): Decode group name; allow a Message-ID as well as an article number; don't use nnrss-format-string; encode a Message-ID string which may contain non-ASCII characters; use mml-to-mime to compose a MIME article. (nnrss-request-expire-articles): Decode group name. (nnrss-request-delete-group): Decode group name. (nnrss-fetch): Clarify error message. (nnrss-read-server-data): Use insert-file-contents instead of load; bind file-name-coding-system; use multibyte buffer. (nnrss-save-server-data): Bind coding-system-for-write to the value of nnrss-file-coding-system; bind file-name-coding-system; add coding cookie. (nnrss-read-group-data): Use insert-file-contents instead of load; bind file-name-coding-system; use multibyte buffer. (nnrss-save-group-data): Bind coding-system-for-write to the value of nnrss-file-coding-system; bind file-name-coding-system. (nnrss-decode-entities-string): Rename from n-d-e-unibyte-string; make it work with non-ASCII text. (nnrss-find-el): Make it work with old xml.el as well. 2004-12-26 Tsuyoshi AKIHO * nnrss.el (nnrss-get-encoding): New function. (nnrss-fetch): Use unibyte buffer initially; bind coding-system-for-read while performing mm-url-insert; remove ^Ms; decode contents according to the encoding attribute. (nnrss-save-group-data): Add coding cookie. (nnrss-mime-encode-string): New function. (nnrss-check-group): Use it to encode subject and author. 2004-12-23 Teodor Zlatanov * spam.el (spam-check-BBDB): Don't get the symbol-value of an imaginary variable. 2004-12-22 Katsumi Yamaoka * gnus-spec.el (gnus-spec-tab): Make a Lisp form which works correctly even if there are wide characters. 2004-12-21 Teodor Zlatanov * spam.el (spam-check-BBDB): Fix the BBDB caching code to use downcased symbol names; make a new cache instead of reusing bbdb-hashtable. 2004-12-21 Katsumi Yamaoka * rfc2231.el (rfc2231-parse-string): Decode encoded value after concatenating segments rather than before concatenating them. Suggested by ARISAWA Akihiro . * message.el (message-get-reply-headers): Bind `extra'. 2004-12-21 Lars Magne Ingebrigtsen * message.el (message-extra-wide-headers): New variable. (message-get-reply-headers): Use it. 2004-12-20 Katsumi Yamaoka * gnus-agent.el (gnus-agent-group-path): Decode group name. (gnus-agent-group-pathname): Ditto. * gnus-cache.el (gnus-cache-file-name): Decode group name. * gnus-group.el (gnus-group-make-group): Decode group name. (gnus-group-make-rss-group): Register the group data after opening the nnrss group. 2004-12-17 Paul Jarc * nnmaildir.el (nnmaildir-request-expire-articles): Articles moved by expiry now get marked as read. 2004-12-17 Katsumi Yamaoka * mm-util.el (mm-xemacs-find-mime-charset): New macro. 2004-12-17 Aidan Kehoe * mm-util.el (mm-xemacs-find-mime-charset-1): New function used to unify Latin characters in XEmacs. (mm-find-mime-charset-region): Use it. 2004-12-17 Katsumi Yamaoka * gnus-util.el (gnus-delete-directory): New function. * gnus-agent.el (gnus-agent-delete-group): Use it. * gnus-cache.el (gnus-cache-delete-group): Use it. 2004-12-16 Katsumi Yamaoka * gnus-group.el (gnus-group-make-rss-group): Unify non-ASCII group names. 2004-12-16 Simon Josefsson * hashcash.el (hashcash-payment-alist): Fix custom :type. 2004-12-15 Katsumi Yamaoka * mm-url.el (mm-url-predefined-programs): Add --silent arg to curl. * gnus-group.el (gnus-group-expire-articles-1): Decode group name. (gnus-group-set-current-level): Decode group name. 2004-12-15 Maciek Pasternacki (tiny change) * nnrss.el (nnrss-fetch): Signal an error if w3-parse-buffer also failed. 2004-12-14 Katsumi Yamaoka * gnus-group.el (gnus-group-delete-group): Decode group name. (gnus-group-make-rss-group): Encode group name. (gnus-group-catchup-current): Decode group name. (gnus-group-kill-group): Decode group name. 2004-12-08 Stefan Monnier * gnus-art.el (gnus-narrow-to-page): Don't hardcode point-min. 2004-12-13 Katsumi Yamaoka * gnus-group.el (gnus-group-make-rss-group): Use gnus-group-make-group instead of gnus-group-unsubscribe-group. * gnus-start.el (gnus-setup-news): Honor user's setting to gnus-message-archive-method. Suggested by Lute Kamstra . 2004-12-10 Arnaud Giersch (tiny change) * gnus-sum.el (gnus-summary-exit-no-update): Don't clear the global counterparts of the buffer-local variables. 2004-11-16 Romain Francoise * gnus-sum.el (gnus-summary-exit): Don't clear the global counterparts of the buffer-local variables. 2004-11-25 Reiner Steib * message.el (message-forbidden-properties): Fixed typo in doc string. 2004-11-25 Reiner Steib * gnus-util.el (gnus-replace-in-string): Added doc string. * nnmail.el (nnmail-split-header-length-limit): Increase to 2048 to avoid problems when splitting mails with many recipients. 2004-11-22 Stefan Monnier * gnus-sum.el (gnus-summary-exit): Remove redundant and harmful pop-to-buffer, covered by the subsequent gnus-configure-windows. 2004-12-05 Nelson Ferreira * spam-stat.el (spam-stat-save): Load the hashtable from disk only if there is no hashtable in memory or file modification time is newer than cached timestamp. 2004-12-03 Reiner Steib * gnus-sum.el (gnus-summary-limit-to-recipient): Implement not-matching option. 2004-12-02 Reiner Steib * gnus-sum.el (gnus-summary-limit-to-recipient): New function. Suggested David Mazieres in analogy to rmail-summary-by-recipients. (gnus-summary-limit-map, gnus-summary-make-menu-bar): Add it. (gnus-article-sort-by-recipient, gnus-summary-sort-by-recipient): New functions. Suggested by Uwe Brauer . (gnus-summary-mode-map, gnus-summary-make-menu-bar): Add it. 2004-12-02 Katsumi Yamaoka * message.el (message-forward-make-body-mml): Remove headers according to message-forward-ignored-headers if a message is decoded. 2004-12-02 Romain Francoise * message.el (message-forward-make-body-plain): Always remove headers according to message-forward-ignored-headers. 2004-12-01 Teodor Zlatanov * spam.el (spam-summary-prepare-exit): Remove the gnus-summary-limit pop for now, it has problems with ham marks for me. 2004-11-29 Teodor Zlatanov * spam.el (spam-summary-prepare-exit): Use gnus-summary-limit correctly. 2004-11-28 Carl Henrik Lunde (tiny change) * format-spec.el (format-spec): Message the char. 2004-11-26 Teodor Zlatanov * gnus-art.el (gnus-split-methods): Reformat comments. * spam.el (spam-summary-prepare-exit): Remove article limits before exiting the summary buffer. 2004-11-26 Katsumi Yamaoka * lpath.el: Remove bbdb-create-internal, bbdb-records, spam-BBDB-register-routine and spam-enter-ham-BBDB. * nnrss.el (nnrss-string-as-multibyte): Redefine it as a macro in order to silence the byte compiler. * spam.el: Fix the way to silence the byte compiler, which complained about bbdb-buffer, bbdb-create-internal, bbdb-records, bbdb-search-simple, spam-BBDB-register-routine, spam-enter-ham-BBDB, spam-stat-buffer-change-to-non-spam, spam-stat-buffer-change-to-spam, spam-stat-buffer-is-non-spam, spam-stat-buffer-is-spam, spam-stat-load, spam-stat-register-ham-routine, spam-stat-register-spam-routine, spam-stat-save and spam-stat-split-fancy. 2004-11-26 Katsumi Yamaoka * canlock.el (canlock-password): Remove `:size 0' or `:size 1' which may confuse users. (canlock-password-for-verify): Ditto. * deuglify.el (gnus-outlook-deuglify-unwrap-stop-chars): Ditto. * gnus-art.el (gnus-emphasis-alist): Ditto. * gnus-registry.el (gnus-registry-max-entries): Ditto. * gnus-score.el (gnus-adaptive-word-length-limit): Ditto. * gnus-start.el (gnus-save-killed-list): Ditto. * gnus-sum.el (gnus-thread-hide-subtree): Ditto. (gnus-sum-thread-tree-root): Ditto. (gnus-sum-thread-tree-false-root): Ditto. (gnus-sum-thread-tree-single-indent): Ditto. * message.el (message-courtesy-message): Ditto. (message-archive-note): Ditto. (message-subscribed-address-file): Ditto. (message-user-fqdn): Ditto. * spam-report.el (spam-report-gmane-regex): Ditto. * spam.el (spam-blackhole-good-server-regex): Ditto. 2004-11-25 Katsumi Yamaoka * mml.el (mml-preview): Widen the message buffer before copying the contents to the preview buffer; sort headers before previewing. * message.el (message-hidden-headers): Fix the way to avoid a bug in the `repeat' widget in Emacs 21.3 or earlier. 2004-11-25 Katsumi Yamaoka * message.el (message-hidden-headers): Default to "^References:". Improve customization type. Suggested by Reiner Steib . 2004-11-25 Romain Francoise * message.el (message-strip-forbidden-properties): Remove check for obsolete `message-hidden' text property, hidden headers are not accessible in the buffer anymore. 2004-11-22 Romain Francoise * message.el (message-header-format-alist): Add `From' in list so that it can be sorted. (message-fix-before-sending): Widen and sort headers before sending. (message-hide-headers): Use narrowing to hide headers by moving them to the top of the buffer and narrowing to the region underneath. 2004-11-23 Lars Magne Ingebrigtsen * message.el (message-strip-forbidden-properties): Bind buffer-read-only (etc) to nil. 2004-11-23 Katsumi Yamaoka * rfc2047.el (rfc2047-header-encoding-alist): Add In-Reply-To to address-mime. Suggested by ARISAWA Akihiro . 2004-11-22 Marek Martin (tiny change) * nnfolder.el (nnfolder-request-create-group): Save current buffer. 2004-11-19 Lars Magne Ingebrigtsen * dns.el (query-dns): Use sit-for to time instead of accept-process-output, since that doesn't seem to work on udp sockets. 2004-11-17 Katsumi Yamaoka * rfc2047.el (rfc2047-encode-region): Encode bogus delimiters. 2004-11-15 Jesper Harder * pop3.el (pop3-leave-mail-on-server): Don't quote nil in doc string. Improve doc string. 2004-11-15 Katsumi Yamaoka * nntp.el (nntp-request-update-info): Return nil if nntp-marks-is-evil is true so that gnus-get-unread-articles-in-group may not call gnus-activate-group which uselessly issues the GROUP commands for all nntp groups and wastes time. Reported by Romain Francoise . * gnus-start.el (gnus-get-unread-articles): Remove redundant test. 2004-11-15 Simon Josefsson * gnus-art.el (gnus-header-button-alist): Handle URLs in OpenPGP: headers separately. (gnus-button-openpgp): New function, inspired by Jochen Küpper . 2004-11-14 Reiner Steib * gnus-start.el (gnus-convert-old-newsrc): Assign legacy-gnus-agent to 5.10.7. 2004-11-14 Lars Magne Ingebrigtsen * gnus-art.el (article-unsplit-urls): Don't anchor urls to the start of the lines. 2004-11-14 Magnus Henoch * hashcash.el (hashcash-default-payment): Change default to 20 (hashcash-default-accept-payment): Change default to 20 (hashcash-process-alist): New variable (hashcash-generate-payment-async): Add (hashcash-already-paid-p): Add (hashcash-insert-payment): Don't generate payments twice (hashcash-insert-payment-async): Add (hashcash-insert-payment-async-2): Add (hashcash-cancel-async): Add (hashcash-wait-async): Add (hashcash-processes-running-p): Add (hashcash-wait-or-cancel): Add (mail-add-payment): New optional argument. Conditionally start asynchronous calculation. (mail-add-payment-async): Add * message.el (message-send-mail): Wait for asynchronous hashcash results. Don't clobber existing X-Hashcash headers. (message-setup-1): Call mail-add-payment-async when message-generate-hashcash is non-nil. 2004-11-11 ARISAWA Akihiro (tiny change) * message.el (message-use-alternative-email-as-from): Examine the From header as well; use message-make-from in order to include a user's full name. 2004-11-10 Katsumi Yamaoka * gnus-art.el (gnus-emphasis-alist): Don't hide asterisks by default; improve customization type. (gnus-emphasis-custom-with-format): New macro. (gnus-emphasis-custom-value-to-external): New function. (gnus-emphasis-custom-value-to-internal): New function. 2004-11-09 Lars Magne Ingebrigtsen * dns.el (query-dns): Resolve reverse addresses. 2004-10-23 Lars Magne Ingebrigtsen * gnus-group.el (gnus-group-get-new-news): Use it. * gnus-start.el (gnus-check-reasonable-setup): New function. 2004-11-07 Katsumi Yamaoka * gnus-msg.el (gnus-configure-posting-styles): Don't cause the "Args out of range" error. Reported by Arnaud Giersch . 2004-11-07 Stefan Wiens (tiny change) * gnus-sum.el (gnus-summary-clear-local-variables): Use symbolp. 2004-11-04 Richard M. Stallman * spam.el (spam group): Add :version. * pgg-def.el (pgg group): Add :version. 2004-11-04 Katsumi Yamaoka * gnus-art.el (gnus-article-edit-article): Don't associate the article buffer with a draft file. This is a temporary measure against the 2004-08-22 change to gnus-article-edit-mode. 2004-11-02 Katsumi Yamaoka * html2text.el (html2text-get-attr): Remove unused argument `tag'. (html2text-format-tags): Remove unused variable `attr'. 2004-11-01 Reiner Steib * gnus-msg.el (gnus-summary-resend-default-address): Add :version. * tls.el (tls-process-connection-type, tls-success) (tls-certtool-program): Add :version. * starttls.el (starttls-gnutls-program, starttls-use-gnutls) (starttls-extra-arguments, starttls-process-connection-type) (starttls-connect, starttls-failure, starttls-success): * spam-stat.el (spam-stat): Add :version. * sieve.el (sieve): Add :version. * sha1.el (sha1): Add :version. (sha1-use-external): Remove redundant version. * nnmail.el (nnmail-split-fancy-with-parent-ignore-groups) (nnmail-cache-ignore-groups, nnmail-spool-hook) (nnmail-split-fancy-match-partial-words) (nnmail-split-lowercase-expanded): Add :version. * nndiary.el (nndiary): Add :version. * mml2015.el (mml2015-unabbrev-trust-alist): Add :version. * mml-sec.el (mml-default-sign-method) (mml-default-encrypt-method, mml-signencrypt-style-alist): Add :version. * mm-uu.el (mm-uu-diff-groups-regexp): Add :version. * mm-url.el (mm-url-use-external, mm-url-program) (mm-url-arguments): Add :version. * mm-decode.el (mm-inline-text-html-with-w3m-keymap) (mm-attachment-file-modes, mm-decrypt-option) (mm-w3m-safe-url-regexp): Add :version. * message.el (message-cite-prefix-regexp) (message-sendmail-envelope-from, message-minibuffer-local-map) (message-user-fqdn, message-completion-alist): Add :version. * gnus-win.el (gnus-configure-windows-hook) (gnus-use-frames-on-any-display): Add :version. * gnus-art.el (gnus-article-address-banner-alist) (gnus-treat-unsplit-urls, gnus-treat-unfold-headers) (gnus-treat-from-picon, gnus-treat-mail-picon) (gnus-treat-x-pgp-sig): Add :version. * gnus-sum.el (gnus-spam-mark, gnus-recent-mark) (gnus-undownloaded-mark, gnus-summary-article-move-hook) (gnus-summary-article-delete-hook) (gnus-summary-display-while-building): Add :version. * gnus-start.el (gnus-subscribe-newsgroup-hooks) (gnus-get-top-new-news-hook):Add :version. * gnus-srvr.el (gnus-server-agent-face, gnus-server-opened-face) (gnus-server-closed-face, gnus-server-denied-face): Add :version. * gnus-registry.el (gnus-registry): Add :version. * gnus-spec.el (gnus-use-correct-string-widths) (gnus-make-format-preserve-properties): Add :version. * gnus.el (gnus-group-charter-alist) (gnus-group-fetch-control-use-browse-url) (gnus-install-group-spam-parameters): Add :version. * gnus-diary.el (gnus-diary): Add :version. * gnus-delay.el (gnus-delay): Add :version. * gnus-cite.el (gnus-cite-unsightly-citation-regexp) (gnus-cite-ignore-quoted-from, gnus-cite-attribution-face) (gnus-cite-blank-line-after-header, gnus-article-boring-faces): Add :version. * gnus-agent.el (gnus-agent-max-fetch-size) (gnus-agent-enable-expiration, gnus-agent-queue-mail) (gnus-agent-prompt-send-queue): Add :version. * deuglify.el (gnus-outlook-deuglify): Add :version. * html2text.el: Beautify code. Improve doc strings. Some checkdoc cleanup. (html2text-get-attr, html2text-fix-paragraph): Simplify code. 2004-11-01 Alfred M. Szmidt (tiny change) * html2text.el (html2text-format-tag-list): Add "strong" and "em". 2004-10-29 Teodor Zlatanov * gnus-registry.el (gnus-registry-hashtb): Create the registry when package is loaded. * spam.el (spam-summary-score-preferred-header): Add global preference for people who want to override the default SpamAssassin over Bogofilter preference (when both are set). (spam-necessary-extra-headers): Add spam-use-bogofilter as an option. (spam-user-format-function-S): Check spam-summary-score-preferred-header. (spam-extra-header-to-number): Add X-Bogosity header parsing. (spam-user-format-function-S): Format the score correctly. 2004-10-29 Katsumi Yamaoka * gnus-msg.el (gnus-configure-posting-styles): Work with empty signature file. Suggested by Manoj Srivastava . * mm-util.el (mm-coding-system-priorities): Prefer iso-8859-1 than iso-2022-jp even in the Japanese language environment. Suggested by Jason Rumney . 2004-10-28 Katsumi Yamaoka * gnus-sum.el (gnus-update-summary-mark-positions): Allow users to use the same characters as the dummy marks; make it free from getting affected by the language environment. (gnus-summary-read-group-1): Update mark positions only when the format spec is updated. * gnus-spec.el (gnus-update-format-specifications): Return a list of updated types. 2004-10-27 Katsumi Yamaoka * gnus-start.el (gnus-check-reasonable-setup): Use fboundp instead of boundp to check if display-warning is available. 2004-10-26 Teodor Zlatanov * nnimap.el (nnimap-open-connection): Fix prog1/prog2 bug. 2004-10-26 Katsumi Yamaoka * nnspool.el (nnspool-spool-directory): Use news-path if the news-directory variable is not bound. * gnus-start.el (gnus-check-reasonable-setup): Use an alternative function instead of display-warning if it is not available. 2004-10-26 Reiner Steib * gnus-agent.el (gnus-agent-expire-group-1): Fix last merge from v5-10: Use `point-at-bol'. 2004-10-26 Simon Josefsson * hashcash.el: Fix URL in comment, reported by Cheng Gao . 2004-10-25 Reiner Steib * html2text.el (html2text-buffer-head): Remove. Use `goto-char' instead. 2004-10-25 Teodor Zlatanov * nnimap.el (nnimap-remove-server-from-buffer-alist): Add function to remove a server from the nnimap-server-buffer-alist. (nnimap-open-connection, nnimap-close-server): Use it. * gnus-encrypt.el: Remove file in favor of encrypt.el. 2004-10-21 Katsumi Yamaoka * mm-view.el (mm-display-inline-fontify): Inhibit font-lock when running the major-mode function. 2004-10-19 Katsumi Yamaoka * gnus-sum.el (gnus-update-summary-mark-positions): Search for dummy marks in the right way. 2004-10-18 David Edmondson * mm-view.el (mm-w3m-cid-retrieve-1): Don't use recursive call excessively. 2004-10-18 Teodor Zlatanov * gnus-util.el (gnus-split-references): Accept a nil references string and go on blissfully. * gnus-registry.el (gnus-registry-split-fancy-with-parent): Catch cases where the references string is non-nil but has no references. * encrypt.el: Add autoload tags. * spam.el (spam-resolve-registrations-routine): Remove article from unregistration list too. Reported by David Hanak 2004-10-18 Reiner Steib * gnus-art.el (gnus-copy-article-ignored-headers): Default to nil. Changed custom type. 2004-10-17 Reiner Steib * gnus-art.el (gnus-copy-article-ignored-headers): New variable. * gnus-sum.el (gnus-summary-move-article): Use it. 2004-10-15 Teodor Zlatanov * encrypt.el: Add autoload cookies. * spam.el (spam-backend-article-list-property) (spam-backend-get-article-todo-list) (spam-backend-put-article-todo-list, ) (spam-summary-prepare-exit, spam-resolve-registrations-routine): Resolve registrations separately. (spam-register-routine): Format comments. (spam-unregister-routine, spam-register-routine): Always call with specific-articles, no default list. (spam-summary-prepare-exit): Use the spam-classifications function. * netrc.el (autoload, netrc-parse): Use encrypt.el instead of gnus-encrypt.el. * encrypt.el: Copied from gnus-encrypt.el. * gnus-encrypt.el: Commented that it's obsolete. 2004-10-15 Reiner Steib * gnus-score.el (gnus-adaptive-pretty-print): New variable. (gnus-score-save): Use it. * message.el (message-bury): Use `window-dedicated-p'. 2004-10-15 Simon Josefsson * pop3.el (top-level): Don't require nnheader. (pop3-read-timeout): Add. (pop3-accept-process-output): Add. (pop3-read-response, pop3-retr): Use it. 2004-10-14 Teodor Zlatanov * spam.el (spam-register-routine): Move comment. (spam-verify-bogofilter): Use 'unknown for the initial spam-bogofilter-valid state, not 'never. * netrc.el (netrc-machine-user-or-password): Add convenience wrapper for netrc-machine. * nnimap.el (nnimap-open-connection): Use netrc-machine-user-or-password. 2004-10-17 Richard M. Stallman * gnus-registry.el (gnus-registry-unload-hook): Set as a variable with add-hook. * nnspool.el (nnspool-spool-directory): Use news-directory instead of news-path. * spam-stat.el (spam-stat-unload-hook): Set as a variable w/ add-hook. * spam.el: Delete duplicate `provide'. (spam-unload-hook): Set as a variable with add-hook. 2004-10-15 Reiner Steib * pop3.el (pop3-leave-mail-on-server): Describe possible problems in the doc string. * message.el (message-ignored-news-headers) (message-ignored-supersedes-headers) (message-ignored-resent-headers) (message-forward-ignored-headers): Improve custom type. 2004-10-13 Katsumi Yamaoka * message.el (message-tokenize-header): Fix 2004-09-06 change which used point-min in the wrong place. 2004-10-12 Simon Josefsson * tls.el (tls-certtool-program): New variable. (tls-certificate-information): New function, based on ssl-certificate-information. 2004-10-12 Katsumi Yamaoka * compface.el: Move the version of ELisp-based uncompface program to the contrib directory because of the copyright problem. 2004-10-12 Reiner Steib * message.el (message-kill-buffer): Raise the current frame. 2004-10-10 Reiner Steib * gnus-sum.el: Mention that multibyte characters don't work as marks. * gnus.el (message-y-or-n-p): Autoload. * pop3.el (pop3-maildrop, pop3-mailhost, pop3-port) (pop3-password-required, pop3-authentication-scheme) (pop3-leave-mail-on-server): Made customizable. (pop3): New custom group. (pop3-retr): Remove `sleep-for' statements. Suggested by Dave Love . * nnheader.el (nnheader-read-timeout): Explain 1.0 timeout for Windows/DOS. * imap.el (imap-parse-flag-list, imap-parse-body-extension) (imap-parse-body): Fix incorrect use of `assert'. Suggested by Dave Love . * mml.el (mml-minibuffer-read-disposition): Require match. Suggested by Dave Love . 2004-10-11 Reiner Steib * gnus-group.el (gnus-group-delete-group): Change "\t." to " " in doc string. 2004-10-08 Katsumi Yamaoka * mm-uu.el (mm-uu-dissect-text-parts): Support all text/* types. 2004-10-07 TSUCHIYA Masatoshi * gnus-art.el (gnus-mime-display-single): Call `mm-display-inline' instead of calling `mm-insert-inline', to decode text/* parts before displaying them. 2004-10-07 Katsumi Yamaoka * mm-uu.el (mm-uu-text-plain-type): New variable. (mm-uu-pgp-signed-extract-1): Use it. (mm-uu-pgp-encrypted-extract-1): Use it. (mm-uu-dissect): Allow MIME type and parameters as an optional arg; bind mm-uu-text-plain-type with that value. (mm-uu-dissect-text-parts): Pass MIME type and parameters to mm-uu-dissect. 2004-10-06 Katsumi Yamaoka * gnus-group.el (gnus-update-group-mark-positions): * gnus-sum.el (gnus-update-summary-mark-positions): * message.el (message-check-news-body-syntax): * gnus-msg.el (gnus-debug): Use mm-string-as-multibyte instead of string-as-multibyte. 2004-10-05 Juri Linkov * gnus-group.el (gnus-update-group-mark-positions): * gnus-sum.el (gnus-update-summary-mark-positions): * message.el (message-check-news-body-syntax): * gnus-msg.el (gnus-debug): Use `string-as-multibyte' to convert 8-bit unibyte values to a multibyte string for search functions. 2004-10-06 Katsumi Yamaoka * mm-uu.el (mm-uu-dissect): Allow optional arg. (mm-uu-dissect-text-parts): New function. * gnus-art.el (gnus-display-mime): Use mm-uu-dissect-text-parts to dissect text parts. * gnus-sum.el (gnus-summary-insert-subject): Remove redundant setq. (gnus-summary-force-verify-and-decrypt): Revert 2004-08-18 change. * mm-decode.el (mm-dissect-singlepart): Revert 2004-08-18 change. * gnus-topic.el (gnus-topic-hierarchical-parameters): Use gnus-current-topics instead of gnus-current-topic. 2004-10-06 Jesper Harder * gnus-sum.el (gnus-summary-show-article): Use with-current-buffer. 2004-10-05 Jesper Harder * nnsoup.el (nnsoup-read-active-file): Use dolist, mapc or last where approriate. * nnml.el (nnml-generate-active-info): do. * nndiary.el (nndiary-generate-active-info): do. * gnus-topic.el (gnus-topic-hierarchical-parameters): do. (gnus-topic-move): do. * gnus-sum.el (gnus-data-enter-list, gnus-summary-process-mark-set) (gnus-summary-set-local-parameters, gnus-summary-read-document): do. * gnus-srvr.el (gnus-server-prepare) (gnus-server-open-all-servers): do. * gnus-msg.el (gnus-summary-cancel-article) (gnus-summary-resend-message) (gnus-summary-mail-crosspost-complaint): do. * gnus-move.el (gnus-change-server): do. * gnus-group.el (gnus-group-unmark-all-groups) (gnus-group-set-current-level): do. 2004-10-04 Simon Josefsson * message.el (message-generate-hashcash): Doc fix. 2004-10-02 Kevin Greiner * nnagent.el (nnagent-request-type): Bind gnus-agent to nil to avoid infinite recursion via gnus-get-function. 2004-10-02 Jesper Harder * mm-partial.el (mm-partial-find-parts): Use with-current-buffer. * nnfolder.el (nnfolder-generate-active-file): Use dolist. * nnmail.el (nnmail-split-history): do. * nnml.el (nnml-generate-nov-databases-1, nnml-request-rename-group) (nnml-request-delete-group): do. * nnslashdot.el (nnslashdot-read-groups): do. * nnsoup.el (nnsoup-delete-unreferenced-message-files): do. (nnsoup-unpack-packets, nnsoup-make-active): Simplify. * nnspool.el (nnspool-find-id): Use with-temp-buffer. (nnspool-sift-nov-with-sed): Use last (nnspool-retrieve-headers-with-nov): Use mapc. (nnspool-request-newgroups): Use dolist. (nnspool-request-group): Use last. * nntp.el (nntp-read-server-type): Use dolist. * nnvirtual.el (nnvirtual-create-mapping) (nnvirtual-update-read-and-marked): Use dolist. (nnvirtual-convert-headers): Simplify. 2004-10-01 Kevin Greiner * gnus-agent.el (gnus-agent-synchronize-group-flags): Added support for sync'ing tick marks. 2004-10-01 Katsumi Yamaoka * gnus-sum.el (gnus-summary-toggle-header): Make it work even if there's no visible header. 2004-10-01 Kevin Greiner * gnus-agent.el (gnus-agent-synchronize-group-flags): When necessary, pass full group name to gnus-request-set-marks. 2004-10-01 Simon Josefsson * mailcap.el (mailcap-mime-data): Add pdf. Remove non-free acroread. 2004-10-01 Lars Magne Ingebrigtsen * spam-report.el (spam-report-gmane): Fix interactive. * gnus-art.el (gnus-treat-body-boundary): Only do stuff under X. * gnus-agent.el (gnus-agent-synchronize-flags-server): Be silent when writing file. (gnus-agent-synchronize-flags): Don't default to being interactive. 2004-09-30 Simon Josefsson * message.el (message-generate-hashcash): Add. (message-send-mail): Use it, call mail-add-payment. 2004-09-29 Teodor Zlatanov * spam.el (spam-verify-bogofilter): Use -V, not -sV option. 2004-09-28 Kevin Greiner * gnus-agent.el (gnus-agent-synchronize-group-flags): Replaced gnus-requst-update-info with explicit code to sync the in-memory info read flags with the marks being sync'd to the backend. *gnus-util.el (gnus-pp): Added optional stream to match pp API. 2004-09-28 Teodor Zlatanov * spam.el (spam-verify-bogofilter): Add new function. (spam-check-bogofilter) (spam-bogofilter-register-with-bogofilter): Use it. (spam-verify-bogofilter): Add small fixes. 2004-09-28 Simon Josefsson * hashcash.el (hashcash-generate-payment): Revert. 2004-09-28 Teodor Zlatanov * gnus-registry.el (gnus-registry-split-fancy-with-parent): Use gnus-extract-references instead of gnus-split-references. * gnus-util.el (gnus-extract-references): Add new function, analogous to gnus-split-references but extracts only the message-ID without anything extra. * hashcash.el (hashcash-generate-payment) (hashcash-check-payment): Do the right thing if hashcash-path is nil (because the hashcash program could not be found). * spam.el (spam-use-hashcash): Remove comment. 2004-09-27 Jesper Harder * gnus-cache.el (gnus-cache-possibly-remove-articles-1) (gnus-cache-enter-article, gnus-cache-remove-article) (gnus-cache-braid-heads, gnus-cache-generate-active): Use dolist. * gnus-async.el (gnus-async-prefetch-remove-group): do. * gnus-art.el (article-hide-boring-headers) (article-translate-strings, article-display-face) (gnus-article-mime-match-handle-first) (gnus-article-highlight-headers) (gnus-article-add-buttons-to-head): do. 2004-09-27 Simon Josefsson * hashcash.el: New version, from http://users.actrix.co.nz/mycroft/hashcash.el. Previously in ../contrib/. 2004-09-27 Katsumi Yamaoka * mm-decode.el (mm-copy-to-buffer): Don't use set-buffer-multibyte. 2004-09-26 Jesper Harder * gnus-dup.el (gnus-dup-open): Use mapc. (gnus-dup-enter-articles, gnus-dup-suppress-articles): Use dolist. (gnus-dup-enter-articles): Remove excess ID's from gnus-dup-hashtb. Reported by Stefan Wiens . * gnus.el (gnus-shutdown): Use dolist. * gnus-undo.el (gnus-undo): Use mapc. * nnrss.el (nnrss-generate-active): do. * message.el (message-cite-original-without-signature) (message-cite-original): Use mapc. (message-do-actions, message-make-forward-subject): Use dolist. 2004-09-25 Kevin Greiner * gnus-agent.el (gnus-agent-check-overview-buffer): Fixed range of deletion to remove entire duplicate line. Fixes merged article number bug. 2004-09-25 Kevin Greiner * gnus-agent.el (gnus-agent-possibly-synchronize-flags): Ignore servers that are offline. Avoids having gnus-agent-toggle-plugged first ask if you want to open a server and then, even when you responded with no, asking if you want to synchronize the server's flags. (gnus-agent-synchronize-flags-server): Rewrote read loop to handle multi-line expressions. (gnus-agent-synchronize-group-flags): New internal function. Updates marks in memory (in the info structure) AND in the backend. * gnus-util.el (gnus-remassoc): Fixed typo in documentation. * nnagent.el (nnagent-request-set-mark): Use gnus-agent-synchronize-group-flags, not backend's request-set-mark method, to ensure that synchronization updates marks in the backend and in the info (in memory) structure. 2004-09-24 Katsumi Yamaoka * gnus-uu.el (gnus-uu-digest-mail-forward): Obey the process/prefix convention fully; don't miss the root article of a thread; make the X-Draft-From header with correct article numbers. 2004-09-23 Kevin Greiner * gnus-agent.el (gnus-agent-synchronize-flags-server): Do nothing unless plugged. Disable the agent so that an open failure causes an error. * gnus-int.el (gnus-request-set-mark, gnus-request-update-mark): Reverted 2004-09-21 change. The backend must be opened while synchronizing flags even when the backend stores the flags locally. 2004-09-23 Reiner Steib * gnus-msg.el (gnus-configure-posting-styles): Narrow to headers in `header' match. Reported by Svend Tollak Munkejord. * message.el (message-cite-original): Fix use of `message-cite-articles-with-x-no-archive'. 2004-09-22 Katsumi Yamaoka * gnus-win.el (gnus-buffer-configuration): Add mml-preview. (gnus-window-to-buffer): Ditto. * mml.el (mml-preview-buffer): New variable. (mml-preview): Manage window layout with gnus-buffer-configuration. * gnus-msg.el (gnus-setup-message): Put article numbers into the X-Draft-From header even if those articles aren't quoted. 2004-09-21 Kevin Greiner * gnus-int.el (gnus-servers-that-use-local-marks): New variable. (gnus-request-set-mark, gnus-request-update-mark): Use new g-s-t-u-l-m to decide to use backend even when unplugged. 2004-09-21 Katsumi Yamaoka * gnus-msg.el (gnus-inews-make-draft-meta-information): Don't add a trailing whitespace. Suggested by Cheng Gao . 2004-09-20 Simon Josefsson * mm-util.el (mm-charset-synonym-alist): Map "unicode" to "utf-16-le". 2004-09-20 Stefan Monnier * mm-decode.el (mm-copy-to-buffer): Preserve the data's unibyteness. 2004-09-19 Reiner Steib * uudecode.el (uudecode-use-external): Add :version. * smime.el (smime-CA-file, smime-encrypt-cipher) (smime-dns-server): Add :version. * smiley.el (gnus-smiley-file-types): Add :version. * sha1.el (sha1-use-external): Add :version. * pgg-def.el (pgg-query-keyserver): Add :version. * nnmail.el (nnmail-fancy-expiry-targets) (nnmail-mail-splitting-charset, nnmail-mail-splitting-decodes): Add :version. * nnimap.el (nnimap-split-download-body, nnimap-dont-close) (nnimap-retrieve-groups-asynchronous): Add :version. (nnimap-close-asynchronous): Add :version. Fixed typo in doc string. * mml.el (mml-content-disposition-parameters) (mml-insert-mime-headers-always): Add :version. * mm-util.el (mm-coding-system-priorities): Add :version. * mm-decode.el (mm-inline-text-html-with-images) (mm-keep-viewer-alive-types, mm-external-terminal-program) (mm-verify-option): Add :version. (mm-text-html-renderer): Change :version. * message.el (message-fcc-externalize-attachments) (message-required-headers, message-draft-headers) (message-subject-trailing-was-query) (message-subject-trailing-was-ask-regexp) (message-subject-trailing-was-regexp, message-mark-insert-begin) (message-mark-insert-end, message-archive-header) (message-archive-note, message-cross-post-default) (message-cross-post-note, message-followup-to-note) (message-cross-post-note-function, message-use-mail-followup-to) (message-subscribed-address-functions) (message-subscribed-address-file, message-subscribed-addresses) (message-subscribed-regexps, message-allow-no-recipients) (message-yank-cited-prefix, message-signature-insert-empty-line) (message-hidden-headers, message-hierarchical-addresses) (message-mail-user-agent, message-use-idna) (message-valid-fqdn-regexp) (message-strip-special-text-properties, message-header-synonyms) (message-beginning-of-line, message-tab-body-function): Add :version. (message-insert-canlock, message-wide-reply-confirm-recipients): Change :version. * mail-source.el (mail-source-ignore-errors): Add :group, :type and :version. (mail-source-delete-old-incoming-confirm) (mail-source-movemail-program): Add :version. * gnus.el (gnus-parameters, gnus-user-agent): Add :version. (gnus-agent-cache, gnus-agent): Change :version. * gnus-util.el (gnus-use-byte-compile): Change :version. * gnus-sum.el (gnus-summary-make-false-root-always) (gnus-summary-default-high-score) (gnus-summary-default-low-score, gnus-auto-goto-ignores) (gnus-forwarded-mark, gnus-unseen-mark, gnus-no-mark) (gnus-read-all-available-headers, gnus-article-emulate-mime) (gnus-sum-thread-tree-root, gnus-sum-thread-tree-false-root) (gnus-sum-thread-tree-single-indent) (gnus-sum-thread-tree-vertical, gnus-sum-thread-tree-indent) (gnus-sum-thread-tree-leaf-with-other) (gnus-sum-thread-tree-single-leaf): Add :version. (gnus-summary-display-arrow, gnus-summary-muttprint-program) (gnus-article-loose-mime): Change :version. * gnus-start.el (gnus-backup-startup-file) (gnus-save-startup-file-via-temp-buffer): Add :version. * gnus-srvr.el (gnus-server-browse-in-group-buffer) (gnus-server-offline-face): Add :version. * gnus-score.el (gnus-adaptive-word-length-limit): Add :version. * gnus-msg.el (gnus-gcc-externalize-attachments) (gnus-debug-files, gnus-debug-exclude-variables) (gnus-discouraged-post-methods): Change :version. (gnus-confirm-mail-reply-to-news) (gnus-confirm-treat-mail-like-news): Add :version. * gnus-int.el (gnus-server-unopen-status): Add :version. * gnus-group.el (gnus-group-jump-to-group-prompt) (gnus-large-ephemeral-newsgroup) (gnus-fetch-old-ephemeral-headers): Add :version. * gnus-fun.el (gnus-x-face-directory) (gnus-convert-pbm-to-x-face-command) (gnus-convert-image-to-x-face-command) (gnus-convert-image-to-face-command): Add :version. * gnus-delay.el (gnus-delay-default-hour): Add :version. * gnus-cite.el (gnus-cite-blank-line-after-header) (gnus-article-boring-faces): Add :version. * gnus-art.el (gnus-buttonized-mime-types) (gnus-inhibit-mime-unbuttonizing) (gnus-treat-display-face) (gnus-treat-body-boundary): Change :version. (gnus-body-boundary-delimiter, gnus-picon-databases) (gnus-treat-strip-cr, gnus-treat-leading-whitespace) (gnus-treat-date-english, gnus-treat-fold-headers) (gnus-article-skip-boring, gnus-treat-fold-newsgroups) (gnus-treat-mail-picon, gnus-treat-wash-html) (gnus-article-encrypt-protocol) (gnus-use-idna, gnus-article-over-scroll) (gnus-mime-display-multipart-alternative-as-mixed) (gnus-mime-display-multipart-related-as-mixed) (gnus-button-valid-fqdn-regexp, gnus-button-man-handler) (gnus-ctan-url, gnus-button-ctan-handler) (gnus-button-handle-ctan-bogus-regexp) (gnus-button-ctan-directory-regexp) (gnus-button-mid-or-mail-regexp, gnus-button-prefer-mid-or-mail) (gnus-button-mid-or-mail-heuristic-alist, gnus-button-tex-level) (gnus-button-man-level, gnus-button-emacs-level) (gnus-button-message-level, gnus-button-browse-level): Add :version. * gnus-agent.el (gnus-agent-fetched-hook): Add :version. (gnus-agent-go-online): Change :version. (gnus-agent-expire-unagentized-dirs) (gnus-agent-auto-agentize-methods): Add :version. * flow-fill.el (fill-flowed-display-column) (fill-flowed-encode-column): Add :version. * deuglify.el (gnus-outlook-deuglify-unwrap-min) (gnus-outlook-deuglify-unwrap-max) (gnus-outlook-deuglify-cite-marks) (gnus-outlook-deuglify-unwrap-stop-chars) (gnus-outlook-deuglify-no-wrap-chars) (gnus-outlook-deuglify-attrib-cut-regexp) (gnus-outlook-deuglify-attrib-verb-regexp) (gnus-outlook-deuglify-attrib-end-regexp) (gnus-outlook-display-hook): Add :version. * binhex.el (binhex-use-external): Add :version. 2004-09-16 Reiner Steib * gnus-sum.el (gnus-fetch-old-headers): Add custom choices `t' and `invisible'. 2004-09-10 Teodor Zlatanov * gnus-registry.el (gnus-registry-trim): Watch out for negatives in gnus-registry-trim. 2004-09-13 Simon Josefsson * dns-mode.el: Add XEmacs auto-mode-alist autoload cookie. * nnimap.el (nnimap-demule): Revert 2004-08-30 change. * dns-mode.el (dns-mode): Fix menu for XEmacs, reported by Steve Youngs and suggested by Katsumi Yamaoka . (dns-mode-font-lock-keywords): Fix faces, reported by Steve Youngs and suggested by Katsumi Yamaoka . * sieve.el (sieve-manage-mode): Ditto. 2004-09-13 Reiner Steib * gnus-sum.el (gnus-summary-copy-article): Fix doc string. 2004-09-11 Simon Josefsson * dns-mode.el: Add. * mm-view.el (mm-display-dns-inline): Add. * mm-decode.el (mm-inline-media-tests): Add text/dns. (mm-automatic-display): Ditto. * mailcap.el (mailcap-mime-data): Add text/dns. (mailcap-mime-extensions): Map .soa to text/dns. 2004-09-10 Miles Bader * gnus-art.el (article-decode-mime-words, article-babel) (gnus-article-highlight-signature, gnus-article-add-buttons) (gnus-signature-toggle): Remove unnecessary bindings of `inhibit-read-only' inherited from v5.10 merge. 2004-09-08 Reiner Steib * nntp.el (nntp): New customization group. (nntp-authinfo-file): Add customization group. * mml2015.el (mml2015-unabbrev-trust-alist): Add customization group. * mml-sec.el (mml-signencrypt-style-alist): Ditto. * gnus.el (to-address, to-list, subscribed) (large-newsgroup-initial): Ditto. * flow-fill.el (fill-flowed-display-column) (fill-flowed-encode-column): Ditto. 2004-09-06 Stefan * message.el (message-tokenize-header, message-send-mail-with-qmail): Use point-min rather than 1. (message-send-mail): Use buffer-size rather than point-max. * gnus-sum.el (gnus-summary-search-article-forward): Signal a specific `search-failed' rather than a generic `error'. * gnus-salt.el (gnus-pick-mouse-pick-region): Switch 1 => point-min. (gnus-generate-vertical-tree): Usue `bobp' rather than compare to 1. (gnus-highlight-selected-tree): Use point-min rather than 1 and 2. 2004-09-10 Simon Josefsson * nndb.el (require): Remove tcp and duplicate cl. 2004-09-10 Katsumi Yamaoka * gnus-agent.el (directory-files-and-attributes): Move forward. 2004-09-09 Kevin Greiner * gnus-agent.el (directory-files-and-attributes): Optionally defined to support XEmacs. 2004-09-09 Kevin Greiner * gnus-agent.el (gnus-agent-cat-groups): Rewrote avoiding defsetf to avoid run-time CL dependencies. (gnus-agent-unfetch-articles): New function. (gnus-agent-fetch-headers): Use gnus-agent-braid-nov to validate article numbers even when local .overview file is missing. (gnus-agent-read-article-number): New function. Only accepts 27-bit article numbers. (gnus-agent-copy-nov-line, gnus-agent-uncached-articles): Use gnus-agent-read-article-number. (gnus-agent-braid-nov): Rewrote to validate article numbers coming from backend while recognizing that article numbers in .overview must be valid. (gnus-agent-update-files-total-fetched-for): Use directory-files-and-attributes to improve performance. * gnus-int.el (gnus-request-move-article): Use gnus-agent-unfetch-articles in place of gnus-agent-expire to improve performance. * gnus-start.el (gnus-convert-old-newsrc): Changed message text as some users confused by references to .newsrc when they only have a .newsrc.eld file. (gnus-convert-mark-converter-prompt, gnus-convert-converter-needs-prompt): Fixed use of property list. * legacy-gnus-agent.el (gnus-agent-convert-to-compressed-agentview-prompt): New function. Used internally to only display 'gnus converting files' message when actually necessary. * gnus-sum.el (): Removed (require 'gnus-agent) as required methods now autoloaded. 2004-09-03 Katsumi Yamaoka * gnus-sum.el (gnus-summary-insert-subject): Remove list identifiers. 2004-09-02 Reiner Steib * gnus-picon.el: Fix indentation and closing parenthesis. 2004-09-01 Simon Josefsson * message.el (message-canlock-generate): Require sha1, not sha1-el. (Can we get rid of this require alltogheter? It is ugly to require within a function. Sadly, if sha1.el isn't loaded, the let binding in m-c-g will hide the defcustom definition, which is bad.) * canlock.el: Require sha1, not sha1-el. * message.el: Don't autoload sha1 (there is a autoload cookie in sha1.el). * sha1-el.el: Renamed to sha1.el. 2004-08-30 Juanma Barranquero * ietf-drums.el (ietf-drums-remove-whitespace): Fix character constant. 2004-08-30 Stefan Monnier * nnimap.el (nnimap-demule): Avoid string-as-multibyte. 2004-08-30 Kim F. Storm * nntp.el (nntp-authinfo-file): Add :group 'nntp. * nnimap.el (nnimap-authinfo-file, nnimap-prune-cache): Add :group 'nnimap. 2004-08-30 Andreas Schwab * rfc2231.el (rfc2231-parse-string): Restore whitespace syntax for ?* and ?\;. * ietf-drums.el (ietf-drums-syntax-table): Set syntax of ?* ?\; and ?\' to symbol instead of whitespace. 2004-08-30 Katsumi Yamaoka * gnus-agent.el (gnus-agent-restore-gcc): Use ^ and regexp-quote. * gnus-sum.el (gnus-summary-morse-message): Use search-forward instead of re-search-forward. * gnus-uu.el (gnus-uu-save-article): Ditto. (gnus-uu-post-encode-uuencode): Ditto. * html2text.el (html2text-clean-list-items): Ditto. (html2text-clean-dtdd): Ditto. (html2text-format-tags): Ditto. * message.el (message-send-mail-with-sendmail): Fix regexp. (message-fill-field-general): Use search-forward instead of re-search-forward. (unbold-region): Ditto. * nnrss.el (nnrss-request-article): Ditto. * nnslashdot.el (nnslashdot-request-article): Ditto. * nnweb.el (nnweb-gmane-wash-article): Ditto. * gnus-sum.el (gnus-summary-make-menu-bar): Avoid the "Unrecognized menu descriptor" error in XEmacs. 2004-08-26 Stefan Wiens (tiny change) * gnus-sum.el (gnus-read-header): Don't remove a header for the parent article of a sparse article in the thread hashtb. 2004-08-26 David Hedbor (tiny change) * nnmail.el (nnmail-split-lowercase-expanded): New user option. (nnmail-expand-newtext): Lowercase expanded entries if nnmail-split-lowercase-expanded is non-nil. 2004-08-26 Katsumi Yamaoka * nndoc.el (nndoc-type-alist): Fix regexp in the rfc822-forward entry. * gnus-group.el (gnus-group-line-format-alist): Convert the value of gnus-tmp-news-method into string under XEmacs. It will be passed to gnus-correct-length which takes only a string argument. 2004-08-24 Katsumi Yamaoka * gnus-util.el (gnus-bind-print-variables): New macro. (gnus-prin1): Use it. (gnus-prin1-to-string): Use it. (gnus-pp): New function. (gnus-pp-to-string): New function. * gnus-cus.el (gnus-agent-cat-prepare-category-field): Replace pp-to-string with gnus-pp-to-string. * gnus-eform.el (gnus-edit-form): Replace pp with gnus-pp. * gnus-group.el (gnus-group-make-kiboze-group): Ditto. * gnus-msg.el (gnus-debug): Ditto. * gnus-score.el (gnus-score-save): Ditto. * gnus-spec.el (gnus-update-format): Replace pp-to-string with gnus-pp-to-string. * legacy-gnus-agent.el (gnus-agent-unlist-expire-days): Replace pp with gnus-pp. * score-mode.el (gnus-score-pretty-print): Ditto. * webmail.el (webmail-debug): Ditto. 2004-08-23 Katsumi Yamaoka * gnus-art.el (article-display-face, article-display-x-face): Use buffer-read-only. 2004-08-22 Katsumi Yamaoka * gnus-art.el (article-hide-list-identifiers): Bind inhibit-read-only as t. 2004-08-22 Reiner Steib * gnus-mlspl.el (gnus-group-split-update): Fix docstring. 2004-08-22 Stefan Monnier * gnus-art.el: Use inhibit-read-only instead of buffer-read-only. (gnus-narrow-to-page): Don't assume point-min == 1. (gnus-article-edit-mode): Derive from message-mode. * gnus-score.el (gnus-score-find-bnews): Simplify and don't assume point-min == 1. * imap.el (imap-parse-address-list, imap-parse-body-ext): Disable incorrect use of `assert'. * message.el (message-mode): Set comment-start-skip. 2004-08-22 Sam Steingold * pop3.el (pop3-leave-mail-on-server): New user variable. (pop3-movemail): Delete mail only when it is nil. 2004-08-21 Reiner Steib * nntp.el (nntp-marks-is-evil): Fix typo in docstring. * mml.el (mml-preview): Use `pop-to-buffer'. * message.el (message-goto-mail-followup-to): Insert after "To". (message-carefully-insert-headers): Add comment. * gnus.el: Remove unused variable `gnus-article-check-size'. * gnus-sum.el (gnus-summary-make-menu-bar): Add help texts. * gnus-art.el (gnus-button-alist): Improve `gnus-button-handle-library' entry. 2004-08-19 Sebastian Freundt (tiny change) * nnmaildir.el (nnmaildir--emlink-p, nnmaildir--enoent-p): Use downcase, since XEmacs capitalizes error messages differently. 2004-08-18 Jesper Harder * nntp.el: Add (require 'gnus) due to reference to `gnus-directory'. Reported by Matt Swift . 2004-08-18 Florian Weimer * gnus-sum.el (gnus-summary-force-verify-and-decrypt): Bind `mm-fill-flowed'. * mm-decode.el (mm-dissect-singlepart): Check it. 2004-08-17 Teodor Zlatanov * nnimap.el (nnimap-open-connection): Add 'imaps' synonym to 'imap' for netrc parsing. 2004-08-16 Reiner Steib * mailcap.el (mailcap-mime-data): Mark as risky. 2004-08-15 Katsumi Yamaoka * rfc2047.el (rfc2047-encode-region): Assume the close parenthesis may be included in the encoded word. (rfc2047-encode): Don't append a space if the encoded word includes close parenthesis. 2004-08-12 Katsumi Yamaoka * rfc2047.el (rfc2047-encode-1, rfc2047-encode): Improve encoding of text within parentheses. 2004-08-06 Teodor Zlatanov * gnus-encrypt.el (gnus-encrypt-insert-file-contents) (gnus-encrypt-write-file-contents): Make the password key the file name PLUS the cipher, not just the cipher. Also remove failed passwords from the cache. 2004-08-06 Simon Josefsson * gnus-sum.el (gnus-article-loose-mime): Change default to t. Doc fix. 2004-08-05 Katsumi Yamaoka * rfc2047.el (rfc2047-fold-region): Use trailing whitespace as LWSP. 2004-08-04 Teodor Zlatanov * gnus-registry.el (gnus-registry-split-fancy-with-parent): Try to append in-reply-to: data to the references: header. * netrc.el: Remove old encryption support, autoload gnus-encrypt.el (netrc-parse): Use gnus-encrypt.el functions. * gnus-encrypt.el: Add new file for encryption support; currently does only a few GPG ciphers and an internal XOR cipher. * password.el: Add comments on using password-read-and-add. (password-read-and-add): Add function to read and add the password to the cache at once. 2004-07-28 Simon Josefsson * pgg-pgp5.el (pgg-pgp5-encrypt-region): Accept sign parameter (but don't use it, for now). * imap.el (imap-ssl-open): Use imap-process-connection-type, instead of hard coding to nil. 2004-07-28 Katsumi Yamaoka * mm-view.el (mm-inline-image-emacs): Open lines under an image as mm-inline-image-xemacs does. 2004-07-26 Simon Josefsson * gnus-group.el (gnus-group-group-map, gnus-group-make-menu-bar): Revert part of 2004-07-17 change below. 2004-07-25 Katsumi Yamaoka * rfc2047.el (rfc2047-encode-region): Don't infloop. Suggested by Hiroshi Fujishima . 2004-07-25 Lars Magne Ingebrigtsen * flow-fill.el (fill-flowed): Remove space stuffing, and only do quotes that actually start with ">" at the beginning of the lines. 2004-07-23 Katsumi Yamaoka * rfc2047.el (rfc2047-encode-region): Fix last change. (rfc2047-encode-parameter): Remove useless concat. 2004-07-22 Katsumi Yamaoka * rfc2047.el (rfc2047-encode-region): Check carefully whether to encode special characters; fix some kind of misconfigured headers; signal a real error if debug-on-quit or debug-on-error is non-nil. (rfc2047-encode-max-chars): New variable. (rfc2047-encode-1): Use it. (rfc2047-encode-parameter): New function. * mml.el (mml-insert-parameter): Remove an excessive space. 2004-07-17 Simon Josefsson * gnus-group.el (gnus-group-make-group-simple): Add, suggested by Kai Grossjohann . (gnus-group-group-map): Use it, instead of gnus-group-make-group. (gnus-group-make-menu-bar): Ditto. * gnus-util.el (gnus-group-server): Add. 2004-07-16 Jesper Harder * message.el (message-clone-locals): Clone sendmail and smtp variables. 2004-07-12 Katsumi Yamaoka * rfc2047.el (rfc2047-encode-region): Fix last change. 2004-07-12 Katsumi Yamaoka * rfc2047.el (rfc2047-encode-region): Treat backslash-quoted characters as non-special. 2004-07-09 Simon Josefsson * gnus-agent.el (gnus-agent-synchronize-flags): Revert to ask. Users will lose all flag changes made while unplugged with e.g. nntp unless flag synchronization happens, thus `nil' is not a good default. See numerous reports on ding mailing list. 2004-07-09 Katsumi Yamaoka * nndoc.el (nndoc-type-alist): Improve regexp for article-begin, add generate-head-function and generate-article-function to the rfc822-forward entry. (nndoc-rfc822-forward-generate-article): New function. (nndoc-rfc822-forward-generate-head): New function. * mm-decode.el (mm-dissect-buffer): Simplify cleaning of CTE. 2004-07-06 Dan Christensen * gnus-sum.el (gnus-summary-read-group-1): When summary is unthreaded, respect display group parameter and gnus-summary-expunge-below. (gnus-articles-to-read): Remove unused reference to display group parameter. 2004-07-03 Lars Magne Ingebrigtsen * nnheader.el (nnheader-uniquify-message-id): New experimental variable. (nnheader-nov-read-message-id): Use it. * spam-report.el (spam-report-gmane): Add interactive. 2004-07-02 Katsumi Yamaoka * mm-encode.el (mm-content-transfer-encoding-defaults): Use qp-or-base64 for the application/* types. 2004-07-02 Joakim Verona (tiny change) * nnrss.el (nnrss-read-group-data): Fix off-by-one error. 2004-06-30 Teodor Zlatanov * gnus-registry.el (gnus-registry-trim): Don't allow a negative trim value. 2004-01-25 Paul Jarc * nnmaildir.el (nnmaildir--condcase, nnmaildir--enoent-p): New macro and function. (nnmaildir--new-number, nnmaildir-request-set-mark): Use them. 2004-06-29 Katsumi Yamaoka * mm-util.el (mm-enrich-utf-8-by-mule-ucs): Fix cleaning of after-load-alist. 2004-06-29 Lars Magne Ingebrigtsen * gnus-group.el (gnus-group-get-new-news-this-group): Don't update info that isn't there. 2004-06-29 Ilya N. Golubev . * mm-util.el (mm-mime-mule-charset-alist): Add the windows-1251 entry. 2004-06-29 Katsumi Yamaoka * mm-view.el (mm-inline-render-with-function): Use multibyte buffer; decode html source by charset. * mm-encode.el (mm-content-transfer-encoding-defaults): Doc fix. * mm-util.el (mm-enrich-utf-8-by-mule-ucs): New function run when Mule-UCS is loaded under XEmacs. (mm-mime-mule-charset-alist): Avoid duplicated entries. 2004-06-28 Jesper Harder * nnheader.el (nnheader-max-head-length): Increase to 8192. 2004-06-28 Katsumi Yamaoka * mm-util.el (mm-coding-system-p): Return a coding-system. (mm-mime-mule-charset-alist): Use shift_jis instead of iso-2022-jp-2 for the katakana-jisx0201 mule charset; add new entries for the mime charsets iso-2022-jp-3 and shift_jis. (mm-coding-system-priorities): Use shift_jis and iso-8859-1 instead of japanese-shift-jis and iso-latin-1 respectively in order to share the default value with both Emacs and XEmacs-mule. (mm-mule-charset-to-mime-charset): Make mm-coding-system-priorities effective. (mm-sort-coding-systems-predicate): Canonicalize coding-systems while predicating of candidates upon the priorities. 2004-06-27 Jesper Harder * gnus-sum.el (gnus-summary-make-menu-bar): Add gnus-uu-invert-processable. * gnus.el: Autoload gnus-uu-invert-processable. 2004-06-24 Katsumi Yamaoka * mm-util.el (mm-with-multibyte-buffer): New macro. * rfc2047.el (rfc2047-encode-string): Use it. (rfc2047-encode-region): Move point to the end of the region after encoding. Suggested by IRIE Tetsuya . 2004-06-23 Katsumi Yamaoka * gnus-cite.el (gnus-cite-parse): Don't ignore case when finding ">From ". Thanks to Reiner Steib . 2004-06-23 Katsumi Yamaoka * gnus-cite.el (gnus-cite-ignore-quoted-from): New user option. (gnus-cite-parse): Ignore quoted envelope From_. Suggested by Karl Chen . 2004-06-23 Jesper Harder * message.el (message-idna-to-ascii-rhs-1): Don't choke on invalid addresses. 2004-06-21 Teodor Zlatanov * spam.el: Change section markers, revise TODO list. (spam-backends): Make new master list of all installed backends. (spam-summary-exit-behavior): Add new variable to determine how messages moves are done at summary exit. (spam-move-spam-nonspam-groups-only) (spam-process-ham-in-nonham-groups) (spam-process-ham-in-spam-groups): Remove variables, the spam-summary-exit-behavior variable should be used to manage this behavior. (spam-old-ham-articles, spam-old-spam-articles): Remove. (spam-old-articles): Add variable, replacing spam-old-ham-articles and spam-old-spam-articles. (spam-use-copy, spam-use-move, spam-use-gmane, spam-use-resend): Add empty variables, placeholders for the backends they represent. (spam-set-difference): Move, unchanged. (spam-list-of-processors): Declare OBSOLETE, not used anymore unless the user has a processor variable. (spam-classifications, spam-classification-valid-p) (spam-backend-properties, spam-backend-property-valid-p) (spam-backend-function-type-valid-p) (spam-process-type-valid-p, spam-list-articles): Add helper functions. (spam-report-articles-gmane, spam-report-articles-resend): Remove functions, they are not needed. (spam-install-backend-super, spam-backend-list) (spam-backend-check, spam-backend-valid-p, spam-backend-info) (spam-backend-function, spam-backend-ham-registration-function) (spam-backend-spam-registration-function) (spam-backend-ham-unregistration-function) (spam-backend-spam-unregistration-function) (spam-backend-statistical-p, spam-backend-mover-p) (spam-install-backend-alias, spam-install-checkonly-backend) (spam-install-mover-backend, spam-install-nocheck-backend) (spam-install-backend, spam-install-statistical-backend) (spam-install-statistical-checkonly-backend): Add backend installation support. (spam-summary-prepare-exit): Rewrite to use the new backend code. (spam-group-processor-p): Use the new backend code and respect the summary exit behavior. (spam-mark-spam-as-expired-and-move-routine): Remove. (spam-summary-prepare): Change to use the new spam-old-articles variable. (spam-copy-or-move-routine, spam-copy-spam-routine) (spam-move-spam-routine, spam-copy-ham-routine) (spam-move-ham-routine): Add code to copy/move ham or spam. (spam-fetch-field-fast): Improve doc and code, plus allow the 'number request. (spam-list-of-checks, spam-list-of-statistical-checks): Remove variables. (spam-split, spam-find-spam): Use the new backend code. (spam-registration-functions): Remove variable. (spam-unregister-routine): Add convenience wrapper. (spam-log-undo-registration, spam-register-routine) (spam-log-processing-to-registry) (spam-log-unregistration-needed-p): Rename "check" to "backend" where possible. (spam-check-gmane-xref, spam-check-regex-headers) (spam-check-blackholes, spam-check-stat, spam-check-ifile) (spam-check-BBDB, spam-check-whitelist, spam-check-blacklist) (spam-check-bogofilter-headers, spam-check-spamoracle) (spam-check-spamassassin-headers, spam-check-bsfilter-headers) (spam-check-crm114-headers): Use the spam-split-group that spam-split prepares, no need to determine it every time. * nnimap.el (nnimap-retrieve-headers-progress): Add the message number to the nnheader-parse-naked-head call. * nnheader.el (nnheader-generate-fake-message-id): Fix indentation. * gnus-sum.el (gnus-nov-parse-line): Add the message number to the nnheader-nov-read-message-id call. 2004-06-21 Katsumi Yamaoka * gnus-group.el (gnus-group-get-new-news-this-group): Don't call gnus-activate-group twice. Suggested by Markus Peter . 2004-06-18 Katsumi Yamaoka * gnus-art.el (gnus-article-time-format): Exchange the order of day and month in the default value; fix customization type. (article-date-ut): Use add-text-properties. (article-make-date-line): Use message-make-date instead of current-time-string. * message.el (message-fetch-field): Don't use set-text-properties. (message-make-date): Simplify. * messagexmas.el (message-xmas-make-date): New function. (message-xmas-redefine): Defalias message-make-date to it. 2004-06-17 Katsumi Yamaoka * rfc2047.el (rfc2047-syntax-table): Treat `(' and `)' as is. (rfc2047-encode-region): Treat text within parentheses as special; show the original text when error has occurred. * gnus-group.el (gnus-group-get-new-news-this-group): Pass the already-computed method to gnus-activate-group. * gnus-start.el (gnus-make-hashtable-from-newsrc-alist): Make the same select-methods identical Lisp objects. * gnus-srvr.el (gnus-server-set-info): Don't make a new Lisp object when modifying the info. 2004-06-16 Katsumi Yamaoka * gnus-srvr.el (gnus-server-set-info): Remove the server from gnus-opened-servers since it has never been opened with the new configuration yet. 2004-06-15 Katsumi Yamaoka * nnheader.el (nnheader-nov-read-message-id): Pass the optional arg to nnheader-generate-fake-message-id. 2004-06-14 Teodor Zlatanov * nnheader.el (nnheader-generate-fake-message-id): Accept a number and build a fake message ID localized to a group and article number (so it's repeatable from that point on). (nnheader-fake-message-id-p): Change regex to accomodate new fake ID format. * gnus-sum.el (gnus-get-newsgroup-headers): Call nnheader-generate-fake-message-id with the article number. 2004-06-12 YAGI Tatsuya (tiny change) * gnus-art.el (gnus-article-next-page): Fix the way to find a real end-of-buffer. 2004-06-12 Lars Magne Ingebrigtsen * message.el (message-ignored-supersedes-headers): Add Approved. 2004-06-11 Katsumi Yamaoka * rfc2047.el (rfc2047-encode-message-header): Remove useless goto-char. (rfc2047-encode): Fold the line before encoding. 2004-06-10 Lars Magne Ingebrigtsen * rfc2047.el (rfc2047-encode-message-header): Disabled header folding -- not all headers can be folded, and this should be done by the message composition mode. Probably. I think. 2004-06-10 Katsumi Yamaoka * gnus-util.el (gnus-remove-text-with-property): Make it slightly fast. * gnus-ems.el (gnus-remove-image): Don't use message-text-with-property; remove only the image found first. * gnus-xmas.el (gnus-xmas-remove-image): Remove only the image found first. 2004-06-09 Jesper Harder * message.el (message-send-mail-with-sendmail): Use with-current-buffer. 2004-06-09 Katsumi Yamaoka * message.el (message-text-with-property): Make it fast and accept optional arguments. (message-strip-forbidden-properties): Use it. (message-fix-before-sending): Follow the m-t-w-p change. * gnus-ems.el (gnus-remove-image): Follow the m-t-w-p change. 2004-06-08 Katsumi Yamaoka * gnus-art.el (article-hide-headers): Don't change the buffer mistakenly when performing mml-preview even if gnus-single-article-buffer is nil. 2004-06-08 Kai Grossjohann * message.el (message-expand-name-databases): New user option. (message-expand-name): Use it. 2004-06-07 Teodor Zlatanov * spam.el (spam-report-articles-resend) (spam-report-resend-register-routine): Allow ham reporting. (spam-report-resend-register-ham-routine): Add wrapper. (spam-registration-functions): Add ham resending functions. (spam-list-of-processors): Add ham resend processor. * gnus.el (ham-resend-to): Add new group parameter. (spam-process): Add ham resend option. * spam-report.el (spam-report-resend): Allow reporting ham. (spam-report-resend-ham): Add wrapper. 2004-06-06 Lars Magne Ingebrigtsen * message.el (message-cite-articles-with-x-no-archive): New variable. (message-cite-original): Use it. 2004-06-04 Lars Magne Ingebrigtsen * message.el (message-cite-original): Respect X-No-Archive. 2004-06-04 Katsumi Yamaoka * gnus-art.el (article-hide-headers): Refer to the values for gnus-ignored-headers and gnus-visible-headers in the summary buffer since a user may have set them as group parameters. 2004-06-03 Teodor Zlatanov * assistant.el (assistant-node-name): Add convenience function. (assistant-render-text, assistant-render-node): Add error handling, plus handle multiple next nodes. (assistant-find-next-node): Comment out for now. (assistant-find-next-nodes): Add function, returns list of next nodes. 2004-06-02 Reiner Steib * mail-source.el (mail-source-directory): Fix doc-string. 2004-05-29 Teodor Zlatanov * assistant.el (assistant-render-text, assistant-eval): Add :set widget type, which is different because it takes and returns a list. Much hilarity ensues. 2004-05-28 Reiner Steib * gnus-art.el (gnus-button-alist): Fixed regexp for manual links. * gnus-group.el (gnus-group-get-new-news-this-group): Added doc-string. * gnus-start.el (gnus-activate-group): Added doc-string. 2004-05-28 Katsumi Yamaoka * mm-encode.el (mm-safer-encoding): Consider 7bit is safe. 2004-05-27 Teodor Zlatanov * assistant.el (assistant-render-text): Try to add a :set widget, more to come. * spam.el (spam-group-spam-contents-p): Handle empty groupname strings. (spam-report-articles-resend) (spam-register-routine): Do registration iff any articles warrant it. (spam-summary-prepare-exit): Change log message for nil group destinations. 2004-05-27 Daniel Pittman * spam.el (spam-report-resend-register-routine): Allow spam-report-resend-to to be a group parameter or a global value. 2004-05-26 Simon Josefsson * starttls.el: Merge with my GNUTLS based starttls.el. (starttls-gnutls-program, starttls-use-gnutls) (starttls-extra-arguments, starttls-process-connection-type) (starttls-connect, starttls-failure, starttls-success): New variables. (starttls-program, starttls-extra-args): Doc fix. (starttls-negotiate-gnutls, starttls-open-stream-gnutls): New functions. (starttls-negotiate, starttls-open-stream): Check `starttls-use-gnutls' and pass on to corresponding *-gnutls function if it is set. 2004-05-27 Katsumi Yamaoka * rfc2047.el (rfc2047-encode-region): Encode encoded words in structured fields. 2004-05-26 Katsumi Yamaoka * message.el (message-resend): Bind rfc2047-encode-encoded-words. 2004-05-26 Teodor Zlatanov * spam.el (spam-mark-new-messages-in-spam-group-as-spam): Add variable. (spam-mark-junk-as-spam-routine): Use it. Allow to disable assigning the spam-mark to new messages. 2004-05-26 Adam Sjøgren (tiny change) (spam-ham-copy-or-move-routine): Don't declare `todo' twice. 2004-05-26 Katsumi Yamaoka * dgnushack.el: Autoload customize-set-variable for XEmacs. * rfc2047.el (rfc2047-encodable-p): Don't move point. (rfc2047-decode): Treat the ascii coding-system as raw-text by default. 2004-05-25 Anand Mitra (tiny change) * gnus-sum.el (gnus-summary-delete-article): Invoke hook with correct data. 2004-05-24 Teodor Zlatanov * spam.el (spam-list-of-processors): Use nil for nonexistent processors. (spam-group-processor-p): Fix function. (spam-group-processor-multiple-p) (spam-group-spam-processor-report-gmane-p) (spam-group-spam-processor-report-resend-p) (spam-group-spam-processor-bogofilter-p) (spam-group-spam-processor-blacklist-p) (spam-group-spam-processor-ifile-p) (spam-group-ham-processor-ifile-p) (spam-group-spam-processor-spamoracle-p) (spam-group-spam-processor-crm114-p) (spam-group-ham-processor-bogofilter-p) (spam-group-spam-processor-stat-p) (spam-group-ham-processor-stat-p) (spam-group-ham-processor-whitelist-p) (spam-group-ham-processor-BBDB-p) (spam-group-ham-processor-spamoracle-p) (spam-group-ham-processor-copy-p): Remove functions with some prejudice against unneeded code. (spam-report-articles-resend) (spam-report-resend-register-routine): Allow the group/topic spam-resend-to value to override spam-report-resend-to. (spam-summary-prepare-exit): Invoke spam-group-processor-p properly now. * gnus.el (spam-resend-to): Add group/topic parameter. (spam-process): Move the OBSOLETE processors to the end of the choices. 2004-05-24 Daniel Pittman * spam-report.el (spam-report-resend-to, spam-report-resend): Start with resend-to set to nil, and then ask the user if necessary. (spam-report-resend): spam-report-resend takes a list of articles, not separate article numbers. 2004-05-23 Katsumi Yamaoka * mm-decode.el (mm-text-html-renderer): Make sure w3m exists in addition to emacs-w3m. 2004-05-23 Lars Magne Ingebrigtsen * assistant.el (assistant-authinfo-data): New function. (assistant-eval): Eval for entire assistant. * netrc.el (netrc-services-file): New variable. (netrc-parse-services): New function. (netrc-find-service-name): New function. (netrc-find-service-number): New function. (netrc-port-equal): New function. (netrc-machine): Use it. * nnimap.el (nnimap-open-connection): Use netrc. * gnus-util.el (gnus-netrc-get): Remove aliases. * gnus-sum.el (gnus-auto-center-summary): Change default to 2. * assistant.el (wid-edit): Fix compilation. * gnus-util.el (gnus-set-file-modes): Just ignore errors. 2004-05-23 Paul Stodghill * gnus-util.el (gnus-set-file-modes): New function. (small patch). 2004-05-23 Lars Magne Ingebrigtsen * gnus-topic.el (gnus-topic-jump-to-topic): Goto missing topic. * assistant.el (assistant-render-node): Fix up rendering and read-only text. (assistant-render-node): Reset. (assistant-make-read-only): Not sticky. 2004-05-20 Danny Siu * gnus-sum.el (gnus-summary-recenter): Summery buffer was not auto centered even when gnus-auto-center-summary is t 2004-05-22 Lars Magne Ingebrigtsen * dns.el (dns-get-txt-answer): New function. (dns-read-txt): Ditto. (query-dns): Use it. 2004-05-21 Katsumi Yamaoka * gnus-start.el (gnus-get-unread-articles): Don't invalidate active for foreign groups even if the group level is higher than the specified value. 2004-05-21 Lars Magne Ingebrigtsen * gnus-group.el (gnus-group-jump-to-group): Don't prompt for non-active groups. * gnus-art.el (gnus-picon-databases): Add /usr/share/picons. 2004-05-20 Magnus Henoch * dns.el (dns-read-type): Add support for SVR. (small patch) 2004-05-20 Teodor Zlatanov * spam.el (spam-use-crm114, spam-crm114, spam-crm114-program) (spam-crm114-header, spam-crm114-spam-switch) (spam-crm114-spam-strong-switch, spam-crm114-ham-strong-switch) (spam-crm114-positive-spam-header) (spam-crm114-database-directory, spam-list-of-processors) (spam-group-spam-processor-crm114-p) (spam-group-ham-processor-crm114-p, spam-extra-header-to-number) (spam-generic-score, spam-list-of-checks) (spam-list-of-statistical-checks, spam-registration-functions) (spam-check-crm114-headers, spam-crm114-score) (spam-check-crm114, spam-crm114-register-with-crm114) (spam-crm114-register-spam-routine) (spam-crm114-unregister-spam-routine) (spam-crm114-register-ham-routine) (spam-crm114-unregister-ham-routine): Add CRM114 support. From asjo@koldfront.dk (Adam Sjøgren). * gnus.el: Add spam-use-crm114. * spam.el (spam-list-of-processors, spam-registration-functions): Add spam-use-resend. (spam-group-spam-processor-report-resend-p): Add utility wrapper. (spam-report-articles-gmane): Add doc fix. (spam-report-articles-resend, spam-report-resend-register-routine): Add wrappers around spam-report-resend-to. * spam-report.el (spam-report-resend-to, spam-report-resend): Add support for resending spam. (spam-report-gmane): Fix line length >80. * gnus.el (spam-process): Add spam-use-resend. 2004-05-20 TSUCHIYA Masatoshi * spam.el (spam-mark-spam-as-expired-and-move-routine): Return the number of processed spam messages. (spam-ham-copy-or-move-routine): Return the number of processed ham messages. (spam-summary-prepare-exit): Use the above values to decide whether status messages shouled be displayed. 2004-05-20 Katsumi Yamaoka * rfc2047.el (rfc2047-encode-function-alist): Renamed from `rfc2047-encoding-function-alist' in order to avoid conflicting with the old version. (rfc2047-encode-region): Concatenate words containing non-ASCII characters in structured fields; don't encode space-delimited ASCII words even in unstructured fields; don't break words at char-category boundaries. (rfc2047-encode-1): New function. (rfc2047-encode): Use it; encode text so that it occupies the maximum width within 76-column; work correctly on Q encoding for iso-2022-* charsets. (rfc2047-fold-region): Use existing whitespace for LWSP; make it sure not to break a line just after the header name. (rfc2047-b-encode-region): Removed. (rfc2047-b-encode-string): New function. (rfc2047-q-encode-region): Removed. (rfc2047-q-encode-string): New function. * mm-util.el (mm-replace-in-string): New function. 2004-05-20 Lars Magne Ingebrigtsen * gnus-msg.el (gnus-inews-make-draft-meta-information): Really get it right. (gnus-inews-make-draft): Really. 2004-05-19 Ben Menasha * nnmh.el (nnmh-request-list-1): Don't check the link count before descending. (small patch) 2004-05-19 Lars Magne Ingebrigtsen * gnus-msg.el (gnus-inews-make-draft-meta-information): Fix quote stuff. * gnus-start.el (gnus-subscribe-hierarchical-interactive): Match on real group name. * gnus-art.el (gnus-signature-limit): Doc fix. * gnus-msg.el (gnus-inews-make-draft): Quote list. * pgg-pgp.el (pgg-pgp-verify-region): Clean up. 2004-05-19 Michael Schierl (tiny change) * pgg-pgp.el (pgg-pgp-verify-region): Default when signature isn't a string. 2004-05-19 Lars Magne Ingebrigtsen * gnus-draft.el (gnus-draft-send): Bind rfc2047-encode-encoded-words. * rfc2047.el (rfc2047-encode-region): Encode =? strings. (rfc2047-encodable-p): Say that =? needs encoding. (rfc2047-encode-encoded-words): New variable. * gnus-group.el (gnus-group-select-group): Doc fix. * gnus-draft.el (gnus-draft-setup): Mark all replied as replied. * gnus-group.el (gnus-group-mode): Set show-trailing-whitespace to nil. * gnus-cache.el (gnus-cache-possibly-enter-article): Use it. * nnheader.el (nnheader-get-lines-and-char): New function. 2004-05-19 Reiner Steib * gnus-msg.el (gnus-summary-followup-with-original): Document yanking of region when active. 2004-05-19 Katsumi Yamaoka * gnus-start.el (gnus-get-unread-articles): Do nothing for foreign groups if the group level is higher than the specified value. 2004-05-18 Reiner Steib * gnus-group.el (gnus-group-jump-to-group-prompt): Allow an alist. (gnus-group-jump-to-group): Added prefix argument using `gnus-group-jump-to-group-prompt'. Query before jumping to non-active group. * compface.el (uncompface): Be verbose when changing `uncompface-use-external'. * gnus-art.el (gnus-button-handle-man, gnus-button-alist): Try to handle manual section. 2004-05-18 Lars Magne Ingebrigtsen * gnus-art.el (gnus-button-alist): Revert previous change. 2004-05-18 Reiner Steib * message.el (message-idna-to-ascii-rhs-1): Fix typo. 2004-05-18 Lars Magne Ingebrigtsen * gnus-msg.el (gnus-inews-do-gcc): Don't use read-only-p to see whether backend can accept message. * message.el (message-idna-to-ascii-rhs-1): Don't use equalp. 2004-05-18 Kai Grossjohann * nntp.el (nntp-request-set-mark, nntp-request-update-info): Avoid creating directory when nntp-marks-is-evil is true. Reported by Reiner Steib. 2004-05-18 Reiner Steib * gnus-picon.el (gnus-picon-style): New variable. (gnus-picon-insert-glyph): Added optional `nostring' argument. (gnus-picon-transform-address): Support `gnus-picon-style'. From Jesper Harder . 2004-05-18 Lars Magne Ingebrigtsen * message.el (message-fill-field): Return point. (message-generate-headers): Go to end of field. * gnus-start.el (gnus-get-unread-articles-in-group): Don't do stuff for non-living groups. 2004-05-18 Jesper Harder * gnus-art.el (gnus-article-followup-with-original) (gnus-article-reply-with-original): gnus-mark-active-p -> gnus-region-active-p. 2004-05-17 Teodor Zlatanov * spam.el (spam-summary-prepare-exit): Fix messages, so they show only when there is spam or ham to be processed. 2004-05-17 Lars Magne Ingebrigtsen * mail-source.el (mail-source-delete-crash-box): Refactor. (mail-source-fetch): Use it. (mail-source-fetch-file): Ditto. (mail-source-fetch-directory): Run postscript in loop. (mail-source-fetch-pop): Delete. (mail-source-fetch-maildir): Ditto. (mail-source-fetch-imap): Ditto. * imap.el (imap-authenticators): Comment out sasl. * message.el (message-skip-to-next-address): New function. (message-fill-header-address): Refactor. (message-fill-address): Use it. (message-delete-address): Use it. (message-fill-header-general): Refactor. (message-fill-field-address): Rename. (message-narrow-to-field): Find the start of the header. (message-header-format-alist): Don't pre-fill. (message-fill-header): Removed. (message-insert-header): New function. (message-shorten-references): Use it. * rfc2047.el (rfc2047-field-value): Strip props. * mail-parse.el (mail-header-make-address): New alias. * ietf-drums.el (ietf-drums-make-address): New function. * imap.el: Add compiler directives. * gnus-score.el (gnus-score-edit-done): run-hook->run-hooks. * gnus-art.el (article-decode-idna-rhs): Don't use message-idna-inside-rhs-p. 2004-05-16 Lars Magne Ingebrigtsen * message.el (message-idna-inside-rhs-p): Removed. (message-idna-to-ascii-rhs-1): Use proper address parsing. * gnus-art.el (gnus-emphasis-alist): Removed strikethru; too many false positives. 2004-05-16 Kim Minh Kaplan * imap.el (imap-sasl-make-mechanisms): Use sasl. 2004-05-16 Lars Magne Ingebrigtsen * nneething.el (nneething-file-name): Don't create spurions files. * gnus-msg.el (gnus-inews-do-gcc): Ignore read-only groups. (gnus-inews-do-gcc): Remove sleep. * gnus-art.el (gnus-mime-delete-part): Error message when no MIME part under point. * gnus-agent.el (gnus-agent-synchronize-flags): Default to nil. (gnus-agent-regenerate-group): Using nil messages aren't valid. 2004-05-15 Teodor Zlatanov * spam.el (spam-summary-prepare-exit): Fixed (length). 2004-05-14 Teodor Zlatanov * spam.el (spam-summary-prepare-exit): Fix to produce "marking spam as expired without moving it" message when there are spam messages left. 2004-05-14 Nelson Ferreira (tiny change) * gnus-dup.el (gnus-dup-unsuppress-article): Don't assume the mail header is not nil. 2004-05-14 Kai Grossjohann * nntp.el (nntp-request-set-mark, nntp-request-update-info): Call nntp-possibly-create-directory, not nntp-possibly-change-group. (nntp-marks-changed-p): New arg SERVER. (nntp-request-update-info): Adjust caller. 2004-05-14 Kai Grossjohann * nntp.el (nntp-save-marks): Pass missing arg. 2004-05-13 Kai Grossjohann * nntp.el: Support marks. (nntp-marks-is-evil, nntp-marks-file-name, nntp-marks) (nntp-marks-modtime, nntp-marks-directory): New variables. (nntp-request-set-mark, nntp-request-update-info) (nntp-possibly-create-directory, nntp-marks-changed-p) (nntp-save-marks, nntp-open-marks, nntp-marks-directory): New functions. 2004-05-12 Jesper Harder * gnus-xmas.el (gnus-xmas-select-lowest-window) (gnus-xmas-redefine): Rename. * gnus-score.el (gnus-score-insert-help): Use gnus-select-lowest-window. * gnus-ems.el (gnus-select-lowest-window): Copy definition of appt-select-lowest-window and rename to gnus-select-lowest-window. * gnus.el: do. 2004-05-12 TSUCHIYA Masatoshi * rfc2047.el (rfc2047-encode): Use uppercase letters to specify encodings of MIME-encoded words, in order to improve interoperability with several broken MUAs. 2004-05-07 TSUCHIYA Masatoshi * mm-view.el (mm-inline-text-html-render-with-w3): Check META tags, only when charsets are not specified in headers. (mm-inline-text-html-render-with-w3m): Ditto. * lpath.el: Remove `w3m-meta-content-type-charset-regexp' and `w3m-charset-to-coding-system'. Add `w3m-detect-meta-charset'. 2004-05-06 TSUCHIYA Masatoshi * gnus-art.el (article-strip-banner): Use MIME-encoded from fields instead of MIME-decoded from fields when checking `gnus-article-address-banner-alist'. 2004-05-03 Jesper Harder * nnrss.el (nnrss-check-group, nnrss-read-group-data): Hash on description rather than subject. 2004-05-02 Steve Youngs * dgnushack.el: Autoload `mail-fetch-field' for XEmacs. 2004-05-01 Lars Magne Ingebrigtsen * gnus.el (gnus-version-number): Bump. 2004-05-01 Lars Magne Ingebrigtsen * gnus.el: No Gnus v0.2 is released. 2004-05-01 Lars Magne Ingebrigtsen * gnus-agent.el (gnus-agent-read-agentview): Inline gnus-uncompress-range. 2004-05-01 TSUCHIYA Masatoshi * spam.el (spam-bsfilter-path): Use `executable-find' instead of `exec-installed-p'. 2004-04-30 TSUCHIYA Masatoshi * gnus.el (spam-process, spam-autodetect-methods): Add bsfilter and bsfilter-headers. * spam.el (spam-bsfilter): New customize group. (spam-use-bsfilter, spam-use-bsfilter-headers, spam-bsfilter-path) (spam-bsfilter-header, spam-bsfilter-probability-header) (spam-bsfilter-spam-switch, spam-bsfilter-ham-switch) (spam-bsfilter-spam-strong-switch, spam-bsfilter-ham-strong-switch) (spam-bsfilter-database-directory): New options. (spam-install-hooks, spam-list-of-processors, spam-list-of-checks) (spam-list-of-statistical-checks, spam-registration-functions): Add `spam-use-bsfilter' and `spam-use-bsfilter-headers'. (spam-bsfilter-score): New command. (spam-check-bsfilter-headers, spam-check-bsfilter) (spam-bsfilter-register-with-bsfilter) (spam-bsfilter-register-spam-routine) (spam-bsfilter-unregister-spam-routine) (spam-bsfilter-register-ham-routine) (spam-bsfilter-unregister-ham-routine): New functions. (spam-generic-score): Support bsfilter; Accept an optional argument to recalcurate spam score even if scoring header has already been added. (spam-bogofilter-score, spam-spamassassin-score): Accept an optional argument to recalcurate spam score even if scoring header has already been added. 2004-04-29 Jesper Harder * nnrss.el (nnrss-get-namespace-prefix): Use string= to compare strings! Reported by David D. Smith . (nnrss-check-group, nnrss-read-group-data): Hash on Subject if link is missing. 2004-04-28 Jesper Harder * html2text.el (html2text-replace-list): Add & and '. (html2text-get-attr): Rewrite. * message.el (message-setup-1): Remove redundant put-text-property on mail-header-separator. 2004-04-27 Teodor Zlatanov * gnus-registry.el (gnus-registry-cache-whitespace) (gnus-registry-action, gnus-registry-spool-action) (gnus-registry-split-fancy-with-parent): Change message levels from 5 to 3 or 7, as needed. * spam.el (spam-summary-prepare-exit) (spam-mark-junk-as-spam-routine, spam-fetch-field-fast) (spam-split, spam-find-spam, spam-log-undo-registration) (spam-check-blackholes, spam-enter-ham-BBDB): Changed message level from 5 to 6. 2004-04-26 Katsumi Yamaoka * gnus-ems.el: Autoload appt-select-lowest-window (revert 2004-03-04 change). 2004-04-25 Jesper Harder * sieve-manage.el (sieve-manage-open): * nnweb.el (nnweb-insert-html): * nnvirtual.el (nnvirtual-catchup-group, nnvirtual-partition-sequence) (nnvirtual-partition-sequence, nnvirtual-create-mapping): * nnspool.el (nnspool-request-group): * nnrss.el (nnrss-opml-export, nnrss-find-el, nnrss-order-hrefs): * nnml.el (nnml-request-update-info): * nnmh.el (nnmh-request-group, nnmh-request-list-1, nnmh-active-number) (nnmh-request-create-group, nnmh-update-gnus-unreads): * nnimap.el (nnimap-request-close, nnimap-acl-edit) (nnimap-request-set-mark): * nnfolder.el (nnfolder-request-update-info): * mm-view.el (mm-pkcs7-signed-magic, mm-pkcs7-enveloped-magic): * mml.el (mml-destroy-buffers, mml-compute-boundary-1): * gnus-uu.el (gnus-uu-find-articles-matching): * gnus-topic.el (gnus-topic-check-topology, gnus-topic-remove-group): * gnus-sum.el (gnus-summary-fetch-faq, gnus-read-move-group-name): * gnus-score.el (gnus-score-load-file, gnus-sort-score-files): * gnus-nocem.el (gnus-nocem-scan-groups): * gnus-int.el (gnus-start-news-server): * gnus-group.el (gnus-group-make-kiboze-group) (gnus-group-browse-foreign-server): * spam-stat.el (spam-stat-score-buffer): Simplify mapcar usage. Use mapc when appropriate. 2004-04-22 Teodor Zlatanov FIXME: Make separate entries for each person. From Dan Christensen , asjo@koldfront.dk (Adam Sjøgren), Wes Hardaker , and Michael Shields : * spam.el (spam-necessary-extra-headers): Get the extra headers we may need for spam sorting and scoring. (spam-user-format-function-S): Add user format function suitable for general use. (spam-article-sort-by-spam-status): Add sorting function for summary sorting. (spam-extra-header-to-number): Add function to get a score from a header. (spam-summary-score): Add function to get a numeric score from the headers. (spam-generic-score): Fix function doc, was in wrong place. (spam-initialize): Take symbols when it's run, and install the extra headers that spam-necessary-extra-headers thinks we need. 2004-04-21 Teodor Zlatanov * spam.el (spam-summary-prepare-exit): Add logic and message fix. Reported by bojohan+news@dd.chalmers.se (Johan Bockgård). 2004-04-17 Jesper Harder * gnus-sum.el (gnus-set-global-variables) (gnus-build-all-threads, gnus-get-newsgroup-headers) (gnus-article-get-xrefs, gnus-summary-best-group) (gnus-summary-next-article, gnus-summary-enter-digest-group) (gnus-summary-set-bookmark, gnus-offer-save-summaries) (gnus-summary-update-info, gnus-kill-or-deaden-summary): Use with-current-buffer. 2004-04-16 Teodor Zlatanov * spam.el (spam-summary-prepare-exit): Simplify logic. (spam-fetch-article-header): Read the article header if it's not available. (spam-list-articles): Simplify logic. (spam-filelist-register-routine): Fix bug with unregister-list. * gnus-registry.el: Fix comments at beginning. 2004-04-16 Jesper Harder * message.el (message-cater-to-broken-inn): Remove. (message-shorten-references): Make sure the total folded length of References is shorter than 998 characters to cater to a bug in INN 2.3. Also, don't pretend that references aren't folded -- this hasn't worked for a while. 2004-04-15 Kevin Greiner * gnus-agent.el (gnus-agentize): gnus-agent-send-mail-real-function no longer set to current value of message-send-mail-function but rather a lambda that calls message-send-mail-function. The change makes the agent real-time responsive to user changes to message-send-mail-function. 2004-04-15 Kevin Greiner * legacy-gnus-agent.el (gnus-agent-convert-to-compressed-agentview): Fixed typos with help from Florian Weimer 2004-04-15 Katsumi Yamaoka * nnmail.el (nnmail-cache-insert): Revert last change. 2004-04-14 Katsumi Yamaoka * nnmail.el (nnmail-cache-insert): Always check whether nnmail-cache-ignore-groups matches a group name. 2004-04-13 Teodor Zlatanov * spam.el (spam-fetch-field-fast, spam-generate-fake-headers) (spam-find-spam, spam-log-processing-to-registry) (spam-log-registered-p, spam-log-unregistration-needed-p) (spam-log-undo-registration): Use gnus-message instead of gnus-error, none of these errors are fatal. * gnus-registry.el (gnus-registry-clean-empty-function) (gnus-registry-clean-empty): Remove only empty entries without extra data. 2004-04-12 Teodor Zlatanov * spam-stat.el (spam-stat-buffer-change-to-spam) (spam-stat-buffer-change-to-non-spam): Change (error) to (gnus-message 8) invocation. 2004-04-12 Katsumi Yamaoka * nntp.el (nntp-via-netcat-command): New variable. (nntp-via-netcat-switches): New variable. (nntp-open-via-rlogin-and-netcat): New function. (nntp-open-connection-function): Doc fix. (nntp-telnet-command): Doc fix. (nntp-end-of-line): Doc fix. (nntp-via-rlogin-command): Doc fix. (nntp-via-user-name): Doc fix. (nntp-via-address): Doc fix. 2004-04-09 Katsumi Yamaoka * mml2015.el (mml2015-use): Avoid the "Recursive load suspected" error in Emacs 21.1. 2004-04-08 Reiner Steib * gnus-start.el (gnus-get-unread-articles): Fix last commit. 2004-04-07 Kevin Greiner * gnus-agent.el (gnus-agent-total-fetched-hashtb): New variable. (gnus-agent-with-refreshed-group): New macro. (gnus-agent-rename-group): New function. (gnus-agent-delete-group): New function. (gnus-agent-save-group-info): Use gnus-command-method when `method' parameter is nil. Don't write nil entries into the active file. (gnus-agent-get-group-info): New function. (gnus-agent-fetch-articles): Use gnus-agent-update-files-total-fetched-for to increment disk space used. (gnus-agent-fetch-headers, gnus-agent-save-alist): Use gnus-agent-update-view-total-fetched-for to increment disk space used. (gnus-agent-get-local): Added optional parameters to avoid calling gnus-group-real-name and gnus-find-method-for-group. (gnus-agent-set-local): Delete stored entry if either min, or max, are nil. (gnus-agent-fetch-session): Reworded error/quit messages. On quit, use gnus-agent-regenerate-group to record existance of any articles fetched to disk before the quit occurred. (gnus-agent-expire-group-1): Use gnus-agent-with-refreshed-group, gnus-agent-update-view-total-fetched-for, and gnus-agent-update-files-total-fetched-for to decrement disk space used. (gnus-agent-retrieve-headers): Use gnus-agent-update-view-total-fetched-for to increment disk space used. (gnus-agent-regenerate-group): Replace gnus-group-update-group with gnus-agent-update-files-total-fetched-for to decrement disk space and fresh group buffer. (gnus-agent-inhibit-update-total-fetched-for): New variable. (gnus-agent-need-update-total-fetched-for): New variable. (gnus-agent-update-files-total-fetched-for): New function. (gnus-agent-update-view-total-fetched-for): New function. (gnus-agent-total-fetched-for): New function. * gnus-cache.el (gnus-cache-save-buffers): Use gnus-cache-update-overview-total-fetched-for to change disk space used by this group. (gnus-cache-possibly-enter-article): Use gnus-cache-update-file-total-fetched-for to increment disk space used by this group. (gnus-cache-possibly-remove-article): Use gnus-cache-update-file-total-fetched-for to decrement disk space used by this group. (gnus-cache-generate-nov-databases): Purge total fetched cache. (gnus-cache-rename-group): New function. (gnus-cache-delete-group): New function. (gnus-cache-inhibit-update-total-fetched-for): New variable. (gnus-cache-need-update-total-fetched-for): New variable. (gnus-cache-with-refreshed-group): New macro. (gnus-cache-update-file-total-fetched-for): New function. (gnus-cache-update-overview-total-fetched-for): New function. (gnus-cache-rename-group-total-fetched-for): New function. (gnus-cache-delete-group-total-fetched-for): New function. (gnus-cache-total-fetched-for): New function. * gnus-group.el: Require gnus-sum and autoload functions to resolve warnings when gnus-group.el compiled alone. (gnus-group-line-format): Documented new %F (size of Fetched data) group line format; identifies disk space used by agent and cache. (gnus-group-line-format-alist): Defined new F format. (gnus-total-fetched-for): New function. (gnus-group-delete-group): No longer update gnus-cache-active-altered as gnus-request-delete-group now keeps the cache in sync. (gnus-group-list-active): Let the agent store a server's active list if currently plugged. * gnus-int.el (gnus-request-delete-group): Use gnus-cache-delete-group and gnus-agent-delete-group to keep the local disk in sync with the server. (gnus-request-rename-group): Use gnus-cache-rename-group and gnus-agent-rename-group to keep the local disk in sync with the server. * gnus-start.el (gnus-get-unread-articles): Cosmetic simplification to logic. * gnus-util.el (gnus-rename-file): New function. 2004-04-07 Christian Neukirchen (tiny change) * mm-util.el (mm-image-load-path): Handle nil in load-path. 2004-04-07 Jesper Harder * rfc2047.el (rfc2047-encoded-word-regexp): Remove unnecessary '+'. Reported by Stefan Wiens . 2004-04-06 Jesper Harder * gnus-cache.el (gnus-cache-save-buffers): Check if buffer is alive. Reported by Laurent Martelli . 2004-04-03 Jesper Harder * gnus.el (gnus-getenv-nntpserver): Strip whitespace. 2004-04-02 Teodor Zlatanov * spam.el (spam-set-difference): Add function to replace gnus-set-difference in spam.el. (spam-summary-prepare-exit): Use spam-set-difference. 2004-03-29 Teodor Zlatanov * gnus-registry.el (gnus-registry-cache-file): Update to use gnus-dribble-directory OR gnus-home-directory OR ~. (gnus-registry-split-fancy-with-parent): Fix doc. 2004-03-27 Katsumi Yamaoka * message.el (message-exchange-point-and-mark): Use message-mark-active-p. Suggested by Jesper Harder . 2004-03-26 Katsumi Yamaoka * message.el (message-exchange-point-and-mark): Don't activate region if it was inactive. Suggested by Hiroshi Fujishima . 2004-03-25 Katsumi Yamaoka * gnus-art.el (article-display-face): Display Faces in the same order as X-Faces. 2004-03-24 Katsumi Yamaoka * nndoc.el (nndoc-forward-type-p): Recognize envelope From_. 2004-03-23 Katsumi Yamaoka * gnus-art.el (gnus-mime-recompute-hierarchical-structure): Remove. (gnus-mime-multipart-functions): Revert 2004-03-19 change. (gnus-article-mime-hierarchy): Remove. (gnus-article-mime-hierarchy-next): Remove. (gnus-article-mode): Revert 2004-03-19 change. (gnus-article-setup-buffer): Revert 2004-03-19 change. (gnus-insert-mime-button): Revert 2004-03-19 change. (gnus-mime-accumulate-hierarchy): Remove. (gnus-mime-enter-multipart): Remove. (gnus-mime-leave-multipart): Remove, (gnus-mime-display-part): Revert 2004-03-19 change. (gnus-mime-display-alternative): Revert 2004-03-19 change. * mml.el (mml-preview): Revert 2004-03-19 change. 2004-03-18 Helmut Waitzmann (tiny change) * gnus-sum.el (gnus-newsgroup-variables): Doc fix. 2004-03-22 Katsumi Yamaoka * mm-decode.el (mm-save-part): Bind enable-multibyte-characters to t while entering a file name using the mm-with-multibyte macro. Suggested by Hiroshi Fujishima . * mm-util.el (mm-with-multibyte): New macro. 2004-03-19 Katsumi Yamaoka * gnus-art.el (gnus-mime-recompute-hierarchical-structure): New user option. (gnus-mime-multipart-functions): Doc and customization fix. (gnus-article-mime-hierarchy): New variable. (gnus-article-mime-hierarchy-next): New variable. (gnus-article-mode): Make gnus-article-mime-hierarchy buffer-local. (gnus-article-setup-buffer): Set gnus-article-mime-hierarchy and gnus-article-mime-hierarchy-next to nil. (gnus-insert-mime-button): Show hierarchy numbers. (gnus-mime-accumulate-hierarchy): New function. (gnus-mime-enter-multipart): New function. (gnus-mime-leave-multipart): New function. (gnus-mime-display-part): Recompute hierarchical MIME structure. (gnus-mime-display-alternative): Show hierarchy numbers. * mml.el (mml-preview): Set gnus-article-mime-hierarchy and gnus-article-mime-hierarchy-next to nil. 2004-03-19 Steve Youngs * dns.el: Don't require gnus-xmas. 2004-03-17 Jesper Harder * mml.el (mml-generate-mime-1): Don't use format=flowed with inline PGP. (mml-menu): Disable mml-quote-region if mark is inactive. 2004-03-17 Katsumi Yamaoka * gnus-agent.el (gnus-agent-regenerate-group): Activate the group when the group's active is not available. 2004-03-15 Katsumi Yamaoka * gnus-agent.el (gnus-agent-read-agentview): Add a missing arg to error. 2004-03-12 Reiner Steib * imap.el (imap-store-password): New variable. (imap-interactive-login): Use it. Suggested by Mark Plaksin . 2004-03-12 Katsumi Yamaoka * gnus-art.el (gnus-article-read-summary-keys): Restore new window-start and hscroll to summary window. 2004-03-12 Kevin Greiner * gnus-start.el (gnus-convert-old-newsrc): Only write the conversion message to newsrc-dribble when an actual conversion is performed. 2004-03-10 Malcolm Purvis (tiny change) * spam-stat.el (spam-stat-coding-system): Use mm-coding-system-p. 2004-03-10 Katsumi Yamaoka * mm-decode.el (mm-complicated-handles): New function reviving former definition of mm-multiple-handles. * gnus-art.el (gnus-mime-save-part-and-strip): Use it. (gnus-mime-delete-part): Use it. 2004-03-09 Kevin Greiner * gnus-agent.el (gnus-agent-read-local): Bind nnheader-file-coding-system to gnus-agent-file-coding-system to avoid the implicit assumption that they will always be equal. (gnus-agent-save-local): Bind buffer-file-coding-system, not coding-system-for-write, as the with-temp-file macro first prints to a buffer then saves the buffer. 2004-03-09 Katsumi Yamaoka * gnus-art.el (gnus-article-edit-part): New function. (gnus-mime-save-part-and-strip): Use it; do query instead of signaling an error; don't use mm-multiple-handles. (gnus-mime-delete-part): Ditto. 2004-03-08 Kevin Greiner * gnus-agent.el (gnus-agent-read-agentview): Removed support for old file versions. (gnus-group-prepare-hook): Removed function that converted list form of gnus-agent-expire-days to group properties. * gnus-int.el: Autoload gnus-agent-regenerate-group. (gnus-request-accept-article): Re-indented. * gnus-start.el (gnus-convert-old-newsrc): Registered new converters to handle old agent file formats. Added logic for a "backup before upgrading warning". (gnus-convert-mark-converter-prompt): Developers can mark functions as needing (default), or not needing, gnus-convert-old-newsrc's "backup before upgrading warning". (gnus-convert-converter-needs-prompt): Tests whether the user should be protected from potentially irreversable changes by the function. * legacy-gnus-agent.el: New. Provides converters that are only loaded when gnus-convert-old-newsrc needs to call them. 2004-03-08 Katsumi Yamaoka * mail-source.el (mail-source-touch-pop): Doc fix. * message.el (message-smtpmail-send-it): Doc fix. 2004-03-05 Jesper Harder * sha1-el.el (sha1-maximum-internal-length): Doc fix. * nnmail.el (nnmail-split-fancy): do. * gnus-kill.el (gnus-kill, gnus-execute): do. 2004-03-05 Per Abrahamsen * gnus-sum.el (gnus-widget-reversible-match) (gnus-widget-reversible-to-internal) (gnus-widget-reversible-to-external): New functions. (gnus-widget-reversible): New widget. (gnus-article-sort-functions, gnus-thread-sort-functions): Use it. 2004-03-05 Kai Grossjohann * gnus-sum.el (gnus-thread-sort-functions) (gnus-article-sort-functions): Document `(not F)' items. 2004-03-04 Teodor Zlatanov * spam.el (spam-use-gmane-xref): Add new backend. (spam-gmane-xref-spam-group): Add variable to control the name of the Gmane spam group. (spam-blackhole-servers, spam-blackhole-good-server-regex) (spam-regex-headers-spam, spam-regex-headers-ham) (spam-regex-body-spam, spam-regex-body-ham): Clarify docs. (spam-list-of-checks): Add spam-use-gmane-xref to list of backends and checks. (spam-check-gmane-xref): Add function for spam-use-gmane-xref. * gnus.el (spam-autodetect-methods): Add spam-use-gmane-xref as an autodetect method. 2004-03-04 Kevin Greiner * gnus-int.el (gnus-request-accept-article): Inform the agent that articles are being added to a group. (gnus-request-replace-article): Inform the agent that articles need to be uncached as the cached contents are no longer valid. 2004-03-04 Katsumi Yamaoka * binhex.el: Don't autoload executable-find. * canlock.el: Don't autoload mail-fetch-field. * dgnushack.el: Autoload c-mode for XEmacs. * gnus-ems.el: Don't autoload appt-select-lowest-window. * gnus-msg.el: Don't autoload news-reply-mode, news-setup, rmail-dont-reply-to and rmail-output. * gnus-score.el: Don't autoload ffap-string-at-point. * gnus-setup.el: Don't autoload sc-cite-original. * imap.el: Don't autoload base64-decode-string, base64-encode-string and md5. * message.el: Autoload rmail-dont-reply-to, rmail-msg-is-pruned and rmail-msg-restore-non-pruned-header. * mm-decode.el: Don't autoload executable-find. * mm-url.el: Don't autoload executable-find. * mm-view.el: Don't autoload diff-mode. * nndb.el: Don't autoload news-reply-mode, news-setup, cancel-timer and telnet. * password.el: Don't autoload run-at-time for Emacs. * sha1-el.el: Don't autoload executable-find. * sieve-mode.el: Don't autoload c-mode. * uudecode.el: Don't autoload executable-find. 2004-03-04 Kevin Greiner * gnus-agent.el (gnus-agent-file-header-cache): Removed. (gnus-agent-possibly-alter-active): Avoid null in numeric comparison. (gnus-agent-set-local): Refuse to save null in local object table. (gnus-agent-regenerate-group): The REREAD parameter can now be a list of articles that will be marked as unread. 2004-03-04 Katsumi Yamaoka * rfc2047.el (rfc2047-encoded-word-regexp): Mismatched paren. 2004-03-04 Jesper Harder * rfc2047.el (rfc2047-encoded-word-regexp): Support RFC 2231 language tags. 2004-03-03 Per Abrahamsen * gnus-agent.el (gnus-agent-read-local, gnus-agent-save-local): Don't bind "obarray". * gnus-sum.el (gnus-thread-sort-functions): Added `gnus-thread-sort-by-most-recent-number' and `gnus-thread-sort-by-most-recent-date'. Reported by Kai Grossjohann . 2004-03-03 Katsumi Yamaoka * gnus-cus.el (gnus-agent-customize-category): Mismatched paren. 2004-03-02 Kevin Greiner * gnus-cus.el (gnus-agent-customize-category): Removed ignore-errors macro reference that required cl to be loaded at run-time. * gnus-range.el (gnus-sorted-range-intersection): Now accepts single-interval range of the form (min . max). Previously the range had to look like ((min . max)). Likewise, return (min . max) rather than ((min . max)). (gnus-range-map): Use gnus-range-normalize to accept single-interval range. * gnus-sum.el (gnus-summary-highlight-line): Articles stored in the cache, but not the agent, now appear with their usual face. * dgnushack.el (loaddir): New variable that is bound to the directory containing the dgnushack.el file. Use loaddir, rather than srcdir, to update load-path. Change lets dgnushack compile code in directories other than GNUS/lisp. 2004-03-01 Katsumi Yamaoka * lpath.el: Don't bind w3m-safe-url-regexp. * gnus-art.el (gnus-article-wash-html-with-w3m): Don't make the w3m-safe-url-regexp variable buffer-local. * mm-view.el (mm-inline-text-html-render-with-w3m): Ditto. 2004-02-27 Simon Josefsson * gnus-sum.el (gnus-move-group-prefix-function): Add, default to gnus-group-real-prefix. (gnus-summary-move-article): Use it, instead of gnus-group-real-prefix. 2004-02-27 Katsumi Yamaoka * lpath.el: Bind w3m-safe-url-regexp. * gnus-art.el (gnus-article-wash-html-with-w3m): Make the w3m-safe-url-regexp variable buffer-local and set it as the value of mm-w3m-safe-url-regexp. * mm-view.el (mm-inline-text-html-render-with-w3m): Ditto. * gnus-msg.el (gnus-setup-message): Ignore an article copy while parsing gnus-posting-styles when the message is not for replying. * dgnushack.el: Autoload sgml-mode for XEmacs. * nnrss.el (nnrss-opml-export): Use mm-set-buffer-file-coding-system instead of set-buffer-file-coding-system. 2004-02-27 Jesper Harder * spam-stat.el: Pedantic docstring and whitespace fixes (courtesy of checkdoc.el). * nnrss.el: do. * gnus-mlspl.el: do. * gnus-ml.el: do. * gnus-srvr.el: do. * nnrss.el (nnrss-opml-export): Turn on sgml-mode. 2004-02-27 Kevin Ryde (tiny change) * gnus.el (gnus-group, gnus-summary, gnus-summary-sort): Corrections to custom-manual links. * gnus-art.el (gnus-article): Ditto. * mm-decode.el (mime-display, mime-security): Ditto. 2004-02-26 Jesper Harder * flow-fill.el: Typo. 2004-02-26 Andrew Cohen * spam-wash.el: New file. 2004-02-26 Mark A. Hershberger * nnrss.el (nnrss-opml-import, nnrss-opml-export): New functions. 2004-02-26 Teodor Zlatanov * spam.el (spam-summary-prepare-exit): Fix gnus-set-difference: needs to be run with new-articles as LIST1, not LIST2. (spam-registration-functions): Add spam-use-ham-copy as a nil registration backend. 2004-02-26 Jesper Harder * spam-stat.el (spam-stat-washing-hook): New option. (spam-stat-buffer-words): Use it. (spam-stat-process-directory, spam-stat-test-directory): Use insert-file-contents-literally. (spam-stat-coding-system): New variable. (spam-stat-load, spam-stat-save): Use it. 2004-02-25 Katsumi Yamaoka * spam-report.el (spam-report-plug-agent): Quote spam-report-url-to-file and spam-report-url-ping-plain. 2004-02-25 Reiner Steib * gnus-art.el (gnus-button-alist, gnus-header-button-alist): Allow / in mailto URLs. 2004-02-24 Reiner Steib * spam-report.el (spam-report-process-queue): Fix interactive use. (spam-report-url-ping-temp-agent-function, spam-report-plug-agent) (spam-report-unplug-agent): Doc fixes. (spam-report-url-ping-mm-url, spam-report-url-to-file) (spam-report-agentize, spam-report-deagentize): Autoload 2004-02-24 Katsumi Yamaoka * dgnushack.el (with-syntax-table): Redefine it for XEmacs 21.5. * message.el (message-setup-fill-variables): Add mml tags to paragraph-start and paragraph-separate. Suggested by Andrew Korty . (message-mode): Don't modify paragraph-separate there. 2004-02-17 Katsumi Yamaoka * compface.el (uncompface-use-external): Default to undecided. (uncompface-use-external-threshold): New variable. (uncompface-float-time): New macro. (uncompface): Determine whether to use the external decoder if uncompface-use-external is undecided. 2004-02-15 Lars Magne Ingebrigtsen * mm-view.el (mm-inline-image-emacs): Don't insert blank lines after images. * gnus-art.el (gnus-mime-display-single): Remove dead code. 2004-02-14 Jesper Harder * nnrss.el (nnrss-request-article, nnrss-find-el): Cleanup. * html2text.el (html2text-get-attr, html2text-fix-paragraph): do. * gnus-sum.el (gnus-summary-limit-to-age) (gnus-summary-limit-children): do. * gnus-int.el (gnus-request-scan): do. * gnus-group.el (gnus-group-suspend): do. * gnus-cus.el (gnus-agent-cat-prepare-category-field): do. * gnus-cite.el (gnus-cite-parse-attributions): do. * gnus-agent.el (gnus-summary-set-agent-mark) (gnus-agent-regenerate-group): do. * deuglify.el (gnus-article-outlook-unwrap-lines): do. * binhex.el (binhex-decode-region-internal): do. 2004-02-12 Katsumi Yamaoka * gnus-fun.el (gnus-face-properties-alist): New user option. (gnus-display-x-face-in-from): Use it. * gnus-art.el (article-display-face): Ditto. * compface.el (uncompface-use-external): Default to nil. 2004-02-12 Jesper Harder * nntp.el (nntp-erase-buffer): New function. (nntp-retrieve-data, nntp-send-command) (nntp-send-buffer, nntp-retrieve-groups, nntp-handle-authinfo) (nntp-possibly-change-group): Use it. * nnnil.el (nnnil-retrieve-headers, nnnil-request-list): Use with-current-buffer. 2004-02-12 TAKAI Kousuke * compface.el: Merge the ELisp-based uncompface program. (compface): New customization group. (uncompface-use-external): New user option. (uncompface): Call uncompface-internal if uncompface-use-external is nil. (uncompface-internal): New function. Note that there are also some other functions and variables added for this function. 2004-02-10 Jesper Harder * nnrss.el (nnrss-read-group-data): Initialize nnrss-group-hashtb if necessary. 2004-02-09 Teodor Zlatanov * spam-report.el (spam-report-unplug-agent) (spam-report-plug-agent, spam-report-deagentize) (spam-report-agentize, spam-report-url-ping-temp-agent-function): Add support for the Agent in spam-report: when unplugged, report to a file; when plugged, submit all the requests. * spam.el (spam-register-routine): Fix message about registration. 2004-02-09 Jesper Harder * rfc2047.el (rfc2047-qp-or-base64): New function to reduce dependencies. (rfc2047-encode): Use it. * gnus-art.el (gnus-button-marker-list): Move before first reference. * imap.el (imap-parse-flag-list, imap-parse-body-extension) (imap-parse-body): Fix format string mismatch. * gnus-score.el (gnus-summary-increase-score): do. * nnrss.el (nnrss-close): New function. 2004-02-08 Jesper Harder * nnrss.el (nnrss-make-filename): New function. (nnrss-request-delete-group, nnrss-read-server-data) (nnrss-save-server-data, nnrss-read-group-data) (nnrss-save-group-data): Use it. (nnrss-save-server-data, nnrss-save-group-data): Use gnus-prin1. (nnrss-read-server-data, nnrss-read-group-data): Use load. (nnrss-group-hashtb): Make it a hash table rather than an obarray. 2004-02-07 Jesper Harder * mml.el (mml-compute-boundary-1): Don't uncompress files. 2004-02-06 Jesper Harder * mml.el (mml-mode, mml-x-dnd-attach-file): Attach drop and drag files. * message.el (message-generate-headers-first): Don't quote nil and t in docstrings. * imap.el (imap-id): do. * gnus-agent.el (gnus-agent-consider-all-articles) (gnus-agent-queue-mail): do. 2004-02-05 Reiner Steib * spam-report.el (spam-report-process-queue): New function. Process requests from `spam-report-requests-file'. (spam-report-process-queue): Doc fix. 2004-02-05 Teodor Zlatanov * spam.el (spam-register-routine) (spam-log-processing-to-registry, spam-log-registered-p) (spam-log-unregistration-needed-p, spam-log-undo-registration): Change "check" to "spam-check" for semi-clarity. 2004-02-05 Jesper Harder * pop3.el: Require nnheader. * mml-smime.el: Require cl. Autoload message-fetch-field. * mml-sec.el (mml-signencrypt-style): Don't depend on Gnus. * gnus-picon.el: Require cl. * gnus-fun.el: Require gnus-ems and gnus-util. * gnus.el (gnus-method-to-server): Move defsubst before first use. * gnus-diary.el (gnus-diary-header-schedule): caddr -> car (cddr * gnus-art.el (gnus-article-edit-mode): Define before first reference. 2004-02-04 Jesper Harder * gnus-uu.el (gnus-uu-check-correct-stripped-uucode): Simplify. (gnus-uu-post-encoded): Use point-at-bol. * gnus-topic.el (gnus-group-active-topic-p): do. * gnus-start.el (gnus-newsrc-to-gnus-format): do. * gnus-group.el (gnus-group-kill-region): do. * gnus-art.el (article-date-ut): do. * message.el (message-fetch-field): Remove redundant case-fold-search binding. (message-narrow-to-field): Simplify. 2004-02-03 Reiner Steib * spam.el (spam-directory): Derive from `gnus-directory'. * spam-report.el (spam-report-url-to-file) (spam-report-requests-file): New function and variable for offline reporting. (spam-report-url-ping-function): Add `spam-report-url-to-file' and user defined function. (spam-report-url-ping-mm-url): Remove doubled slash. 2004-02-03 Teodor Zlatanov * spam.el (spam-list-of-processors): Fix spamassassin variable names. 2004-02-03 Jesper Harder * spam.el (spam-check-spamoracle, spam-spamoracle-learn): Fix format string mismatch. * sieve.el (sieve-deactivate-all): do. * nnfolder.el (nnfolder-request-set-mark, nnfolder-save-marks): do. * nnlistserv.el (nnlistserv-kk-wash-article): do. * nnml.el (nnml-request-set-mark, nnml-save-marks): do. * mm-bodies.el (mm-7bit-chars): Don't include \r. 2004-02-02 Teodor Zlatanov * spam.el (spam-list-of-checks): Add spam-use-BBDB-eclusive to the list of checks. 2004-01-31 Jesper Harder * rfc2047.el (rfc2047-pad-base64): Deal with more cases of invalid padding. 2004-01-27 Ralf Angeli * mm-view.el (mm-fill-flowed): New variable. (mm-inline-text): Use it. 2004-01-27 Teodor Zlatanov * spam.el (spam-spamassassin-register-ham-routine) (spam-spamassassin-register-spam-routine): Fix function names. 2004-01-27 Katsumi Yamaoka * gnus.el (gnus-tmp-grouplens): Remove. (gnus-summary-line-format): Remove grouplens. * gnus-group.el (gnus-group-line-format): Ditto. * gnus-spec.el (gnus-format-specs): Ditto. (gnus-update-format-specifications): Flush the group format spec cache if there's the grouplens stuff. (gnus-parse-simple-format): Replace %l with the empty string. 2004-01-27 Jerry James (tiny change) * gnus-spec.el (gnus-parse-simple-format): Fix setq value omission. 2004-01-26 Katsumi Yamaoka * gnus-msg.el (gnus-summary-resend-message-edit): Call mime-to-mml. Suggested by Hiroshi Fujishima . 2004-01-25 Paul Jarc * nnmaildir.el (nnmaildir--num-file, nnmaildir--mkfile, nnmaildir--emlink-p, nnmaildir--eexist-p, nnmaildir--new-number): New macros and functions. * nnmaildir.el (nnmaildir--group-maxnum, nnmaildir--update-nov): Handle > NLINK_MAX messages. * nnmaildir.el (nnmaildir-request-set-mark): Use nnmaildir--emlink-p and nnmaildir--eexist-p. 2004-01-25 Alex Schroeder * spam-stat.el (spam-stat-process-directory-age): New option. (spam-stat-process-directory): Use it. 2004-01-24 Hiroshi Fujishima (tiny change) * spam-stat.el (spam-stat-reduce-size): Set spam-stat-dirty. (spam-stat-save): Accept prefix argument. 2004-01-23 Paul Jarc * nnmaildir.el (nnmaildir-request-set-mark): Handle the "too many links" error. 2004-01-23 Katsumi Yamaoka * dgnushack.el: Advise byte-optimize-form-code-walker to optimize the rest of the and/or forms. 2004-01-23 Jesper Harder * gnus.el (gnus-tmp-grouplens): Define for the sake of backward compatibility with old .newsrc.eld files. * gnus-xmas.el (gnus-xmas-grouplens-menu-add): Remove. * gnus-sum.el (gnus-summary-line-format-alist): Remove grouplens. * gnus-start.el (gnus-1): do. * gnus-group.el (gnus-group-line-format-alist): do. * gnus.el (gnus-use-grouplens, gnus-visual): do. * gnus-gl.el: Remove. 2004-01-23 Kevin Greiner * gnus-sum.el (gnus-adjust-marks): Now correctly handles a list of marks consisting of a single range {for example, (3 . 5)} rather than a list of a single range { ((3 . 5)) }. 2004-01-23 Jesper Harder * spam-stat.el (spam-stat-store-gnus-article-buffer): Use with-current-buffer. (spam-stat-store-current-buffer): Use insert-buffer-substring to avoid consing a string. * mm-util.el (mm-charset-synonym-alist): Add ks_c_5601-1987. Remove obsolete entries for big5 and gb2312. 2004-01-22 Kevin Greiner * gnus-sum.el (gnus-adjust-marks): Avoid splicing null INTO the uncompressed list. 2004-01-22 Jesper Harder * spam-stat.el (spam-stat-strip-xref): New function. (spam-stat-process-directory): Use it. * gnus-util.el (gnus-fetch-field): Don't bind case-fold-search here -- it's done in message-fetch-field. 2004-01-21 Kevin Greiner * gnus-agent.el (gnus-agent-queue-mail, gnus-agent-prompt-send-queue): New variables. (gnus-agent-send-mail): Use gnus-agent-queue-mail. * gnus-draft.el (gnus-group-send-queue): Pass the group name "nndraft:queue" along to gnus-draft-send. Use gnus-agent-prompt-send-queue. (gnus-draft-send): Rebind gnus-agent-queue-mail to nil when group is "nndraft:queue". Suggested by Gaute Strokkenes * gnus-agent.el (agent-disable-undownloaded-faces): Removed (agent-enable-undownloaded-faces): Added (gnus-agent-cat-groups): Use eval-and-compile, not eval-when-compile, to define gnus-agent-set-cat-groups as the setf method of gnus-agent-cat-groups even when the buffer has been evaled. (gnus-agent-save-active, gnus-agent-save-active-1): Merged to delete gnus-agent-save-active-1. (gnus-agent-save-groups): Deleted. Identical to gnus-agent-save-active. (gnus-agent-write-active): No longer adjust agent's copy of active file as agent's adjustments are now stored in their own file. Removed optional parameter. (gnus-agent-possibly-alter-active): Ignore groups of unagentized servers. Add use of min/max range limits from server's local file. (gnus-agent-save-alist): Removed unused optional argument. (gnus-agent-load-local, gnus-agent-read-and-cache-local), (gnus-agent-read-local, gnus-agent-save-local, gnus-agent-get-local), (gnus-agent-set-local): A per-server file that keeps min/max range limits for articles known to the agent. Provides a fast mechanism for altering many active ranges. (gnus-agent-expire-group, gnus-agent-expire): No longer save the active file (local makes it unnecessary). (gnus-agent-regenerate-group): Fixed XEmacs compatibility. * gnus-cus.el (agent-disable-undownloaded-faces): Removed (agent-enable-undownloaded-faces): Added * gnus-draft.el (gnus-draft-send): Bind gnus-agent-queue-mail to disable it when sending to "nndraft:queue". (gnus-group-send-queue): Add safety check to avoid sending queue when unplugged. * gnus-group.el (gnus-group-catchup): Use new gnus-sequence-of-unread-articles, not gnus-list-of-unread-articles, to avoid exhausting memory with huge numbers of articles. Use gnus-range-map to avoid having to uncompress the unread list. (gnus-group-archive-directory, gnus-group-recent-archive-directory): Fixed invalid ange-ftp reference. * gnus-range.el (gnus-range-map): Iterate over list or sequence. (gnus-sorted-range-intersection): Intersection of two ranges without requiring that they first be uncompressed. * gnus-start.el (gnus-activate-group): Unless blocked by the caller, possibly expand the active range to include both cached and agentized articles. (gnus-convert-old-newsrc): Rewrote in anticipation of having multiple version-dependent converters. (gnus-groups-to-gnus-format): Replaced gnus-agent-save-groups with gnus-agent-save-active. (gnus-save-newsrc-file): Save dirty agent range limits. * gnus-sum.el (gnus-select-newgroup): Replaced inline code with gnus-agent-possibly-alter-active. (gnus-adjust-marked-articles): Faster handling of simple lists 2004-01-21 Jesper Harder * spam-stat.el (spam-stat-test-directory): New optional argument displays a list of files detected. Suggested by Andrew Cohen . (spam-stat-buffer-words-with-scores): Don't narrow and change syntax table here. Reported by Andrew Cohen . 2004-01-20 Hubert Chan : * spam.el (spam-use-spamassassin, spam-use-spamassassin-headers) (spam-install-hooks, spam-spamassassin, spam-spamassassin-path) (spam-spamassassin-arguments) (spam-spamassassin-spam-flag-header) (spam-spamassassin-positive-spam-flag-header) (spam-spamassassin-spam-status-header, spam-sa-learn-path) (spam-sa-learn-rebuild, spam-sa-learn-spam-switch) (spam-sa-learn-ham-switch, spam-sa-learn-unregister-switch) (spam-list-of-processors, spam-list-of-checks) (spam-list-of-statistical-checks, spam-registration-functions) (spam-check-spamassassin-headers, spam-check-spamassassin) (spam-spamassassin-score) (spam-spamassassin-register-with-sa-learn) (spam-spamassassin-register-spam-routine) (spam-spamassassin-register-ham-routine) (spam-assassin-register-spam-routine) (spam-assassin-register-ham-routine): Add SpamAssassin support. (spam-bogofilter-score): Fix to show article before scoring. 2004-01-20 Teodor Zlatanov * spam.el (gnus-summary-mode-map): Make spam-generic-score the default scoring function. (spam-generic-score): Call spam-spamassassin-score if spam-use-spamassassin or spam-use-spamassassin-headers is on; spam-bogofilter-score otherwise. * gnus.el (spam-process, spam-autodetect-methods): Add spamassassin and spamassassin-headers. 2004-01-20 Nevin Kapur * gnus-registry.el (gnus-registry-split-fancy-with-parent): Suppress unnecessary messages. 2004-01-20 Jesper Harder * spam-stat.el (spam-stat-to-hash-table): Use :size keyword in make-hash-table. 2004-01-19 Katsumi Yamaoka * canlock.el (base64-encode-string): Don't autoload it. 2004-01-16 Katsumi Yamaoka * run-at-time.el: Remove useless (require 'itimer), eval-and-compile and (featurep 'xemacs). 2004-01-16 Jesper Harder * gnus-msg.el (gnus-post-news): Use blank Newsgroups line if GROUP is a virtual group. 2004-01-16 Steve Youngs * gnus.el: Autoload `message-y-or-n-p'. 2004-01-15 Jesper Harder * pgg-parse.el: Remove unnecessary (require 'custom). * pgg-def.el: do. * nnmail.el: do. * gnus-undo.el: do. * gnus-picon.el: do. * gnus-util.el: do. 2004-01-15 Reiner Steib * gnus-sum.el (gnus-pick-line-number): Add autoload. 2004-01-15 Katsumi Yamaoka * mm-decode.el (mm-multiple-handles): Recognize a string as a mime handle, as well as a list. * mm-view.el (mm-w3m-cid-retrieve-1): Call itself recursively. Suggested by ARISAWA Akihiro . (mm-w3m-cid-retrieve): Simplify. 2004-01-14 Vasily Korytov * message.el (message-kill-to-signature): Allow prefix arg to specify number of lines to keep before signature. 2004-01-14 Kai Grossjohann (message-kill-to-signature): Change docstring. 2004-01-14 Katsumi Yamaoka * canlock.el: Always require sha1-el. (canlock-sha1): Bind sha1-maximum-internal-length to nil. * message.el: Autoload sha1 only when compiling. * lpath.el: Bind eudc-protocol for both Emacs and XEmacs; fbind eudc-expand-inline for XEmacs. 2004-01-13 Katsumi Yamaoka * message.el (message-canlock-generate): Require sha1-el. 2004-01-13 Jesper Harder * message.el (message-expand-name): Silence the byte compiler. * lpath.el: Add detect-coding-system. * dgnushack.el (dgnushack-compile): Remove obsolete check for cus-edit. 2004-01-13 Simon Josefsson * gnus-score.el (gnus-score-edit-all-score): Fix prototype. Invoke gnus-score-mode. Reported by bojohan+news@dd.chalmers.se (Johan Bockgård). * gnus-range.el (gnus-compress-sequence): Doc fix. Suggested by Jim Blandy (tiny change). 2004-01-12 Jesper Harder * gnus-srvr.el (gnus-browse-foreign-server): Reduce consing. 2004-01-12 Teodor Zlatanov * spam.el (spam-get-article-as-string): Update to use gnus-request-article-this-buffer, much simpler. (spam-get-article-as-buffer): Remove. 2004-01-12 Kai Grossjohann * message.el (message-expand-name): Use EUDC if the user uses that. 2004-01-12 Jesper Harder * rfc2047.el (rfc2047-parse-and-decode, rfc2047-decode): Use a character for the encoding to avoid consing a string. * rfc2047.el (rfc2047-decode-string): Don't cons a string unnecessarily. * mm-util.el (mm-replace-chars-in-string): Remove. * rfc2047.el (rfc2047-decode): Use mm-subst-char-in-string instead of mm-replace-chars-in-string. 2004-01-11 Jesper Harder * gnus.sum.el (gnus-remove-odd-characters): Don't cons two new strings. * mm-util.el (mm-subst-char-in-string): Support inplace. * gnus-sum.el (gnus-summary-remove-list-identifiers): Don't cons a new string in every iteration. Use shy groups. 2004-01-10 Jesper Harder * gnus-srvr.el (gnus-browse-unsubscribe-group): * gnus-soup.el (gnus-soup-group-brew): * gnus-msg.el (gnus-put-message): * gnus-move.el (gnus-group-move-group-to-server): * gnus-kill.el (gnus-batch-score): * gnus-group.el (gnus-group-prepare-flat, gnus-group-delete-group) (gnus-group-update-group-line, gnus-group-insert-group-line-info) (gnus-group-update-group, gnus-group-read-group) (gnus-group-make-group, gnus-group-make-help-group) (gnus-group-make-archive-group, gnus-group-make-directory-group) (gnus-group-make-empty-virtual, gnus-group-sort-selected-flat) (gnus-group-sort-by-unread, gnus-group-catchup) (gnus-group-unsubscribe-group, gnus-group-kill-group) (gnus-group-yank-group, gnus-group-set-info) (gnus-group-list-groups): * gnus.el (gnus-generate-new-group-name): * gnus-delay.el (gnus-delay-send-queue): * nnvirtual.el (nnvirtual-catchup-group): * nnkiboze.el (nnkiboze-generate-group, nnkiboze-generate-group): * gnus-topic.el (gnus-topic-find-groups, gnus-topic-clean-alist) (gnus-group-prepare-topics, gnus-topic-check-topology): * gnus-sum.el (gnus-update-read-articles, gnus-select-newsgroup) (gnus-mark-xrefs-as-read, gnus-compute-read-articles) (gnus-summary-walk-group-buffer, gnus-summary-move-article) (gnus-group-make-articles-read): * gnus-start.el (gnus-subscribe-newsgroup, gnus-start-draft-setup) (gnus-group-change-level, gnus-kill-newsgroup) (gnus-check-bogus-newsgroups, gnus-get-unread-articles-in-group) (gnus-get-unread-articles, gnus-make-articles-unread) (gnus-make-ascending-articles-unread): Use accessor macros (gnus-group-entry, gnus-group-unread, gnus-info-marks etc.) to get group information for improved readability. 2004-01-09 Jesper Harder * gnus-art.el (article-decode-mime-words, article-babel) (gnus-article-highlight-signature, gnus-article-add-buttons) (gnus-signature-toggle): Use gnus-with-article-buffer. * gnus-art.el (gnus-article-highlight-headers) (gnus-article-add-buttons-to-head): Use gnus-with-article-headers. * gnus-art.el (gnus-mm-display-part, gnus-article-wash-status) (gnus-article-set-globals, gnus-request-article-this-buffer) (gnus-button-message-id, gnus-article-maybe-hide-headers) (gnus-mime-view-part-externally, gnus-mime-view-part-internally) (gnus-mime-display-alternative): Use with-current-buffer. 2004-01-09 Teodor Zlatanov * spam.el (spam-generate-fake-headers): Rewrite to be simpler, also under 80 char limit, and call gnus-error if needed. (spam-fetch-article-header): Fix - it was a buffer-local variable (gnus-newsgroup-data). (spam-find-spam): Use spam-generate-fake-headers, forget about spam-insert-fake-headers. (spam-insert-fake-headers): Remove. 2004-01-09 Jesper Harder * deuglify.el (gnus-article-outlook-unwrap-lines) (gnus-outlook-rearrange-article) (gnus-outlook-repair-attribution-outlook) (gnus-outlook-repair-attribution-block) (gnus-outlook-repair-attribution-other): Remove redundant save-excursion. 2004-01-09 Teodor Zlatanov * spam.el (spam-fetch-field-fast, spam-fetch-field-from-fast) (spam-fetch-field-subject-fast) (spam-fetch-field-message-id-fast, spam-generate-fake-headers) (spam-fetch-article-header): Add functions to deal with Gnus internals for fast retrieval of article header data. (spam-initialize): Put spam-find-spam in the gnus-summary-prepared-hook. 2004-01-09 Jesper Harder * pop3.el (pop3-md5): Remove. (pop3-apop): Replace pop3-md5 with md5. * mm-bodies.el: base64 is always built-in. * gnus-sum.el (gnus-summary-from-or-to-or-newsgroups): Use with-current-buffer. 2004-01-08 Katsumi Yamaoka * canlock.el (canlock-insert-header): Remove excessive grouping in regexp. * gnus-sum.el (gnus-summary-read-document): Ditto. * gnus-uu.el (gnus-uu-part-number): Ditto. * html2text.el (html2text-remove-tags): Ditto. (html2text-format-tags): Ditto. (html2text-format-single-elements): Ditto. * mml.el (mml-parse-1): Ditto. 2004-01-08 Jesper Harder * gnus-sum.el (gnus-summary-update-mark): Revert previous change. * gnus-group.el (gnus-group-mark-group): Fix for multibyte marks. * gnus-sum.el (gnus-summary-update-mark): Fix for multibyte marks. * gnus-util.el (gnus-replace-in-string): Remove Emacs 20 code. 2003-11-15 Simon Josefsson * pgg-gpg.el (pgg-gpg-lookup-all-secret-keys) (pgg-gpg-lookup-key): Use regexp match instead of split-string (split-string is different between emacs 21.2 and 22.1). Reported by ultrasoul@ultrasoul.com (David D. Smith). 2004-01-08 Jesper Harder * gnus-art.el (gnus-mime-view-all-parts) (gnus-article-part-wrapper, gnus-article-view-part): Use with-current-buffer. 2004-01-07 Teodor Zlatanov * spam.el (spam-disable-spam-split-during-ham-respool) (spam-spamoracle-database, spam-cache-lookups) (spam-split-last-successful-check, spam-clear-cache, spam-xor) (spam-group-ham-mark-p, spam-group-spam-mark-p) (spam-group-ham-marks, spam-group-spam-marks) (spam-group-spam-contents-p, spam-group-ham-contents-p) (spam-list-of-processors, spam-list-of-statistical-checks): Fix doc, also add spam-use-blackholes to the statistical checks. (spam-fetch-field-fast): Add interface to fetching fields, may become a macro. (spam-fetch-field-from-fast, spam-fetch-field-subject-fast) (spam-fetch-field-message-id-fast): Use spam-fetch-field-fast. (spam-insert-fake-headers): Fake an article when needed. (spam-find-spam): Fake article when possible. (spam-check-blackholes, spam-check-BBDB, spam-from-listed-p) (spam-check-bogofilter-headers): Use message-fetch-field instead of nnmail-fetch-field. 2004-01-07 Reiner Steib * gnus-score.el (gnus-score-find-trace): Add `k' (kill-buffer). 2004-01-07 Teodor Zlatanov * spam.el (spam-split): Do not require spam-use-CHECK to be enabled if that check is passed to spam-split explicitly; also fix so 'spam doesn't get converted to spam-split-group when spam-split-symbolic-return is t. (spam-find-spam): Find registrations of the article and use those instead of re-running spam-split to find the spam/ham classification of the article. (spam-log-processing-to-registry, spam-log-registered-p) (spam-log-unregistration-needed-p, spam-log-undo-registration): Use gnus-error instead of gnus-message. (spam-log-registration-type): Add function to determine the classification of a message based on registry entries; will return nil if both 'spam and 'ham are found. (spam-check-BBDB): Expand all the BBDB macros here so we can have a reasonably fast local cache without the loading errors. (spam-cache-lookups): Set to t by default. (spam-find-spam): Don't try to guess spam-cache-lookups. (spam-enter-whitelist, spam-enter-blacklist): Clear the spam-caches entry. (spam-filelist-build-cache, spam-filelist-check-cache): Fix caching of whitelist/blacklist entries. (spam-check-whitelist, spam-check-blacklist): Invoke spam-from-listed-p with a type, not a cache variable. (spam-from-listed-p): Wrap around spam-filelist-check-cache. 2004-01-07 Jesper Harder * message.el (message-cite-prefix-regexp): Use with-syntax-table. * nnmail.el (nnmail-split-fancy): do. * mml.el (mml-parse): do. * gnus-score.el (gnus-enter-score-words-into-hashtb) (gnus-score-adaptive): do. 2004-01-07 Katsumi Yamaoka * gnus-art.el (gnus-treat-emphasize): Ignore Emacs version number. (gnus-mime-button-map): Don't set keymap parent. (gnus-button-ctan-directory-regexp): Use shy grouping. (gnus-prev-page-map): Don't set keymap parent. (gnus-prev-page-map): Remove duplicated one. (gnus-next-page-map): Don't set keymap parent. (gnus-mime-security-button-map): Ditto. * nnheader.el (nnheader-directory-files-is-safe): Ignore Emacs version number. * sha1-el.el (sha1-string-external): Use with-temp-buffer. 2004-01-07 Katsumi Yamaoka * canlock.el (canlock-sha1-function): Remove. (canlock-sha1-function-for-verify): Remove. (canlock-openssl-program): Remove. (canlock-openssl-args): Remove. (canlock-ignore-errors): Remove. (canlock-sha1-with-openssl): Remove. (canlock-sha1): Use sha1 instead of to call canlock-sha1-function. (canlock-verify): Don't use canlock-ignore-errors. * sha1-el.el (sha1-string-external): Make it can return a string in binary form. (sha1-region-external): Ditto. (sha1-string-internal): Ditto. (sha1-region-internal): Ditto. (sha1-region): Ditto. (sha1-string): Ditto. (sha1): Ditto. 2004-01-07 Lars Magne Ingebrigtsen * spam.el (spam-report-articles-gmane): New command. 2004-01-07 Katsumi Yamaoka * gnus.el: Don't make unnecessary *Group* buffer when loading. * run-at-time.el (run-at-time-saved): Remove. (run-at-time): Doc fix. 2004-01-07 Jesper Harder * gnus-sum.el (gnus-summary-limit-to-replied): New command. (gnus-summary-limit-map): Add it. (gnus-summary-make-menu-bar): do. 2004-01-06 Teodor Zlatanov * spam.el (spam-cache-lookups, spam-caches, spam-clear-cache): Make attempt at some caching support (done for BBDB only now). (spam-find-spam): Set spam-cache-lookups if there are more than 2 addresses to be checked. (spam-clear-cache-BBDB): Add function, to be invoked by bbdb-change-hook, and triggering spam-clear-cache of 'spam-use-BBDB. (spam-check-BBDB): Check and use the caches, if spam-cache-lookups is on, remove superfluous (provide). 2004-01-06 Reiner Steib * gnus-art.el (gnus-treat-ansi-sequences): Changed default. 2004-01-07 Steve Youngs * run-at-time.el (run-at-time-saved): Move to after the definition of `run-at-time'. * dgnushack.el: Autoload `font-lock-fontify-buffer' in XEmacs. 2004-01-06 Katsumi Yamaoka * gnus-art.el (gnus-article-wash-html-with-w3m): Don't use mm-w3m-local-map-property. * mm-view.el (mm-w3m-mode-map): Remove. (mm-w3m-local-map-property): Remove. (mm-inline-text-html-render-with-w3m): Don't use mm-w3m-local-map-property. 2004-01-06 Lars Magne Ingebrigtsen * run-at-time.el: New file. * dgnushack.el (dgnushack-compile): Don't compile run-at-time under Emacs. * gnus.el ((fboundp 'gnus-set-text-properties)): Remove definition of gnus-set-text-properties. * gnus-uu.el (gnus-uu-save-article): Ditto. * gnus-salt.el (gnus-carpal-setup-buffer): Ditto. * gnus-cite.el (gnus-cite-parse): Ditto. * gnus-art.el (gnus-button-push): Use set-text-properties instead of gnus-. * gnus-xmas.el (run-at-time): Require run-at-time. * gnus.el: Changed calls to nnheader-run-at-time and password-run-at-time throughout to use run-at-time directly. * password.el: Removed definition of run-at-time. * nnheaderxm.el: Remove definition of run-at-time. 2004-01-05 Karl Pflästerer (tiny change) * mml.el (mml-minibuffer-read-disposition): Show attachment type in prompt. 2004-01-06 Steve Youngs * messagexmas.el (message-xmas-redefine): Alias `message-make-caesar-translation-table' to ``message-xmas-make-caesar-translation-table' regardless of XEmacs version. * gnus-xmas.el (gnus-xmas-set-text-properties): Removed. (gnus-xmas-define): Don't alias `gnus-set-text-properties' to `gnus-xmas-set-text-properties'. (gnus-xmas-redefine): Don't alias `gnus-completing-read' to `gnus-xmas-completing-read'. (gnus-xmas-completing-read): Removed. (gnus-xmas-open-network-stream): Removed. * gnus-ems.el (gnus-mode-line-modified): Don't conditionalise on XEmacs version. * dns.el (dns-make-network-process): Use `open-network-stream' instead of `gnus-xmas-open-network-stream'. * dgnushack.el: Remove some XEmacs 21.1 specific stuff. * .cvsignore: Add auto-autoloads.el, custom-load.el. 2004-01-06 Jesper Harder * gnus-art.el (gnus-mime-display-alternative) (gnus-insert-mime-button, gnus-insert-mime-security-button) (gnus-insert-prev-page-button, gnus-insert-next-page-button): Don't use gnus-local-map-property. * gnus-util.el (gnus-local-map-property): Remove. * mm-view.el (mm-view-pkcs7-decrypt): Replace gnus-completing-read-maybe-default with completing-read. * gnus-util.el (gnus-completing-read): do. (gnus-completing-read-maybe-default): Remove. 2004-01-06 Steve Youngs * password.el: Only autoload `run-at-time' if not XEmacs. Only autoload the itimer functions if XEmacs. 2004-01-06 Katsumi Yamaoka * gnus-xmas.el (gnus-xmas-define): Defun char-width for non-MULE XEmacsen. * dgnushack.el: Autoload executable-find for XEmacs. 2004-01-06 Jesper Harder * gnus-art.el (gnus-read-string): Remove. (gnus-summary-pipe-to-muttprint): Replace gnus-read-string with read-string. 2004-01-05 Teodor Zlatanov * netrc.el: Autoload password-read. (netrc): Add configuration group. (netrc-encoding-method, netrc-openssl-path): Add variables for encoding and decoding of files with symmetric ciphers. (netrc-encode): Add assistant function to encode a file with netrc-encoding-method. (netrc-parse): Add interactive parameter, added optional decoding if netrc-encoding-method is non-nil but otherwise behavior is standard. (netrc-encrypting-method, netrc-encrypt, netrc-parse): Do s/encode/encrypt/ everywhere. * spam.el: Remove executable-find autoload. 2004-01-05 Jesper Harder * gnus-registry.el: Remove Emacs 20 hash table compatibility code. * gnus-uu.el (gnus-uu-post-encoded): bury-buffer is always fbound. 2004-01-05 Reiner Steib * gnus-art.el (gnus-treat-ansi-sequences, article-treat-ansi-sequences): New variable and function. Suggested by Dan Jacobson . * gnus-sum.el (gnus-summary-wash-map, gnus-summary-make-menu-bar): Use it. 2004-01-05 Jesper Harder * mm-util.el (mm-quote-arg): Remove. * mm-decode.el (mm-mailcap-command): Replace mm-quote-arg with shell-quote-argument. * gnus-uu.el (gnus-uu-command): do. * gnus-sum.el (gnus-summary-insert-pseudos): do. * ietf-drums.el (ietf-drums-token-to-list): Replace mm-make-char with make-char. * mm-util.el (mm-make-char): Remove. * mml.el (mml-mode): Replace gnus-add-minor-mode with add-minor-mode. * gnus-undo.el (gnus-undo-mode): do. * gnus-topic.el (gnus-topic-mode): do. * gnus-sum.el (gnus-dead-summary-mode): do. * gnus-start.el (gnus-slave-mode): do. * gnus-salt.el (gnus-binary-mode, gnus-pick-mode): do. * gnus-ml.el (gnus-mailing-list-mode): do. * gnus-gl.el (gnus-grouplens-mode): do. * gnus-draft.el (gnus-draft-mode): do. * gnus-dired.el (gnus-dired-mode): do. * gnus-ems.el (gnus-add-minor-mode): Remove. * gnus-spec.el (gnus-correct-length, gnus-correct-substring): Replace gnus-char-width with char-width. * gnus-ems.el (gnus-char-width): Remove. * gnus-spec.el (gnus-correct-length, gnus-correct-substring): Replace gnus-char-width with char-width. * gnus-ems.el (gnus-char-width): Remove. * spam-stat.el (with-syntax-table): Remove with-syntax-table definition. Remove Emacs 20 hash table compatibility code. * rfc2047.el (with-syntax-table): Remove with-syntax-table Emacs 20 compatibility code. * spam.el (spam-point-at-eol): Replace with point-at-eol. * smime.el (smime-point-at-eol): Replace with point-at-eol. * rfc2047.el (rfc2047-point-at-bol, rfc2047-point-at-eol): Replace with point-at-{eol,bol}. * netrc.el (netrc-point-at-eol): Replace with point-at-eol. * imap.el (imap-point-at-eol): Replace with point-at-eol. * flow-fill.el (fill-flowed-point-at-bol, fill-flowed-point-at-eol): Replace with point-at-{eol,bol}. * gnus-util.el (gnus-point-at-bol, gnus-point-at-eol): Remove. Replace with point-at-{eol,bol} throughout all files. 2004-01-05 Katsumi Yamaoka * ntlm.el (ntlm-string-as-unibyte): New macro. (ntlm-build-auth-response): Use it. Remove Emacs 20 stuff: * dgnushack.el (dgnushack-compile): Don't modify max-specpdl-size. (butlast, mapc, remove): Remove the compiler macros. * gnus-msg.el (gnus-summary-news-other-window): Use remove instead of delq and copy-sequence. * gnus-art.el (popup-menu): Remove the compiler macro. * nnmail.el (nnmail-split-fancy): Don't support customizing with Emacs 20. 2004-01-05 Simon Josefsson * ntlm.el: Fix namespace. Change smb-passwd-hash into ntlm-smb-passwd-hash, smb-owf-encrypt into ntlm-smb-owf-encrypt, smb-passwd-hash into ntlm-smb-passwd-hash, smbdes-e-p16 into ntlm-smb-des-e-p16, smbdes-e-p24 into ntlm-smb-des-e-p24, smbhash into ntlm-smb-hash, smb-sp8 into ntlm-smb-sp8, smb-str-to-key into ntlm-smb-str-to-key, smb-dohash into ntlm-smb-dohash, smb-perm1 into ntlm-smb-perm1, smb-perm2 into ntlm-smb-perm2, smb-perm3 into ntlm-smb-perm3, smb-perm4 into ntlm-smb-perm4, smb-perm5 into ntlm-smb-perm5, smb-perm6 into ntlm-smb-perm6, smb-sc into ntlm-smb-sc, smb-sbox into ntlm-smb-sbox, string-permute into ntlm-string-permute, string-lshift into ntlm-string-lshift, string-xor into ntlm-string-xor. Suggested by Jesper Harder . * ntlm.el: Don't include poem. * md4.el (print-int32, print-string-hexa): Remove. Suggested by Jesper Harder . * sasl-ntlm.el, ntlm.el, md4.el: New files. * hmac-md5.el (md5-binary): Fix byte compile warning. (This probably breaks emacs with DL patch, but do we care? Is anyone still using the DL stuff?) * sieve-manage.el: Use the password package. (sieve-manage-read-passwd): Remove. (sieve-manage-interactive-login): Use password. Re-add condition-case around loop. * pgg.el (pgg-passphrase-cache, pgg-run-at-time): Remove. (pgg-add-passphrase-cache, pgg-remove-passphrase-cache): Use the password package. 2003-02-19 Simon Josefsson * sieve-manage.el (sieve-sasl-auth): Quote optional initial SASL token. 2002-08-07 Simon Josefsson * sieve-manage.el (require): Use SASL, not RFC2104/MD5. (sieve-manage-authenticators): (sieve-manage-authenticator-alist): Add some SASL mechs. (sieve-sasl-auth): New function. (sieve-manage-cram-md5-auth): (sieve-manage-plain-auth): Rewrite using SASL library. (sieve-manage-digest-md5-p, sieve-manage-digest-md5-auth) (sieve-manage-scram-md5-p, sieve-manage-scram-md5-auth) (sieve-manage-ntlm-p, sieve-manage-ntlm-auth) (sieve-manage-login-p, sieve-manage-login-auth): Add wrappers. 2004-01-05 Simon Josefsson * sasl.el, sasl-cram.el, sasl-digest.el, hmac-md5.el, hmac-def.el: New files. 2004-01-04 Lars Magne Ingebrigtsen * gnus-group.el (gnus-no-groups-message): Update. * gnus-sum.el (gnus-summary-insert-new-articles): Remove . 2003-11-09 Simon Josefsson * imap.el: Support for ID IMAP extension (RFC 2971). (imap-local-variables): Add imap-id. (imap-id): New variable. (imap-id): New function. (imap-parse-response): Parse untagged ID response. * nnimap.el (nnimap-id): New variable. (nnimap-open-connection): Use it. 2003-12-28 Simon Josefsson * gnus-score.el (gnus-score-edit-all-score): New. * gnus-group.el (gnus-group-score-map): Bind it to W e. 2004-01-04 Simon Josefsson * password.el: Add. 2004-01-04 Mario Lang * dns.el: Add support for AAAA records (see RFC 3596) * Fix typo PRT -> PTR * Parse MX, PTR and SOA replies (see RFC 1035) 2004-01-04 Lars Magne Ingebrigtsen * gnus.el (gnus-logo-color-style): Changed colors to `no'. * Moved to Changelog.2. 2004-01-04 Lars Magne Ingebrigtsen * gnus.el (gnus-version-number): Bump version. 2004-01-04 Lars Magne Ingebrigtsen * gnus.el: No Gnus v0.1 is released. 2004-01-04 Lars Magne Ingebrigtsen * gnus.el: No Gnus v0.0 is released. 2004-01-04 Lars Magne Ingebrigtsen * gnus.el (gnus-version-number): Bump. (gnus-version): No. See ChangeLog.2 for earlier changes. Copyright (C) 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc. This file is part of GNU Emacs. GNU Emacs is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 3, or (at your option) any later version. GNU Emacs is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with GNU Emacs; see the file COPYING. If not, write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. ;; Local Variables: ;; coding: utf-8 ;; fill-column: 79 ;; add-log-time-zone-rule: t ;; End: ;;; arch-tag: 3f33a3e7-090d-492b-bedd-02a1417d32b4 gnus-5.11+v0.10.dfsg/lisp/ecomplete.el0000644000175000017500000001142710744555355017564 0ustar tvainikatvainika;;; ecomplete.el --- electric completion of addresses and the like ;; Copyright (C) 2006, 2007, 2008 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; Keywords: mail ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 3, or (at your option) ;; any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Commentary: ;;; Code: (eval-when-compile (require 'cl)) (defgroup ecomplete nil "Electric completion of email addresses and the like." :group 'mail) (defcustom ecomplete-database-file "~/.ecompleterc" "*The name of the file to store the ecomplete data." :group 'ecomplete :type 'file) (defcustom ecomplete-database-file-coding-system 'iso-2022-7bit "Coding system used for writing the ecomplete database file." :type '(symbol :tag "Coding system") :group 'ecomplete) ;;; Internal variables. (defvar ecomplete-database nil) ;;;###autoload (defun ecomplete-setup () (when (file-exists-p ecomplete-database-file) (with-temp-buffer (let ((coding-system-for-read ecomplete-database-file-coding-system)) (insert-file-contents ecomplete-database-file) (setq ecomplete-database (read (current-buffer))))))) (defun ecomplete-add-item (type key text) (let ((elems (assq type ecomplete-database)) (now (string-to-number (format "%.0f" (time-to-seconds (current-time))))) entry) (unless elems (push (setq elems (list type)) ecomplete-database)) (if (setq entry (assoc key (cdr elems))) (setcdr entry (list (1+ (cadr entry)) now text)) (nconc elems (list (list key 1 now text)))))) (defun ecomplete-get-item (type key) (assoc key (cdr (assq type ecomplete-database)))) (defun ecomplete-save () (with-temp-buffer (let ((coding-system-for-write ecomplete-database-file-coding-system)) (insert "(") (loop for (type . elems) in ecomplete-database do (insert (format "(%s\n" type)) (dolist (entry elems) (prin1 entry (current-buffer)) (insert "\n")) (insert ")\n")) (insert ")") (write-region (point-min) (point-max) ecomplete-database-file nil 'silent)))) (defun ecomplete-get-matches (type match) (let* ((elems (cdr (assq type ecomplete-database))) (match (regexp-quote match)) (candidates (sort (loop for (key count time text) in elems when (string-match match text) collect (list count time text)) (lambda (l1 l2) (> (car l1) (car l2)))))) (when (> (length candidates) 10) (setcdr (nthcdr 10 candidates) nil)) (unless (zerop (length candidates)) (with-temp-buffer (dolist (candidate candidates) (insert (caddr candidate) "\n")) (goto-char (point-min)) (put-text-property (point) (1+ (point)) 'ecomplete t) (while (re-search-forward match nil t) (put-text-property (match-beginning 0) (match-end 0) 'face 'isearch)) (buffer-string))))) (defun ecomplete-display-matches (type word &optional choose) (let* ((matches (ecomplete-get-matches type word)) (line 0) (max-lines (when matches (- (length (split-string matches "\n")) 2))) (message-log-max nil) command highlight) (if (not matches) (progn (message "No ecomplete matches") nil) (if (not choose) (progn (message "%s" matches) nil) (setq highlight (ecomplete-highlight-match-line matches line)) (while (not (memq (setq command (read-event highlight)) '(? return))) (cond ((eq command ?\M-n) (setq line (min (1+ line) max-lines))) ((eq command ?\M-p) (setq line (max (1- line) 0)))) (setq highlight (ecomplete-highlight-match-line matches line))) (when (eq command 'return) (nth line (split-string matches "\n"))))))) (defun ecomplete-highlight-match-line (matches line) (with-temp-buffer (insert matches) (goto-char (point-min)) (forward-line line) (save-restriction (narrow-to-region (point) (point-at-eol)) (while (not (eobp)) ;; Put the 'region face on any charactes on this line that ;; aren't already highlighted. (unless (get-text-property (point) 'face) (put-text-property (point) (1+ (point)) 'face 'highlight)) (forward-char 1))) (buffer-string))) (provide 'ecomplete) ;; arch-tag: 34622935-bb81-4711-a600-57b89c2ece72 ;;; ecomplete.el ends here gnus-5.11+v0.10.dfsg/lisp/qp.el0000644000175000017500000001423111004005110016164 0ustar tvainikatvainika;;; qp.el --- Quoted-Printable functions ;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, ;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; Keywords: mail, extensions ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 3, or (at your option) ;; any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Commentary: ;; Functions for encoding and decoding quoted-printable text as ;; defined in RFC 2045. ;;; Code: (require 'mm-util) (defvar mm-use-ultra-safe-encoding) ;;;###autoload (defun quoted-printable-decode-region (from to &optional coding-system) "Decode quoted-printable in the region between FROM and TO, per RFC 2045. If CODING-SYSTEM is non-nil, decode bytes into characters with that coding-system. Interactively, you can supply the CODING-SYSTEM argument with \\[universal-coding-system-argument]. The CODING-SYSTEM argument is a historical hangover and is deprecated. QP encodes raw bytes and should be decoded into raw bytes. Decoding them into characters should be done separately." (interactive ;; Let the user determine the coding system with "C-x RET c". (list (region-beginning) (region-end) coding-system-for-read)) (unless (mm-coding-system-p coding-system) ; e.g. `ascii' from Gnus (setq coding-system nil)) (save-excursion (save-restriction ;; RFC 2045: ``An "=" followed by two hexadecimal digits, one ;; or both of which are lowercase letters in "abcdef", is ;; formally illegal. A robust implementation might choose to ;; recognize them as the corresponding uppercase letters.'' (let ((case-fold-search t)) (narrow-to-region from to) ;; Do this in case we're called from Gnus, say, in a buffer ;; which already contains non-ASCII characters which would ;; then get doubly-decoded below. (if coding-system (mm-encode-coding-region (point-min) (point-max) coding-system)) (goto-char (point-min)) (while (and (skip-chars-forward "^=") (not (eobp))) (cond ((eq (char-after (1+ (point))) ?\n) (delete-char 2)) ((looking-at "=[0-9A-F][0-9A-F]") (let ((byte (string-to-number (buffer-substring (1+ (point)) (+ 3 (point))) 16))) (mm-insert-byte byte 1) (delete-char 3))) (t (message "Malformed quoted-printable text") (forward-char))))) (if coding-system (mm-decode-coding-region (point-min) (point-max) coding-system))))) (defun quoted-printable-decode-string (string &optional coding-system) "Decode the quoted-printable encoded STRING and return the result. If CODING-SYSTEM is non-nil, decode the string with coding-system. Use of CODING-SYSTEM is deprecated; this function should deal with raw bytes, and coding conversion should be done separately." (mm-with-unibyte-buffer (insert string) (quoted-printable-decode-region (point-min) (point-max) coding-system) (buffer-string))) (defun quoted-printable-encode-region (from to &optional fold class) "Quoted-printable encode the region between FROM and TO per RFC 2045. If FOLD, fold long lines at 76 characters (as required by the RFC). If CLASS is non-nil, translate the characters not matched by that regexp class, which is in the form expected by `skip-chars-forward'. You should probably avoid non-ASCII characters in this arg. If `mm-use-ultra-safe-encoding' is set, fold lines unconditionally and encode lines starting with \"From\"." (interactive "r") (unless class ;; Avoid using 8bit characters. = is \075. ;; Equivalent to "^\000-\007\013\015-\037\200-\377=" (setq class "\010-\012\014\040-\074\076-\177")) (save-excursion (goto-char from) (if (re-search-forward (mm-string-to-multibyte "[^\x0-\x7f\x80-\xff]") to t) (error "Multibyte character in QP encoding region")) (save-restriction (narrow-to-region from to) ;; Encode all the non-ascii and control characters. (goto-char (point-min)) (while (and (skip-chars-forward class) (not (eobp))) (insert (prog1 ;; To unibyte in case of Emacs 23 (unicode) eight-bit. (format "=%02X" (mm-multibyte-char-to-unibyte (char-after))) (delete-char 1)))) ;; Encode white space at the end of lines. (goto-char (point-min)) (while (re-search-forward "[ \t]+$" nil t) (goto-char (match-beginning 0)) (while (not (eolp)) (insert (prog1 (format "=%02X" (char-after)) (delete-char 1))))) (let ((mm-use-ultra-safe-encoding (and (boundp 'mm-use-ultra-safe-encoding) mm-use-ultra-safe-encoding))) (when (or fold mm-use-ultra-safe-encoding) (let ((tab-width 1)) ; HTAB is one character. (goto-char (point-min)) (while (not (eobp)) ;; In ultra-safe mode, encode "From " at the beginning ;; of a line. (when mm-use-ultra-safe-encoding (if (looking-at "From ") (replace-match "From=20" nil t) (if (looking-at "-") (replace-match "=2D" nil t)))) (end-of-line) ;; Fold long lines. (while (> (current-column) 76) ; tab-width must be 1. (beginning-of-line) (forward-char 75) ; 75 chars plus an "=" (search-backward "=" (- (point) 2) t) (insert "=\n") (end-of-line)) (forward-line)))))))) (defun quoted-printable-encode-string (string) "Encode the STRING as quoted-printable and return the result." (let ((default-enable-multibyte-characters (mm-multibyte-string-p string))) (with-temp-buffer (insert string) (quoted-printable-encode-region (point-min) (point-max)) (buffer-string)))) (provide 'qp) ;; arch-tag: db89e52a-e4a1-4b69-926f-f434f04216ba ;;; qp.el ends here gnus-5.11+v0.10.dfsg/lisp/nndb.el0000644000175000017500000002416611004005110016475 0ustar tvainikatvainika;;; nndb.el --- nndb access for Gnus ;; Copyright (C) 1997, 1998, 2000, 2002, 2003, 2004, ;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc. ;; Author: Masanobu UMEDA ;; Kai Grossjohann ;; Joe Hildebrand ;; David Blacka ;; Keywords: news ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 3, or (at your option) ;; any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Commentary: ;;; This was based upon Kai Grossjohan's shamessly snarfed code and ;;; further modified by Joe Hildebrand. It has been updated for Red ;;; Gnus. ;; TODO: ;; ;; * Fix bug where server connection can be lost and impossible to regain ;; This hasn't happened to me in a while; think it was fixed in Rgnus ;; ;; * make it handle different nndb servers seemlessly ;; ;; * Optimize expire if FORCE ;; ;; * Optimize move (only expire once) ;; ;; * Deal with add/deletion of groups ;; ;; * make the backend TOUCH an article when marked as expireable (will ;; make article expire 'expiry' days after that moment). ;;; Code: ;; For Emacs < 22.2. (eval-and-compile (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) ;;- ;; Register nndb with known select methods. (require 'gnus-start) (unless (assoc "nndb" gnus-valid-select-methods) (gnus-declare-backend "nndb" 'mail 'respool 'address 'prompt-address)) (require 'nnmail) (require 'nnheader) (require 'nntp) (eval-when-compile (require 'cl)) ;; Declare nndb as derived from nntp (nnoo-declare nndb nntp) ;; Variables specific to nndb ;;- currently not used but just in case... (defvoo nndb-deliver-program "nndel" "*The program used to put a message in an NNDB group.") (defvoo nndb-server-side-expiry nil "If t, expiry calculation will occur on the server side.") (defvoo nndb-set-expire-date-on-mark nil "If t, the expiry date for a given article will be set to the time it was marked as expireable; otherwise the date will be the time the article was posted to nndb") ;; Variables copied from nntp (defvoo nndb-server-opened-hook '(nntp-send-authinfo-from-file) "Like nntp-server-opened-hook." nntp-server-opened-hook) (defvoo nndb-address "localhost" "*The name of the NNDB server." nntp-address) (defvoo nndb-port-number 9000 "*Port number to connect to." nntp-port-number) ;; change to 'news if you are actually using nndb for news (defvoo nndb-article-type 'mail) (defvoo nndb-status-string nil "" nntp-status-string) (defconst nndb-version "nndb 0.7" "Version numbers of this version of NNDB.") ;;; Interface functions. (nnoo-define-basics nndb) ;;------------------------------------------------------------------ ;; this function turns the lisp list into a string list. There is ;; probably a more efficient way to do this. (defun nndb-build-article-string (articles) (let (art-string art) (while articles (setq art (pop articles)) (setq art-string (concat art-string art " "))) art-string)) (defun nndb-build-expire-rest-list (total expire) (let (art rest) (while total (setq art (pop total)) (if (memq art expire) () (push art rest))) rest)) ;; (deffoo nndb-request-type (group &optional article) nndb-article-type) ;; nndb-request-update-info does not exist and is not needed ;; nndb-request-update-mark does not exist; it should be used to TOUCH ;; articles as they are marked exipirable (defun nndb-touch-article (group article) (nntp-send-command nil "X-TOUCH" article)) (deffoo nndb-request-update-mark (group article mark) "Sets the expiry date for ARTICLE in GROUP to now, if the mark is 'E'" (if (and nndb-set-expire-date-on-mark (string-equal mark "E")) (nndb-touch-article group article)) mark) ;; nndb-request-create-group -- currently this isn't necessary; nndb ;; creates groups on demand. ;; todo -- use some other time than the creation time of the article ;; best is time since article has been marked as expirable (defun nndb-request-expire-articles-local (articles &optional group server force) "Let gnus do the date check and issue the delete commands." (let (msg art delete-list (num-delete 0) rest) (nntp-possibly-change-group group server) (while articles (setq art (pop articles)) (nntp-send-command "^\\([23]\\|^423\\).*\n" "X-DATE" art) (setq msg (nndb-status-message)) (if (string-match "^423" msg) () (or (string-match "'\\(.+\\)'" msg) (error "Not a valid response for X-DATE command: %s" msg)) (if (nnmail-expired-article-p group (date-to-time (substring msg (match-beginning 1) (match-end 1))) force) (progn (setq delete-list (concat delete-list " " (int-to-string art))) (setq num-delete (1+ num-delete))) (push art rest)))) (if (> (length delete-list) 0) (progn (nnheader-message 5 "Deleting %s article(s) from %s" (int-to-string num-delete) group) (nntp-send-command "^[23].*\n" "X-DELETE" delete-list)) ) (nnheader-message 5 "") (nconc rest articles))) (defun nndb-get-remote-expire-response () (let (list) (set-buffer nntp-server-buffer) (goto-char (point-min)) (if (looking-at "^[34]") ;; x-expire returned error--presume no articles were expirable) (setq list nil) ;; otherwise, pull all of the following numbers into the list (re-search-forward "follows\r?\n?" nil t) (while (re-search-forward "^[0-9]+$" nil t) (push (string-to-number (match-string 0)) list))) list)) (defun nndb-request-expire-articles-remote (articles &optional group server force) "Let the nndb backend expire articles" (let (days art-string delete-list (num-delete 0)) (nntp-possibly-change-group group server) ;; first calculate the wait period in days (setq days (or (and nnmail-expiry-wait-function (funcall nnmail-expiry-wait-function group)) nnmail-expiry-wait)) ;; now handle the special cases (cond (force (setq days 0)) ((eq days 'never) ;; This isn't an expirable group. (setq days -1)) ((eq days 'immediate) (setq days 0))) ;; build article string (setq art-string (concat days " " (nndb-build-article-string articles))) (nntp-send-command "^\.\r?\n\\|^[345].*\n" "X-EXPIRE" art-string) (setq delete-list (nndb-get-remote-expire-response)) (setq num-delete (length delete-list)) (if (> num-delete 0) (nnheader-message 5 "Deleting %s article(s) from %s" (int-to-string num-delete) group)) (nndb-build-expire-rest-list articles delete-list))) (deffoo nndb-request-expire-articles (articles &optional group server force) "Expires ARTICLES from GROUP on SERVER. If FORCE, delete regardless of exiration date, otherwise use normal expiry mechanism." (if nndb-server-side-expiry (nndb-request-expire-articles-remote articles group server force) (nndb-request-expire-articles-local articles group server force))) ;; _Something_ defines it... (declare-function nndb-request-article "nndb" t t) (deffoo nndb-request-move-article (article group server accept-form &optional last move-is-internal) "Move ARTICLE (a number) from GROUP on SERVER. Evals ACCEPT-FORM in current buffer, where the article is. Optional LAST is ignored." ;; we guess that the second arg in accept-form is the new group, ;; which it will be for nndb, which is all that matters anyway (let ((new-group (nth 1 accept-form)) result) (nntp-possibly-change-group group server) ;; use the move command for nndb-to-nndb moves (if (string-match "^nndb" new-group) (let ((new-group-name (gnus-group-real-name new-group))) (nntp-send-command "^[23].*\n" "X-MOVE" article new-group-name) (cons new-group article)) ;; else move normally (let ((artbuf (get-buffer-create " *nndb move*"))) (and (nndb-request-article article group server artbuf) (save-excursion (set-buffer artbuf) (insert-buffer-substring nntp-server-buffer) (setq result (eval accept-form)) (kill-buffer (current-buffer)) result) (nndb-request-expire-articles (list article) group server t)) result) ))) (deffoo nndb-request-accept-article (group server &optional last) "The article in the current buffer is put into GROUP." (nntp-possibly-change-group group server) (let (art msg) (when (nntp-send-command "^[23].*\r?\n" "ACCEPT" group) (nnheader-insert "") (nntp-send-buffer "^[23].*\n")) (set-buffer nntp-server-buffer) (setq msg (buffer-string)) (or (string-match "^\\([0-9]+\\)" msg) (error "nndb: %s" msg)) (setq art (substring msg (match-beginning 1) (match-end 1))) (nnheader-message 5 "nndb: accepted %s" art) (list art))) (deffoo nndb-request-replace-article (article group buffer) "ARTICLE is the number of the article in GROUP to be replaced with the contents of the BUFFER." (set-buffer buffer) (when (nntp-send-command "^[23].*\r?\n" "X-REPLACE" (int-to-string article)) (nnheader-insert "") (nntp-send-buffer "^[23.*\n") (list (int-to-string article)))) ; nndb-request-delete-group does not exist ; todo -- maybe later ; nndb-request-rename-group does not exist ; todo -- maybe later ;; -- standard compatability functions (deffoo nndb-status-message (&optional server) "Return server status as a string." (set-buffer nntp-server-buffer) (buffer-string)) ;; Import stuff from nntp (nnoo-import nndb (nntp)) (provide 'nndb) ;; arch-tag: 83bd6fb4-58d9-4fed-a901-c6c625ad5f8a ;;; nndb.el ends here gnus-5.11+v0.10.dfsg/lisp/gnus-ems.el0000644000175000017500000002355311004005110017311 0ustar tvainikatvainika;;; gnus-ems.el --- functions for making Gnus work under different Emacsen ;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, ;; 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; Keywords: news ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 3, or (at your option) ;; any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Commentary: ;;; Code: (eval-when-compile (require 'cl) (require 'ring)) ;;; Function aliases later to be redefined for XEmacs usage. (defvar gnus-mouse-2 [mouse-2]) (defvar gnus-down-mouse-3 [down-mouse-3]) (defvar gnus-down-mouse-2 [down-mouse-2]) (defvar gnus-widget-button-keymap nil) (defvar gnus-mode-line-modified (if (featurep 'xemacs) '("--**-" . "-----") '("**" "--"))) (eval-and-compile (autoload 'gnus-xmas-define "gnus-xmas") (autoload 'gnus-xmas-redefine "gnus-xmas") (autoload 'gnus-get-buffer-create "gnus") (autoload 'nnheader-find-etc-directory "nnheader")) (autoload 'smiley-region "smiley") (defun gnus-kill-all-overlays () "Delete all overlays in the current buffer." (let* ((overlayss (overlay-lists)) (buffer-read-only nil) (overlays (delq nil (nconc (car overlayss) (cdr overlayss))))) (while overlays (delete-overlay (pop overlays))))) ;;; Mule functions. (defun gnus-mule-max-width-function (el max-width) `(let* ((val (eval (, el))) (valstr (if (numberp val) (int-to-string val) val))) (if (> (length valstr) ,max-width) (truncate-string-to-width valstr ,max-width) valstr))) (eval-and-compile (if (featurep 'xemacs) (gnus-xmas-define) (defvar gnus-mouse-face-prop 'mouse-face "Property used for highlighting mouse regions."))) (defvar gnus-tmp-unread) (defvar gnus-tmp-replied) (defvar gnus-tmp-score-char) (defvar gnus-tmp-indentation) (defvar gnus-tmp-opening-bracket) (defvar gnus-tmp-lines) (defvar gnus-tmp-name) (defvar gnus-tmp-closing-bracket) (defvar gnus-tmp-subject-or-nil) (defvar gnus-check-before-posting) (defvar gnus-mouse-face) (defvar gnus-group-buffer) (defun gnus-ems-redefine () (cond ((featurep 'xemacs) (gnus-xmas-redefine)) ((featurep 'mule) ;; Mule and new Emacs definitions ;; [Note] Now there are three kinds of mule implementations, ;; original MULE, XEmacs/mule and Emacs 20+ including ;; MULE features. Unfortunately these APIs are different. In ;; particular, Emacs (including original Mule) and XEmacs are ;; quite different. However, this version of Gnus doesn't support ;; anything other than XEmacs 20+ and Emacs 20.3+. ;; Predicates to check are following: ;; (boundp 'MULE) is t only if Mule (original; anything older than ;; Mule 2.3) is running. ;; (featurep 'mule) is t when other mule variants are running. ;; It is possible to detect XEmacs/mule by (featurep 'mule) and ;; (featurep 'xemacs). In this case, the implementation for ;; XEmacs/mule may be shareable between XEmacs and XEmacs/mule. (defvar gnus-summary-display-table nil "Display table used in summary mode buffers.") (defalias 'gnus-max-width-function 'gnus-mule-max-width-function) (when (boundp 'gnus-check-before-posting) (setq gnus-check-before-posting (delq 'long-lines (delq 'control-chars gnus-check-before-posting)))) (defun gnus-summary-line-format-spec () (insert gnus-tmp-unread gnus-tmp-replied gnus-tmp-score-char gnus-tmp-indentation) (put-text-property (point) (progn (insert gnus-tmp-opening-bracket (format "%4d: %-20s" gnus-tmp-lines (if (> (length gnus-tmp-name) 20) (truncate-string-to-width gnus-tmp-name 20) gnus-tmp-name)) gnus-tmp-closing-bracket) (point)) gnus-mouse-face-prop gnus-mouse-face) (insert " " gnus-tmp-subject-or-nil "\n"))))) ;; Clone of `appt-select-lowest-window' in appt.el. (defun gnus-select-lowest-window () "Select the lowest window on the frame." (let ((lowest-window (selected-window)) (bottom-edge (nth 3 (window-edges)))) (walk-windows (lambda (w) (let ((next-bottom-edge (nth 3 (window-edges w)))) (when (< bottom-edge next-bottom-edge) (setq bottom-edge next-bottom-edge lowest-window w))))) (select-window lowest-window))) (defun gnus-region-active-p () "Say whether the region is active." (and (boundp 'transient-mark-mode) transient-mark-mode (boundp 'mark-active) mark-active)) (defun gnus-mark-active-p () "Non-nil means the mark and region are currently active in this buffer." mark-active) ; aliased to region-exists-p in XEmacs. (autoload 'gnus-alive-p "gnus-util") (autoload 'mm-disable-multibyte "mm-util") (defun gnus-x-splash () "Show a splash screen using a pixmap in the current buffer." (interactive) (unless window-system (error "`gnus-x-splash' requires running on the window system")) (switch-to-buffer (gnus-get-buffer-create (if (or (gnus-alive-p) (interactive-p)) "*gnus-x-splash*" gnus-group-buffer))) (let ((inhibit-read-only t) (file (nnheader-find-etc-directory "images/gnus/x-splash" t)) pixmap fcw fch width height fringes sbars left yoffset top ls) (erase-buffer) (sit-for 0) ;; Necessary for measuring the window size correctly. (when (and file (ignore-errors (let ((coding-system-for-read 'raw-text)) (with-temp-buffer (mm-disable-multibyte) (insert-file-contents file) (goto-char (point-min)) (setq pixmap (read (current-buffer))))))) (setq fcw (float (frame-char-width)) fch (float (frame-char-height)) width (/ (car pixmap) fcw) height (/ (cadr pixmap) fch) fringes (if (fboundp 'window-fringes) (eval '(window-fringes)) '(10 11 nil)) sbars (frame-parameter nil 'vertical-scroll-bars)) (cond ((eq sbars 'right) (setq sbars (cons 0 (/ (or (frame-parameter nil 'scroll-bar-width) 14) fcw)))) (sbars (setq sbars (cons (/ (or (frame-parameter nil 'scroll-bar-width) 14) fcw) 0))) (t (setq sbars '(0 . 0)))) (setq left (- (* (round (/ (1- (/ (+ (window-width) (car sbars) (cdr sbars) (/ (+ (or (car fringes) 0) (or (cadr fringes) 0)) fcw)) width)) 2)) width) (car sbars) (/ (or (car fringes) 0) fcw)) yoffset (cadr (window-edges)) top (max 0 (- (* (max (if (and tool-bar-mode (not (featurep 'gtk)) (eq (frame-first-window) (selected-window))) 1 0) (round (/ (1- (/ (+ (1- (window-height)) (* 2 yoffset)) height)) 2))) height) yoffset)) ls (/ (or line-spacing 0) fch) height (max 0 (- height ls))) (cond ((>= (- top ls) 1) (insert (propertize " " 'display `(space :width 0 :ascent 100)) "\n" (propertize " " 'display `(space :width 0 :height ,(- top ls 1) :ascent 100)) "\n")) ((> (- top ls) 0) (insert (propertize " " 'display `(space :width 0 :height ,(- top ls) :ascent 100)) "\n"))) (if (and (> width 0) (> left 0)) (insert (propertize " " 'display `(space :width ,left :height ,height :ascent 0))) (setq width (+ width left))) (when (> width 0) (insert (propertize " " 'display `(space :width ,width :height ,height :ascent 0) 'face `(gnus-splash :stipple ,pixmap)))) (goto-char (if (<= (- top ls) 0) (1- (point)) (point-min))) (redraw-frame (selected-frame)) (sit-for 0)))) ;;; Image functions. (defun gnus-image-type-available-p (type) (and (fboundp 'image-type-available-p) (image-type-available-p type) (if (fboundp 'display-images-p) (display-images-p) t))) (defun gnus-create-image (file &optional type data-p &rest props) (let ((face (plist-get props :face))) (when face (setq props (plist-put props :foreground (face-foreground face))) (setq props (plist-put props :background (face-background face)))) (apply 'create-image file type data-p props))) (defun gnus-put-image (glyph &optional string category) (let ((point (point))) (insert-image glyph (or string " ")) (put-text-property point (point) 'gnus-image-category category) (unless string (put-text-property (1- (point)) (point) 'gnus-image-text-deletable t)) glyph)) (defun gnus-remove-image (image &optional category) "Remove the image matching IMAGE and CATEGORY found first." (let ((start (point-min)) val end) (while (and (not end) (or (setq val (get-text-property start 'display)) (and (setq start (next-single-property-change start 'display)) (setq val (get-text-property start 'display))))) (setq end (or (next-single-property-change start 'display) (point-max))) (if (and (equal val image) (equal (get-text-property start 'gnus-image-category) category)) (progn (put-text-property start end 'display nil) (when (get-text-property start 'gnus-image-text-deletable) (delete-region start end))) (unless (= end (point-max)) (setq start end end nil)))))) (provide 'gnus-ems) ;; arch-tag: e7360b45-14b5-4171-aa39-69a44aed3cdb ;;; gnus-ems.el ends here gnus-5.11+v0.10.dfsg/lisp/nnlistserv.el0000644000175000017500000001117011004005110017752 0ustar tvainikatvainika;;; nnlistserv.el --- retrieving articles via web mailing list archives ;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, ;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; Keywords: news, mail ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 3, or (at your option) ;; any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Commentary: ;;; Code: (eval-when-compile (require 'cl)) (require 'nnoo) (require 'mm-url) (require 'nnweb) (nnoo-declare nnlistserv nnweb) (defvoo nnlistserv-directory (nnheader-concat gnus-directory "nnlistserv/") "Where nnlistserv will save its files." nnweb-directory) (defvoo nnlistserv-name 'kk "What search engine type is being used." nnweb-type) (defvoo nnlistserv-type-definition '((kk (article . nnlistserv-kk-wash-article) (map . nnlistserv-kk-create-mapping) (search . nnlistserv-kk-search) (address . "http://www.itk.ntnu.no/ansatte/Andresen_Trond/kk-f/%s/") (pages "fra160396" "fra160796" "fra061196" "fra160197" "fra090997" "fra040797" "fra130397" "nye") (index . "date.html") (identifier . nnlistserv-kk-identity))) "Type-definition alist." nnweb-type-definition) (defvoo nnlistserv-search nil "Search string to feed to DejaNews." nnweb-search) (defvoo nnlistserv-ephemeral-p nil "Whether this nnlistserv server is ephemeral." nnweb-ephemeral-p) ;;; Internal variables ;;; Interface functions (nnoo-define-basics nnlistserv) (nnoo-import nnlistserv (nnweb)) ;;; Internal functions ;;; ;;; KK functions. ;;; (defun nnlistserv-kk-create-mapping () "Perform the search and create a number-to-url alist." (save-excursion (set-buffer nnweb-buffer) (let ((case-fold-search t) (active (or (cadr (assoc nnweb-group nnweb-group-alist)) (cons 1 0))) (pages (nnweb-definition 'pages)) map url page subject from ) (while (setq page (pop pages)) (erase-buffer) (when (funcall (nnweb-definition 'search) page) ;; Go through all the article hits on this page. (goto-char (point-min)) (mm-url-decode-entities) (goto-char (point-min)) (while (re-search-forward "^
  • *\\([^\\>]+\\) *<[^>]+>\\([^>]+\\)<" nil t) (setq url (match-string 1) subject (match-string 2) from (match-string 3)) (setq url (concat (format (nnweb-definition 'address) page) url)) (unless (nnweb-get-hashtb url) (push (list (incf (cdr active)) (make-full-mail-header (cdr active) subject from "" (concat "<" (nnweb-identifier url) "@kk>") nil 0 0 url)) map) (nnweb-set-hashtb (cadar map) (car map)) (nnheader-message 5 "%s %s %s" (cdr active) (point) pages))))) ;; Return the articles in the right order. (setq nnweb-articles (sort (nconc nnweb-articles map) 'car-less-than-car))))) (defun nnlistserv-kk-wash-article () (let ((case-fold-search t) (headers '(sent name email subject id)) sent name email subject id) (mm-url-decode-entities) (while headers (goto-char (point-min)) (re-search-forward (format "<----------2,3----------><--4--><-5-> ;; They mean: ;; 1. After "Q?", allow "?"s that follow a character other than "=". ;; 2. Allow "=" after "Q?"; it isn't regarded as the terminator. ;; 3. In the middle of an encoded word, allow "?"s that follow a ;; character other than "=". ;; 4. Allow any characters other than "?" in the middle of an ;; encoded word. ;; 5. At the end, allow "?"s. )) ;;; ;;; Functions for encoding RFC2047 messages ;;; (defun rfc2047-qp-or-base64 () "Return the type with which to encode the buffer. This is either `base64' or `quoted-printable'." (save-excursion (let ((limit (min (point-max) (+ 2000 (point-min)))) (n8bit 0)) (goto-char (point-min)) (skip-chars-forward "\x20-\x7f\r\n\t" limit) (while (< (point) limit) (incf n8bit) (forward-char 1) (skip-chars-forward "\x20-\x7f\r\n\t" limit)) (if (or (< (* 6 n8bit) (- limit (point-min))) ;; Don't base64, say, a short line with a single ;; non-ASCII char when splitting parts by charset. (= n8bit 1)) 'quoted-printable 'base64)))) (defun rfc2047-narrow-to-field () "Narrow the buffer to the header on the current line." (beginning-of-line) (narrow-to-region (point) (progn (forward-line 1) (if (re-search-forward "^[^ \n\t]" nil t) (point-at-bol) (point-max)))) (goto-char (point-min))) (defun rfc2047-field-value () "Return the value of the field at point." (save-excursion (save-restriction (rfc2047-narrow-to-field) (re-search-forward ":[ \t\n]*" nil t) (buffer-substring-no-properties (point) (point-max))))) (defun rfc2047-quote-special-characters-in-quoted-strings (&optional encodable-regexp) "Quote special characters with `\\'s in quoted strings. Quoting will not be done in a quoted string if it contains characters matching ENCODABLE-REGEXP or it is within parentheses." (goto-char (point-min)) (let ((tspecials (concat "[" ietf-drums-tspecials "]")) (start (point)) beg end) (with-syntax-table (standard-syntax-table) (while (not (eobp)) (if (ignore-errors (forward-list 1) (eq (char-before) ?\))) (forward-list -1) (goto-char (point-max))) (save-restriction (narrow-to-region start (point)) (goto-char start) (while (search-forward "\"" nil t) (setq beg (match-beginning 0)) (unless (eq (char-before beg) ?\\) (goto-char beg) (setq beg (1+ beg)) (condition-case nil (progn (forward-sexp) (setq end (1- (point))) (goto-char beg) (if (and encodable-regexp (re-search-forward encodable-regexp end t)) (goto-char (1+ end)) (save-restriction (narrow-to-region beg end) (while (re-search-forward tspecials nil 'move) (if (eq (char-before) ?\\) (if (looking-at tspecials) ;; Already quoted. (forward-char) (insert "\\")) (goto-char (match-beginning 0)) (insert "\\") (forward-char)))) (forward-char))) (error (goto-char beg))))) (goto-char (point-max))) (forward-list 1) (setq start (point)))))) (defvar rfc2047-encoding-type 'address-mime "The type of encoding done by `rfc2047-encode-region'. This should be dynamically bound around calls to `rfc2047-encode-region' to either `mime' or `address-mime'. See `rfc2047-header-encoding-alist', for definitions.") (defun rfc2047-encode-message-header () "Encode the message header according to `rfc2047-header-encoding-alist'. Should be called narrowed to the head of the message." (interactive "*") (save-excursion (goto-char (point-min)) (let (alist elem method) (while (not (eobp)) (save-restriction (rfc2047-narrow-to-field) (setq method nil alist rfc2047-header-encoding-alist) (while (setq elem (pop alist)) (when (or (and (stringp (car elem)) (looking-at (car elem))) (eq (car elem) t)) (setq alist nil method (cdr elem)))) (if (not (rfc2047-encodable-p)) (prog2 (when (eq method 'address-mime) (rfc2047-quote-special-characters-in-quoted-strings)) (if (and (eq (mm-body-7-or-8) '8bit) (mm-multibyte-p) (mm-coding-system-p (car message-posting-charset))) ;; 8 bit must be decoded. (mm-encode-coding-region (point-min) (point-max) (mm-charset-to-coding-system (car message-posting-charset)))) ;; No encoding necessary, but folding is nice (when nil (rfc2047-fold-region (save-excursion (goto-char (point-min)) (skip-chars-forward "^:") (when (looking-at ": ") (forward-char 2)) (point)) (point-max)))) ;; We found something that may perhaps be encoded. (re-search-forward "^[^:]+: *" nil t) (cond ((eq method 'address-mime) (rfc2047-encode-region (point) (point-max))) ((eq method 'mime) (let ((rfc2047-encoding-type 'mime)) (rfc2047-encode-region (point) (point-max)))) ((eq method 'default) (if (and (featurep 'mule) (if (boundp 'default-enable-multibyte-characters) default-enable-multibyte-characters) mail-parse-charset) (mm-encode-coding-region (point) (point-max) mail-parse-charset))) ;; We get this when CC'ing messsages to newsgroups with ;; 8-bit names. The group name mail copy just got ;; unconditionally encoded. Previously, it would ask ;; whether to encode, which was quite confusing for the ;; user. If the new behaviour is wrong, tell me. I have ;; left the old code commented out below. ;; -- Per Abrahamsen Date: 2001-10-07. ;; Modified by Dave Love, with the commented-out code changed ;; in accordance with changes elsewhere. ((null method) (rfc2047-encode-region (point) (point-max))) ;;; ((null method) ;;; (if (or (message-options-get ;;; 'rfc2047-encode-message-header-encode-any) ;;; (message-options-set ;;; 'rfc2047-encode-message-header-encode-any ;;; (y-or-n-p ;;; "Some texts are not encoded. Encode anyway?"))) ;;; (rfc2047-encode-region (point-min) (point-max)) ;;; (error "Cannot send unencoded text"))) ((mm-coding-system-p method) (if (or (and (featurep 'mule) (if (boundp 'default-enable-multibyte-characters) default-enable-multibyte-characters)) (featurep 'file-coding)) (mm-encode-coding-region (point) (point-max) method))) ;; Hm. (t))) (goto-char (point-max))))))) ;; Fixme: This, and the require below may not be the Right Thing, but ;; should be safe just before release. -- fx 2001-02-08 (defun rfc2047-encodable-p () "Return non-nil if any characters in current buffer need encoding in headers. The buffer may be narrowed." (require 'message) ; for message-posting-charset (let ((charsets (mm-find-mime-charset-region (point-min) (point-max)))) (goto-char (point-min)) (or (and rfc2047-encode-encoded-words (prog1 (re-search-forward rfc2047-encoded-word-regexp nil t) (goto-char (point-min)))) (and charsets (not (equal charsets (list (car message-posting-charset)))))))) ;; Use this syntax table when parsing into regions that may need ;; encoding. Double quotes are string delimiters, backslash is ;; character quoting, and all other RFC 2822 special characters are ;; treated as punctuation so we can use forward-sexp/forward-word to ;; skip to the end of regions appropriately. Nb. ietf-drums does ;; things differently. (defconst rfc2047-syntax-table ;; (make-char-table 'syntax-table '(2)) only works in Emacs. (let ((table (make-syntax-table))) ;; The following is done to work for setting all elements of the table ;; in Emacs 21-23 and XEmacs; it appears to be the cleanest way. ;; Play safe and don't assume the form of the word syntax entry -- ;; copy it from ?a. (if (fboundp 'set-char-table-range) ; Emacs (funcall (intern "set-char-table-range") table t (aref (standard-syntax-table) ?a)) (if (fboundp 'put-char-table) (if (fboundp 'get-char-table) ; warning avoidance (put-char-table t (get-char-table ?a (standard-syntax-table)) table)))) (modify-syntax-entry ?\\ "\\" table) (modify-syntax-entry ?\" "\"" table) (modify-syntax-entry ?\( "(" table) (modify-syntax-entry ?\) ")" table) (modify-syntax-entry ?\< "." table) (modify-syntax-entry ?\> "." table) (modify-syntax-entry ?\[ "." table) (modify-syntax-entry ?\] "." table) (modify-syntax-entry ?: "." table) (modify-syntax-entry ?\; "." table) (modify-syntax-entry ?, "." table) (modify-syntax-entry ?@ "." table) table)) (defun rfc2047-encode-region (b e) "Encode words in region B to E that need encoding. By default, the region is treated as containing RFC2822 addresses. Dynamically bind `rfc2047-encoding-type' to change that." (save-restriction (narrow-to-region b e) (let ((encodable-regexp (if rfc2047-encode-encoded-words "[^\000-\177]+\\|=\\?" "[^\000-\177]+")) start ; start of current token end begin csyntax ;; Whether there's an encoded word before the current token, ;; either immediately or separated by space. last-encoded (orig-text (buffer-substring-no-properties b e))) (if (eq 'mime rfc2047-encoding-type) ;; Simple case. Continuous words in which all those contain ;; non-ASCII characters are encoded collectively. Encoding ;; ASCII words, including `Re:' used in Subject headers, is ;; avoided for interoperability with non-MIME clients and ;; for making it easy to find keywords. (progn (goto-char (point-min)) (while (progn (skip-chars-forward " \t\n") (not (eobp))) (setq start (point)) (while (and (looking-at "[ \t\n]*\\([^ \t\n]+\\)") (progn (setq end (match-end 0)) (re-search-forward encodable-regexp end t))) (goto-char end)) (if (> (point) start) (rfc2047-encode start (point)) (goto-char end)))) ;; `address-mime' case -- take care of quoted words, comments. (rfc2047-quote-special-characters-in-quoted-strings encodable-regexp) (with-syntax-table rfc2047-syntax-table (goto-char (point-min)) (condition-case err ; in case of unbalanced quotes ;; Look for rfc2822-style: sequences of atoms, quoted ;; strings, specials, whitespace. (Specials mustn't be ;; encoded.) (while (not (eobp)) ;; Skip whitespace. (skip-chars-forward " \t\n") (setq start (point)) (cond ((not (char-after))) ; eob ;; else token start ((eq ?\" (setq csyntax (char-syntax (char-after)))) ;; Quoted word. (forward-sexp) (setq end (point)) ;; Does it need encoding? (goto-char start) (if (re-search-forward encodable-regexp end 'move) ;; It needs encoding. Strip the quotes first, ;; since encoded words can't occur in quotes. (progn (goto-char end) (delete-backward-char 1) (goto-char start) (delete-char 1) (when last-encoded ;; There was a preceding quoted word. We need ;; to include any separating whitespace in this ;; word to avoid it getting lost. (skip-chars-backward " \t") ;; A space is needed between the encoded words. (insert ? ) (setq start (point) end (1+ end))) ;; Adjust the end position for the deleted quotes. (rfc2047-encode start (- end 2)) (setq last-encoded t)) ; record that it was encoded (setq last-encoded nil))) ((eq ?. csyntax) ;; Skip other delimiters, but record that they've ;; potentially separated quoted words. (forward-char) (setq last-encoded nil)) ((eq ?\) csyntax) (error "Unbalanced parentheses")) ((eq ?\( csyntax) ;; Look for the end of parentheses. (forward-list) ;; Encode text as an unstructured field. (let ((rfc2047-encoding-type 'mime)) (rfc2047-encode-region (1+ start) (1- (point)))) (skip-chars-forward ")")) (t ; normal token/whitespace sequence ;; Find the end. ;; Skip one ASCII word, or encode continuous words ;; in which all those contain non-ASCII characters. (setq end nil) (while (not (or end (eobp))) (when (looking-at "[\000-\177]+") (setq begin (point) end (match-end 0)) (when (progn (while (and (or (re-search-forward "[ \t\n]\\|\\Sw" end 'move) (setq end nil)) (eq ?\\ (char-syntax (char-before)))) ;; Skip backslash-quoted characters. (forward-char)) end) (setq end (match-beginning 0)) (if rfc2047-encode-encoded-words (progn (goto-char begin) (when (search-forward "=?" end 'move) (goto-char (match-beginning 0)) (setq end nil))) (goto-char end)))) ;; Where the value nil of `end' means there may be ;; text to have to be encoded following the point. ;; Otherwise, the point reached to the end of ASCII ;; words separated by whitespace or a special char. (unless end (when (looking-at encodable-regexp) (goto-char (setq begin (match-end 0))) (while (and (looking-at "[ \t\n]+\\([^ \t\n]+\\)") (setq end (match-end 0)) (progn (while (re-search-forward encodable-regexp end t)) (< begin (point))) (goto-char begin) (or (not (re-search-forward "\\Sw" end t)) (progn (goto-char (match-beginning 0)) nil))) (goto-char end)) (when (looking-at "[^ \t\n]+") (setq end (match-end 0)) (if (re-search-forward "\\Sw+" end t) ;; There are special characters better ;; to be encoded so that MTAs may parse ;; them safely. (cond ((= end (point))) ((looking-at (concat "\\sw*\\(" encodable-regexp "\\)")) (setq end nil)) (t (goto-char (1- (match-end 0))) (unless (= (point) (match-beginning 0)) ;; Separate encodable text and ;; delimiter. (insert " ")))) (goto-char end) (skip-chars-forward " \t\n") (if (and (looking-at "[^ \t\n]+") (string-match encodable-regexp (match-string 0))) (setq end nil) (goto-char end))))))) (skip-chars-backward " \t\n") (setq end (point)) (goto-char start) (if (re-search-forward encodable-regexp end 'move) (progn (unless (memq (char-before start) '(nil ?\t ? )) (if (progn (goto-char start) (skip-chars-backward "^ \t\n") (and (looking-at "\\Sw+") (= (match-end 0) start))) ;; Also encode bogus delimiters. (setq start (point)) ;; Separate encodable text and delimiter. (goto-char start) (insert " ") (setq start (1+ start) end (1+ end)))) (rfc2047-encode start end) (setq last-encoded t)) (setq last-encoded nil))))) (error (if (or debug-on-quit debug-on-error) (signal (car err) (cdr err)) (error "Invalid data for rfc2047 encoding: %s" (mm-replace-in-string orig-text "[ \t\n]+" " ")))))))) (rfc2047-fold-region b (point)) (goto-char (point-max)))) (defun rfc2047-encode-string (string) "Encode words in STRING. By default, the string is treated as containing addresses (see `rfc2047-encoding-type')." (mm-with-multibyte-buffer (insert string) (rfc2047-encode-region (point-min) (point-max)) (buffer-string))) ;; From RFC 2047: ;; 2. Syntax of encoded-words ;; [...] ;; While there is no limit to the length of a multiple-line header ;; field, each line of a header field that contains one or more ;; 'encoded-word's is limited to 76 characters. ;; ;; In `rfc2047-encode-parameter' it is bound to nil, so don't defconst it. (defvar rfc2047-encode-max-chars 76 "Maximum characters of each header line that contain encoded-words. According to RFC 2047, it is 76. If it is nil, encoded-words will not be folded. Too small value may cause an error. You should not change this value.") (defun rfc2047-encode-1 (column string cs encoder start crest tail &optional eword) "Subroutine used by `rfc2047-encode'." (cond ((string-equal string "") (or eword "")) ((not rfc2047-encode-max-chars) (concat start (funcall encoder (if cs (mm-encode-coding-string string cs) string)) "?=")) ((>= column rfc2047-encode-max-chars) (when eword (cond ((string-match "\n[ \t]+\\'" eword) ;; Reomove a superfluous empty line. (setq eword (substring eword 0 (match-beginning 0)))) ((string-match "(+\\'" eword) ;; Break the line before the open parenthesis. (setq crest (concat crest (match-string 0 eword)) eword (substring eword 0 (match-beginning 0)))))) (rfc2047-encode-1 (length crest) string cs encoder start " " tail (concat eword "\n" crest))) (t (let ((index 0) (limit (1- (length string))) (prev "") next len) (while (and prev (<= index limit)) (setq next (concat start (funcall encoder (if cs (mm-encode-coding-string (substring string 0 (1+ index)) cs) (substring string 0 (1+ index)))) "?=") len (+ column (length next))) (if (> len rfc2047-encode-max-chars) (setq next prev prev nil) (if (or (< index limit) (<= (+ len (or (string-match "\n" tail) (length tail))) rfc2047-encode-max-chars)) (setq prev next index (1+ index)) (if (string-match "\\`)+" tail) ;; Break the line after the close parenthesis. (setq tail (concat (substring tail 0 (match-end 0)) "\n " (substring tail (match-end 0))) prev next index (1+ index)) (setq next prev prev nil))))) (if (> index limit) (concat eword next tail) (if (= 0 index) (if (and eword (string-match "(+\\'" eword)) (setq crest (concat crest (match-string 0 eword)) eword (substring eword 0 (match-beginning 0))) (setq eword (concat eword next))) (setq crest " " eword (concat eword next))) (when (string-match "\n[ \t]+\\'" eword) ;; Reomove a superfluous empty line. (setq eword (substring eword 0 (match-beginning 0)))) (rfc2047-encode-1 (length crest) (substring string index) cs encoder start " " tail (concat eword "\n" crest))))))) (defun rfc2047-encode (b e) "Encode the word(s) in the region B to E. Point moves to the end of the region." (let ((mime-charset (or (mm-find-mime-charset-region b e) (list 'us-ascii))) cs encoding tail crest eword) (cond ((> (length mime-charset) 1) (error "Can't rfc2047-encode `%s'" (buffer-substring-no-properties b e))) ((= (length mime-charset) 1) (setq mime-charset (car mime-charset) cs (mm-charset-to-coding-system mime-charset)) (unless (and (mm-multibyte-p) (mm-coding-system-p cs)) (setq cs nil)) (save-restriction (narrow-to-region b e) (setq encoding (or (cdr (assq mime-charset rfc2047-charset-encoding-alist)) ;; For the charsets that don't have a preferred ;; encoding, choose the one that's shorter. (if (eq (rfc2047-qp-or-base64) 'base64) 'B 'Q))) (widen) (goto-char e) (skip-chars-forward "^ \t\n") ;; `tail' may contain a close parenthesis. (setq tail (buffer-substring-no-properties e (point))) (goto-char b) (setq b (point-marker) e (set-marker (make-marker) e)) (rfc2047-fold-region (point-at-bol) b) (goto-char b) (skip-chars-backward "^ \t\n") (unless (= 0 (skip-chars-backward " \t")) ;; `crest' may contain whitespace and an open parenthesis. (setq crest (buffer-substring-no-properties (point) b))) (setq eword (rfc2047-encode-1 (- b (point-at-bol)) (mm-replace-in-string (buffer-substring-no-properties b e) "\n\\([ \t]?\\)" "\\1") cs (or (cdr (assq encoding rfc2047-encode-function-alist)) 'identity) (concat "=?" (downcase (symbol-name mime-charset)) "?" (upcase (symbol-name encoding)) "?") (or crest " ") tail)) (delete-region (if (eq (aref eword 0) ?\n) (if (bolp) ;; The line was folded before encoding. (1- (point)) (point)) (goto-char b)) (+ e (length tail))) ;; `eword' contains `crest' and `tail'. (insert eword) (set-marker b nil) (set-marker e nil) (unless (or (/= 0 (length tail)) (eobp) (looking-at "[ \t\n)]")) (insert " ")))) (t (goto-char e))))) (defun rfc2047-fold-field () "Fold the current header field." (save-excursion (save-restriction (rfc2047-narrow-to-field) (rfc2047-fold-region (point-min) (point-max))))) (defun rfc2047-fold-region (b e) "Fold long lines in region B to E." (save-restriction (narrow-to-region b e) (goto-char (point-min)) (let ((break nil) (qword-break nil) (first t) (bol (save-restriction (widen) (point-at-bol)))) (while (not (eobp)) (when (and (or break qword-break) (> (- (point) bol) 76)) (goto-char (or break qword-break)) (setq break nil qword-break nil) (skip-chars-backward " \t") (if (looking-at "[ \t]") (insert ?\n) (insert "\n ")) (setq bol (1- (point))) ;; Don't break before the first non-LWSP characters. (skip-chars-forward " \t") (unless (eobp) (forward-char 1))) (cond ((eq (char-after) ?\n) (forward-char 1) (setq bol (point) break nil qword-break nil) (skip-chars-forward " \t") (unless (or (eobp) (eq (char-after) ?\n)) (forward-char 1))) ((eq (char-after) ?\r) (forward-char 1)) ((memq (char-after) '(? ?\t)) (skip-chars-forward " \t") (unless first ;; Don't break just after the header name. (setq break (point)))) ((not break) (if (not (looking-at "=\\?[^=]")) (if (eq (char-after) ?=) (forward-char 1) (skip-chars-forward "^ \t\n\r=")) ;; Don't break at the start of the field. (unless (= (point) b) (setq qword-break (point))) (skip-chars-forward "^ \t\n\r"))) (t (skip-chars-forward "^ \t\n\r"))) (setq first nil)) (when (and (or break qword-break) (> (- (point) bol) 76)) (goto-char (or break qword-break)) (setq break nil qword-break nil) (if (or (> 0 (skip-chars-backward " \t")) (looking-at "[ \t]")) (insert ?\n) (insert "\n ")) (setq bol (1- (point))) ;; Don't break before the first non-LWSP characters. (skip-chars-forward " \t") (unless (eobp) (forward-char 1)))))) (defun rfc2047-unfold-field () "Fold the current line." (save-excursion (save-restriction (rfc2047-narrow-to-field) (rfc2047-unfold-region (point-min) (point-max))))) (defun rfc2047-unfold-region (b e) "Unfold lines in region B to E." (save-restriction (narrow-to-region b e) (goto-char (point-min)) (let ((bol (save-restriction (widen) (point-at-bol))) (eol (point-at-eol))) (forward-line 1) (while (not (eobp)) (if (and (looking-at "[ \t]") (< (- (point-at-eol) bol) 76)) (delete-region eol (progn (goto-char eol) (skip-chars-forward "\r\n") (point))) (setq bol (point-at-bol))) (setq eol (point-at-eol)) (forward-line 1))))) (defun rfc2047-b-encode-string (string) "Base64-encode the header contained in STRING." (base64-encode-string string t)) (defun rfc2047-q-encode-string (string) "Quoted-printable-encode the header in STRING." (mm-with-unibyte-buffer (insert string) (quoted-printable-encode-region (point-min) (point-max) nil ;; = (\075), _ (\137), ? (\077) are used in the encoded word. ;; Avoid using 8bit characters. ;; This list excludes `especials' (see the RFC2047 syntax), ;; meaning that some characters in non-structured fields will ;; get encoded when they con't need to be. The following is ;; what it used to be. ;;; ;; Equivalent to "^\000-\007\011\013\015-\037\200-\377=_?" ;;; "\010\012\014\040-\074\076\100-\136\140-\177") "-\b\n\f !#-'*+0-9A-Z\\^`-~\d") (subst-char-in-region (point-min) (point-max) ? ?_) (buffer-string))) (defun rfc2047-encode-parameter (param value) "Return and PARAM=VALUE string encoded in the RFC2047-like style. This is a replacement for the `rfc2231-encode-string' function. When attaching files as MIME parts, we should use the RFC2231 encoding to specify the file names containing non-ASCII characters. However, many mail softwares don't support it in practice and recipients won't be able to extract files with correct names. Instead, the RFC2047-like encoding is acceptable generally. This function provides the very RFC2047-like encoding, resigning to such a regrettable trend. To use it, put the following line in your ~/.gnus.el file: \(defalias 'mail-header-encode-parameter 'rfc2047-encode-parameter) " (let ((rfc2047-encoding-type 'mime) (rfc2047-encode-max-chars nil)) (rfc2045-encode-string param (rfc2047-encode-string value)))) ;;; ;;; Functions for decoding RFC2047 messages ;;; (defvar rfc2047-quote-decoded-words-containing-tspecials nil "If non-nil, quote decoded words containing special characters.") (defvar rfc2047-allow-incomplete-encoded-text t "*Non-nil means allow incomplete encoded-text in successive encoded-words. Dividing of encoded-text in the place other than character boundaries violates RFC2047 section 5, while we have a capability to decode it. If it is non-nil, the decoder will decode B- or Q-encoding in each encoded-word, concatenate them, and decode it by charset. Otherwise, the decoder will fully decode each encoded-word before concatenating them.") (defun rfc2047-strip-backslashes-in-quoted-strings () "Strip backslashes in quoted strings. `\\\"' remains." (goto-char (point-min)) (let (beg) (with-syntax-table (standard-syntax-table) (while (search-forward "\"" nil t) (unless (eq (char-before) ?\\) (setq beg (match-end 0)) (goto-char (match-beginning 0)) (condition-case nil (progn (forward-sexp) (save-restriction (narrow-to-region beg (1- (point))) (goto-char beg) (while (search-forward "\\" nil 'move) (unless (memq (char-after) '(?\")) (delete-backward-char 1)) (forward-char))) (forward-char)) (error (goto-char beg)))))))) (defun rfc2047-charset-to-coding-system (charset) "Return coding-system corresponding to MIME CHARSET. If your Emacs implementation can't decode CHARSET, return nil." (when (stringp charset) (setq charset (intern (downcase charset)))) (when (or (not charset) (eq 'gnus-all mail-parse-ignored-charsets) (memq 'gnus-all mail-parse-ignored-charsets) (memq charset mail-parse-ignored-charsets)) (setq charset mail-parse-charset)) (let ((cs (mm-charset-to-coding-system charset))) (cond ((eq cs 'ascii) (setq cs (or (mm-charset-to-coding-system mail-parse-charset) 'raw-text))) ((mm-coding-system-p cs)) ((and charset (listp mail-parse-ignored-charsets) (memq 'gnus-unknown mail-parse-ignored-charsets)) (setq cs (mm-charset-to-coding-system mail-parse-charset)))) (if (eq cs 'ascii) 'raw-text cs))) (defun rfc2047-decode-encoded-words (words) "Decode successive encoded-words in WORDS and return a decoded string. Each element of WORDS looks like (CHARSET ENCODING ENCODED-TEXT ENCODED-WORD)." (let (word charset cs encoding text rest) (while words (setq word (pop words)) (if (and (setq cs (rfc2047-charset-to-coding-system (setq charset (car word)))) (condition-case code (cond ((char-equal ?B (nth 1 word)) (setq text (base64-decode-string (rfc2047-pad-base64 (nth 2 word))))) ((char-equal ?Q (nth 1 word)) (setq text (quoted-printable-decode-string (mm-subst-char-in-string ?_ ? (nth 2 word) t))))) (error (message "%s" (error-message-string code)) nil))) (if (and rfc2047-allow-incomplete-encoded-text (eq cs (caar rest))) ;; Concatenate text of which the charset is the same. (setcdr (car rest) (concat (cdar rest) text)) (push (cons cs text) rest)) ;; Don't decode encoded-word. (push (cons nil (nth 3 word)) rest))) (while rest (setq words (concat (or (and (setq cs (caar rest)) (condition-case code (mm-decode-coding-string (cdar rest) cs) (error (message "%s" (error-message-string code)) nil))) (concat (when (cdr rest) " ") (cdar rest) (when (and words (not (eq (string-to-char words) ? ))) " "))) words) rest (cdr rest))) words)) ;; Fixme: This should decode in place, not cons intermediate strings. ;; Also check whether it needs to worry about delimiting fields like ;; encoding. ;; In fact it's reported that (invalid) encoding of mailboxes in ;; addr-specs is in use, so delimiting fields might help. Probably ;; not decoding a word which isn't properly delimited is good enough ;; and worthwhile (is it more correct or not?), e.g. something like ;; `=?iso-8859-1?q?foo?=@'. (defun rfc2047-decode-region (start end &optional address-mime) "Decode MIME-encoded words in region between START and END. If ADDRESS-MIME is non-nil, strip backslashes which precede characters other than `\"' and `\\' in quoted strings." (interactive "r") (let ((case-fold-search t) (eword-regexp (if rfc2047-allow-irregular-q-encoded-words (eval-when-compile (concat "[\n\t ]*\\(" rfc2047-encoded-word-regexp-loose "\\)")) (eval-when-compile (concat "[\n\t ]*\\(" rfc2047-encoded-word-regexp "\\)")))) b e match words) (save-excursion (save-restriction (narrow-to-region start end) (when address-mime (rfc2047-strip-backslashes-in-quoted-strings)) (goto-char (setq b start)) ;; Look for the encoded-words. (while (setq match (re-search-forward eword-regexp nil t)) (setq e (match-beginning 1) end (match-end 0) words nil) (while match (push (list (match-string 2) ;; charset (char-after (match-beginning 3)) ;; encoding (substring (match-string 3) 2) ;; encoded-text (match-string 1)) ;; encoded-word words) ;; Look for the subsequent encoded-words. (when (setq match (looking-at eword-regexp)) (goto-char (setq end (match-end 0))))) ;; Replace the encoded-words with the decoded one. (delete-region e end) (insert (rfc2047-decode-encoded-words (nreverse words))) (save-restriction (narrow-to-region e (point)) (goto-char e) ;; Remove newlines between decoded words, though such ;; things essentially must not be there. (while (re-search-forward "[\n\r]+" nil t) (replace-match " ")) ;; Quote decoded words if there are special characters ;; which might violate RFC2822. (when (and rfc2047-quote-decoded-words-containing-tspecials (let ((regexp (car (rassq 'address-mime rfc2047-header-encoding-alist)))) (when regexp (save-restriction (widen) (beginning-of-line) (while (and (memq (char-after) '(? ?\t)) (zerop (forward-line -1)))) (looking-at regexp))))) (let (quoted) (goto-char e) (skip-chars-forward " \t") (setq start (point)) (setq quoted (eq (char-after) ?\")) (goto-char (point-max)) (skip-chars-backward " \t") (if (setq quoted (and quoted (> (point) (1+ start)) (eq (char-before) ?\"))) (progn (backward-char) (setq start (1+ start) end (point-marker))) (setq end (point-marker))) (goto-char start) (while (search-forward "\"" end t) (when (prog2 (backward-char) (zerop (% (skip-chars-backward "\\\\") 2)) (goto-char (match-beginning 0))) (insert "\\")) (forward-char)) (when (and (not quoted) (progn (goto-char start) (re-search-forward (concat "[" ietf-drums-tspecials "]") end t))) (goto-char start) (insert "\"") (goto-char end) (insert "\"")) (set-marker end nil))) (goto-char (point-max))) (when (and (mm-multibyte-p) mail-parse-charset (not (eq mail-parse-charset 'us-ascii)) (not (eq mail-parse-charset 'gnus-decoded))) (mm-decode-coding-region b e mail-parse-charset)) (setq b (point))) (when (and (mm-multibyte-p) mail-parse-charset (not (eq mail-parse-charset 'us-ascii)) (not (eq mail-parse-charset 'gnus-decoded))) (mm-decode-coding-region b (point-max) mail-parse-charset)))))) (defun rfc2047-decode-address-region (start end) "Decode MIME-encoded words in region between START and END. Backslashes which precede characters other than `\"' and `\\' in quoted strings are stripped." (rfc2047-decode-region start end t)) (defun rfc2047-decode-string (string &optional address-mime) "Decode MIME-encoded STRING and return the result. If ADDRESS-MIME is non-nil, strip backslashes which precede characters other than `\"' and `\\' in quoted strings." ;; (let ((m (mm-multibyte-p))) (if (string-match "=\\?" string) (with-temp-buffer ;; We used to only call mm-enable-multibyte if `m' is non-nil, ;; but this can't be the right criterion. Don't just revert this ;; change if it encounters a bug. Please help me fix it ;; right instead. --Stef ;; The string returned should always be multibyte in a multibyte ;; session, i.e. the buffer should be multibyte before ;; `buffer-string' is called. (mm-enable-multibyte) (insert string) (inline (rfc2047-decode-region (point-min) (point-max) address-mime)) (buffer-string)) (when address-mime (setq string (with-temp-buffer (when (mm-multibyte-string-p string) (mm-enable-multibyte)) (insert string) (rfc2047-strip-backslashes-in-quoted-strings) (buffer-string)))) ;; Fixme: As above, `m' here is inappropriate. (if (and ;; m mail-parse-charset (not (eq mail-parse-charset 'us-ascii)) (not (eq mail-parse-charset 'gnus-decoded))) ;; `decode-coding-string' in Emacs offers a third optional ;; arg NOCOPY to avoid consing a new string if the decoding ;; is "trivial". Unfortunately it currently doesn't ;; consider anything else than a `nil' coding system ;; trivial. ;; `rfc2047-decode-string' is called multiple times for each ;; article during summary buffer generation, and we really ;; want to avoid unnecessary consing. So we bypass ;; `decode-coding-string' if the string is purely ASCII. (if (and (fboundp 'detect-coding-string) ;; string is purely ASCII (eq (detect-coding-string string t) 'undecided)) string (mm-decode-coding-string string mail-parse-charset)) (mm-string-to-multibyte string)))) ;; ) (defun rfc2047-decode-address-string (string) "Decode MIME-encoded STRING and return the result. Backslashes which precede characters other than `\"' and `\\' in quoted strings are stripped." (rfc2047-decode-string string t)) (defun rfc2047-pad-base64 (string) "Pad STRING to quartets." ;; Be more liberal to accept buggy base64 strings. If ;; base64-decode-string accepts buggy strings, this function could ;; be aliased to identity. (if (= 0 (mod (length string) 4)) string (when (string-match "=+$" string) (setq string (substring string 0 (match-beginning 0)))) (case (mod (length string) 4) (0 string) (1 string) ;; Error, don't pad it. (2 (concat string "==")) (3 (concat string "="))))) (provide 'rfc2047) ;; arch-tag: a07fe3d4-22b5-4c4a-bd89-b1f82d5d36f6 ;;; rfc2047.el ends here gnus-5.11+v0.10.dfsg/lisp/nnweb.el0000644000175000017500000004544311004005111016667 0ustar tvainikatvainika;;; nnweb.el --- retrieving articles via web search engines ;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, ;; 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; Keywords: news ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 3, or (at your option) ;; any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Commentary: ;; Note: You need to have `w3' installed for some functions to work. ;;; Code: (eval-when-compile (require 'cl)) (require 'nnoo) (require 'message) (require 'gnus-util) (require 'gnus) (require 'nnmail) (require 'mm-util) (require 'mm-url) (eval-and-compile (ignore-errors (require 'url))) (autoload 'w3-parse-buffer "w3-parse") (nnoo-declare nnweb) (defvoo nnweb-directory (nnheader-concat gnus-directory "nnweb/") "Where nnweb will save its files.") (defvoo nnweb-type 'google "What search engine type is being used. Valid types include `google', `dejanews', and `gmane'.") (defvar nnweb-type-definition '((google (id . "http://www.google.com/groups?as_umsgid=%s&hl=en&dmode=source") (result . "http://groups.google.com/group/%s/msg/%s?dmode=source") (article . nnweb-google-wash-article) (reference . identity) (map . nnweb-google-create-mapping) (search . nnweb-google-search) (address . "http://groups.google.com/groups") (base . "http://groups.google.com") (identifier . nnweb-google-identity)) (dejanews ;; alias of google (id . "http://www.google.com/groups?as_umsgid=%s&hl=en&dmode=source") (result . "http://groups.google.com/group/%s/msg/%s?dmode=source") (article . nnweb-google-wash-article) (reference . identity) (map . nnweb-google-create-mapping) (search . nnweb-google-search) (address . "http://groups.google.com/groups") (base . "http://groups.google.com") (identifier . nnweb-google-identity)) (gmane (article . nnweb-gmane-wash-article) (id . "http://gmane.org/view.php?group=%s") (reference . identity) (map . nnweb-gmane-create-mapping) (search . nnweb-gmane-search) (address . "http://search.gmane.org/nov.php") (identifier . nnweb-gmane-identity))) "Type-definition alist.") (defvoo nnweb-search nil "Search string to feed to Google.") (defvoo nnweb-max-hits 999 "Maximum number of hits to display.") (defvoo nnweb-ephemeral-p nil "Whether this nnweb server is ephemeral.") ;;; Internal variables (defvoo nnweb-articles nil) (defvoo nnweb-buffer nil) (defvoo nnweb-group-alist nil) (defvoo nnweb-group nil) (defvoo nnweb-hashtb nil) ;;; Interface functions (nnoo-define-basics nnweb) (deffoo nnweb-retrieve-headers (articles &optional group server fetch-old) (nnweb-possibly-change-server group server) (save-excursion (set-buffer nntp-server-buffer) (erase-buffer) (let (article header) (mm-with-unibyte-current-buffer (while (setq article (pop articles)) (when (setq header (cadr (assq article nnweb-articles))) (nnheader-insert-nov header)))) 'nov))) (deffoo nnweb-request-scan (&optional group server) (nnweb-possibly-change-server group server) (if nnweb-ephemeral-p (setq nnweb-hashtb (gnus-make-hashtable 4095)) (unless nnweb-articles (nnweb-read-overview group))) (funcall (nnweb-definition 'map)) (unless nnweb-ephemeral-p (nnweb-write-active) (nnweb-write-overview group))) (deffoo nnweb-request-group (group &optional server dont-check) (nnweb-possibly-change-server group server) (unless (or nnweb-ephemeral-p dont-check nnweb-articles) (nnweb-read-overview group)) (cond ((not nnweb-articles) (nnheader-report 'nnweb "No matching articles")) (t (let ((active (if nnweb-ephemeral-p (cons (caar nnweb-articles) (caar (last nnweb-articles))) (cadr (assoc group nnweb-group-alist))))) (nnheader-report 'nnweb "Opened group %s" group) (nnheader-insert "211 %d %d %d %s\n" (length nnweb-articles) (car active) (cdr active) group))))) (deffoo nnweb-close-group (group &optional server) (nnweb-possibly-change-server group server) (when (gnus-buffer-live-p nnweb-buffer) (save-excursion (set-buffer nnweb-buffer) (set-buffer-modified-p nil) (kill-buffer nnweb-buffer))) t) (deffoo nnweb-request-article (article &optional group server buffer) (nnweb-possibly-change-server group server) (save-excursion (set-buffer (or buffer nntp-server-buffer)) (let* ((header (cadr (assq article nnweb-articles))) (url (and header (mail-header-xref header)))) (when (or (and url (mm-with-unibyte-current-buffer (mm-url-insert url))) (and (stringp article) (nnweb-definition 'id t) (let ((fetch (nnweb-definition 'id)) art active) (when (string-match "^<\\(.*\\)>$" article) (setq art (match-string 1 article))) (when (and fetch art) (setq url (format fetch (mm-url-form-encode-xwfu art))) (mm-with-unibyte-current-buffer (mm-url-insert url)) (if (nnweb-definition 'reference t) (setq article (funcall (nnweb-definition 'reference) article))))))) (unless nnheader-callback-function (funcall (nnweb-definition 'article))) (nnheader-report 'nnweb "Fetched article %s" article) (cons group (and (numberp article) article)))))) (deffoo nnweb-close-server (&optional server) (when (and (nnweb-server-opened server) (gnus-buffer-live-p nnweb-buffer)) (save-excursion (set-buffer nnweb-buffer) (set-buffer-modified-p nil) (kill-buffer nnweb-buffer))) (nnoo-close-server 'nnweb server)) (deffoo nnweb-request-list (&optional server) (nnweb-possibly-change-server nil server) (save-excursion (set-buffer nntp-server-buffer) (nnmail-generate-active (list (assoc server nnweb-group-alist))) t)) (deffoo nnweb-request-update-info (group info &optional server) (nnweb-possibly-change-server group server)) (deffoo nnweb-asynchronous-p () nil) (deffoo nnweb-request-create-group (group &optional server args) (nnweb-possibly-change-server nil server) (nnweb-request-delete-group group) (push `(,group ,(cons 1 0)) nnweb-group-alist) (nnweb-write-active) t) (deffoo nnweb-request-delete-group (group &optional force server) (nnweb-possibly-change-server group server) (gnus-pull group nnweb-group-alist t) (nnweb-write-active) (gnus-delete-file (nnweb-overview-file group)) t) (nnoo-define-skeleton nnweb) ;;; Internal functions (defun nnweb-read-overview (group) "Read the overview of GROUP and build the map." (when (file-exists-p (nnweb-overview-file group)) (mm-with-unibyte-buffer (nnheader-insert-file-contents (nnweb-overview-file group)) (goto-char (point-min)) (let (header) (while (not (eobp)) (setq header (nnheader-parse-nov)) (forward-line 1) (push (list (mail-header-number header) header (mail-header-xref header)) nnweb-articles) (nnweb-set-hashtb header (car nnweb-articles))))))) (defun nnweb-write-overview (group) "Write the overview file for GROUP." (with-temp-file (nnweb-overview-file group) (let ((articles nnweb-articles)) (while articles (nnheader-insert-nov (cadr (pop articles))))))) (defun nnweb-set-hashtb (header data) (gnus-sethash (nnweb-identifier (mail-header-xref header)) data nnweb-hashtb)) (defun nnweb-get-hashtb (url) (gnus-gethash (nnweb-identifier url) nnweb-hashtb)) (defun nnweb-identifier (ident) (funcall (nnweb-definition 'identifier) ident)) (defun nnweb-overview-file (group) "Return the name of the overview file of GROUP." (nnheader-concat nnweb-directory group ".overview")) (defun nnweb-write-active () "Save the active file." (gnus-make-directory nnweb-directory) (with-temp-file (nnheader-concat nnweb-directory "active") (prin1 `(setq nnweb-group-alist ',nnweb-group-alist) (current-buffer)))) (defun nnweb-read-active () "Read the active file." (load (nnheader-concat nnweb-directory "active") t t t)) (defun nnweb-definition (type &optional noerror) "Return the definition of TYPE." (let ((def (cdr (assq type (assq nnweb-type nnweb-type-definition))))) (when (and (not def) (not noerror)) (error "Undefined definition %s" type)) def)) (defun nnweb-possibly-change-server (&optional group server) (when server (unless (nnweb-server-opened server) (nnweb-open-server server)) (nnweb-init server)) (unless nnweb-group-alist (nnweb-read-active)) (unless nnweb-hashtb (setq nnweb-hashtb (gnus-make-hashtable 4095))) (when group (setq nnweb-group group))) (defun nnweb-init (server) "Initialize buffers and such." (unless (gnus-buffer-live-p nnweb-buffer) (setq nnweb-buffer (save-current-buffer (nnheader-set-temp-buffer (format " *nnweb %s %s %s*" nnweb-type nnweb-search server)) (mm-disable-multibyte) (current-buffer))))) ;;; ;;; groups.google.com ;;; (defun nnweb-google-wash-article () ;; We have Google's masked e-mail addresses here. :-/ (let ((case-fold-search t) (start-re "
    [\r\n ]*")
	(end-re "[\r\n ]*
    ")) (goto-char (point-min)) (if (save-excursion (or (re-search-forward "The requested message.*could not be found." nil t) (not (and (re-search-forward start-re nil t) (re-search-forward end-re nil t))))) ;; FIXME: Don't know how to indicate "not found". ;; Should this function throw an error? --rsteib (progn (gnus-message 3 "Requested article not found") (erase-buffer)) (delete-region (point-min) (re-search-forward start-re)) (goto-char (point-min)) (delete-region (progn (re-search-forward end-re) (match-beginning 0)) (point-max)) (mm-url-decode-entities)))) (defun nnweb-google-parse-1 (&optional Message-ID) "Parse search result in current buffer." (let ((i 0) (case-fold-search t) (active (cadr (assoc nnweb-group nnweb-group-alist))) Subject Score Date Newsgroups From map url mid) (unless active (push (list nnweb-group (setq active (cons 1 0))) nnweb-group-alist)) ;; Go through all the article hits on this page. (goto-char (point-min)) (while (re-search-forward "a +href=\"/group/\\([^>\"]+\\)/browse_thread/[^>]+#\\([0-9a-f]+\\)" nil t) (setq Newsgroups (match-string-no-properties 1) ;; Note: Starting with Google Groups 2, `mid' is a Google-internal ;; ID, not a proper Message-ID. mid (match-string-no-properties 2) url (format (nnweb-definition 'result) Newsgroups mid)) (narrow-to-region (search-forward ">" nil t) (search-forward "" nil t)) (mm-url-remove-markup) (mm-url-decode-entities) (setq Subject (buffer-string)) (goto-char (point-max)) (widen) (narrow-to-region (point) (search-forward "]+href=\"\n?\\([^>\" \n\t]+\\)[^<]*]+src=[^>]+next" nil t)) (>= i nnweb-max-hits)) (setq more nil) ;; Yup, there are more articles (setq more (concat (nnweb-definition 'base) (match-string 1))) (when more (erase-buffer) (nnheader-message 7 "Searching google...(%d)" i) (mm-url-insert more)))) ;; Return the articles in the right order. (nnheader-message 7 "Searching google...done") (setq nnweb-articles (sort nnweb-articles 'car-less-than-car)))))) (defun nnweb-google-search (search) (mm-url-insert (concat (nnweb-definition 'address) "?" (mm-url-encode-www-form-urlencoded `(("q" . ,search) ("num" . ,(number-to-string (min 100 nnweb-max-hits))) ("hq" . "") ("hl" . "en") ("lr" . "") ("safe" . "off") ("sites" . "groups") ("filter" . "0"))))) t) (defun nnweb-google-identity (url) "Return an unique identifier based on URL." (if (string-match "selm=\\([^ &>]+\\)" url) (match-string 1 url) url)) ;;; ;;; gmane.org ;;; (defun nnweb-gmane-create-mapping () "Perform the search and create a number-to-url alist." (save-excursion (set-buffer nnweb-buffer) (let ((case-fold-search t) (active (or (cadr (assoc nnweb-group nnweb-group-alist)) (cons 1 0))) map) (erase-buffer) (nnheader-message 7 "Searching Gmane..." ) (when (funcall (nnweb-definition 'search) nnweb-search) (goto-char (point-min)) ;; Skip the status line (forward-line 1) ;; Thanks to Olly Betts we now have NOV lines in our buffer! (while (not (eobp)) (unless (or (eolp) (looking-at "\x0d")) (let ((header (nnheader-parse-nov))) (let ((xref (mail-header-xref header)) (from (mail-header-from header)) (subject (mail-header-subject header)) (rfc2047-encoding-type 'mime)) (when (string-match " \\([^:]+\\)[:/]\\([0-9]+\\)" xref) (mail-header-set-xref header (format "http://article.gmane.org/%s/%s/raw" (match-string 1 xref) (match-string 2 xref)))) ;; Add host part to gmane-encrypted addresses (when (string-match "@$" from) (mail-header-set-from header (concat from "public.gmane.org"))) (mail-header-set-subject header (rfc2047-encode-string subject)) (unless (nnweb-get-hashtb (mail-header-xref header)) (mail-header-set-number header (incf (cdr active))) (push (list (mail-header-number header) header) map) (nnweb-set-hashtb (cadar map) (car map)))))) (forward-line 1))) (nnheader-message 7 "Searching Gmane...done") (setq nnweb-articles (sort (nconc nnweb-articles map) 'car-less-than-car))))) (defun nnweb-gmane-wash-article () (let ((case-fold-search t)) (goto-char (point-min)) (when (search-forward "" nil t) (delete-region (point-min) (point)) (goto-char (point-min)) (while (looking-at "^
  • \\([^ ]+\\).*
    • ") (replace-match "\\1\\2" t) (forward-line 1)) (mm-url-remove-markup)))) (defun nnweb-gmane-search (search) (mm-url-insert (concat (nnweb-definition 'address) "?" (mm-url-encode-www-form-urlencoded `(("query" . ,search) ("HITSPERPAGE" . ,(number-to-string nnweb-max-hits)) ;;("TOPDOC" . "1000") )))) (setq buffer-file-name nil) (set-buffer-multibyte t) (mm-decode-coding-region (point-min) (point-max) 'utf-8) t) (defun nnweb-gmane-identity (url) "Return a unique identifier based on URL." (if (string-match "group=\\(.+\\)" url) (match-string 1 url) url)) ;;; ;;; General web/w3 interface utility functions ;;; (defun nnweb-insert-html (parse) "Insert HTML based on a w3 parse tree." (if (stringp parse) ;; We used to call nnheader-string-as-multibyte here, but it cannot ;; be right, so I removed it. If a bug shows up because of this change, ;; please do not blindly revert the change, but help me find the real ;; cause of the bug instead. --Stef (insert parse) (insert "<" (symbol-name (car parse)) " ") (insert (mapconcat (lambda (param) (concat (symbol-name (car param)) "=" (prin1-to-string (if (consp (cdr param)) (cadr param) (cdr param))))) (nth 1 parse) " ")) (insert ">\n") (mapc 'nnweb-insert-html (nth 2 parse)) (insert "\n"))) (defun nnweb-parse-find (type parse &optional maxdepth) "Find the element of TYPE in PARSE." (catch 'found (nnweb-parse-find-1 type parse maxdepth))) (defun nnweb-parse-find-1 (type contents maxdepth) (when (or (null maxdepth) (not (zerop maxdepth))) (when (consp contents) (when (eq (car contents) type) (throw 'found contents)) (when (listp (cdr contents)) (dolist (element contents) (when (consp element) (nnweb-parse-find-1 type element (and maxdepth (1- maxdepth))))))))) (defun nnweb-parse-find-all (type parse) "Find all elements of TYPE in PARSE." (catch 'found (nnweb-parse-find-all-1 type parse))) (defun nnweb-parse-find-all-1 (type contents) (let (result) (when (consp contents) (if (eq (car contents) type) (push contents result) (when (listp (cdr contents)) (dolist (element contents) (when (consp element) (setq result (nconc result (nnweb-parse-find-all-1 type element)))))))) result)) (defvar nnweb-text) (defun nnweb-text (parse) "Return a list of text contents in PARSE." (let ((nnweb-text nil)) (nnweb-text-1 parse) (nreverse nnweb-text))) (defun nnweb-text-1 (contents) (dolist (element contents) (if (stringp element) (push element nnweb-text) (when (and (consp element) (listp (cdr element))) (nnweb-text-1 element))))) (provide 'nnweb) ;; arch-tag: f59307eb-c90f-479f-b7d2-dbd8bf51b697 ;;; nnweb.el ends here gnus-5.11+v0.10.dfsg/lisp/nndir.el0000644000175000017500000000625511004005111016666 0ustar tvainikatvainika;;; nndir.el --- single directory newsgroup access for Gnus ;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, ;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; Keywords: news ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 3, or (at your option) ;; any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Commentary: ;;; Code: (require 'nnheader) (require 'nnmh) (require 'nnml) (require 'nnoo) (eval-when-compile (require 'cl)) (nnoo-declare nndir nnml nnmh) (defvoo nndir-directory nil "Where nndir will look for groups." nnml-current-directory nnmh-current-directory) (defvoo nndir-nov-is-evil nil "*Non-nil means that nndir will never retrieve NOV headers." nnml-nov-is-evil) (defvoo nndir-current-group "" nil nnml-current-group nnmh-current-group) (defvoo nndir-top-directory nil nil nnml-directory nnmh-directory) (defvoo nndir-get-new-mail nil nil nnml-get-new-mail nnmh-get-new-mail) (defvoo nndir-status-string "" nil nnmh-status-string) (defconst nndir-version "nndir 1.0") ;;; Interface functions. (nnoo-define-basics nndir) (deffoo nndir-open-server (server &optional defs) (setq nndir-directory (or (cadr (assq 'nndir-directory defs)) server)) (unless (assq 'nndir-directory defs) (push `(nndir-directory ,server) defs)) (push `(nndir-current-group ,(file-name-nondirectory (directory-file-name nndir-directory))) defs) (push `(nndir-top-directory ,(file-name-directory (directory-file-name nndir-directory))) defs) (nnoo-change-server 'nndir server defs) (let (err) (cond ((not (condition-case arg (file-exists-p nndir-directory) (ftp-error (setq err (format "%s" arg))))) (nndir-close-server) (nnheader-report 'nndir (or err "No such file or directory: %s" nndir-directory))) ((not (file-directory-p (file-truename nndir-directory))) (nndir-close-server) (nnheader-report 'nndir "Not a directory: %s" nndir-directory)) (t (nnheader-report 'nndir "Opened server %s using directory %s" server nndir-directory) t)))) (nnoo-map-functions nndir (nnml-retrieve-headers 0 nndir-current-group 0 0) (nnml-request-article 0 nndir-current-group 0 0) (nnmh-request-group nndir-current-group 0 0) (nnml-close-group nndir-current-group 0) (nnml-request-list (nnoo-current-server 'nndir) nndir-directory) (nnml-request-newsgroups (nnoo-current-server 'nndir) nndir-directory)) (provide 'nndir) ;; arch-tag: 56f09f68-0e4e-4816-818a-df80b4a394c8 ;;; nndir.el ends here gnus-5.11+v0.10.dfsg/lisp/mm-util.el0000644000175000017500000015714411004005110017143 0ustar tvainikatvainika;;; mm-util.el --- Utility functions for Mule and low level things ;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, ;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; MORIOKA Tomohiko ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 3, or (at your option) ;; any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Commentary: ;;; Code: ;; For Emacs < 22.2. (eval-and-compile (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) (eval-when-compile (require 'cl)) (require 'mail-prsvr) (eval-and-compile (if (featurep 'xemacs) (unless (ignore-errors (require 'timer-funcs)) (require 'timer)) (require 'timer))) (defvar mm-mime-mule-charset-alist ) (eval-and-compile (mapc (lambda (elem) (let ((nfunc (intern (format "mm-%s" (car elem))))) (if (fboundp (car elem)) (defalias nfunc (car elem)) (defalias nfunc (cdr elem))))) '((coding-system-list . ignore) (char-int . identity) (coding-system-equal . equal) (annotationp . ignore) (set-buffer-file-coding-system . ignore) (read-charset . (lambda (prompt) "Return a charset." (intern (completing-read prompt (mapcar (lambda (e) (list (symbol-name (car e)))) mm-mime-mule-charset-alist) nil t)))) (subst-char-in-string . (lambda (from to string &optional inplace) ;; stolen (and renamed) from nnheader.el "Replace characters in STRING from FROM to TO. Unless optional argument INPLACE is non-nil, return a new string." (let ((string (if inplace string (copy-sequence string))) (len (length string)) (idx 0)) ;; Replace all occurrences of FROM with TO. (while (< idx len) (when (= (aref string idx) from) (aset string idx to)) (setq idx (1+ idx))) string))) (replace-in-string . (lambda (string regexp rep &optional literal) "See `replace-regexp-in-string', only the order of args differs." (replace-regexp-in-string regexp rep string nil literal))) (string-as-unibyte . identity) (string-make-unibyte . identity) ;; string-as-multibyte often doesn't really do what you think it does. ;; Example: ;; (aref (string-as-multibyte "\201") 0) -> 129 (aka ?\201) ;; (aref (string-as-multibyte "\300") 0) -> 192 (aka ?\300) ;; (aref (string-as-multibyte "\300\201") 0) -> 192 (aka ?\300) ;; (aref (string-as-multibyte "\300\201") 1) -> 129 (aka ?\201) ;; but ;; (aref (string-as-multibyte "\201\300") 0) -> 2240 ;; (aref (string-as-multibyte "\201\300") 1) -> ;; Better use string-to-multibyte or encode-coding-string. ;; If you really need string-as-multibyte somewhere it's usually ;; because you're using the internal emacs-mule representation (maybe ;; because you're using string-as-unibyte somewhere), which is ;; generally a problem in itself. ;; Here is an approximate equivalence table to help think about it: ;; (string-as-multibyte s) ~= (decode-coding-string s 'emacs-mule) ;; (string-to-multibyte s) ~= (decode-coding-string s 'binary) ;; (string-make-multibyte s) ~= (decode-coding-string s locale-coding-system) (string-as-multibyte . identity) (multibyte-string-p . ignore) (insert-byte . insert-char) (multibyte-char-to-unibyte . identity) (set-buffer-multibyte . ignore) (special-display-p . (lambda (buffer-name) "Returns non-nil if a buffer named BUFFER-NAME gets a special frame." (and special-display-function (or (and (member buffer-name special-display-buffer-names) t) (cdr (assoc buffer-name special-display-buffer-names)) (catch 'return (dolist (elem special-display-regexps) (and (stringp elem) (string-match elem buffer-name) (throw 'return t)) (and (consp elem) (stringp (car elem)) (string-match (car elem) buffer-name) (throw 'return (cdr elem)))))))))))) (eval-and-compile (if (featurep 'xemacs) (if (featurep 'file-coding) ;; Don't modify string if CODING-SYSTEM is nil. (progn (defun mm-decode-coding-string (str coding-system) (if coding-system (decode-coding-string str coding-system) str)) (defun mm-encode-coding-string (str coding-system) (if coding-system (encode-coding-string str coding-system) str)) (defun mm-decode-coding-region (start end coding-system) (if coding-system (decode-coding-region start end coding-system))) (defun mm-encode-coding-region (start end coding-system) (if coding-system (encode-coding-region start end coding-system)))) (defun mm-decode-coding-string (str coding-system) str) (defun mm-encode-coding-string (str coding-system) str) (defalias 'mm-decode-coding-region 'ignore) (defalias 'mm-encode-coding-region 'ignore)) (defalias 'mm-decode-coding-string 'decode-coding-string) (defalias 'mm-encode-coding-string 'encode-coding-string) (defalias 'mm-decode-coding-region 'decode-coding-region) (defalias 'mm-encode-coding-region 'encode-coding-region))) (defalias 'mm-string-to-multibyte (cond ((featurep 'xemacs) 'identity) ((fboundp 'string-to-multibyte) 'string-to-multibyte) (t (lambda (string) "Return a multibyte string with the same individual chars as string." (mapconcat (lambda (ch) (mm-string-as-multibyte (char-to-string ch))) string ""))))) (eval-and-compile (defalias 'mm-char-or-char-int-p (cond ((fboundp 'char-or-char-int-p) 'char-or-char-int-p) ((fboundp 'char-valid-p) 'char-valid-p) (t 'identity)))) ;; Fixme: This seems always to be used to read a MIME charset, so it ;; should be re-named and fixed (in Emacs) to offer completion only on ;; proper charset names (base coding systems which have a ;; mime-charset defined). XEmacs doesn't believe in mime-charset; ;; test with ;; `(or (coding-system-get 'iso-8859-1 'mime-charset) ;; (coding-system-get 'iso-8859-1 :mime-charset))' ;; Actually, there should be an `mm-coding-system-mime-charset'. (eval-and-compile (defalias 'mm-read-coding-system (cond ((fboundp 'read-coding-system) (if (and (featurep 'xemacs) (<= (string-to-number emacs-version) 21.1)) (lambda (prompt &optional default-coding-system) (read-coding-system prompt)) 'read-coding-system)) (t (lambda (prompt &optional default-coding-system) "Prompt the user for a coding system." (completing-read prompt (mapcar (lambda (s) (list (symbol-name (car s)))) mm-mime-mule-charset-alist))))))) (defvar mm-coding-system-list nil) (defun mm-get-coding-system-list () "Get the coding system list." (or mm-coding-system-list (setq mm-coding-system-list (mm-coding-system-list)))) (defun mm-coding-system-p (cs) "Return non-nil if CS is a symbol naming a coding system. In XEmacs, also return non-nil if CS is a coding system object. If CS is available, return CS itself in Emacs, and return a coding system object in XEmacs." (if (fboundp 'find-coding-system) (and cs (find-coding-system cs)) (if (fboundp 'coding-system-p) (when (coding-system-p cs) cs) ;; no-MULE XEmacs: (car (memq cs (mm-get-coding-system-list)))))) (defun mm-codepage-setup (number &optional alias) "Create a coding system cpNUMBER. The coding system is created using `codepage-setup'. If ALIAS is non-nil, an alias is created and added to `mm-charset-synonym-alist'. If ALIAS is a string, it's used as the alias. Else windows-NUMBER is used." (interactive (let ((completion-ignore-case t) (candidates (if (fboundp 'cp-supported-codepages) (cp-supported-codepages) ;; Removed in Emacs 23 (unicode), sosignal an error: (error "`codepage-setup' is obsolete in this Emacs version.")))) (list (completing-read "Setup DOS Codepage: (default 437) " candidates nil t nil nil "437")))) (when alias (setq alias (if (stringp alias) (intern alias) (intern (format "windows-%s" number))))) (let* ((cp (intern (format "cp%s" number)))) (unless (mm-coding-system-p cp) (codepage-setup number)) (when (and alias ;; Don't add alias if setup of cp failed. (mm-coding-system-p cp)) (add-to-list 'mm-charset-synonym-alist (cons alias cp))))) (defvar mm-charset-synonym-alist `( ;; Not in XEmacs, but it's not a proper MIME charset anyhow. ,@(unless (mm-coding-system-p 'x-ctext) '((x-ctext . ctext))) ;; ISO-8859-15 is very similar to ISO-8859-1. But it's _different_ in 8 ;; positions! ,@(unless (mm-coding-system-p 'iso-8859-15) '((iso-8859-15 . iso-8859-1))) ;; BIG-5HKSCS is similar to, but different than, BIG-5. ,@(unless (mm-coding-system-p 'big5-hkscs) '((big5-hkscs . big5))) ;; A Microsoft misunderstanding. ,@(when (and (not (mm-coding-system-p 'unicode)) (mm-coding-system-p 'utf-16-le)) '((unicode . utf-16-le))) ;; A Microsoft misunderstanding. ,@(unless (mm-coding-system-p 'ks_c_5601-1987) (if (mm-coding-system-p 'cp949) '((ks_c_5601-1987 . cp949)) '((ks_c_5601-1987 . euc-kr)))) ;; Windows-31J is Windows Codepage 932. ,@(when (and (not (mm-coding-system-p 'windows-31j)) (mm-coding-system-p 'cp932)) '((windows-31j . cp932))) ;; Charset name: GBK, Charset aliases: CP936, MS936, windows-936 ;; http://www.iana.org/assignments/charset-reg/GBK ;; Emacs 22.1 has cp936, but not gbk, so we alias it: ,@(when (and (not (mm-coding-system-p 'gbk)) (mm-coding-system-p 'cp936)) '((gbk . cp936))) ;; ISO8859-1 is a bogus name for ISO-8859-1 ,@(when (and (not (mm-coding-system-p 'iso8859-1)) (mm-coding-system-p 'iso-8859-1)) '((iso8859-1 . iso-8859-1))) ) "A mapping from unknown or invalid charset names to the real charset names. See `mm-codepage-iso-8859-list' and `mm-codepage-ibm-list'.") (defcustom mm-codepage-iso-8859-list (list 1250 ;; Windows-1250 is a variant of Latin-2 heavily used by Microsoft ;; Outlook users in Czech republic. Use this to allow reading of ;; their e-mails. cp1250 should be defined by M-x codepage-setup ;; (Emacs 21). '(1252 . 1) ;; Windows-1252 is a superset of iso-8859-1 (West ;; Europe). See also `gnus-article-dumbquotes-map'. '(1254 . 9) ;; Windows-1254 is a superset of iso-8859-9 (Turkish). '(1255 . 8));; Windows-1255 is a superset of iso-8859-8 (Hebrew). "A list of Windows codepage numbers and iso-8859 charset numbers. If an element is a number corresponding to a supported windows codepage, appropriate entries to `mm-charset-synonym-alist' are added by `mm-setup-codepage-iso-8859'. An element may also be a cons cell where the car is a codepage number and the cdr is the corresponding number of an iso-8859 charset." :type '(list (set :inline t (const 1250 :tag "Central and East European") (const (1252 . 1) :tag "West European") (const (1254 . 9) :tag "Turkish") (const (1255 . 8) :tag "Hebrew")) (repeat :inline t :tag "Other options" (choice (integer :tag "Windows codepage number") (cons (integer :tag "Windows codepage number") (integer :tag "iso-8859 charset number"))))) :version "22.1" ;; Gnus 5.10.9 :group 'mime) (defcustom mm-codepage-ibm-list (list 437 ;; (US etc.) 860 ;; (Portugal) 861 ;; (Iceland) 862 ;; (Israel) 863 ;; (Canadian French) 865 ;; (Nordic) 852 ;; 850 ;; (Latin 1) 855 ;; (Cyrillic) 866 ;; (Cyrillic - Russian) 857 ;; (Turkish) 864 ;; (Arabic) 869 ;; (Greek) 874);; (Thai) ;; In Emacs 23 (unicode), cp... and ibm... are aliases. ;; Cf. http://thread.gmane.org/v9lkng5nwy.fsf@marauder.physik.uni-ulm.de "List of IBM codepage numbers. The codepage mappings slighly differ between IBM and other vendors. See \"ftp://ftp.unicode.org/Public/MAPPINGS/VENDORS/IBM/README.TXT\". If an element is a number corresponding to a supported windows codepage, appropriate entries to `mm-charset-synonym-alist' are added by `mm-setup-codepage-ibm'." :type '(list (set :inline t (const 437 :tag "US etc.") (const 860 :tag "Portugal") (const 861 :tag "Iceland") (const 862 :tag "Israel") (const 863 :tag "Canadian French") (const 865 :tag "Nordic") (const 852) (const 850 :tag "Latin 1") (const 855 :tag "Cyrillic") (const 866 :tag "Cyrillic - Russian") (const 857 :tag "Turkish") (const 864 :tag "Arabic") (const 869 :tag "Greek") (const 874 :tag "Thai")) (repeat :inline t :tag "Other options" (integer :tag "Codepage number"))) :version "22.1" ;; Gnus 5.10.9 :group 'mime) (defun mm-setup-codepage-iso-8859 (&optional list) "Add appropriate entries to `mm-charset-synonym-alist'. Unless LIST is given, `mm-codepage-iso-8859-list' is used." (unless list (setq list mm-codepage-iso-8859-list)) (dolist (i list) (let (cp windows iso) (if (consp i) (setq cp (intern (format "cp%d" (car i))) windows (intern (format "windows-%d" (car i))) iso (intern (format "iso-8859-%d" (cdr i)))) (setq cp (intern (format "cp%d" i)) windows (intern (format "windows-%d" i)))) (unless (mm-coding-system-p windows) (if (mm-coding-system-p cp) (add-to-list 'mm-charset-synonym-alist (cons windows cp)) (add-to-list 'mm-charset-synonym-alist (cons windows iso))))))) (defun mm-setup-codepage-ibm (&optional list) "Add appropriate entries to `mm-charset-synonym-alist'. Unless LIST is given, `mm-codepage-ibm-list' is used." (unless list (setq list mm-codepage-ibm-list)) (dolist (number list) (let ((ibm (intern (format "ibm%d" number))) (cp (intern (format "cp%d" number)))) (when (and (not (mm-coding-system-p ibm)) (mm-coding-system-p cp)) (add-to-list 'mm-charset-synonym-alist (cons ibm cp)))))) ;; Initialize: (mm-setup-codepage-iso-8859) (mm-setup-codepage-ibm) (defcustom mm-charset-override-alist '((iso-8859-1 . windows-1252) (iso-8859-8 . windows-1255) (iso-8859-9 . windows-1254)) "A mapping from undesired charset names to their replacement. You may add pairs like (iso-8859-1 . windows-1252) here, i.e. treat iso-8859-1 as windows-1252. windows-1252 is a superset of iso-8859-1." :type '(list (set :inline t (const (iso-8859-1 . windows-1252)) (const (iso-8859-8 . windows-1255)) (const (iso-8859-9 . windows-1254)) (const (undecided . windows-1252))) (repeat :inline t :tag "Other options" (cons (symbol :tag "From charset") (symbol :tag "To charset")))) :version "22.1" ;; Gnus 5.10.9 :group 'mime) (defcustom mm-charset-eval-alist (if (featurep 'xemacs) nil ;; I don't know what would be useful for XEmacs. '(;; Emacs 21 offers 1250 1251 1253 1257. Emacs 22 provides autoloads for ;; 1250-1258 (i.e. `mm-codepage-setup' does nothing). (windows-1250 . (mm-codepage-setup 1250 t)) (windows-1251 . (mm-codepage-setup 1251 t)) (windows-1253 . (mm-codepage-setup 1253 t)) (windows-1257 . (mm-codepage-setup 1257 t)))) "An alist of (CHARSET . FORM) pairs. If an article is encoded in an unknown CHARSET, FORM is evaluated. This allows to load additional libraries providing charsets on demand. If supported by your Emacs version, you could use `autoload-coding-system' here." :version "22.1" ;; Gnus 5.10.9 :type '(list (set :inline t (const (windows-1250 . (mm-codepage-setup 1250 t))) (const (windows-1251 . (mm-codepage-setup 1251 t))) (const (windows-1253 . (mm-codepage-setup 1253 t))) (const (windows-1257 . (mm-codepage-setup 1257 t))) (const (cp850 . (mm-codepage-setup 850 nil)))) (repeat :inline t :tag "Other options" (cons (symbol :tag "charset") (symbol :tag "form")))) :group 'mime) (put 'mm-charset-eval-alist 'risky-local-variable t) (defvar mm-binary-coding-system (cond ((mm-coding-system-p 'binary) 'binary) ((mm-coding-system-p 'no-conversion) 'no-conversion) (t nil)) "100% binary coding system.") (defvar mm-text-coding-system (or (if (memq system-type '(windows-nt ms-dos ms-windows)) (and (mm-coding-system-p 'raw-text-dos) 'raw-text-dos) (and (mm-coding-system-p 'raw-text) 'raw-text)) mm-binary-coding-system) "Text-safe coding system (For removing ^M).") (defvar mm-text-coding-system-for-write nil "Text coding system for write.") (defvar mm-auto-save-coding-system (cond ((mm-coding-system-p 'utf-8-emacs) ; Mule 7 (if (memq system-type '(windows-nt ms-dos ms-windows)) (if (mm-coding-system-p 'utf-8-emacs-dos) 'utf-8-emacs-dos mm-binary-coding-system) 'utf-8-emacs)) ((mm-coding-system-p 'emacs-mule) (if (memq system-type '(windows-nt ms-dos ms-windows)) (if (mm-coding-system-p 'emacs-mule-dos) 'emacs-mule-dos mm-binary-coding-system) 'emacs-mule)) ((mm-coding-system-p 'escape-quoted) 'escape-quoted) (t mm-binary-coding-system)) "Coding system of auto save file.") (defvar mm-universal-coding-system mm-auto-save-coding-system "The universal coding system.") ;; Fixme: some of the cars here aren't valid MIME charsets. That ;; should only matter with XEmacs, though. (defvar mm-mime-mule-charset-alist `((us-ascii ascii) (iso-8859-1 latin-iso8859-1) (iso-8859-2 latin-iso8859-2) (iso-8859-3 latin-iso8859-3) (iso-8859-4 latin-iso8859-4) (iso-8859-5 cyrillic-iso8859-5) ;; Non-mule (X)Emacs uses the last mule-charset for 8bit characters. ;; The fake mule-charset, gnus-koi8-r, tells Gnus that the default ;; charset is koi8-r, not iso-8859-5. (koi8-r cyrillic-iso8859-5 gnus-koi8-r) (iso-8859-6 arabic-iso8859-6) (iso-8859-7 greek-iso8859-7) (iso-8859-8 hebrew-iso8859-8) (iso-8859-9 latin-iso8859-9) (iso-8859-14 latin-iso8859-14) (iso-8859-15 latin-iso8859-15) (viscii vietnamese-viscii-lower) (iso-2022-jp latin-jisx0201 japanese-jisx0208 japanese-jisx0208-1978) (euc-kr korean-ksc5601) (gb2312 chinese-gb2312) (gbk chinese-gbk) (gb18030 gb18030-2-byte gb18030-4-byte-bmp gb18030-4-byte-smp gb18030-4-byte-ext-1 gb18030-4-byte-ext-2) (big5 chinese-big5-1 chinese-big5-2) (tibetan tibetan) (thai-tis620 thai-tis620) (windows-1251 cyrillic-iso8859-5) (iso-2022-7bit ethiopic arabic-1-column arabic-2-column) (iso-2022-jp-2 latin-iso8859-1 greek-iso8859-7 latin-jisx0201 japanese-jisx0208-1978 chinese-gb2312 japanese-jisx0208 korean-ksc5601 japanese-jisx0212) (iso-2022-int-1 latin-iso8859-1 greek-iso8859-7 latin-jisx0201 japanese-jisx0208-1978 chinese-gb2312 japanese-jisx0208 korean-ksc5601 japanese-jisx0212 chinese-cns11643-1 chinese-cns11643-2) (iso-2022-int-1 latin-iso8859-1 latin-iso8859-2 cyrillic-iso8859-5 greek-iso8859-7 latin-jisx0201 japanese-jisx0208-1978 chinese-gb2312 japanese-jisx0208 korean-ksc5601 japanese-jisx0212 chinese-cns11643-1 chinese-cns11643-2 chinese-cns11643-3 chinese-cns11643-4 chinese-cns11643-5 chinese-cns11643-6 chinese-cns11643-7) (iso-2022-jp-3 latin-jisx0201 japanese-jisx0208-1978 japanese-jisx0208 japanese-jisx0213-1 japanese-jisx0213-2) (shift_jis latin-jisx0201 katakana-jisx0201 japanese-jisx0208) ,(cond ((fboundp 'unicode-precedence-list) (cons 'utf-8 (delq 'ascii (mapcar 'charset-name (unicode-precedence-list))))) ((or (not (fboundp 'charsetp)) ;; non-Mule case (charsetp 'unicode-a) (not (mm-coding-system-p 'mule-utf-8))) '(utf-8 unicode-a unicode-b unicode-c unicode-d unicode-e)) (t ;; If we have utf-8 we're in Mule 5+. (append '(utf-8) (delete 'ascii (coding-system-get 'mule-utf-8 'safe-charsets)))))) "Alist of MIME-charset/MULE-charsets.") (defun mm-enrich-utf-8-by-mule-ucs () "Make the `utf-8' MIME charset usable by the Mule-UCS package. This function will run when the `un-define' module is loaded under XEmacs, and fill the `utf-8' entry in `mm-mime-mule-charset-alist' with Mule charsets. It is completely useless for Emacs." (when (boundp 'unicode-basic-translation-charset-order-list) (condition-case nil (let ((val (delq 'ascii (copy-sequence (symbol-value 'unicode-basic-translation-charset-order-list)))) (elem (assq 'utf-8 mm-mime-mule-charset-alist))) (if elem (setcdr elem val) (setq mm-mime-mule-charset-alist (nconc mm-mime-mule-charset-alist (list (cons 'utf-8 val)))))) (error)))) ;; Correct by construction, but should be unnecessary for Emacs: (if (featurep 'xemacs) (eval-after-load "un-define" '(mm-enrich-utf-8-by-mule-ucs)) (when (and (fboundp 'coding-system-list) (fboundp 'sort-coding-systems)) (let ((css (sort-coding-systems (coding-system-list 'base-only))) cs mime mule alist) (while css (setq cs (pop css) mime (or (coding-system-get cs :mime-charset); Emacs 23 (unicode) (coding-system-get cs 'mime-charset))) (when (and mime (not (eq t (setq mule (coding-system-get cs 'safe-charsets)))) (not (assq mime alist))) (push (cons mime (delq 'ascii mule)) alist))) (setq mm-mime-mule-charset-alist (nreverse alist))))) (defvar mm-hack-charsets '(iso-8859-15 iso-2022-jp-2) "A list of special charsets. Valid elements include: `iso-8859-15' convert ISO-8859-1, -9 to ISO-8859-15 if ISO-8859-15 exists. `iso-2022-jp-2' convert ISO-2022-jp to ISO-2022-jp-2 if ISO-2022-jp-2 exists." ) (defvar mm-iso-8859-15-compatible '((iso-8859-1 "\xA4\xA6\xA8\xB4\xB8\xBC\xBD\xBE") (iso-8859-9 "\xA4\xA6\xA8\xB4\xB8\xBC\xBD\xBE\xD0\xDD\xDE\xF0\xFD\xFE")) "ISO-8859-15 exchangeable coding systems and inconvertible characters.") (defvar mm-iso-8859-x-to-15-table (and (fboundp 'coding-system-p) (mm-coding-system-p 'iso-8859-15) (mapcar (lambda (cs) (if (mm-coding-system-p (car cs)) (let ((c (string-to-char (decode-coding-string "\341" (car cs))))) (cons (char-charset c) (cons (- (string-to-char (decode-coding-string "\341" 'iso-8859-15)) c) (string-to-list (decode-coding-string (car (cdr cs)) (car cs)))))) '(gnus-charset 0))) mm-iso-8859-15-compatible)) "A table of the difference character between ISO-8859-X and ISO-8859-15.") (defcustom mm-coding-system-priorities (if (boundp 'current-language-environment) (let ((lang (symbol-value 'current-language-environment))) (cond ((string= lang "Japanese") ;; Japanese users prefer iso-2022-jp to euc-japan or ;; shift_jis, however iso-8859-1 should be used when ;; there are only ASCII text and Latin-1 characters. '(iso-8859-1 iso-2022-jp iso-2022-jp-2 shift_jis utf-8))))) "Preferred coding systems for encoding outgoing messages. More than one suitable coding system may be found for some text. By default, the coding system with the highest priority is used to encode outgoing messages (see `sort-coding-systems'). If this variable is set, it overrides the default priority." :version "21.2" :type '(repeat (symbol :tag "Coding system")) :group 'mime) ;; ?? (defvar mm-use-find-coding-systems-region (fboundp 'find-coding-systems-region) "Use `find-coding-systems-region' to find proper coding systems. Setting it to nil is useful on Emacsen supporting Unicode if sending mail with multiple parts is preferred to sending a Unicode one.") ;;; Internal variables: ;;; Functions: (defun mm-mule-charset-to-mime-charset (charset) "Return the MIME charset corresponding to the given Mule CHARSET." (if (and (fboundp 'find-coding-systems-for-charsets) (fboundp 'sort-coding-systems)) (let ((css (sort (sort-coding-systems (find-coding-systems-for-charsets (list charset))) 'mm-sort-coding-systems-predicate)) cs mime) (while (and (not mime) css) (when (setq cs (pop css)) (setq mime (or (coding-system-get cs :mime-charset) (coding-system-get cs 'mime-charset))))) mime) (let ((alist (mapcar (lambda (cs) (assq cs mm-mime-mule-charset-alist)) (sort (mapcar 'car mm-mime-mule-charset-alist) 'mm-sort-coding-systems-predicate))) out) (while alist (when (memq charset (cdar alist)) (setq out (caar alist) alist nil)) (pop alist)) out))) (defun mm-charset-to-coding-system (charset &optional lbt allow-override) "Return coding-system corresponding to CHARSET. CHARSET is a symbol naming a MIME charset. If optional argument LBT (`unix', `dos' or `mac') is specified, it is used as the line break code type of the coding system. If ALLOW-OVERRIDE is given, use `mm-charset-override-alist' to map undesired charset names to their replacement. This should only be used for decoding, not for encoding." ;; OVERRIDE is used (only) in `mm-decode-body' and `mm-decode-string'. (when (stringp charset) (setq charset (intern (downcase charset)))) (when lbt (setq charset (intern (format "%s-%s" charset lbt)))) (cond ((null charset) charset) ;; Running in a non-MULE environment. ((or (null (mm-get-coding-system-list)) (not (fboundp 'coding-system-get))) charset) ;; Check override list quite early. Should only used for decoding, not for ;; encoding! ((and allow-override (let ((cs (cdr (assq charset mm-charset-override-alist)))) (and cs (mm-coding-system-p cs) cs)))) ;; ascii ((eq charset 'us-ascii) 'ascii) ;; Check to see whether we can handle this charset. (This depends ;; on there being some coding system matching each `mime-charset' ;; property defined, as there should be.) ((and (mm-coding-system-p charset) ;;; Doing this would potentially weed out incorrect charsets. ;;; charset ;;; (eq charset (coding-system-get charset 'mime-charset)) ) charset) ;; Eval expressions from `mm-charset-eval-alist' ((let* ((el (assq charset mm-charset-eval-alist)) (cs (car el)) (form (cdr el))) (and cs form (prog2 ;; Avoid errors... (condition-case nil (eval form) (error nil)) ;; (message "Failed to eval `%s'" form)) (mm-coding-system-p cs) (message "Added charset `%s' via `mm-charset-eval-alist'" cs)) cs))) ;; Translate invalid charsets. ((let ((cs (cdr (assq charset mm-charset-synonym-alist)))) (and cs (mm-coding-system-p cs) ;; (message ;; "Using synonym `%s' from `mm-charset-synonym-alist' for `%s'" ;; cs charset) cs))) ;; Last resort: search the coding system list for entries which ;; have the right mime-charset in case the canonical name isn't ;; defined (though it should be). ((let (cs) ;; mm-get-coding-system-list returns a list of cs without lbt. ;; Do we need -lbt? (dolist (c (mm-get-coding-system-list)) (if (and (null cs) (eq charset (or (coding-system-get c :mime-charset) (coding-system-get c 'mime-charset)))) (setq cs c))) (unless cs ;; Warn the user about unknown charset: (if (fboundp 'gnus-message) (gnus-message 7 "Unknown charset: %s" charset) (message "Unknown charset: %s" charset))) cs)))) (eval-and-compile (defvar mm-emacs-mule (and (not (featurep 'xemacs)) (boundp 'default-enable-multibyte-characters) default-enable-multibyte-characters (fboundp 'set-buffer-multibyte)) "True in Emacs with Mule.") (if mm-emacs-mule (defun mm-enable-multibyte () "Set the multibyte flag of the current buffer. Only do this if the default value of `enable-multibyte-characters' is non-nil. This is a no-op in XEmacs." (set-buffer-multibyte 'to)) (defalias 'mm-enable-multibyte 'ignore)) (if mm-emacs-mule (defun mm-disable-multibyte () "Unset the multibyte flag of in the current buffer. This is a no-op in XEmacs." (set-buffer-multibyte nil)) (defalias 'mm-disable-multibyte 'ignore))) (defun mm-preferred-coding-system (charset) ;; A typo in some Emacs versions. (or (get-charset-property charset 'preferred-coding-system) (get-charset-property charset 'prefered-coding-system))) ;; Mule charsets shouldn't be used. (defsubst mm-guess-charset () "Guess Mule charset from the language environment." (or mail-parse-mule-charset ;; cached mule-charset (progn (setq mail-parse-mule-charset (and (boundp 'current-language-environment) (car (last (assq 'charset (assoc current-language-environment language-info-alist)))))) (if (or (not mail-parse-mule-charset) (eq mail-parse-mule-charset 'ascii)) (setq mail-parse-mule-charset (or (car (last (assq mail-parse-charset mm-mime-mule-charset-alist))) ;; default 'latin-iso8859-1))) mail-parse-mule-charset))) (defun mm-charset-after (&optional pos) "Return charset of a character in current buffer at position POS. If POS is nil, it defauls to the current point. If POS is out of range, the value is nil. If the charset is `composition', return the actual one." (let ((char (char-after pos)) charset) (if (< (mm-char-int char) 128) (setq charset 'ascii) ;; charset-after is fake in some Emacsen. (setq charset (and (fboundp 'char-charset) (char-charset char))) (if (eq charset 'composition) ; Mule 4 (let ((p (or pos (point)))) (cadr (find-charset-region p (1+ p)))) (if (and charset (not (memq charset '(ascii eight-bit-control eight-bit-graphic)))) charset (mm-guess-charset)))))) (defun mm-mime-charset (charset) "Return the MIME charset corresponding to the given Mule CHARSET." (if (eq charset 'unknown) (error "The message contains non-printable characters, please use attachment")) (if (and (fboundp 'coding-system-get) (fboundp 'get-charset-property)) ;; This exists in Emacs 20. (or (and (mm-preferred-coding-system charset) (or (coding-system-get (mm-preferred-coding-system charset) :mime-charset) (coding-system-get (mm-preferred-coding-system charset) 'mime-charset))) (and (eq charset 'ascii) 'us-ascii) (mm-preferred-coding-system charset) (mm-mule-charset-to-mime-charset charset)) ;; This is for XEmacs. (mm-mule-charset-to-mime-charset charset))) (if (fboundp 'delete-dups) (defalias 'mm-delete-duplicates 'delete-dups) (defun mm-delete-duplicates (list) "Destructively remove `equal' duplicates from LIST. Store the result in LIST and return it. LIST must be a proper list. Of several `equal' occurrences of an element in LIST, the first one is kept. This is a compatibility function for Emacsen without `delete-dups'." ;; Code from `subr.el' in Emacs 22: (let ((tail list)) (while tail (setcdr tail (delete (car tail) (cdr tail))) (setq tail (cdr tail)))) list)) ;; Fixme: This is used in places when it should be testing the ;; default multibyteness. See mm-default-multibyte-p. (eval-and-compile (if (and (not (featurep 'xemacs)) (boundp 'enable-multibyte-characters)) (defun mm-multibyte-p () "Non-nil if multibyte is enabled in the current buffer." enable-multibyte-characters) (defun mm-multibyte-p () (featurep 'mule)))) (defun mm-default-multibyte-p () "Return non-nil if the session is multibyte. This affects whether coding conversion should be attempted generally." (if (featurep 'mule) (if (boundp 'default-enable-multibyte-characters) default-enable-multibyte-characters t))) (defun mm-iso-8859-x-to-15-region (&optional b e) (if (fboundp 'char-charset) (let (charset item c inconvertible) (save-restriction (if e (narrow-to-region b e)) (goto-char (point-min)) (skip-chars-forward "\0-\177") (while (not (eobp)) (cond ((not (setq item (assq (char-charset (setq c (char-after))) mm-iso-8859-x-to-15-table))) (forward-char)) ((memq c (cdr (cdr item))) (setq inconvertible t) (forward-char)) (t (insert-before-markers (prog1 (+ c (car (cdr item))) (delete-char 1))))) (skip-chars-forward "\0-\177"))) (not inconvertible)))) (defun mm-sort-coding-systems-predicate (a b) (let ((priorities (mapcar (lambda (cs) ;; Note: invalid entries are dropped silently (and (setq cs (mm-coding-system-p cs)) (coding-system-base cs))) mm-coding-system-priorities))) (and (setq a (mm-coding-system-p a)) (if (setq b (mm-coding-system-p b)) (> (length (memq (coding-system-base a) priorities)) (length (memq (coding-system-base b) priorities))) t)))) (eval-when-compile (autoload 'latin-unity-massage-name "latin-unity") (autoload 'latin-unity-maybe-remap "latin-unity") (autoload 'latin-unity-representations-feasible-region "latin-unity") (autoload 'latin-unity-representations-present-region "latin-unity")) (defvar latin-unity-coding-systems) (defvar latin-unity-ucs-list) (defun mm-xemacs-find-mime-charset-1 (begin end) "Determine which MIME charset to use to send region as message. This uses the XEmacs-specific latin-unity package to better handle the case where identical characters from diverse ISO-8859-? character sets can be encoded using a single one of the corresponding coding systems. It treats `mm-coding-system-priorities' as the list of preferred coding systems; a useful example setting for this list in Western Europe would be '(iso-8859-1 iso-8859-15 utf-8), which would default to the very standard Latin 1 coding system, and only move to coding systems that are less supported as is necessary to encode the characters that exist in the buffer. Latin Unity doesn't know about those non-ASCII Roman characters that are available in various East Asian character sets. As such, its behavior if you have a JIS 0212 LATIN SMALL LETTER A WITH ACUTE in a buffer and it can otherwise be encoded as Latin 1, won't be ideal. But this is very much a corner case, so don't worry about it." (let ((systems mm-coding-system-priorities) csets psets curset) ;; Load the Latin Unity library, if available. (when (and (not (featurep 'latin-unity)) (locate-library "latin-unity")) (require 'latin-unity)) ;; Now, can we use it? (if (featurep 'latin-unity) (progn (setq csets (latin-unity-representations-feasible-region begin end) psets (latin-unity-representations-present-region begin end)) (catch 'done ;; Pass back the first coding system in the preferred list ;; that can encode the whole region. (dolist (curset systems) (setq curset (latin-unity-massage-name 'buffer-default curset)) ;; If the coding system is a universal coding system, then ;; it can certainly encode all the characters in the region. (if (memq curset latin-unity-ucs-list) (throw 'done (list curset))) ;; If a coding system isn't universal, and isn't in ;; the list that latin unity knows about, we can't ;; decide whether to use it here. Leave that until later ;; in `mm-find-mime-charset-region' function, whence we ;; have been called. (unless (memq curset latin-unity-coding-systems) (throw 'done nil)) ;; Right, we know about this coding system, and it may ;; conceivably be able to encode all the characters in ;; the region. (if (latin-unity-maybe-remap begin end curset csets psets t) (throw 'done (list curset)))) ;; Can't encode using anything from the ;; `mm-coding-system-priorities' list. ;; Leave `mm-find-mime-charset' to do most of the work. nil)) ;; Right, latin unity isn't available; let `mm-find-charset-region' ;; take its default action, which equally applies to GNU Emacs. nil))) (defmacro mm-xemacs-find-mime-charset (begin end) (when (featurep 'xemacs) `(and (featurep 'mule) (mm-xemacs-find-mime-charset-1 ,begin ,end)))) (declare-function mm-delete-duplicates "mm-util" (list)) (defun mm-find-mime-charset-region (b e &optional hack-charsets) "Return the MIME charsets needed to encode the region between B and E. nil means ASCII, a single-element list represents an appropriate MIME charset, and a longer list means no appropriate charset." (let (charsets) ;; The return possibilities of this function are a mess... (or (and (mm-multibyte-p) mm-use-find-coding-systems-region ;; Find the mime-charset of the most preferred coding ;; system that has one. (let ((systems (find-coding-systems-region b e))) (when mm-coding-system-priorities (setq systems (sort systems 'mm-sort-coding-systems-predicate))) (setq systems (delq 'compound-text systems)) (unless (equal systems '(undecided)) (while systems (let* ((head (pop systems)) (cs (or (coding-system-get head :mime-charset) (coding-system-get head 'mime-charset)))) ;; The mime-charset (`x-ctext') of ;; `compound-text' is not in the IANA list. We ;; shouldn't normally use anything here with a ;; mime-charset having an `x-' prefix. ;; Fixme: Allow this to be overridden, since ;; there is existing use of x-ctext. ;; Also people apparently need the coding system ;; `iso-2022-jp-3' (which Mule-UCS defines with ;; mime-charset, though it's not valid). (if (and cs (not (string-match "^[Xx]-" (symbol-name cs))) ;; UTF-16 of any variety is invalid for ;; text parts and, unfortunately, has ;; mime-charset defined both in Mule-UCS ;; and versions of Emacs. (The name ;; might be `mule-utf-16...' or ;; `utf-16...'.) (not (string-match "utf-16" (symbol-name cs)))) (setq systems nil charsets (list cs)))))) charsets)) ;; If we're XEmacs, and some coding system is appropriate, ;; mm-xemacs-find-mime-charset will return an appropriate list. ;; Otherwise, we'll get nil, and the next setq will get invoked. (setq charsets (mm-xemacs-find-mime-charset b e)) ;; Fixme: won't work for unibyte Emacs 23: ;; We're not multibyte, or a single coding system won't cover it. (setq charsets (mm-delete-duplicates (mapcar 'mm-mime-charset (delq 'ascii (mm-find-charset-region b e)))))) (if (and (> (length charsets) 1) (memq 'iso-8859-15 charsets) (memq 'iso-8859-15 hack-charsets) (save-excursion (mm-iso-8859-x-to-15-region b e))) (dolist (x mm-iso-8859-15-compatible) (setq charsets (delq (car x) charsets)))) (if (and (memq 'iso-2022-jp-2 charsets) (memq 'iso-2022-jp-2 hack-charsets)) (setq charsets (delq 'iso-2022-jp charsets))) ;; Attempt to reduce the number of charsets if utf-8 is available. (if (and (featurep 'xemacs) (> (length charsets) 1) (mm-coding-system-p 'utf-8)) (let ((mm-coding-system-priorities (cons 'utf-8 mm-coding-system-priorities))) (setq charsets (mm-delete-duplicates (mapcar 'mm-mime-charset (delq 'ascii (mm-find-charset-region b e))))))) charsets)) (defmacro mm-with-unibyte-buffer (&rest forms) "Create a temporary buffer, and evaluate FORMS there like `progn'. Use unibyte mode for this." `(with-temp-buffer (mm-disable-multibyte) ,@forms)) (put 'mm-with-unibyte-buffer 'lisp-indent-function 0) (put 'mm-with-unibyte-buffer 'edebug-form-spec '(body)) (defmacro mm-with-multibyte-buffer (&rest forms) "Create a temporary buffer, and evaluate FORMS there like `progn'. Use multibyte mode for this." `(with-temp-buffer (mm-enable-multibyte) ,@forms)) (put 'mm-with-multibyte-buffer 'lisp-indent-function 0) (put 'mm-with-multibyte-buffer 'edebug-form-spec '(body)) (defmacro mm-with-unibyte-current-buffer (&rest forms) "Evaluate FORMS with current buffer temporarily made unibyte. Also bind `default-enable-multibyte-characters' to nil. Equivalent to `progn' in XEmacs NOTE: Use this macro with caution in multibyte buffers (it is not worth using this macro in unibyte buffers of course). Use of `(set-buffer-multibyte t)', which is run finally, is generally harmful since it is likely to modify existing data in the buffer. For instance, it converts \"\\300\\255\" into \"\\255\" in Emacs 23 (unicode)." (let ((multibyte (make-symbol "multibyte")) (buffer (make-symbol "buffer"))) `(if mm-emacs-mule (let ((,multibyte enable-multibyte-characters) (,buffer (current-buffer))) (unwind-protect (let (default-enable-multibyte-characters) (set-buffer-multibyte nil) ,@forms) (set-buffer ,buffer) (set-buffer-multibyte ,multibyte))) (let (default-enable-multibyte-characters) ,@forms)))) (put 'mm-with-unibyte-current-buffer 'lisp-indent-function 0) (put 'mm-with-unibyte-current-buffer 'edebug-form-spec '(body)) (defmacro mm-with-unibyte (&rest forms) "Eval the FORMS with the default value of `enable-multibyte-characters' nil." `(let (default-enable-multibyte-characters) ,@forms)) (put 'mm-with-unibyte 'lisp-indent-function 0) (put 'mm-with-unibyte 'edebug-form-spec '(body)) (defmacro mm-with-multibyte (&rest forms) "Eval the FORMS with the default value of `enable-multibyte-characters' t." `(let ((default-enable-multibyte-characters t)) ,@forms)) (put 'mm-with-multibyte 'lisp-indent-function 0) (put 'mm-with-multibyte 'edebug-form-spec '(body)) (defun mm-find-charset-region (b e) "Return a list of Emacs charsets in the region B to E." (cond ((and (mm-multibyte-p) (fboundp 'find-charset-region)) ;; Remove composition since the base charsets have been included. ;; Remove eight-bit-*, treat them as ascii. (let ((css (find-charset-region b e))) (dolist (cs '(composition eight-bit-control eight-bit-graphic control-1) css) (setq css (delq cs css))))) (t ;; We are in a unibyte buffer or XEmacs non-mule, so we futz around a bit. (save-excursion (save-restriction (narrow-to-region b e) (goto-char (point-min)) (skip-chars-forward "\0-\177") (if (eobp) '(ascii) (let (charset) (setq charset (and (boundp 'current-language-environment) (car (last (assq 'charset (assoc current-language-environment language-info-alist)))))) (if (eq charset 'ascii) (setq charset nil)) (or charset (setq charset (car (last (assq mail-parse-charset mm-mime-mule-charset-alist))))) (list 'ascii (or charset 'latin-iso8859-1))))))))) (defun mm-auto-mode-alist () "Return an `auto-mode-alist' with only the .gz (etc) thingies." (let ((alist auto-mode-alist) out) (while alist (when (listp (cdar alist)) (push (car alist) out)) (pop alist)) (nreverse out))) (defvar mm-inhibit-file-name-handlers '(jka-compr-handler image-file-handler epa-file-handler) "A list of handlers doing (un)compression (etc) thingies.") (defun mm-insert-file-contents (filename &optional visit beg end replace inhibit) "Like `insert-file-contents', but only reads in the file. A buffer may be modified in several ways after reading into the buffer due to advanced Emacs features, such as file-name-handlers, format decoding, `find-file-hooks', etc. If INHIBIT is non-nil, inhibit `mm-inhibit-file-name-handlers'. This function ensures that none of these modifications will take place." (let* ((format-alist nil) (auto-mode-alist (if inhibit nil (mm-auto-mode-alist))) (default-major-mode 'fundamental-mode) (enable-local-variables nil) (after-insert-file-functions nil) (enable-local-eval nil) (inhibit-file-name-operation (if inhibit 'insert-file-contents inhibit-file-name-operation)) (inhibit-file-name-handlers (if inhibit (append mm-inhibit-file-name-handlers inhibit-file-name-handlers) inhibit-file-name-handlers)) (ffh (if (boundp 'find-file-hook) 'find-file-hook 'find-file-hooks)) (val (symbol-value ffh))) (set ffh nil) (unwind-protect (insert-file-contents filename visit beg end replace) (set ffh val)))) (defun mm-append-to-file (start end filename &optional codesys inhibit) "Append the contents of the region to the end of file FILENAME. When called from a function, expects three arguments, START, END and FILENAME. START and END are buffer positions saying what text to write. Optional fourth argument specifies the coding system to use when encoding the file. If INHIBIT is non-nil, inhibit `mm-inhibit-file-name-handlers'." (let ((coding-system-for-write (or codesys mm-text-coding-system-for-write mm-text-coding-system)) (inhibit-file-name-operation (if inhibit 'append-to-file inhibit-file-name-operation)) (inhibit-file-name-handlers (if inhibit (append mm-inhibit-file-name-handlers inhibit-file-name-handlers) inhibit-file-name-handlers))) (write-region start end filename t 'no-message) (message "Appended to %s" filename))) (defun mm-write-region (start end filename &optional append visit lockname coding-system inhibit) "Like `write-region'. If INHIBIT is non-nil, inhibit `mm-inhibit-file-name-handlers'." (let ((coding-system-for-write (or coding-system mm-text-coding-system-for-write mm-text-coding-system)) (inhibit-file-name-operation (if inhibit 'write-region inhibit-file-name-operation)) (inhibit-file-name-handlers (if inhibit (append mm-inhibit-file-name-handlers inhibit-file-name-handlers) inhibit-file-name-handlers))) (write-region start end filename append visit lockname))) (autoload 'gmm-write-region "gmm-utils") ;; It is not a MIME function, but some MIME functions use it. (if (and (fboundp 'make-temp-file) (ignore-errors (let ((def (symbol-function 'make-temp-file))) (and (byte-code-function-p def) (setq def (if (fboundp 'compiled-function-arglist) ;; XEmacs (eval (list 'compiled-function-arglist def)) (aref def 0))) (>= (length def) 4) (eq (nth 3 def) 'suffix))))) (defalias 'mm-make-temp-file 'make-temp-file) ;; Stolen (and modified for XEmacs) from Emacs 22. (defun mm-make-temp-file (prefix &optional dir-flag suffix) "Create a temporary file. The returned file name (created by appending some random characters at the end of PREFIX, and expanding against `temporary-file-directory' if necessary), is guaranteed to point to a newly created empty file. You can then use `write-region' to write new data into the file. If DIR-FLAG is non-nil, create a new empty directory instead of a file. If SUFFIX is non-nil, add that at the end of the file name." (let ((umask (default-file-modes)) file) (unwind-protect (progn ;; Create temp files with strict access rights. It's easy to ;; loosen them later, whereas it's impossible to close the ;; time-window of loose permissions otherwise. (set-default-file-modes 448) (while (condition-case err (progn (setq file (make-temp-name (expand-file-name prefix (if (fboundp 'temp-directory) ;; XEmacs (temp-directory) temporary-file-directory)))) (if suffix (setq file (concat file suffix))) (if dir-flag (make-directory file) ;; NOTE: This is unsafe if Emacs 20 ;; users and XEmacs users don't use ;; a secure temp directory. (gmm-write-region "" nil file nil 'silent nil 'excl)) nil) (file-already-exists t) ;; The XEmacs version of `make-directory' issues ;; `file-error'. (file-error (or (and (featurep 'xemacs) (file-exists-p file)) (signal (car err) (cdr err))))) ;; the file was somehow created by someone else between ;; `make-temp-name' and `write-region', let's try again. nil) file) ;; Reset the umask. (set-default-file-modes umask))))) (defun mm-image-load-path (&optional package) (let (dir result) (dolist (path load-path (nreverse result)) (when (and path (file-directory-p (setq dir (concat (file-name-directory (directory-file-name path)) "etc/images/" (or package "gnus/"))))) (push dir result)) (push path result)))) ;; Fixme: This doesn't look useful where it's used. (if (fboundp 'detect-coding-region) (defun mm-detect-coding-region (start end) "Like `detect-coding-region' except returning the best one." (let ((coding-systems (detect-coding-region start end))) (or (car-safe coding-systems) coding-systems))) (defun mm-detect-coding-region (start end) (let ((point (point))) (goto-char start) (skip-chars-forward "\0-\177" end) (prog1 (if (eq (point) end) 'ascii (mm-guess-charset)) (goto-char point))))) (declare-function mm-detect-coding-region "mm-util" (start end)) (if (fboundp 'coding-system-get) (defun mm-detect-mime-charset-region (start end) "Detect MIME charset of the text in the region between START and END." (let ((cs (mm-detect-coding-region start end))) (or (coding-system-get cs :mime-charset) (coding-system-get cs 'mime-charset)))) (defun mm-detect-mime-charset-region (start end) "Detect MIME charset of the text in the region between START and END." (let ((cs (mm-detect-coding-region start end))) cs))) (eval-when-compile (unless (fboundp 'coding-system-to-mime-charset) (defalias 'coding-system-to-mime-charset 'ignore))) (defun mm-coding-system-to-mime-charset (coding-system) "Return the MIME charset corresponding to CODING-SYSTEM. To make this function work with XEmacs, the APEL package is required." (when coding-system (or (and (fboundp 'coding-system-get) (or (coding-system-get coding-system :mime-charset) (coding-system-get coding-system 'mime-charset))) (and (featurep 'xemacs) (or (and (fboundp 'coding-system-to-mime-charset) (not (eq (symbol-function 'coding-system-to-mime-charset) 'ignore))) (and (condition-case nil (require 'mcharset) (error nil)) (fboundp 'coding-system-to-mime-charset))) (coding-system-to-mime-charset coding-system))))) (eval-when-compile (require 'jka-compr)) (defun mm-decompress-buffer (filename &optional inplace force) "Decompress buffer's contents, depending on jka-compr. Only when FORCE is t or `auto-compression-mode' is enabled and FILENAME agrees with `jka-compr-compression-info-list', decompression is done. Signal an error if FORCE is neither nil nor t and compressed data are not decompressed because `auto-compression-mode' is disabled. If INPLACE is nil, return decompressed data or nil without modifying the buffer. Otherwise, replace the buffer's contents with the decompressed data. The buffer's multibyteness must be turned off." (when (and filename (if force (prog1 t (require 'jka-compr)) (and (fboundp 'jka-compr-installed-p) (jka-compr-installed-p)))) (let ((info (jka-compr-get-compression-info filename))) (when info (unless (or (memq force (list nil t)) (jka-compr-installed-p)) (error "")) (let ((prog (jka-compr-info-uncompress-program info)) (args (jka-compr-info-uncompress-args info)) (msg (format "%s %s..." (jka-compr-info-uncompress-message info) filename)) (err-file (jka-compr-make-temp-name)) (cur (current-buffer)) (coding-system-for-read mm-binary-coding-system) (coding-system-for-write mm-binary-coding-system) retval err-msg) (message "%s" msg) (mm-with-unibyte-buffer (insert-buffer-substring cur) (condition-case err (progn (unless (memq (apply 'call-process-region (point-min) (point-max) prog t (list t err-file) nil args) jka-compr-acceptable-retval-list) (erase-buffer) (insert (mapconcat 'identity (delete "" (split-string (prog2 (insert-file-contents err-file) (buffer-string) (erase-buffer)))) " ") "\n") (setq err-msg (format "Error while executing \"%s %s < %s\"" prog (mapconcat 'identity args " ") filename))) (setq retval (buffer-string))) (error (setq err-msg (error-message-string err))))) (when (file-exists-p err-file) (ignore-errors (jka-compr-delete-temp-file err-file))) (when inplace (unless err-msg (delete-region (point-min) (point-max)) (insert retval)) (setq retval nil)) (message "%s" (or err-msg (concat msg "done"))) retval))))) (eval-when-compile (unless (fboundp 'coding-system-name) (defalias 'coding-system-name 'ignore)) (unless (fboundp 'find-file-coding-system-for-read-from-filename) (defalias 'find-file-coding-system-for-read-from-filename 'ignore)) (unless (fboundp 'find-operation-coding-system) (defalias 'find-operation-coding-system 'ignore))) (defun mm-find-buffer-file-coding-system (&optional filename) "Find coding system used to decode the contents of the current buffer. This function looks for the coding system magic cookie or examines the coding system specified by `file-coding-system-alist' being associated with FILENAME which defaults to `buffer-file-name'. Data compressed by gzip, bzip2, etc. are allowed." (unless filename (setq filename buffer-file-name)) (save-excursion (let ((decomp (unless ;; No worth to examine charset of tar files. (and filename (string-match "\\.\\(?:tar\\.[^.]+\\|tbz\\|tgz\\)\\'" filename)) (mm-decompress-buffer filename nil t)))) (when decomp (set-buffer (let (default-enable-multibyte-characters) (generate-new-buffer " *temp*"))) (insert decomp) (setq filename (file-name-sans-extension filename))) (goto-char (point-min)) (prog1 (cond ((boundp 'set-auto-coding-function) ;; Emacs (if filename (or (funcall (symbol-value 'set-auto-coding-function) filename (- (point-max) (point-min))) (car (find-operation-coding-system 'insert-file-contents filename))) (let (auto-coding-alist) (condition-case nil (funcall (symbol-value 'set-auto-coding-function) nil (- (point-max) (point-min))) (error nil))))) ((and (featurep 'xemacs) (featurep 'file-coding)) ;; XEmacs (let ((case-fold-search t) (end (point-at-eol)) codesys start) (or (and (re-search-forward "-\\*-+[\t ]*" end t) (progn (setq start (match-end 0)) (re-search-forward "[\t ]*-+\\*-" end t)) (progn (setq end (match-beginning 0)) (goto-char start) (or (looking-at "coding:[\t ]*\\([^\t ;]+\\)") (re-search-forward "[\t ;]+coding:[\t ]*\\([^\t ;]+\\)" end t))) (find-coding-system (setq codesys (intern (match-string 1)))) codesys) (and (re-search-forward "^[\t ]*;+[\t ]*Local[\t ]+Variables:" nil t) (progn (setq start (match-end 0)) (re-search-forward "^[\t ]*;+[\t ]*End:" nil t)) (progn (setq end (match-beginning 0)) (goto-char start) (re-search-forward "^[\t ]*;+[\t ]*coding:[\t ]*\\([^\t\n\r ]+\\)" end t)) (find-coding-system (setq codesys (intern (match-string 1)))) codesys) (and (progn (goto-char (point-min)) (setq case-fold-search nil) (re-search-forward "^;;;coding system: " ;;(+ (point-min) 3000) t)) nil t)) (looking-at "[^\t\n\r ]+") (find-coding-system (setq codesys (intern (match-string 0)))) codesys) (and filename (setq codesys (find-file-coding-system-for-read-from-filename filename)) (coding-system-name (coding-system-base codesys))))))) (when decomp (kill-buffer (current-buffer))))))) (provide 'mm-util) ;; arch-tag: 94dc5388-825d-4fd1-bfa5-2100aa351238 ;;; mm-util.el ends here gnus-5.11+v0.10.dfsg/lisp/gnus-soup.el0000644000175000017500000004660111004005111017513 0ustar tvainikatvainika;;; gnus-soup.el --- SOUP packet writing support for Gnus ;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, ;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc. ;; Author: Per Abrahamsen ;; Lars Magne Ingebrigtsen ;; Keywords: news, mail ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 3, or (at your option) ;; any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Commentary: ;;; Code: (eval-when-compile (require 'cl)) (require 'gnus) (require 'gnus-art) (require 'message) (require 'gnus-start) (require 'gnus-range) (defgroup gnus-soup nil "SOUP packet writing support for Gnus." :group 'gnus) ;;; User Variables: (defcustom gnus-soup-directory (nnheader-concat gnus-home-directory "SoupBrew/") "Directory containing an unpacked SOUP packet." :version "22.1" ;; Gnus 5.10.9 :type 'directory :group 'gnus-soup) (defcustom gnus-soup-replies-directory (nnheader-concat gnus-soup-directory "SoupReplies/") "Directory where Gnus will do processing of replies." :version "22.1" ;; Gnus 5.10.9 :type 'directory :group 'gnus-soup) (defcustom gnus-soup-prefix-file "gnus-prefix" "Name of the file where Gnus stores the last used prefix." :version "22.1" ;; Gnus 5.10.9 :type 'file :group 'gnus-soup) (defcustom gnus-soup-packer "tar cf - %s | gzip > $HOME/Soupout%d.tgz" "Format string command for packing a SOUP packet. The SOUP files will be inserted where the %s is in the string. This string MUST contain both %s and %d. The file number will be inserted where %d appears." :version "22.1" ;; Gnus 5.10.9 :type 'string :group 'gnus-soup) (defcustom gnus-soup-unpacker "gunzip -c %s | tar xvf -" "Format string command for unpacking a SOUP packet. The SOUP packet file name will be inserted at the %s." :version "22.1" ;; Gnus 5.10.9 :type 'string :group 'gnus-soup) (defcustom gnus-soup-packet-directory gnus-home-directory "Where gnus-soup will look for REPLIES packets." :version "22.1" ;; Gnus 5.10.9 :type 'directory :group 'gnus-soup) (defcustom gnus-soup-packet-regexp "Soupin" "Regular expression matching SOUP REPLIES packets in `gnus-soup-packet-directory'." :version "22.1" ;; Gnus 5.10.9 :type 'regexp :group 'gnus-soup) (defcustom gnus-soup-ignored-headers "^Xref:" "Regexp to match headers to be removed when brewing SOUP packets." :version "22.1" ;; Gnus 5.10.9 :type 'regexp :group 'gnus-soup) ;;; Internal Variables: (defvar gnus-soup-encoding-type ?u "*Soup encoding type. `u' is USENET news format, `m' is Unix mbox format, and `M' is MMDF mailbox format.") (defvar gnus-soup-index-type ?c "*Soup index type. `n' means no index file and `c' means standard Cnews overview format.") (defvar gnus-soup-areas nil) (defvar gnus-soup-last-prefix nil) (defvar gnus-soup-prev-prefix nil) (defvar gnus-soup-buffers nil) ;;; Access macros: (defmacro gnus-soup-area-prefix (area) `(aref ,area 0)) (defmacro gnus-soup-set-area-prefix (area prefix) `(aset ,area 0 ,prefix)) (defmacro gnus-soup-area-name (area) `(aref ,area 1)) (defmacro gnus-soup-area-encoding (area) `(aref ,area 2)) (defmacro gnus-soup-area-description (area) `(aref ,area 3)) (defmacro gnus-soup-area-number (area) `(aref ,area 4)) (defmacro gnus-soup-area-set-number (area value) `(aset ,area 4 ,value)) (defmacro gnus-soup-encoding-format (encoding) `(aref ,encoding 0)) (defmacro gnus-soup-encoding-index (encoding) `(aref ,encoding 1)) (defmacro gnus-soup-encoding-kind (encoding) `(aref ,encoding 2)) (defmacro gnus-soup-reply-prefix (reply) `(aref ,reply 0)) (defmacro gnus-soup-reply-kind (reply) `(aref ,reply 1)) (defmacro gnus-soup-reply-encoding (reply) `(aref ,reply 2)) ;;; Commands: (defun gnus-soup-send-replies () "Unpack and send all replies in the reply packet." (interactive) (let ((packets (directory-files gnus-soup-packet-directory t gnus-soup-packet-regexp))) (while packets (when (gnus-soup-send-packet (car packets)) (delete-file (car packets))) (setq packets (cdr packets))))) (defun gnus-soup-add-article (n) "Add the current article to SOUP packet. If N is a positive number, add the N next articles. If N is a negative number, add the N previous articles. If N is nil and any articles have been marked with the process mark, move those articles instead." (interactive "P") (let* ((articles (gnus-summary-work-articles n)) (tmp-buf (gnus-get-buffer-create "*soup work*")) (area (gnus-soup-area gnus-newsgroup-name)) (prefix (gnus-soup-area-prefix area)) headers) (buffer-disable-undo tmp-buf) (save-excursion (while articles ;; Put the article in a buffer. (set-buffer tmp-buf) (when (gnus-request-article-this-buffer (car articles) gnus-newsgroup-name) (setq headers (nnheader-parse-head t)) (save-restriction (message-narrow-to-head) (message-remove-header gnus-soup-ignored-headers t)) (gnus-soup-store gnus-soup-directory prefix headers gnus-soup-encoding-type gnus-soup-index-type) (gnus-soup-area-set-number area (1+ (or (gnus-soup-area-number area) 0))) ;; Mark article as read. (set-buffer gnus-summary-buffer) (gnus-summary-mark-as-read (car articles) gnus-souped-mark)) (gnus-summary-remove-process-mark (car articles)) (setq articles (cdr articles))) (kill-buffer tmp-buf)) (gnus-soup-save-areas) (gnus-set-mode-line 'summary))) (defun gnus-soup-pack-packet () "Make a SOUP packet from the SOUP areas." (interactive) (gnus-soup-read-areas) (if (file-exists-p gnus-soup-directory) (if (directory-files gnus-soup-directory nil "\\.MSG$") (gnus-soup-pack gnus-soup-directory gnus-soup-packer) (message "No files to pack.")) (message "No such directory: %s" gnus-soup-directory))) (defun gnus-group-brew-soup (n) "Make a soup packet from the current group. Uses the process/prefix convention." (interactive "P") (let ((groups (gnus-group-process-prefix n))) (while groups (gnus-group-remove-mark (car groups)) (gnus-soup-group-brew (car groups) t) (setq groups (cdr groups))) (gnus-soup-save-areas))) (defun gnus-brew-soup (&optional level) "Go through all groups on LEVEL or less and make a soup packet." (interactive "P") (let ((level (or level gnus-level-subscribed)) (newsrc (cdr gnus-newsrc-alist))) (while newsrc (when (<= (nth 1 (car newsrc)) level) (gnus-soup-group-brew (caar newsrc) t)) (setq newsrc (cdr newsrc))) (gnus-soup-save-areas))) ;;;###autoload (defun gnus-batch-brew-soup () "Brew a SOUP packet from groups mention on the command line. Will use the remaining command line arguments as regular expressions for matching on group names. For instance, if you want to brew on all the nnml groups, as well as groups with \"emacs\" in the name, you could say something like: $ emacs -batch -f gnus-batch-brew-soup ^nnml \".*emacs.*\" Note -- this function hasn't been implemented yet." (interactive) nil) ;;; Internal Functions: ;; Store the current buffer. (defun gnus-soup-store (directory prefix headers format index) ;; Create the directory, if needed. (gnus-make-directory directory) (let* ((msg-buf (nnheader-find-file-noselect (concat directory prefix ".MSG"))) (idx-buf (if (= index ?n) nil (nnheader-find-file-noselect (concat directory prefix ".IDX")))) (article-buf (current-buffer)) from head-line beg type) (setq gnus-soup-buffers (cons msg-buf (delq msg-buf gnus-soup-buffers))) (buffer-disable-undo msg-buf) (when idx-buf (push idx-buf gnus-soup-buffers) (buffer-disable-undo idx-buf)) (save-excursion ;; Make sure the last char in the buffer is a newline. (goto-char (point-max)) (unless (= (current-column) 0) (insert "\n")) ;; Find the "from". (goto-char (point-min)) (setq from (gnus-mail-strip-quoted-names (or (mail-fetch-field "from") (mail-fetch-field "really-from") (mail-fetch-field "sender")))) (goto-char (point-min)) ;; Depending on what encoding is supposed to be used, we make ;; a soup header. (setq head-line (cond ((or (= gnus-soup-encoding-type ?u) (= gnus-soup-encoding-type ?n)) ;;Gnus back compatibility. (format "#! rnews %d\n" (buffer-size))) ((= gnus-soup-encoding-type ?m) (while (search-forward "\nFrom " nil t) (replace-match "\n>From " t t)) (concat "From " (or from "unknown") " " (current-time-string) "\n")) ((= gnus-soup-encoding-type ?M) "\^a\^a\^a\^a\n") (t (error "Unsupported type: %c" gnus-soup-encoding-type)))) ;; Insert the soup header and the article in the MSG buf. (set-buffer msg-buf) (goto-char (point-max)) (insert head-line) (setq beg (point)) (insert-buffer-substring article-buf) ;; Insert the index in the IDX buf. (cond ((= index ?c) (set-buffer idx-buf) (gnus-soup-insert-idx beg headers)) ((/= index ?n) (error "Unknown index type: %c" type))) ;; Return the MSG buf. msg-buf))) (defun gnus-soup-group-brew (group &optional not-all) "Enter GROUP and add all articles to a SOUP package. If NOT-ALL, don't pack ticked articles." (let ((gnus-expert-user t) (gnus-large-newsgroup nil) (entry (gnus-group-entry group))) (when (or (null entry) (eq (car entry) t) (and (car entry) (> (car entry) 0)) (and (not not-all) (gnus-range-length (cdr (assq 'tick (gnus-info-marks (nth 2 entry))))))) (when (gnus-summary-read-group group nil t) (setq gnus-newsgroup-processable (reverse (if (not not-all) (append gnus-newsgroup-marked gnus-newsgroup-unreads) gnus-newsgroup-unreads))) (gnus-soup-add-article nil) (gnus-summary-exit))))) (defun gnus-soup-insert-idx (offset header) ;; [number subject from date id references chars lines xref] (goto-char (point-max)) (insert (format "%d\t%s\t%s\t%s\t%s\t%s\t%d\t%s\t\t\n" offset (or (mail-header-subject header) "(none)") (or (mail-header-from header) "(nobody)") (or (mail-header-date header) "") (or (mail-header-id header) (concat "soup-dummy-id-" (mapconcat (lambda (time) (int-to-string time)) (current-time) "-"))) (or (mail-header-references header) "") (or (mail-header-chars header) 0) (or (mail-header-lines header) "0")))) (defun gnus-soup-save-areas () "Write all SOUP buffers." (interactive) (gnus-soup-write-areas) (save-excursion (let (buf) (while gnus-soup-buffers (setq buf (car gnus-soup-buffers) gnus-soup-buffers (cdr gnus-soup-buffers)) (if (not (buffer-name buf)) () (set-buffer buf) (when (buffer-modified-p) (save-buffer)) (kill-buffer (current-buffer))))) (gnus-soup-write-prefixes))) (defun gnus-soup-write-prefixes () (let ((prefixes gnus-soup-last-prefix) prefix) (save-excursion (gnus-set-work-buffer) (while (setq prefix (pop prefixes)) (erase-buffer) (insert (format "(setq gnus-soup-prev-prefix %d)\n" (cdr prefix))) (let ((coding-system-for-write mm-text-coding-system)) (gnus-write-buffer (concat (car prefix) gnus-soup-prefix-file))))))) (defun gnus-soup-pack (dir packer) (let* ((files (mapconcat 'identity '("AREAS" "*.MSG" "*.IDX" "INFO" "LIST" "REPLIES" "COMMANDS" "ERRORS") " ")) (packer (if (< (string-match "%s" packer) (string-match "%d" packer)) (format packer files (string-to-number (gnus-soup-unique-prefix dir))) (format packer (string-to-number (gnus-soup-unique-prefix dir)) files))) (dir (expand-file-name dir))) (gnus-make-directory dir) (setq gnus-soup-areas nil) (gnus-message 4 "Packing %s..." packer) (if (eq 0 (call-process shell-file-name nil nil nil shell-command-switch (concat "cd " dir " ; " packer))) (progn (call-process shell-file-name nil nil nil shell-command-switch (concat "cd " dir " ; rm " files)) (gnus-message 4 "Packing...done" packer)) (error "Couldn't pack packet")))) (defun gnus-soup-parse-areas (file) "Parse soup area file FILE. The result is a of vectors, each containing one entry from the AREA file. The vector contain five strings, [prefix name encoding description number] though the two last may be nil if they are missing." (let (areas) (when (file-exists-p file) (save-excursion (set-buffer (nnheader-find-file-noselect file 'force)) (buffer-disable-undo) (goto-char (point-min)) (while (not (eobp)) (push (vector (gnus-soup-field) (gnus-soup-field) (gnus-soup-field) (and (eq (preceding-char) ?\t) (gnus-soup-field)) (and (eq (preceding-char) ?\t) (string-to-number (gnus-soup-field)))) areas) (when (eq (preceding-char) ?\t) (beginning-of-line 2))) (kill-buffer (current-buffer)))) areas)) (defun gnus-soup-parse-replies (file) "Parse soup REPLIES file FILE. The result is a of vectors, each containing one entry from the REPLIES file. The vector contain three strings, [prefix name encoding]." (let (replies) (save-excursion (set-buffer (nnheader-find-file-noselect file)) (buffer-disable-undo) (goto-char (point-min)) (while (not (eobp)) (push (vector (gnus-soup-field) (gnus-soup-field) (gnus-soup-field)) replies) (when (eq (preceding-char) ?\t) (beginning-of-line 2))) (kill-buffer (current-buffer))) replies)) (defun gnus-soup-field () (prog1 (buffer-substring (point) (progn (skip-chars-forward "^\t\n") (point))) (forward-char 1))) (defun gnus-soup-read-areas () (or gnus-soup-areas (setq gnus-soup-areas (gnus-soup-parse-areas (concat gnus-soup-directory "AREAS"))))) (defun gnus-soup-write-areas () "Write the AREAS file." (interactive) (when gnus-soup-areas (with-temp-file (concat gnus-soup-directory "AREAS") (let ((areas gnus-soup-areas) area) (while (setq area (pop areas)) (insert (format "%s\t%s\t%s%s\n" (gnus-soup-area-prefix area) (gnus-soup-area-name area) (gnus-soup-area-encoding area) (if (or (gnus-soup-area-description area) (gnus-soup-area-number area)) (concat "\t" (or (gnus-soup-area-description area) "") (if (gnus-soup-area-number area) (concat "\t" (int-to-string (gnus-soup-area-number area))) "")) "")))))))) (defun gnus-soup-write-replies (dir areas) "Write a REPLIES file in DIR containing AREAS." (with-temp-file (concat dir "REPLIES") (let (area) (while (setq area (pop areas)) (insert (format "%s\t%s\t%s\n" (gnus-soup-reply-prefix area) (gnus-soup-reply-kind area) (gnus-soup-reply-encoding area))))))) (defun gnus-soup-area (group) (gnus-soup-read-areas) (let ((areas gnus-soup-areas) (real-group (gnus-group-real-name group)) area result) (while areas (setq area (car areas) areas (cdr areas)) (when (equal (gnus-soup-area-name area) real-group) (setq result area))) (unless result (setq result (vector (gnus-soup-unique-prefix) real-group (format "%c%c%c" gnus-soup-encoding-type gnus-soup-index-type (if (gnus-member-of-valid 'mail group) ?m ?n)) nil nil) gnus-soup-areas (cons result gnus-soup-areas))) result)) (defun gnus-soup-unique-prefix (&optional dir) (let* ((dir (file-name-as-directory (or dir gnus-soup-directory))) (entry (assoc dir gnus-soup-last-prefix)) gnus-soup-prev-prefix) (if entry () (when (file-exists-p (concat dir gnus-soup-prefix-file)) (ignore-errors (load (concat dir gnus-soup-prefix-file) nil t t))) (push (setq entry (cons dir (or gnus-soup-prev-prefix 0))) gnus-soup-last-prefix)) (setcdr entry (1+ (cdr entry))) (gnus-soup-write-prefixes) (int-to-string (cdr entry)))) (defun gnus-soup-unpack-packet (dir unpacker packet) "Unpack PACKET into DIR using UNPACKER. Return whether the unpacking was successful." (gnus-make-directory dir) (gnus-message 4 "Unpacking: %s" (format unpacker packet)) (prog1 (eq 0 (call-process shell-file-name nil nil nil shell-command-switch (format "cd %s ; %s" (expand-file-name dir) (format unpacker packet)))) (gnus-message 4 "Unpacking...done"))) (defun gnus-soup-send-packet (packet) (gnus-soup-unpack-packet gnus-soup-replies-directory gnus-soup-unpacker packet) (let ((replies (gnus-soup-parse-replies (concat gnus-soup-replies-directory "REPLIES")))) (save-excursion (while replies (let* ((msg-file (concat gnus-soup-replies-directory (gnus-soup-reply-prefix (car replies)) ".MSG")) (msg-buf (and (file-exists-p msg-file) (nnheader-find-file-noselect msg-file))) (tmp-buf (gnus-get-buffer-create " *soup send*")) beg end) (cond ((and (/= (gnus-soup-encoding-format (gnus-soup-reply-encoding (car replies))) ?u) (/= (gnus-soup-encoding-format (gnus-soup-reply-encoding (car replies))) ?n)) ;; Gnus back compatibility. (error "Unsupported encoding")) ((null msg-buf) t) (t (buffer-disable-undo msg-buf) (set-buffer msg-buf) (goto-char (point-min)) (while (not (eobp)) (unless (looking-at "#! *rnews +\\([0-9]+\\)") (error "Bad header")) (forward-line 1) (setq beg (point) end (+ (point) (string-to-number (buffer-substring (match-beginning 1) (match-end 1))))) (switch-to-buffer tmp-buf) (erase-buffer) (mm-disable-multibyte) (insert-buffer-substring msg-buf beg end) (cond ((string= (gnus-soup-reply-kind (car replies)) "news") (gnus-message 5 "Sending news message to %s..." (mail-fetch-field "newsgroups")) (sit-for 1) (let ((message-syntax-checks 'dont-check-for-anything-just-trust-me) (method (if (functionp message-post-method) (funcall message-post-method) message-post-method)) result) (run-hooks 'message-send-news-hook) (gnus-open-server method) (message "Sending news via %s..." (gnus-server-string method)) (unless (let ((mail-header-separator "")) (gnus-request-post method)) (message "Couldn't send message via news: %s" (nnheader-get-report (car method)))))) ((string= (gnus-soup-reply-kind (car replies)) "mail") (gnus-message 5 "Sending mail to %s..." (mail-fetch-field "to")) (sit-for 1) (let ((mail-header-separator "")) (funcall (or message-send-mail-real-function message-send-mail-function)))) (t (error "Unknown reply kind"))) (set-buffer msg-buf) (goto-char end)) (delete-file (buffer-file-name)) (kill-buffer msg-buf) (kill-buffer tmp-buf) (gnus-message 4 "Sent packet")))) (setq replies (cdr replies))) t))) (provide 'gnus-soup) ;; arch-tag: eddfa69d-13e8-4aea-84ef-62a526ef185c ;;; gnus-soup.el ends here gnus-5.11+v0.10.dfsg/lisp/uudecode.el0000644000175000017500000001665411004005110017354 0ustar tvainikatvainika;;; uudecode.el -- elisp native uudecode ;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, ;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc. ;; Author: Shenghuo Zhu ;; Keywords: uudecode news ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 3, or (at your option) ;; any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Commentary: ;;; Code: (eval-when-compile (require 'cl)) (eval-and-compile (defalias 'uudecode-char-int (if (fboundp 'char-int) 'char-int 'identity))) (defgroup uudecode nil "Decoding of uuencoded data." :group 'mail :group 'news) (defcustom uudecode-decoder-program "uudecode" "*Non-nil value should be a string that names a uu decoder. The program should expect to read uu data on its standard input and write the converted data to its standard output." :type 'string :group 'uudecode) (defcustom uudecode-decoder-switches nil "*List of command line flags passed to `uudecode-decoder-program'." :group 'uudecode :type '(repeat string)) (defcustom uudecode-use-external (executable-find uudecode-decoder-program) "*Use external uudecode program." :version "22.1" :group 'uudecode :type 'boolean) (defconst uudecode-alphabet "\040-\140") (defconst uudecode-begin-line "^begin[ \t]+[0-7][0-7][0-7][ \t]+\\(.*\\)$") (defconst uudecode-end-line "^end[ \t]*$") (defconst uudecode-body-line (let ((i 61) (str "^M")) (while (> (setq i (1- i)) 0) (setq str (concat str "[^a-z]"))) (concat str ".?$"))) (defvar uudecode-temporary-file-directory (cond ((fboundp 'temp-directory) (temp-directory)) ((boundp 'temporary-file-directory) temporary-file-directory) ("/tmp"))) ;;;###autoload (defun uudecode-decode-region-external (start end &optional file-name) "Uudecode region between START and END using external program. If FILE-NAME is non-nil, save the result to FILE-NAME. The program used is specified by `uudecode-decoder-program'." (interactive "r\nP") (let ((cbuf (current-buffer)) tempfile firstline status) (save-excursion (goto-char start) (when (re-search-forward uudecode-begin-line nil t) (forward-line 1) (setq firstline (point)) (cond ((null file-name)) ((stringp file-name)) (t (setq file-name (read-file-name "File to Name:" nil nil nil (match-string 1))))) (setq tempfile (if file-name (expand-file-name file-name) (if (fboundp 'make-temp-file) (let ((temporary-file-directory uudecode-temporary-file-directory)) (make-temp-file "uu")) (expand-file-name (make-temp-name "uu") uudecode-temporary-file-directory)))) (let ((cdir default-directory) (default-process-coding-system (if (featurep 'xemacs) ;; In XEmacs, `nil' is not a valid coding system. '(binary . binary) nil))) (unwind-protect (with-temp-buffer (insert "begin 600 " (file-name-nondirectory tempfile) "\n") (insert-buffer-substring cbuf firstline end) (cd (file-name-directory tempfile)) (apply 'call-process-region (point-min) (point-max) uudecode-decoder-program nil nil nil uudecode-decoder-switches)) (cd cdir) (set-buffer cbuf))) (if (file-exists-p tempfile) (unless file-name (goto-char start) (delete-region start end) (let (format-alist) (insert-file-contents-literally tempfile))) (message "Can not uudecode"))) (ignore-errors (or file-name (delete-file tempfile)))))) (eval-and-compile (defalias 'uudecode-string-to-multibyte (cond ((featurep 'xemacs) 'identity) ((fboundp 'string-to-multibyte) 'string-to-multibyte) (t (lambda (string) "Return a multibyte string with the same individual chars as string." (mapconcat (lambda (ch) (string-as-multibyte (char-to-string ch))) string "")))))) ;;;###autoload (defun uudecode-decode-region-internal (start end &optional file-name) "Uudecode region between START and END without using an external program. If FILE-NAME is non-nil, save the result to FILE-NAME." (interactive "r\nP") (let ((done nil) (counter 0) (remain 0) (bits 0) (lim 0) inputpos result (non-data-chars (concat "^" uudecode-alphabet))) (save-excursion (goto-char start) (when (re-search-forward uudecode-begin-line nil t) (cond ((null file-name)) ((stringp file-name)) (t (setq file-name (expand-file-name (read-file-name "File to Name:" nil nil nil (match-string 1)))))) (forward-line 1) (skip-chars-forward non-data-chars end) (while (not done) (setq inputpos (point)) (setq remain 0 bits 0 counter 0) (cond ((> (skip-chars-forward uudecode-alphabet end) 0) (setq lim (point)) (setq remain (logand (- (uudecode-char-int (char-after inputpos)) 32) 63)) (setq inputpos (1+ inputpos)) (if (= remain 0) (setq done t)) (while (and (< inputpos lim) (> remain 0)) (setq bits (+ bits (logand (- (uudecode-char-int (char-after inputpos)) 32) 63))) (if (/= counter 0) (setq remain (1- remain))) (setq counter (1+ counter) inputpos (1+ inputpos)) (cond ((= counter 4) (setq result (cons (concat (char-to-string (lsh bits -16)) (char-to-string (logand (lsh bits -8) 255)) (char-to-string (logand bits 255))) result)) (setq bits 0 counter 0)) (t (setq bits (lsh bits 6))))))) (cond (done) ((> 0 remain) (error "uucode line ends unexpectly") (setq done t)) ((and (= (point) end) (not done)) ;;(error "uucode ends unexpectly") (setq done t)) ((= counter 3) (setq result (cons (concat (char-to-string (logand (lsh bits -16) 255)) (char-to-string (logand (lsh bits -8) 255))) result))) ((= counter 2) (setq result (cons (char-to-string (logand (lsh bits -10) 255)) result)))) (skip-chars-forward non-data-chars end)) (if file-name (with-temp-file file-name (set-buffer-multibyte nil) (insert (apply 'concat (nreverse result)))) (or (markerp end) (setq end (set-marker (make-marker) end))) (goto-char start) (if enable-multibyte-characters (dolist (x (nreverse result)) (insert (uudecode-string-to-multibyte x))) (insert (apply 'concat (nreverse result)))) (delete-region (point) end)))))) ;;;###autoload (defun uudecode-decode-region (start end &optional file-name) "Uudecode region between START and END. If FILE-NAME is non-nil, save the result to FILE-NAME." (if uudecode-use-external (uudecode-decode-region-external start end file-name) (uudecode-decode-region-internal start end file-name))) (provide 'uudecode) ;; arch-tag: e1f09ed5-62b4-4677-9f13-4e81c4fe8ce3 ;;; uudecode.el ends here gnus-5.11+v0.10.dfsg/lisp/gnus-picon.el0000644000175000017500000002436111004005110017633 0ustar tvainikatvainika;;; gnus-picon.el --- displaying pretty icons in Gnus ;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, ;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; Keywords: news xpm annotation glyph faces ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 3, or (at your option) ;; any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Commentary: ;; There are three picon types relevant to Gnus: ;; ;; Persons: person@subdomain.dom ;; users/dom/subdomain/person/face.gif ;; usenix/dom/subdomain/person/face.gif ;; misc/MISC/person/face.gif ;; Domains: subdomain.dom ;; domain/dom/subdomain/unknown/face.gif ;; Groups: comp.lang.lisp ;; news/comp/lang/lisp/unknown/face.gif ;; ;; Original implementation by Wes Hardaker . ;; ;;; Code: (eval-when-compile (require 'cl)) (require 'gnus) (require 'gnus-art) ;;; User variables: (defcustom gnus-picon-news-directories '("news") "*List of directories to search for newsgroups faces." :type '(repeat string) :group 'gnus-picon) (defcustom gnus-picon-user-directories '("users" "usenix" "local" "misc") "*List of directories to search for user faces." :type '(repeat string) :group 'gnus-picon) (defcustom gnus-picon-domain-directories '("domains") "*List of directories to search for domain faces. Some people may want to add \"unknown\" to this list." :type '(repeat string) :group 'gnus-picon) (defcustom gnus-picon-file-types (let ((types (list "xbm"))) (when (gnus-image-type-available-p 'gif) (push "gif" types)) (when (gnus-image-type-available-p 'xpm) (push "xpm" types)) types) "*List of suffixes on picon file names to try." :type '(repeat string) :group 'gnus-picon) (defcustom gnus-picon-style 'inline "How should picons be displayed. If `inline', the textual representation is replaced. If `right', picons are added right to the textual representation." ;; FIXME: `right' needs improvement for XEmacs. :type '(choice (const inline) (const right)) :group 'gnus-picon) (defface gnus-picon-xbm '((t (:foreground "black" :background "white"))) "Face to show xbm picon in." :group 'gnus-picon) ;; backward-compatibility alias (put 'gnus-picon-xbm-face 'face-alias 'gnus-picon-xbm) (defface gnus-picon '((t (:foreground "black" :background "white"))) "Face to show picon in." :group 'gnus-picon) ;; backward-compatibility alias (put 'gnus-picon-face 'face-alias 'gnus-picon) ;;; Internal variables: (defvar gnus-picon-setup-p nil) (defvar gnus-picon-glyph-alist nil "Picon glyphs cache. List of pairs (KEY . GLYPH) where KEY is either a filename or an URL.") (defvar gnus-picon-cache nil) ;;; Functions: (defsubst gnus-picon-split-address (address) (setq address (split-string address "@")) (if (stringp (cadr address)) (cons (car address) (split-string (cadr address) "\\.")) (if (stringp (car address)) (split-string (car address) "\\.")))) (defun gnus-picon-find-face (address directories &optional exact) (let* ((address (gnus-picon-split-address address)) (user (pop address)) (faddress address) database directory result instance base) (catch 'found (dolist (database gnus-picon-databases) (dolist (directory directories) (setq address faddress base (expand-file-name directory database)) (while address (when (setq result (gnus-picon-find-image (concat base "/" (mapconcat 'downcase (reverse address) "/") "/" (downcase user) "/"))) (throw 'found result)) (if exact (setq address nil) (pop address))) ;; Kludge to search MISC as well. But not in "news". (unless (string= directory "news") (when (setq result (gnus-picon-find-image (concat base "/MISC/" user "/"))) (throw 'found result)))))))) (defun gnus-picon-find-image (directory) (let ((types gnus-picon-file-types) found type file) (while (and (not found) (setq type (pop types))) (setq found (file-exists-p (setq file (concat directory "face." type))))) (if found file nil))) (defun gnus-picon-insert-glyph (glyph category &optional nostring) "Insert GLYPH into the buffer. GLYPH can be either a glyph or a string. When NOSTRING, no textual replacement is added." ;; Using NOSTRING prevents wrong BBDB entries with `gnus-picon-style' set to ;; 'right. (if (stringp glyph) (insert glyph) (gnus-add-wash-type category) (gnus-add-image category (car glyph)) (gnus-put-image (car glyph) (unless nostring (cdr glyph)) category))) (defun gnus-picon-create-glyph (file) (or (cdr (assoc file gnus-picon-glyph-alist)) (cdar (push (cons file (gnus-create-image file)) gnus-picon-glyph-alist)))) ;;; Functions that does picon transformations: (defun gnus-picon-transform-address (header category) (gnus-with-article-headers (let ((addresses (mail-header-parse-addresses ;; mail-header-parse-addresses does not work (reliably) on ;; decoded headers. (or (ignore-errors (mail-encode-encoded-word-string (or (mail-fetch-field header) ""))) (mail-fetch-field header)))) spec file point cache len) (dolist (address addresses) (setq address (car address)) (when (and (stringp address) (setq spec (gnus-picon-split-address address))) (if (setq cache (cdr (assoc address gnus-picon-cache))) (setq spec cache) (when (setq file (or (gnus-picon-find-face address gnus-picon-user-directories) (gnus-picon-find-face (concat "unknown@" (mapconcat 'identity (cdr spec) ".")) gnus-picon-user-directories))) (setcar spec (cons (gnus-picon-create-glyph file) (car spec)))) (dotimes (i (1- (length spec))) (when (setq file (gnus-picon-find-face (concat "unknown@" (mapconcat 'identity (nthcdr (1+ i) spec) ".")) gnus-picon-domain-directories t)) (setcar (nthcdr (1+ i) spec) (cons (gnus-picon-create-glyph file) (nth (1+ i) spec))))) (setq spec (nreverse spec)) (push (cons address spec) gnus-picon-cache)) (gnus-article-goto-header header) (mail-header-narrow-to-field) (case gnus-picon-style (right (when (= (length addresses) 1) (setq len (apply '+ (mapcar (lambda (x) (condition-case nil (car (image-size (car x))) (error 0))) spec))) (when (> len 0) (goto-char (point-at-eol)) (insert (propertize " " 'display (cons 'space (list :align-to (- (window-width) 1 len)))))) (goto-char (point-at-eol)) (setq point (point-at-eol)) (dolist (image spec) (unless (stringp image) (goto-char point) (gnus-picon-insert-glyph image category 'nostring))))) (inline (when (search-forward address nil t) (delete-region (match-beginning 0) (match-end 0)) (setq point (point)) (while spec (goto-char point) (if (> (length spec) 2) (insert ".") (if (= (length spec) 2) (insert "@"))) (gnus-picon-insert-glyph (pop spec) category)))))))))) (defun gnus-picon-transform-newsgroups (header) (interactive) (gnus-with-article-headers (gnus-article-goto-header header) (mail-header-narrow-to-field) (let ((groups (message-tokenize-header (mail-fetch-field header))) spec file point) (dolist (group groups) (unless (setq spec (cdr (assoc group gnus-picon-cache))) (setq spec (nreverse (split-string group "[.]"))) (dotimes (i (length spec)) (when (setq file (gnus-picon-find-face (concat "unknown@" (mapconcat 'identity (nthcdr i spec) ".")) gnus-picon-news-directories t)) (setcar (nthcdr i spec) (cons (gnus-picon-create-glyph file) (nth i spec))))) (push (cons group spec) gnus-picon-cache)) (when (search-forward group nil t) (delete-region (match-beginning 0) (match-end 0)) (save-restriction (narrow-to-region (point) (point)) (while spec (goto-char (point-min)) (if (> (length spec) 1) (insert ".")) (gnus-picon-insert-glyph (pop spec) 'newsgroups-picon)) (goto-char (point-max)))))))) ;;; Commands: ;; #### NOTE: the test for buffer-read-only is the same as in ;; article-display-[x-]face. See the comment up there. ;;;###autoload (defun gnus-treat-from-picon () "Display picons in the From header. If picons are already displayed, remove them." (interactive) (let ((wash-picon-p buffer-read-only)) (gnus-with-article-buffer (if (and wash-picon-p (memq 'from-picon gnus-article-wash-types)) (gnus-delete-images 'from-picon) (gnus-picon-transform-address "from" 'from-picon))))) ;;;###autoload (defun gnus-treat-mail-picon () "Display picons in the Cc and To headers. If picons are already displayed, remove them." (interactive) (let ((wash-picon-p buffer-read-only)) (gnus-with-article-buffer (if (and wash-picon-p (memq 'mail-picon gnus-article-wash-types)) (gnus-delete-images 'mail-picon) (gnus-picon-transform-address "cc" 'mail-picon) (gnus-picon-transform-address "to" 'mail-picon))))) ;;;###autoload (defun gnus-treat-newsgroups-picon () "Display picons in the Newsgroups and Followup-To headers. If picons are already displayed, remove them." (interactive) (let ((wash-picon-p buffer-read-only)) (gnus-with-article-buffer (if (and wash-picon-p (memq 'newsgroups-picon gnus-article-wash-types)) (gnus-delete-images 'newsgroups-picon) (gnus-picon-transform-newsgroups "newsgroups") (gnus-picon-transform-newsgroups "followup-to"))))) (provide 'gnus-picon) ;; arch-tag: fe9aede0-1b1b-463a-b4ab-807f98bcb31f ;;; gnus-picon.el ends here gnus-5.11+v0.10.dfsg/lisp/gnus-agent.el0000644000175000017500000047354411004005111017635 0ustar tvainikatvainika;;; gnus-agent.el --- unplugged support for Gnus ;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, ;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 3, or (at your option) ;; any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Commentary: ;;; Code: (require 'gnus) (require 'gnus-cache) (require 'nnmail) (require 'nnvirtual) (require 'gnus-sum) (require 'gnus-score) (require 'gnus-srvr) (require 'gnus-util) (eval-when-compile (if (featurep 'xemacs) (require 'itimer) (require 'timer)) (require 'cl)) (eval-and-compile (autoload 'gnus-server-update-server "gnus-srvr") (autoload 'gnus-agent-customize-category "gnus-cus") ) (defcustom gnus-agent-directory (nnheader-concat gnus-directory "agent/") "Where the Gnus agent will store its files." :group 'gnus-agent :type 'directory) (defcustom gnus-agent-plugged-hook nil "Hook run when plugging into the network." :group 'gnus-agent :type 'hook) (defcustom gnus-agent-unplugged-hook nil "Hook run when unplugging from the network." :group 'gnus-agent :type 'hook) (defcustom gnus-agent-fetched-hook nil "Hook run when finished fetching articles." :version "22.1" :group 'gnus-agent :type 'hook) (defcustom gnus-agent-handle-level gnus-level-subscribed "Groups on levels higher than this variable will be ignored by the Agent." :group 'gnus-agent :type 'integer) (defcustom gnus-agent-expire-days 7 "Read articles older than this will be expired. If you wish to disable Agent expiring, see `gnus-agent-enable-expiration'." :group 'gnus-agent :type '(number :tag "days")) (defcustom gnus-agent-expire-all nil "If non-nil, also expire unread, ticked and dormant articles. If nil, only read articles will be expired." :group 'gnus-agent :type 'boolean) (defcustom gnus-agent-group-mode-hook nil "Hook run in Agent group minor modes." :group 'gnus-agent :type 'hook) ;; Extracted from gnus-xmas-redefine in order to preserve user settings (when (featurep 'xemacs) (add-hook 'gnus-agent-group-mode-hook 'gnus-xmas-agent-group-menu-add)) (defcustom gnus-agent-summary-mode-hook nil "Hook run in Agent summary minor modes." :group 'gnus-agent :type 'hook) ;; Extracted from gnus-xmas-redefine in order to preserve user settings (when (featurep 'xemacs) (add-hook 'gnus-agent-summary-mode-hook 'gnus-xmas-agent-summary-menu-add)) (defcustom gnus-agent-server-mode-hook nil "Hook run in Agent summary minor modes." :group 'gnus-agent :type 'hook) ;; Extracted from gnus-xmas-redefine in order to preserve user settings (when (featurep 'xemacs) (add-hook 'gnus-agent-server-mode-hook 'gnus-xmas-agent-server-menu-add)) (defcustom gnus-agent-confirmation-function 'y-or-n-p "Function to confirm when error happens." :version "21.1" :group 'gnus-agent :type 'function) (defcustom gnus-agent-synchronize-flags nil "Indicate if flags are synchronized when you plug in. If this is `ask' the hook will query the user." ;; If the default switches to something else than nil, then the function ;; should be fixed not be exceedingly slow. See 2005-09-20 ChangeLog entry. :version "21.1" :type '(choice (const :tag "Always" t) (const :tag "Never" nil) (const :tag "Ask" ask)) :group 'gnus-agent) (defcustom gnus-agent-go-online 'ask "Indicate if offline servers go online when you plug in. If this is `ask' the hook will query the user." :version "21.3" :type '(choice (const :tag "Always" t) (const :tag "Never" nil) (const :tag "Ask" ask)) :group 'gnus-agent) (defcustom gnus-agent-mark-unread-after-downloaded t "Indicate whether to mark articles unread after downloaded." :version "21.1" :type 'boolean :group 'gnus-agent) (defcustom gnus-agent-download-marks '(download) "Marks for downloading." :version "21.1" :type '(repeat (symbol :tag "Mark")) :group 'gnus-agent) (defcustom gnus-agent-consider-all-articles nil "When non-nil, the agent will let the agent predicate decide whether articles need to be downloaded or not, for all articles. When nil, the default, the agent will only let the predicate decide whether unread articles are downloaded or not. If you enable this, groups with large active ranges may open slower and you may also want to look into the agent expiry settings to block the expiration of read articles as they would just be downloaded again." :version "22.1" :type 'boolean :group 'gnus-agent) (defcustom gnus-agent-max-fetch-size 10000000 ;; 10 Mb "Chunk size for `gnus-agent-fetch-session'. The function will split its article fetches into chunks smaller than this limit." :version "22.1" :group 'gnus-agent :type 'integer) (defcustom gnus-agent-enable-expiration 'ENABLE "The default expiration state for each group. When set to ENABLE, the default, `gnus-agent-expire' will expire old contents from a group's local storage. This value may be overridden to disable expiration in specific categories, topics, and groups. Of course, you could change gnus-agent-enable-expiration to DISABLE then enable expiration per categories, topics, and groups." :version "22.1" :group 'gnus-agent :type '(radio (const :format "Enable " ENABLE) (const :format "Disable " DISABLE))) (defcustom gnus-agent-expire-unagentized-dirs t "*Whether expiration should expire in unagentized directories. Have gnus-agent-expire scan the directories under \(gnus-agent-directory) for groups that are no longer agentized. When found, offer to remove them." :version "22.1" :type 'boolean :group 'gnus-agent) (defcustom gnus-agent-auto-agentize-methods '(nntp nnimap) "Initially, all servers from these methods are agentized. The user may remove or add servers using the Server buffer. See Info node `(gnus)Server Buffer'." :version "22.1" :type '(repeat symbol) :group 'gnus-agent) (defcustom gnus-agent-queue-mail t "Whether and when outgoing mail should be queued by the agent. When `always', always queue outgoing mail. When nil, never queue. Otherwise, queue if and only if unplugged." :version "22.1" :group 'gnus-agent :type '(radio (const :format "Always" always) (const :format "Never" nil) (const :format "When unplugged" t))) (defcustom gnus-agent-prompt-send-queue nil "If non-nil, `gnus-group-send-queue' will prompt if called when unplugged." :version "22.1" :group 'gnus-agent :type 'boolean) (defcustom gnus-agent-article-alist-save-format 1 "Indicates whether to use compression(2), versus no compression(1), when writing agentview files. The compressed files do save space but load times are 6-7 times higher. A group must be opened then closed for the agentview to be updated using the new format." ;; Wouldn't symbols instead numbers be nicer? --rsteib :version "22.1" :group 'gnus-agent :type '(radio (const :format "Compressed" 2) (const :format "Uncompressed" 1))) ;;; Internal variables (defvar gnus-agent-history-buffers nil) (defvar gnus-agent-buffer-alist nil) (defvar gnus-agent-article-alist nil "An assoc list identifying the articles whose headers have been fetched. If successfully fetched, these headers will be stored in the group's overview file. The key of each assoc pair is the article ID, the value of each assoc pair is a flag indicating whether the identified article has been downloaded \(gnus-agent-fetch-articles sets the value to the day of the download). NOTES: 1) The last element of this list can not be expired as some routines (for example, get-agent-fetch-headers) use the last value to track which articles have had their headers retrieved. 2) The function `gnus-agent-regenerate' may destructively modify the value.") (defvar gnus-agent-group-alist nil) (defvar gnus-category-alist nil) (defvar gnus-agent-current-history nil) (defvar gnus-agent-overview-buffer nil) (defvar gnus-category-predicate-cache nil) (defvar gnus-category-group-cache nil) (defvar gnus-agent-spam-hashtb nil) (defvar gnus-agent-file-name nil) (defvar gnus-agent-send-mail-function nil) (defvar gnus-agent-file-coding-system 'raw-text) (defvar gnus-agent-file-loading-cache nil) (defvar gnus-agent-total-fetched-hashtb nil) (defvar gnus-agent-inhibit-update-total-fetched-for nil) (defvar gnus-agent-need-update-total-fetched-for nil) ;; Dynamic variables (defvar gnus-headers) (defvar gnus-score) ;; Added to support XEmacs (eval-and-compile (unless (fboundp 'directory-files-and-attributes) (defun directory-files-and-attributes (directory &optional full match nosort) (let (result) (dolist (file (directory-files directory full match nosort)) (push (cons file (file-attributes file)) result)) (nreverse result))))) ;;; ;;; Setup ;;; (defun gnus-open-agent () (setq gnus-agent t) (gnus-agent-read-servers) (gnus-category-read) (gnus-agent-create-buffer) (add-hook 'gnus-group-mode-hook 'gnus-agent-mode) (add-hook 'gnus-summary-mode-hook 'gnus-agent-mode) (add-hook 'gnus-server-mode-hook 'gnus-agent-mode)) (defun gnus-agent-create-buffer () (if (gnus-buffer-live-p gnus-agent-overview-buffer) t (setq gnus-agent-overview-buffer (gnus-get-buffer-create " *Gnus agent overview*")) (with-current-buffer gnus-agent-overview-buffer (mm-enable-multibyte)) nil)) (gnus-add-shutdown 'gnus-close-agent 'gnus) (defun gnus-close-agent () (setq gnus-category-predicate-cache nil gnus-category-group-cache nil gnus-agent-spam-hashtb nil) (gnus-kill-buffer gnus-agent-overview-buffer)) ;;; ;;; Utility functions ;;; (defmacro gnus-agent-with-refreshed-group (group &rest body) "Performs the body then updates the group's line in the group buffer. Automatically blocks multiple updates due to recursion." `(prog1 (let ((gnus-agent-inhibit-update-total-fetched-for t)) ,@body) (when (and gnus-agent-need-update-total-fetched-for (not gnus-agent-inhibit-update-total-fetched-for)) (save-excursion (set-buffer gnus-group-buffer) (setq gnus-agent-need-update-total-fetched-for nil) (gnus-group-update-group ,group t))))) (defun gnus-agent-read-file (file) "Load FILE and do a `read' there." (with-temp-buffer (ignore-errors (nnheader-insert-file-contents file) (goto-char (point-min)) (read (current-buffer))))) (defsubst gnus-agent-method () (concat (symbol-name (car gnus-command-method)) "/" (if (equal (cadr gnus-command-method) "") "unnamed" (cadr gnus-command-method)))) (defsubst gnus-agent-directory () "The name of the Gnus agent directory." (nnheader-concat gnus-agent-directory (nnheader-translate-file-chars (gnus-agent-method)) "/")) (defun gnus-agent-lib-file (file) "The full name of the Gnus agent library FILE." (expand-file-name file (file-name-as-directory (expand-file-name "agent.lib" (gnus-agent-directory))))) (defun gnus-agent-cat-set-property (category property value) (if value (setcdr (or (assq property category) (let ((cell (cons property nil))) (setcdr category (cons cell (cdr category))) cell)) value) (let ((category category)) (while (cond ((eq property (caadr category)) (setcdr category (cddr category)) nil) (t (setq category (cdr category))))))) category) (eval-when-compile (defmacro gnus-agent-cat-defaccessor (name prop-name) "Define accessor and setter methods for manipulating a list of the form \(NAME (PROPERTY1 VALUE1) ... (PROPERTY_N VALUE_N)). Given the call (gnus-agent-cat-defaccessor func PROPERTY1), the list may be manipulated as follows: (func LIST): Returns VALUE1 (setf (func LIST) NEW_VALUE1): Replaces VALUE1 with NEW_VALUE1." `(progn (defmacro ,name (category) (list (quote cdr) (list (quote assq) (quote (quote ,prop-name)) category))) (define-setf-method ,name (category) (let* ((--category--temp-- (make-symbol "--category--")) (--value--temp-- (make-symbol "--value--"))) (list (list --category--temp--) ; temporary-variables (list category) ; value-forms (list --value--temp--) ; store-variables (let* ((category --category--temp--) ; store-form (value --value--temp--)) (list (quote gnus-agent-cat-set-property) category (quote (quote ,prop-name)) value)) (list (quote ,name) --category--temp--) ; access-form ))))) ) (defmacro gnus-agent-cat-name (category) `(car ,category)) (gnus-agent-cat-defaccessor gnus-agent-cat-days-until-old agent-days-until-old) (gnus-agent-cat-defaccessor gnus-agent-cat-enable-expiration agent-enable-expiration) (gnus-agent-cat-defaccessor gnus-agent-cat-groups agent-groups) (gnus-agent-cat-defaccessor gnus-agent-cat-high-score agent-high-score) (gnus-agent-cat-defaccessor gnus-agent-cat-length-when-long agent-long-article) (gnus-agent-cat-defaccessor gnus-agent-cat-length-when-short agent-short-article) (gnus-agent-cat-defaccessor gnus-agent-cat-low-score agent-low-score) (gnus-agent-cat-defaccessor gnus-agent-cat-predicate agent-predicate) (gnus-agent-cat-defaccessor gnus-agent-cat-score-file agent-score) (gnus-agent-cat-defaccessor gnus-agent-cat-enable-undownloaded-faces agent-enable-undownloaded-faces) ;; This form is equivalent to defsetf except that it calls make-symbol ;; whereas defsetf calls gensym (Using gensym creates a run-time ;; dependency on the CL library). (eval-and-compile (define-setf-method gnus-agent-cat-groups (category) (let* ((--category--temp-- (make-symbol "--category--")) (--groups--temp-- (make-symbol "--groups--"))) (list (list --category--temp--) (list category) (list --groups--temp--) (let* ((category --category--temp--) (groups --groups--temp--)) (list (quote gnus-agent-set-cat-groups) category groups)) (list (quote gnus-agent-cat-groups) --category--temp--)))) ) (defun gnus-agent-set-cat-groups (category groups) (unless (eq groups 'ignore) (let ((new-g groups) (old-g (gnus-agent-cat-groups category))) (cond ((eq new-g old-g) ;; gnus-agent-add-group is fiddling with the group ;; list. Still, Im done. nil ) ((eq new-g (cdr old-g)) ;; gnus-agent-add-group is fiddling with the group list (setcdr (or (assq 'agent-groups category) (let ((cell (cons 'agent-groups nil))) (setcdr category (cons cell (cdr category))) cell)) new-g)) (t (let ((groups groups)) (while groups (let* ((group (pop groups)) (old-category (gnus-group-category group))) (if (eq category old-category) nil (setf (gnus-agent-cat-groups old-category) (delete group (gnus-agent-cat-groups old-category)))))) ;; Purge cache as preceeding loop invalidated it. (setq gnus-category-group-cache nil)) (setcdr (or (assq 'agent-groups category) (let ((cell (cons 'agent-groups nil))) (setcdr category (cons cell (cdr category))) cell)) groups)))))) (defsubst gnus-agent-cat-make (name &optional default-agent-predicate) (list name `(agent-predicate . ,(or default-agent-predicate 'false)))) (defun gnus-agent-read-group () "Read a group name in the minibuffer, with completion." (let ((def (or (gnus-group-group-name) gnus-newsgroup-name))) (when def (setq def (gnus-group-decoded-name def))) (gnus-group-completing-read (if def (concat "Group Name (" def "): ") "Group Name: ") nil nil t nil nil def))) ;;; Fetching setup functions. (defun gnus-agent-start-fetch () "Initialize data structures for efficient fetching." (gnus-agent-create-buffer)) (defun gnus-agent-stop-fetch () "Save all data structures and clean up." (setq gnus-agent-spam-hashtb nil) (save-excursion (set-buffer nntp-server-buffer) (widen))) (defmacro gnus-agent-with-fetch (&rest forms) "Do FORMS safely." `(unwind-protect (let ((gnus-agent-fetching t)) (gnus-agent-start-fetch) ,@forms) (gnus-agent-stop-fetch))) (put 'gnus-agent-with-fetch 'lisp-indent-function 0) (put 'gnus-agent-with-fetch 'edebug-form-spec '(body)) (defmacro gnus-agent-append-to-list (tail value) `(setq ,tail (setcdr ,tail (cons ,value nil)))) (defmacro gnus-agent-message (level &rest args) `(if (<= ,level gnus-verbose) (message ,@args))) ;;; ;;; Mode infestation ;;; (defvar gnus-agent-mode-hook nil "Hook run when installing agent mode.") (defvar gnus-agent-mode nil) (defvar gnus-agent-mode-status '(gnus-agent-mode " Plugged")) (defun gnus-agent-mode () "Minor mode for providing a agent support in Gnus buffers." (let* ((buffer (progn (string-match "^gnus-\\(.*\\)-mode$" (symbol-name major-mode)) (match-string 1 (symbol-name major-mode)))) (mode (intern (format "gnus-agent-%s-mode" buffer)))) (set (make-local-variable 'gnus-agent-mode) t) (set mode nil) (set (make-local-variable mode) t) ;; Set up the menu. (when (gnus-visual-p 'agent-menu 'menu) (funcall (intern (format "gnus-agent-%s-make-menu-bar" buffer)))) (unless (assq 'gnus-agent-mode minor-mode-alist) (push gnus-agent-mode-status minor-mode-alist)) (unless (assq mode minor-mode-map-alist) (push (cons mode (symbol-value (intern (format "gnus-agent-%s-mode-map" buffer)))) minor-mode-map-alist)) (when (eq major-mode 'gnus-group-mode) (let ((init-plugged gnus-plugged) (gnus-agent-go-online nil)) ;; g-a-t-p does nothing when gnus-plugged isn't changed. ;; Therefore, make certain that the current value does not ;; match the desired initial value. (setq gnus-plugged :unknown) (gnus-agent-toggle-plugged init-plugged))) (gnus-run-hooks 'gnus-agent-mode-hook (intern (format "gnus-agent-%s-mode-hook" buffer))))) (defvar gnus-agent-group-mode-map (make-sparse-keymap)) (gnus-define-keys gnus-agent-group-mode-map "Ju" gnus-agent-fetch-groups "Jc" gnus-enter-category-buffer "Jj" gnus-agent-toggle-plugged "Js" gnus-agent-fetch-session "JY" gnus-agent-synchronize-flags "JS" gnus-group-send-queue "Ja" gnus-agent-add-group "Jr" gnus-agent-remove-group "Jo" gnus-agent-toggle-group-plugged) (defun gnus-agent-group-make-menu-bar () (unless (boundp 'gnus-agent-group-menu) (easy-menu-define gnus-agent-group-menu gnus-agent-group-mode-map "" '("Agent" ["Toggle plugged" gnus-agent-toggle-plugged t] ["Toggle group plugged" gnus-agent-toggle-group-plugged t] ["List categories" gnus-enter-category-buffer t] ["Add (current) group to category" gnus-agent-add-group t] ["Remove (current) group from category" gnus-agent-remove-group t] ["Send queue" gnus-group-send-queue gnus-plugged] ("Fetch" ["All" gnus-agent-fetch-session gnus-plugged] ["Group" gnus-agent-fetch-group gnus-plugged]) ["Synchronize flags" gnus-agent-synchronize-flags t] )))) (defvar gnus-agent-summary-mode-map (make-sparse-keymap)) (gnus-define-keys gnus-agent-summary-mode-map "Jj" gnus-agent-toggle-plugged "Ju" gnus-agent-summary-fetch-group "JS" gnus-agent-fetch-group "Js" gnus-agent-summary-fetch-series "J#" gnus-agent-mark-article "J\M-#" gnus-agent-unmark-article "@" gnus-agent-toggle-mark "Jc" gnus-agent-catchup) (defun gnus-agent-summary-make-menu-bar () (unless (boundp 'gnus-agent-summary-menu) (easy-menu-define gnus-agent-summary-menu gnus-agent-summary-mode-map "" '("Agent" ["Toggle plugged" gnus-agent-toggle-plugged t] ["Mark as downloadable" gnus-agent-mark-article t] ["Unmark as downloadable" gnus-agent-unmark-article t] ["Toggle mark" gnus-agent-toggle-mark t] ["Fetch downloadable" gnus-agent-summary-fetch-group t] ["Catchup undownloaded" gnus-agent-catchup t])))) (defvar gnus-agent-server-mode-map (make-sparse-keymap)) (gnus-define-keys gnus-agent-server-mode-map "Jj" gnus-agent-toggle-plugged "Ja" gnus-agent-add-server "Jr" gnus-agent-remove-server) (defun gnus-agent-server-make-menu-bar () (unless (boundp 'gnus-agent-server-menu) (easy-menu-define gnus-agent-server-menu gnus-agent-server-mode-map "" '("Agent" ["Toggle plugged" gnus-agent-toggle-plugged t] ["Add" gnus-agent-add-server t] ["Remove" gnus-agent-remove-server t])))) (defun gnus-agent-make-mode-line-string (string mouse-button mouse-func) (if (and (fboundp 'propertize) (fboundp 'make-mode-line-mouse-map)) (propertize string 'local-map (make-mode-line-mouse-map mouse-button mouse-func) 'mouse-face (cond ((and (featurep 'xemacs) ;; XEmacs' `facep' only checks for a face ;; object, not for a face name, so it's useless ;; to check with `facep'. (find-face 'modeline)) 'modeline) ((facep 'mode-line-highlight) ;; Emacs 22 'mode-line-highlight) ((facep 'mode-line) ;; Emacs 21 'mode-line)) ) string)) (defun gnus-agent-toggle-plugged (set-to) "Toggle whether Gnus is unplugged or not." (interactive (list (not gnus-plugged))) (cond ((eq set-to gnus-plugged) nil) (set-to (setq gnus-plugged set-to) (gnus-run-hooks 'gnus-agent-plugged-hook) (setcar (cdr gnus-agent-mode-status) (gnus-agent-make-mode-line-string " Plugged" 'mouse-2 'gnus-agent-toggle-plugged)) (gnus-agent-go-online gnus-agent-go-online)) (t (gnus-agent-close-connections) (setq gnus-plugged set-to) (gnus-run-hooks 'gnus-agent-unplugged-hook) (setcar (cdr gnus-agent-mode-status) (gnus-agent-make-mode-line-string " Unplugged" 'mouse-2 'gnus-agent-toggle-plugged)))) (set-buffer-modified-p t)) (defmacro gnus-agent-while-plugged (&rest body) `(let ((original-gnus-plugged gnus-plugged)) (unwind-protect (progn (gnus-agent-toggle-plugged t) ,@body) (gnus-agent-toggle-plugged original-gnus-plugged)))) (put 'gnus-agent-while-plugged 'lisp-indent-function 0) (put 'gnus-agent-while-plugged 'edebug-form-spec '(body)) (defun gnus-agent-close-connections () "Close all methods covered by the Gnus agent." (let ((methods (gnus-agent-covered-methods))) (while methods (gnus-close-server (pop methods))))) ;;;###autoload (defun gnus-unplugged () "Start Gnus unplugged." (interactive) (setq gnus-plugged nil) (gnus)) ;;;###autoload (defun gnus-plugged () "Start Gnus plugged." (interactive) (setq gnus-plugged t) (gnus)) ;;;###autoload (defun gnus-slave-unplugged (&optional arg) "Read news as a slave unplugged." (interactive "P") (setq gnus-plugged nil) (gnus arg nil 'slave)) ;;;###autoload (defun gnus-agentize () "Allow Gnus to be an offline newsreader. The gnus-agentize function is now called internally by gnus when gnus-agent is set. If you wish to avoid calling gnus-agentize, customize gnus-agent to nil. This will modify the `gnus-setup-news-hook', and `message-send-mail-real-function' variables, and install the Gnus agent minor mode in all Gnus buffers." (interactive) (gnus-open-agent) (add-hook 'gnus-setup-news-hook 'gnus-agent-queue-setup) (unless gnus-agent-send-mail-function (setq gnus-agent-send-mail-function (or message-send-mail-real-function (function (lambda () (funcall message-send-mail-function)))) message-send-mail-real-function 'gnus-agent-send-mail)) ;; If the servers file doesn't exist, auto-agentize some servers and ;; save the servers file so this auto-agentizing isn't invoked ;; again. (unless (file-exists-p (nnheader-concat gnus-agent-directory "lib/servers")) (gnus-message 3 "First time agent user, agentizing remote groups...") (mapc (lambda (server-or-method) (let ((method (gnus-server-to-method server-or-method))) (when (memq (car method) gnus-agent-auto-agentize-methods) (push (gnus-method-to-server method) gnus-agent-covered-methods) (setq gnus-agent-method-p-cache nil)))) (cons gnus-select-method gnus-secondary-select-methods)) (gnus-agent-write-servers))) (defun gnus-agent-queue-setup (&optional group-name) "Make sure the queue group exists. Optional arg GROUP-NAME allows to specify another group." (unless (gnus-gethash (format "nndraft:%s" (or group-name "queue")) gnus-newsrc-hashtb) (gnus-request-create-group (or group-name "queue") '(nndraft "")) (let ((gnus-level-default-subscribed 1)) (gnus-subscribe-group (format "nndraft:%s" (or group-name "queue")) nil '(nndraft ""))) (gnus-group-set-parameter (format "nndraft:%s" (or group-name "queue")) 'gnus-dummy '((gnus-draft-mode))))) (defun gnus-agent-send-mail () (if (or (not gnus-agent-queue-mail) (and gnus-plugged (not (eq gnus-agent-queue-mail 'always)))) (funcall gnus-agent-send-mail-function) (goto-char (point-min)) (re-search-forward (concat "^" (regexp-quote mail-header-separator) "\n")) (replace-match "\n") (gnus-agent-insert-meta-information 'mail) (gnus-request-accept-article "nndraft:queue" nil t t))) (defun gnus-agent-insert-meta-information (type &optional method) "Insert meta-information into the message that says how it's to be posted. TYPE can be either `mail' or `news'. If the latter, then METHOD can be a select method." (save-excursion (message-remove-header gnus-agent-meta-information-header) (goto-char (point-min)) (insert gnus-agent-meta-information-header ": " (symbol-name type) " " (format "%S" method) "\n") (forward-char -1) (while (search-backward "\n" nil t) (replace-match "\\n" t t)))) (defun gnus-agent-restore-gcc () "Restore GCC field from saved header." (save-excursion (goto-char (point-min)) (while (re-search-forward (concat "^" (regexp-quote gnus-agent-gcc-header) ":") nil t) (replace-match "Gcc:" 'fixedcase)))) (defun gnus-agent-any-covered-gcc () (save-restriction (message-narrow-to-headers) (let* ((gcc (mail-fetch-field "gcc" nil t)) (methods (and gcc (mapcar 'gnus-inews-group-method (message-unquote-tokens (message-tokenize-header gcc " ,"))))) covered) (while (and (not covered) methods) (setq covered (gnus-agent-method-p (car methods)) methods (cdr methods))) covered))) ;;;###autoload (defun gnus-agent-possibly-save-gcc () "Save GCC if Gnus is unplugged." (when (and (not gnus-plugged) (gnus-agent-any-covered-gcc)) (save-excursion (goto-char (point-min)) (let ((case-fold-search t)) (while (re-search-forward "^gcc:" nil t) (replace-match (concat gnus-agent-gcc-header ":") 'fixedcase)))))) (defun gnus-agent-possibly-do-gcc () "Do GCC if Gnus is plugged." (when (or gnus-plugged (not (gnus-agent-any-covered-gcc))) (gnus-inews-do-gcc))) ;;; ;;; Group mode commands ;;; (defun gnus-agent-fetch-groups (n) "Put all new articles in the current groups into the Agent." (interactive "P") (unless gnus-plugged (error "Groups can't be fetched when Gnus is unplugged")) (gnus-group-iterate n 'gnus-agent-fetch-group)) (defun gnus-agent-fetch-group (&optional group) "Put all new articles in GROUP into the Agent." (interactive (list (gnus-group-group-name))) (setq group (or group gnus-newsgroup-name)) (unless group (error "No group on the current line")) (gnus-agent-while-plugged (let ((gnus-command-method (gnus-find-method-for-group group))) (gnus-agent-with-fetch (gnus-agent-fetch-group-1 group gnus-command-method) (gnus-message 5 "Fetching %s...done" group))))) (defun gnus-agent-add-group (category arg) "Add the current group to an agent category." (interactive (list (intern (completing-read "Add to category: " (mapcar (lambda (cat) (list (symbol-name (car cat)))) gnus-category-alist) nil t)) current-prefix-arg)) (let ((cat (assq category gnus-category-alist)) c groups) (gnus-group-iterate arg (lambda (group) (when (gnus-agent-cat-groups (setq c (gnus-group-category group))) (setf (gnus-agent-cat-groups c) (delete group (gnus-agent-cat-groups c)))) (push group groups))) (setf (gnus-agent-cat-groups cat) (nconc (gnus-agent-cat-groups cat) groups)) (gnus-category-write))) (defun gnus-agent-remove-group (arg) "Remove the current group from its agent category, if any." (interactive "P") (let (c) (gnus-group-iterate arg (lambda (group) (when (gnus-agent-cat-groups (setq c (gnus-group-category group))) (setf (gnus-agent-cat-groups c) (delete group (gnus-agent-cat-groups c)))))) (gnus-category-write))) (defun gnus-agent-synchronize-flags () "Synchronize unplugged flags with servers." (interactive) (save-excursion (dolist (gnus-command-method (gnus-agent-covered-methods)) (when (file-exists-p (gnus-agent-lib-file "flags")) (gnus-agent-synchronize-flags-server gnus-command-method))))) (defun gnus-agent-possibly-synchronize-flags () "Synchronize flags according to `gnus-agent-synchronize-flags'." (interactive) (save-excursion (dolist (gnus-command-method (gnus-agent-covered-methods)) (when (eq (gnus-server-status gnus-command-method) 'ok) (gnus-agent-possibly-synchronize-flags-server gnus-command-method))))) (defun gnus-agent-synchronize-flags-server (method) "Synchronize flags set when unplugged for server." (let ((gnus-command-method method) (gnus-agent nil)) (when (file-exists-p (gnus-agent-lib-file "flags")) (set-buffer (get-buffer-create " *Gnus Agent flag synchronize*")) (erase-buffer) (nnheader-insert-file-contents (gnus-agent-lib-file "flags")) (cond ((null gnus-plugged) (gnus-message 1 "You must be plugged to synchronize flags with server %s" (nth 1 gnus-command-method))) ((null (gnus-check-server gnus-command-method)) (gnus-message 1 "Couldn't open server %s" (nth 1 gnus-command-method))) (t (condition-case err (while t (let ((bgn (point))) (eval (read (current-buffer))) (delete-region bgn (point)))) (end-of-file (delete-file (gnus-agent-lib-file "flags"))) (error (let ((file (gnus-agent-lib-file "flags"))) (write-region (point-min) (point-max) (gnus-agent-lib-file "flags") nil 'silent) (error "Couldn't set flags from file %s due to %s" file (error-message-string err))))))) (kill-buffer nil)))) (defun gnus-agent-possibly-synchronize-flags-server (method) "Synchronize flags for server according to `gnus-agent-synchronize-flags'." (when (and (file-exists-p (gnus-agent-lib-file "flags")) (or (and gnus-agent-synchronize-flags (not (eq gnus-agent-synchronize-flags 'ask))) (and (eq gnus-agent-synchronize-flags 'ask) (gnus-y-or-n-p (format "Synchronize flags on server `%s'? " (cadr method)))))) (gnus-agent-synchronize-flags-server method))) ;;;###autoload (defun gnus-agent-rename-group (old-group new-group) "Rename fully-qualified OLD-GROUP as NEW-GROUP. Always updates the agent, even when disabled, as the old agent files would corrupt gnus when the agent was next enabled. Depends upon the caller to determine whether group renaming is supported." (let* ((old-command-method (gnus-find-method-for-group old-group)) (old-path (directory-file-name (let (gnus-command-method old-command-method) (gnus-agent-group-pathname old-group)))) (new-command-method (gnus-find-method-for-group new-group)) (new-path (directory-file-name (let (gnus-command-method new-command-method) (gnus-agent-group-pathname new-group)))) (file-name-coding-system nnmail-pathname-coding-system)) (gnus-rename-file old-path new-path t) (let* ((old-real-group (gnus-group-real-name old-group)) (new-real-group (gnus-group-real-name new-group)) (old-active (gnus-agent-get-group-info old-command-method old-real-group))) (gnus-agent-save-group-info old-command-method old-real-group nil) (gnus-agent-save-group-info new-command-method new-real-group old-active) (let ((old-local (gnus-agent-get-local old-group old-real-group old-command-method))) (gnus-agent-set-local old-group nil nil old-real-group old-command-method) (gnus-agent-set-local new-group (car old-local) (cdr old-local) new-real-group new-command-method))))) ;;;###autoload (defun gnus-agent-delete-group (group) "Delete fully-qualified GROUP. Always updates the agent, even when disabled, as the old agent files would corrupt gnus when the agent was next enabled. Depends upon the caller to determine whether group deletion is supported." (let* ((command-method (gnus-find-method-for-group group)) (path (directory-file-name (let (gnus-command-method command-method) (gnus-agent-group-pathname group)))) (file-name-coding-system nnmail-pathname-coding-system)) (gnus-delete-directory path) (let* ((real-group (gnus-group-real-name group))) (gnus-agent-save-group-info command-method real-group nil) (let ((local (gnus-agent-get-local group real-group command-method))) (gnus-agent-set-local group nil nil real-group command-method))))) ;;; ;;; Server mode commands ;;; (defun gnus-agent-add-server () "Enroll SERVER in the agent program." (interactive) (let* ((server (gnus-server-server-name)) (named-server (gnus-server-named-server)) (method (and server (gnus-server-get-method nil server)))) (unless server (error "No server on the current line")) (when (gnus-agent-method-p method) (error "Server already in the agent program")) (push named-server gnus-agent-covered-methods) (setq gnus-agent-method-p-cache nil) (gnus-server-update-server server) (gnus-agent-write-servers) (gnus-message 1 "Entered %s into the Agent" server))) (defun gnus-agent-remove-server () "Remove SERVER from the agent program." (interactive) (let* ((server (gnus-server-server-name)) (named-server (gnus-server-named-server))) (unless server (error "No server on the current line")) (unless (member named-server gnus-agent-covered-methods) (error "Server not in the agent program")) (setq gnus-agent-covered-methods (delete named-server gnus-agent-covered-methods) gnus-agent-method-p-cache nil) (gnus-server-update-server server) (gnus-agent-write-servers) (gnus-message 1 "Removed %s from the agent" server))) (defun gnus-agent-read-servers () "Read the alist of covered servers." (setq gnus-agent-covered-methods (gnus-agent-read-file (nnheader-concat gnus-agent-directory "lib/servers")) gnus-agent-method-p-cache nil) ;; I am called so early in start-up that I can not validate server ;; names. When that is the case, I skip the validation. That is ;; alright as the gnus startup code calls the validate methods ;; directly. (if gnus-server-alist (gnus-agent-read-servers-validate))) (defun gnus-agent-read-servers-validate () (mapcar (lambda (server-or-method) (let* ((server (if (stringp server-or-method) server-or-method (gnus-method-to-server server-or-method))) (method (gnus-server-to-method server))) (if method (unless (member server gnus-agent-covered-methods) (push server gnus-agent-covered-methods) (setq gnus-agent-method-p-cache nil)) (gnus-message 1 "Ignoring disappeared server `%s'" server)))) (prog1 gnus-agent-covered-methods (setq gnus-agent-covered-methods nil)))) (defun gnus-agent-read-servers-validate-native (native-method) (setq gnus-agent-covered-methods (mapcar (lambda (method) (if (or (not method) (equal method native-method)) "native" method)) gnus-agent-covered-methods))) (defun gnus-agent-write-servers () "Write the alist of covered servers." (gnus-make-directory (nnheader-concat gnus-agent-directory "lib")) (let ((coding-system-for-write nnheader-file-coding-system) (file-name-coding-system nnmail-pathname-coding-system)) (with-temp-file (nnheader-concat gnus-agent-directory "lib/servers") (prin1 gnus-agent-covered-methods (current-buffer))))) ;;; ;;; Summary commands ;;; (defun gnus-agent-mark-article (n &optional unmark) "Mark the next N articles as downloadable. If N is negative, mark backward instead. If UNMARK is non-nil, remove the mark instead. The difference between N and the actual number of articles marked is returned." (interactive "p") (let ((backward (< n 0)) (n (abs n))) (while (and (> n 0) (progn (gnus-summary-set-agent-mark (gnus-summary-article-number) unmark) (zerop (gnus-summary-next-subject (if backward -1 1) nil t)))) (setq n (1- n))) (when (/= 0 n) (gnus-message 7 "No more articles")) (gnus-summary-recenter) (gnus-summary-position-point) n)) (defun gnus-agent-unmark-article (n) "Remove the downloadable mark from the next N articles. If N is negative, unmark backward instead. The difference between N and the actual number of articles unmarked is returned." (interactive "p") (gnus-agent-mark-article n t)) (defun gnus-agent-toggle-mark (n) "Toggle the downloadable mark from the next N articles. If N is negative, toggle backward instead. The difference between N and the actual number of articles toggled is returned." (interactive "p") (gnus-agent-mark-article n 'toggle)) (defun gnus-summary-set-agent-mark (article &optional unmark) "Mark ARTICLE as downloadable. If UNMARK is nil, article is marked. When UNMARK is t, the article is unmarked. For any other value, the article's mark is toggled." (let ((unmark (cond ((eq nil unmark) nil) ((eq t unmark) t) (t (memq article gnus-newsgroup-downloadable))))) (when (gnus-summary-goto-subject article nil t) (gnus-summary-update-mark (if unmark (progn (setq gnus-newsgroup-downloadable (delq article gnus-newsgroup-downloadable)) (gnus-article-mark article)) (setq gnus-newsgroup-downloadable (gnus-add-to-sorted-list gnus-newsgroup-downloadable article)) gnus-downloadable-mark) 'unread)))) ;;;###autoload (defun gnus-agent-get-undownloaded-list () "Construct list of articles that have not been downloaded." (let ((gnus-command-method (gnus-find-method-for-group gnus-newsgroup-name))) (when (set (make-local-variable 'gnus-newsgroup-agentized) (gnus-agent-method-p gnus-command-method)) (let* ((alist (gnus-agent-load-alist gnus-newsgroup-name)) (headers (sort (mapcar (lambda (h) (mail-header-number h)) gnus-newsgroup-headers) '<)) (cached (and gnus-use-cache gnus-newsgroup-cached)) (undownloaded (list nil)) (tail-undownloaded undownloaded) (unfetched (list nil)) (tail-unfetched unfetched)) (while (and alist headers) (let ((a (caar alist)) (h (car headers))) (cond ((< a h) ;; Ignore IDs in the alist that are not being ;; displayed in the summary. (setq alist (cdr alist))) ((> a h) ;; Headers that are not in the alist should be ;; fictious (see nnagent-retrieve-headers); they ;; imply that this article isn't in the agent. (gnus-agent-append-to-list tail-undownloaded h) (gnus-agent-append-to-list tail-unfetched h) (setq headers (cdr headers))) ((cdar alist) (setq alist (cdr alist)) (setq headers (cdr headers)) nil ; ignore already downloaded ) (t (setq alist (cdr alist)) (setq headers (cdr headers)) ;; This article isn't in the agent. Check to see ;; if it is in the cache. If it is, it's been ;; downloaded. (while (and cached (< (car cached) a)) (setq cached (cdr cached))) (unless (equal a (car cached)) (gnus-agent-append-to-list tail-undownloaded a)))))) (while headers (let ((num (pop headers))) (gnus-agent-append-to-list tail-undownloaded num) (gnus-agent-append-to-list tail-unfetched num))) (setq gnus-newsgroup-undownloaded (cdr undownloaded) gnus-newsgroup-unfetched (cdr unfetched)))))) (defun gnus-agent-catchup () "Mark as read all unhandled articles. An article is unhandled if it is neither cached, nor downloaded, nor downloadable." (interactive) (save-excursion (let ((articles gnus-newsgroup-undownloaded)) (when (or gnus-newsgroup-downloadable gnus-newsgroup-cached) (setq articles (gnus-sorted-ndifference (gnus-sorted-ndifference (gnus-copy-sequence articles) gnus-newsgroup-downloadable) gnus-newsgroup-cached))) (while articles (gnus-summary-mark-article (pop articles) gnus-catchup-mark))) (gnus-summary-position-point))) (defun gnus-agent-summary-fetch-series () (interactive) (when gnus-newsgroup-processable (setq gnus-newsgroup-downloadable (let* ((dl gnus-newsgroup-downloadable) (processable (sort (gnus-copy-sequence gnus-newsgroup-processable) '<)) (gnus-newsgroup-downloadable processable)) (gnus-agent-summary-fetch-group) ;; For each article that I processed that is no longer ;; undownloaded, remove its processable mark. (mapc #'gnus-summary-remove-process-mark (gnus-sorted-ndifference gnus-newsgroup-processable gnus-newsgroup-undownloaded)) ;; The preceeding call to (gnus-agent-summary-fetch-group) ;; updated the temporary gnus-newsgroup-downloadable to ;; remove each article successfully fetched. Now, I ;; update the real gnus-newsgroup-downloadable to only ;; include undownloaded articles. (gnus-sorted-ndifference dl (gnus-sorted-ndifference processable gnus-newsgroup-undownloaded)))))) (defun gnus-agent-summary-fetch-group (&optional all) "Fetch the downloadable articles in the group. Optional arg ALL, if non-nil, means to fetch all articles." (interactive "P") (let ((articles (if all gnus-newsgroup-articles gnus-newsgroup-downloadable)) (gnus-command-method (gnus-find-method-for-group gnus-newsgroup-name)) fetched-articles) (gnus-agent-while-plugged (unless articles (error "No articles to download")) (gnus-agent-with-fetch (setq gnus-newsgroup-undownloaded (gnus-sorted-ndifference gnus-newsgroup-undownloaded (setq fetched-articles (gnus-agent-fetch-articles gnus-newsgroup-name articles))))) (save-excursion (dolist (article articles) (let ((was-marked-downloadable (memq article gnus-newsgroup-downloadable))) (cond (gnus-agent-mark-unread-after-downloaded (setq gnus-newsgroup-downloadable (delq article gnus-newsgroup-downloadable)) (gnus-summary-mark-article article gnus-unread-mark)) (was-marked-downloadable (gnus-summary-set-agent-mark article t))) (when (gnus-summary-goto-subject article nil t) (gnus-summary-update-download-mark article)))))) fetched-articles)) (defun gnus-agent-fetch-selected-article () "Fetch the current article as it is selected. This can be added to `gnus-select-article-hook' or `gnus-mark-article-hook'." (let ((gnus-command-method gnus-current-select-method)) (when (and gnus-plugged (gnus-agent-method-p gnus-command-method)) (when (gnus-agent-fetch-articles gnus-newsgroup-name (list gnus-current-article)) (setq gnus-newsgroup-undownloaded (delq gnus-current-article gnus-newsgroup-undownloaded)) (gnus-summary-update-download-mark gnus-current-article))))) ;;; ;;; Internal functions ;;; (defun gnus-agent-synchronize-group-flags (group actions server) "Update a plugged group by performing the indicated actions." (let* ((gnus-command-method (gnus-server-to-method server)) (info ;; This initializer is required as gnus-request-set-mark ;; calls gnus-group-real-name to strip off the host name ;; before calling the backend. Now that the backend is ;; trying to call gnus-request-set-mark, I have to ;; reconstruct the original group name. (or (gnus-get-info group) (gnus-get-info (setq group (gnus-group-full-name group gnus-command-method)))))) (gnus-request-set-mark group actions) (when info (dolist (action actions) (let ((range (nth 0 action)) (what (nth 1 action)) (marks (nth 2 action))) (dolist (mark marks) (cond ((eq mark 'read) (gnus-info-set-read info (funcall (if (eq what 'add) 'gnus-range-add 'gnus-remove-from-range) (gnus-info-read info) range)) (gnus-get-unread-articles-in-group info (gnus-active (gnus-info-group info)))) ((memq mark '(tick)) (let ((info-marks (assoc mark (gnus-info-marks info)))) (unless info-marks (gnus-info-set-marks info (cons (setq info-marks (list mark)) (gnus-info-marks info)))) (setcdr info-marks (funcall (if (eq what 'add) 'gnus-range-add 'gnus-remove-from-range) (cdr info-marks) range)))))))) ;;Marks can be synchronized at any time by simply toggling from ;;unplugged to plugged. If that is what is happening right now, make ;;sure that the group buffer is up to date. (when (gnus-buffer-live-p gnus-group-buffer) (gnus-group-update-group group t))) nil)) (defun gnus-agent-save-active (method) (when (gnus-agent-method-p method) (let* ((gnus-command-method method) (new (gnus-make-hashtable (count-lines (point-min) (point-max)))) (file (gnus-agent-lib-file "active"))) (gnus-active-to-gnus-format nil new) (gnus-agent-write-active file new) (erase-buffer) (let ((nnheader-file-coding-system gnus-agent-file-coding-system)) (nnheader-insert-file-contents file))))) (defun gnus-agent-write-active (file new) (gnus-make-directory (file-name-directory file)) (let ((nnmail-active-file-coding-system gnus-agent-file-coding-system)) ;; The hashtable contains real names of groups. However, do NOT ;; add the foreign server prefix as gnus-active-to-gnus-format ;; will add it while reading the file. (gnus-write-active-file file new nil))) ;;;###autoload (defun gnus-agent-possibly-alter-active (group active &optional info) "Possibly expand a group's active range to include articles downloaded into the agent." (let* ((gnus-command-method (or gnus-command-method (gnus-find-method-for-group group)))) (when (gnus-agent-method-p gnus-command-method) (let* ((local (gnus-agent-get-local group)) (active-min (or (car active) 0)) (active-max (or (cdr active) 0)) (agent-min (or (car local) active-min)) (agent-max (or (cdr local) active-max))) (when (< agent-min active-min) (setcar active agent-min)) (when (> agent-max active-max) (setcdr active agent-max)) (when (and info (< agent-max (- active-min 100))) ;; I'm expanding the active range by such a large amount ;; that there is a gap of more than 100 articles between the ;; last article known to the agent and the first article ;; currently available on the server. This gap contains ;; articles that have been lost, mark them as read so that ;; gnus doesn't waste resources trying to fetch them. ;; NOTE: I don't do this for smaller gaps (< 100) as I don't ;; want to modify the local file everytime someone restarts ;; gnus. The small gap will cause a tiny performance hit ;; when gnus tries, and fails, to retrieve the articles. ;; Still that should be smaller than opening a buffer, ;; printing this list to the buffer, and then writing it to a ;; file. (let ((read (gnus-info-read info))) (gnus-info-set-read info (gnus-range-add read (list (cons (1+ agent-max) (1- active-min)))))) ;; Lie about the agent's local range for this group to ;; disable the set read each time this server is opened. ;; NOTE: Opening this group will restore the valid local ;; range but it will also expand the local range to ;; incompass the new active range. (gnus-agent-set-local group agent-min (1- active-min))))))) (defun gnus-agent-save-group-info (method group active) "Update a single group's active range in the agent's copy of the server's active file." (when (gnus-agent-method-p method) (let* ((gnus-command-method (or method gnus-command-method)) (coding-system-for-write nnheader-file-coding-system) (file-name-coding-system nnmail-pathname-coding-system) (file (gnus-agent-lib-file "active")) oactive-min oactive-max) (gnus-make-directory (file-name-directory file)) (with-temp-file file ;; Emacs got problem to match non-ASCII group in multibyte buffer. (mm-disable-multibyte) (when (file-exists-p file) (nnheader-insert-file-contents file) (goto-char (point-min)) (when (re-search-forward (concat "^" (regexp-quote group) " ") nil t) (save-excursion (setq oactive-max (read (current-buffer)) ;; max oactive-min (read (current-buffer)))) ;; min (gnus-delete-line))) (when active (insert (format "%S %d %d y\n" (intern group) (max (or oactive-max (cdr active)) (cdr active)) (min (or oactive-min (car active)) (car active)))) (goto-char (point-max)) (while (search-backward "\\." nil t) (delete-char 1))))))) (defun gnus-agent-get-group-info (method group) "Get a single group's active range in the agent's copy of the server's active file." (when (gnus-agent-method-p method) (let* ((gnus-command-method (or method gnus-command-method)) (coding-system-for-write nnheader-file-coding-system) (file-name-coding-system nnmail-pathname-coding-system) (file (gnus-agent-lib-file "active")) oactive-min oactive-max) (gnus-make-directory (file-name-directory file)) (with-temp-buffer ;; Emacs got problem to match non-ASCII group in multibyte buffer. (mm-disable-multibyte) (when (file-exists-p file) (nnheader-insert-file-contents file) (goto-char (point-min)) (when (re-search-forward (concat "^" (regexp-quote group) " ") nil t) (save-excursion (setq oactive-max (read (current-buffer)) ;; max oactive-min (read (current-buffer))) ;; min (cons oactive-min oactive-max)))))))) (defvar gnus-agent-decoded-group-names nil "Alist of non-ASCII group names and decoded ones.") (defun gnus-agent-decoded-group-name (group) "Return a decoded group name of GROUP." (or (cdr (assoc group gnus-agent-decoded-group-names)) (if (string-match "[^\000-\177]" group) (let ((decoded (gnus-group-decoded-name group))) (push (cons group decoded) gnus-agent-decoded-group-names) decoded) group))) (defun gnus-agent-group-path (group) "Translate GROUP into a file name." ;; NOTE: This is what nnmail-group-pathname does as of Apr 2003. ;; The two methods must be kept synchronized, which is why ;; gnus-agent-group-pathname was added. (setq group (nnheader-translate-file-chars (nnheader-replace-duplicate-chars-in-string (nnheader-replace-chars-in-string (gnus-group-real-name (gnus-agent-decoded-group-name group)) ?/ ?_) ?. ?_))) (if (or nnmail-use-long-file-names (file-directory-p (expand-file-name group (gnus-agent-directory)))) group (nnheader-replace-chars-in-string group ?. ?/))) (defun gnus-agent-group-pathname (group) "Translate GROUP into a file name." ;; nnagent uses nnmail-group-pathname to read articles while ;; unplugged. The agent must, therefore, use the same directory ;; while plugged. (nnmail-group-pathname (gnus-group-real-name (gnus-agent-decoded-group-name group)) (if gnus-command-method (gnus-agent-directory) (let ((gnus-command-method (gnus-find-method-for-group group))) (gnus-agent-directory))))) (defun gnus-agent-get-function (method) (if (gnus-online method) (car method) (require 'nnagent) 'nnagent)) (defun gnus-agent-covered-methods () "Return the subset of methods that are covered by the agent." (delq nil (mapcar #'gnus-server-to-method gnus-agent-covered-methods))) ;;; History functions (defun gnus-agent-history-buffer () (cdr (assoc (gnus-agent-method) gnus-agent-history-buffers))) (defun gnus-agent-open-history () (save-excursion (push (cons (gnus-agent-method) (set-buffer (gnus-get-buffer-create (format " *Gnus agent %s history*" (gnus-agent-method))))) gnus-agent-history-buffers) (mm-disable-multibyte) ;; everything is binary (erase-buffer) (insert "\n") (let ((file (gnus-agent-lib-file "history"))) (when (file-exists-p file) (nnheader-insert-file-contents file)) (set (make-local-variable 'gnus-agent-file-name) file)))) (defun gnus-agent-close-history () (when (gnus-buffer-live-p gnus-agent-current-history) (kill-buffer gnus-agent-current-history) (setq gnus-agent-history-buffers (delq (assoc (gnus-agent-method) gnus-agent-history-buffers) gnus-agent-history-buffers)))) ;;; ;;; Fetching ;;; (defun gnus-agent-fetch-articles (group articles) "Fetch ARTICLES from GROUP and put them into the Agent." (when articles (gnus-agent-load-alist group) (let* ((alist gnus-agent-article-alist) (headers (if (< (length articles) 2) nil gnus-newsgroup-headers)) (selected-sets (list nil)) (current-set-size 0) article header-number) ;; Check each article (while (setq article (pop articles)) ;; Skip alist entries preceeding this article (while (> article (or (caar alist) (1+ article))) (setq alist (cdr alist))) ;; Prune off articles that we have already fetched. (unless (and (eq article (caar alist)) (cdar alist)) ;; Skip headers preceeding this article (while (> article (setq header-number (let* ((header (car headers))) (if header (mail-header-number header) (1+ article))))) (setq headers (cdr headers))) ;; Add this article to the current set (setcar selected-sets (cons article (car selected-sets))) ;; Update the set size, when the set is too large start a ;; new one. I do this after adding the article as I want at ;; least one article in each set. (when (< gnus-agent-max-fetch-size (setq current-set-size (+ current-set-size (if (= header-number article) (let ((char-size (mail-header-chars (car headers)))) (if (<= char-size 0) ;; The char size was missing/invalid, ;; assume a worst-case situation of ;; 65 char/line. If the line count ;; is missing, arbitrarily assume a ;; size of 1000 characters. (max (* 65 (mail-header-lines (car headers))) 1000) char-size)) 0)))) (setcar selected-sets (nreverse (car selected-sets))) (setq selected-sets (cons nil selected-sets) current-set-size 0)))) (when (or (cdr selected-sets) (car selected-sets)) (let* ((fetched-articles (list nil)) (tail-fetched-articles fetched-articles) (dir (gnus-agent-group-pathname group)) (date (time-to-days (current-time))) (case-fold-search t) pos crosses id (file-name-coding-system nnmail-pathname-coding-system)) (setcar selected-sets (nreverse (car selected-sets))) (setq selected-sets (nreverse selected-sets)) (gnus-make-directory dir) (gnus-message 7 "Fetching articles for %s..." group) (unwind-protect (while (setq articles (pop selected-sets)) ;; Fetch the articles from the backend. (if (gnus-check-backend-function 'retrieve-articles group) (setq pos (gnus-retrieve-articles articles group)) (with-temp-buffer (let (article) (while (setq article (pop articles)) (gnus-message 10 "Fetching article %s for %s..." article group) (when (or (gnus-backlog-request-article group article nntp-server-buffer) (gnus-request-article article group)) (goto-char (point-max)) (push (cons article (point)) pos) (insert-buffer-substring nntp-server-buffer))) (copy-to-buffer nntp-server-buffer (point-min) (point-max)) (setq pos (nreverse pos))))) ;; Then save these articles into the Agent. (save-excursion (set-buffer nntp-server-buffer) (while pos (narrow-to-region (cdar pos) (or (cdadr pos) (point-max))) (goto-char (point-min)) (unless (eobp) ;; Don't save empty articles. (when (search-forward "\n\n" nil t) (when (search-backward "\nXrefs: " nil t) ;; Handle cross posting. (goto-char (match-end 0)) ; move to end of header name (skip-chars-forward "^ ") ; skip server name (skip-chars-forward " ") (setq crosses nil) (while (looking-at "\\([^: \n]+\\):\\([0-9]+\\) *") (push (cons (buffer-substring (match-beginning 1) (match-end 1)) (string-to-number (buffer-substring (match-beginning 2) (match-end 2)))) crosses) (goto-char (match-end 0))) (gnus-agent-crosspost crosses (caar pos) date))) (goto-char (point-min)) (if (not (re-search-forward "^Message-ID: *<\\([^>\n]+\\)>" nil t)) (setq id "No-Message-ID-in-article") (setq id (buffer-substring (match-beginning 1) (match-end 1)))) (let ((coding-system-for-write gnus-agent-file-coding-system)) (write-region (point-min) (point-max) (concat dir (number-to-string (caar pos))) nil 'silent)) (gnus-agent-append-to-list tail-fetched-articles (caar pos))) (widen) (setq pos (cdr pos))))) (gnus-agent-save-alist group (cdr fetched-articles) date) (gnus-agent-update-files-total-fetched-for group (cdr fetched-articles)) (gnus-message 7 "")) (cdr fetched-articles)))))) (defun gnus-agent-unfetch-articles (group articles) "Delete ARTICLES that were fetched from GROUP into the agent." (when articles (gnus-agent-with-refreshed-group group (gnus-agent-load-alist group) (let* ((alist (cons nil gnus-agent-article-alist)) (articles (sort articles #'<)) (next-possibility alist) (delete-this (pop articles))) (while (and (cdr next-possibility) delete-this) (let ((have-this (caar (cdr next-possibility)))) (cond ((< delete-this have-this) (setq delete-this (pop articles))) ((= delete-this have-this) (let ((timestamp (cdar (cdr next-possibility)))) (when timestamp (let* ((file-name (concat (gnus-agent-group-pathname group) (number-to-string have-this))) (size-file (float (or (and gnus-agent-total-fetched-hashtb (nth 7 (file-attributes file-name))) 0))) (file-name-coding-system nnmail-pathname-coding-system)) (delete-file file-name) (gnus-agent-update-files-total-fetched-for group (- size-file))))) (setcdr next-possibility (cddr next-possibility))) (t (setq next-possibility (cdr next-possibility)))))) (setq gnus-agent-article-alist (cdr alist)) (gnus-agent-save-alist group))))) (defun gnus-agent-crosspost (crosses article &optional date) (setq date (or date t)) (let (gnus-agent-article-alist group alist beg end) (save-excursion (set-buffer gnus-agent-overview-buffer) (when (nnheader-find-nov-line article) (forward-word 1) (setq beg (point)) (setq end (progn (forward-line 1) (point))))) (while crosses (setq group (caar crosses)) (unless (setq alist (assoc group gnus-agent-group-alist)) (push (setq alist (list group (gnus-agent-load-alist (caar crosses)))) gnus-agent-group-alist)) (setcdr alist (cons (cons (cdar crosses) date) (cdr alist))) (save-excursion (set-buffer (gnus-get-buffer-create (format " *Gnus agent overview %s*" group))) (when (= (point-max) (point-min)) (push (cons group (current-buffer)) gnus-agent-buffer-alist) (ignore-errors (let ((file-name-coding-system nnmail-pathname-coding-system)) (nnheader-insert-file-contents (gnus-agent-article-name ".overview" group))))) (nnheader-find-nov-line (string-to-number (cdar crosses))) (insert (string-to-number (cdar crosses))) (insert-buffer-substring gnus-agent-overview-buffer beg end) (gnus-agent-check-overview-buffer)) (setq crosses (cdr crosses))))) (defun gnus-agent-backup-overview-buffer () (when gnus-newsgroup-name (let ((root (gnus-agent-article-name ".overview" gnus-newsgroup-name)) (cnt 0) name (file-name-coding-system nnmail-pathname-coding-system)) (while (file-exists-p (setq name (concat root "~" (int-to-string (setq cnt (1+ cnt))) "~")))) (write-region (point-min) (point-max) name nil 'no-msg) (gnus-message 1 "Created backup copy of overview in %s." name))) t) (defun gnus-agent-check-overview-buffer (&optional buffer) "Check the overview file given for sanity. In particular, checks that the file is sorted by article number and that there are no duplicates." (let ((prev-num -1) (backed-up nil)) (save-excursion (when buffer (set-buffer buffer)) (save-restriction (widen) (goto-char (point-min)) (while (< (point) (point-max)) (let ((p (point)) (cur (condition-case nil (read (current-buffer)) (error nil)))) (cond ((or (not (integerp cur)) (not (eq (char-after) ?\t))) (or backed-up (setq backed-up (gnus-agent-backup-overview-buffer))) (gnus-message 1 "Overview buffer contains garbage '%s'." (buffer-substring p (point-at-eol)))) ((= cur prev-num) (or backed-up (setq backed-up (gnus-agent-backup-overview-buffer))) (gnus-message 1 "Duplicate overview line for %d" cur) (delete-region p (progn (forward-line 1) (point)))) ((< cur prev-num) (or backed-up (setq backed-up (gnus-agent-backup-overview-buffer))) (gnus-message 1 "Overview buffer not sorted!") (sort-numeric-fields 1 (point-min) (point-max)) (goto-char (point-min)) (setq prev-num -1)) (t (setq prev-num cur))) (forward-line 1))))))) (defun gnus-agent-flush-server (&optional server-or-method) "Flush all agent index files for every subscribed group within the given SERVER-OR-METHOD. When called with nil, the current value of gnus-command-method identifies the server." (let* ((gnus-command-method (if server-or-method (gnus-server-to-method server-or-method) gnus-command-method)) (alist gnus-newsrc-alist)) (while alist (let ((entry (pop alist))) (when (gnus-methods-equal-p gnus-command-method (gnus-info-method entry)) (gnus-agent-flush-group (gnus-info-group entry))))))) (defun gnus-agent-flush-group (group) "Flush the agent's index files such that the GROUP no longer appears to have any local content. The actual content, the article files, may then be deleted using gnus-agent-expire-group. If flushing was a mistake, the gnus-agent-regenerate-group method provides an undo mechanism by reconstructing the index files from the article files." (interactive (list (gnus-agent-read-group))) (let* ((gnus-command-method (or gnus-command-method (gnus-find-method-for-group group))) (overview (gnus-agent-article-name ".overview" group)) (agentview (gnus-agent-article-name ".agentview" group)) (file-name-coding-system nnmail-pathname-coding-system)) (if (file-exists-p overview) (delete-file overview)) (if (file-exists-p agentview) (delete-file agentview)) (gnus-agent-update-view-total-fetched-for group nil gnus-command-method) (gnus-agent-update-view-total-fetched-for group t gnus-command-method) ;(gnus-agent-set-local group nil nil) ;(gnus-agent-save-local t) (gnus-agent-save-group-info nil group nil))) (defun gnus-agent-flush-cache () "Flush the agent's index files such that the group no longer appears to have any local content. The actual content, the article files, is then deleted using gnus-agent-expire-group. The gnus-agent-regenerate-group method provides an undo mechanism by reconstructing the index files from the article files." (interactive) (save-excursion (let ((file-name-coding-system nnmail-pathname-coding-system)) (while gnus-agent-buffer-alist (set-buffer (cdar gnus-agent-buffer-alist)) (let ((coding-system-for-write gnus-agent-file-coding-system)) (write-region (point-min) (point-max) (gnus-agent-article-name ".overview" (caar gnus-agent-buffer-alist)) nil 'silent)) (setq gnus-agent-buffer-alist (cdr gnus-agent-buffer-alist))) (while gnus-agent-group-alist (with-temp-file (gnus-agent-article-name ".agentview" (caar gnus-agent-group-alist)) (princ (cdar gnus-agent-group-alist)) (insert "\n") (princ 1 (current-buffer)) (insert "\n")) (setq gnus-agent-group-alist (cdr gnus-agent-group-alist)))))) ;;;###autoload (defun gnus-agent-find-parameter (group symbol) "Search for GROUPs SYMBOL in the group's parameters, the group's topic parameters, the group's category, or the customizable variables. Returns the first non-nil value found." (or (gnus-group-find-parameter group symbol t) (gnus-group-parameter-value (cdr (gnus-group-category group)) symbol t) (symbol-value (cdr (assq symbol '((agent-short-article . gnus-agent-short-article) (agent-long-article . gnus-agent-long-article) (agent-low-score . gnus-agent-low-score) (agent-high-score . gnus-agent-high-score) (agent-days-until-old . gnus-agent-expire-days) (agent-enable-expiration . gnus-agent-enable-expiration) (agent-predicate . gnus-agent-predicate))))))) (defun gnus-agent-fetch-headers (group &optional force) "Fetch interesting headers into the agent. The group's overview file will be updated to include the headers while a list of available article numbers will be returned." (let* ((fetch-all (and gnus-agent-consider-all-articles ;; Do not fetch all headers if the predicate ;; implies that we only consider unread articles. (not (gnus-predicate-implies-unread (gnus-agent-find-parameter group 'agent-predicate))))) (articles (if fetch-all (if gnus-newsgroup-maximum-articles (let ((active (gnus-active group))) (gnus-uncompress-range (cons (max (car active) (- (cdr active) gnus-newsgroup-maximum-articles -1)) (cdr active)))) (gnus-uncompress-range (gnus-active group))) (gnus-list-of-unread-articles group))) (gnus-decode-encoded-word-function 'identity) (gnus-decode-encoded-address-function 'identity) (file (gnus-agent-article-name ".overview" group)) (file-name-coding-system nnmail-pathname-coding-system)) (unless fetch-all ;; Add articles with marks to the list of article headers we want to ;; fetch. Don't fetch articles solely on the basis of a recent or seen ;; mark, but do fetch recent or seen articles if they have other, more ;; interesting marks. (We have to fetch articles with boring marks ;; because otherwise the agent will remove their marks.) (dolist (arts (gnus-info-marks (gnus-get-info group))) (unless (memq (car arts) '(seen recent killed cache)) (setq articles (gnus-range-add articles (cdr arts))))) (setq articles (sort (gnus-uncompress-sequence articles) '<))) ;; At this point, I have the list of articles to consider for ;; fetching. This is the list that I'll return to my caller. Some ;; of these articles may have already been fetched. That's OK as ;; the fetch article code will filter those out. Internally, I'll ;; filter this list to just those articles whose headers need to ;; be fetched. (let ((articles articles)) ;; Remove known articles. (when (and (or gnus-agent-cache (not gnus-plugged)) (gnus-agent-load-alist group)) ;; Remove articles marked as downloaded. (if fetch-all ;; I want to fetch all headers in the active range. ;; Therefore, exclude only those headers that are in the ;; article alist. ;; NOTE: This is probably NOT what I want to do after ;; agent expiration in this group. (setq articles (gnus-agent-uncached-articles articles group)) ;; I want to only fetch those headers that have never been ;; fetched. Therefore, exclude all headers that are, or ;; WERE, in the article alist. (let ((low (1+ (caar (last gnus-agent-article-alist)))) (high (cdr (gnus-active group)))) ;; Low can be greater than High when the same group is ;; fetched twice in the same session {The first fetch will ;; fill the article alist such that (last ;; gnus-agent-article-alist) equals (cdr (gnus-active ;; group))}. The addition of one(the 1+ above) then ;; forces Low to be greater than High. When this happens, ;; gnus-list-range-intersection returns nil which ;; indicates that no headers need to be fetched. -- Kevin (setq articles (gnus-list-range-intersection articles (list (cons low high))))))) (gnus-message 10 "gnus-agent-fetch-headers: undownloaded articles are '%s'" (gnus-compress-sequence articles t)) (save-excursion (set-buffer nntp-server-buffer) (if articles (progn (gnus-message 7 "Fetching headers for %s..." group) ;; Fetch them. (gnus-make-directory (nnheader-translate-file-chars (file-name-directory file) t)) (unless (eq 'nov (gnus-retrieve-headers articles group)) (nnvirtual-convert-headers)) (gnus-agent-check-overview-buffer) ;; Move these headers to the overview buffer so that ;; gnus-agent-braid-nov can merge them with the contents ;; of FILE. (copy-to-buffer gnus-agent-overview-buffer (point-min) (point-max)) ;; NOTE: Call g-a-brand-nov even when the file does not ;; exist. As a minimum, it will validate the article ;; numbers already in the buffer. (gnus-agent-braid-nov group articles file) (let ((coding-system-for-write gnus-agent-file-coding-system)) (gnus-agent-check-overview-buffer) (write-region (point-min) (point-max) file nil 'silent)) (gnus-agent-update-view-total-fetched-for group t) (gnus-agent-save-alist group articles nil) articles) (ignore-errors (erase-buffer) (nnheader-insert-file-contents file))))) articles)) (defsubst gnus-agent-read-article-number () "Reads the article number at point. Returns nil when a valid article number can not be read." ;; It is unfortunate but the read function quietly overflows ;; integer. As a result, I have to use string operations to test ;; for overflow BEFORE calling read. (when (looking-at "[0-9]+\t") (let ((len (- (match-end 0) (match-beginning 0)))) (cond ((< len 9) (read (current-buffer))) ((= len 9) ;; Many 9 digit base-10 numbers can be represented in a 27-bit int ;; Back convert from int to string to ensure that this is one of them. (let* ((str1 (buffer-substring (match-beginning 0) (1- (match-end 0)))) (num (read (current-buffer))) (str2 (int-to-string num))) (when (equal str1 str2) num))))))) (defsubst gnus-agent-copy-nov-line (article) "Copy the indicated ARTICLE from the overview buffer to the nntp server buffer." (let (art b e) (set-buffer gnus-agent-overview-buffer) (while (and (not (eobp)) (or (not (setq art (gnus-agent-read-article-number))) (< art article))) (forward-line 1)) (beginning-of-line) (if (or (eobp) (not (eq article art))) (set-buffer nntp-server-buffer) (setq b (point)) (setq e (progn (forward-line 1) (point))) (set-buffer nntp-server-buffer) (insert-buffer-substring gnus-agent-overview-buffer b e)))) (defun gnus-agent-braid-nov (group articles file) "Merge agent overview data with given file. Takes unvalidated headers for ARTICLES from `gnus-agent-overview-buffer' and validated headers from the given FILE and places the combined valid headers into `nntp-server-buffer'. This function can be used, when file doesn't exist, to valid the overview buffer." (let (start last) (set-buffer gnus-agent-overview-buffer) (goto-char (point-min)) (set-buffer nntp-server-buffer) (erase-buffer) (when (file-exists-p file) (nnheader-insert-file-contents file)) (goto-char (point-max)) (forward-line -1) (unless (or (= (point-min) (point-max)) (< (setq last (read (current-buffer))) (car articles))) ;; Old and new overlap -- We do it the hard way. (when (nnheader-find-nov-line (car articles)) ;; Replacing existing NOV entry (delete-region (point) (progn (forward-line 1) (point)))) (gnus-agent-copy-nov-line (pop articles)) (ignore-errors (while articles (while (let ((art (read (current-buffer)))) (cond ((< art (car articles)) (forward-line 1) t) ((= art (car articles)) (beginning-of-line) (delete-region (point) (progn (forward-line 1) (point))) nil) (t (beginning-of-line) nil)))) (gnus-agent-copy-nov-line (pop articles))))) (goto-char (point-max)) ;; Append the remaining lines (when articles (when last (set-buffer gnus-agent-overview-buffer) (setq start (point)) (set-buffer nntp-server-buffer)) (let ((p (point))) (insert-buffer-substring gnus-agent-overview-buffer start) (goto-char p)) (setq last (or last -134217728)) (while (catch 'problems (let (sort art) (while (not (eobp)) (setq art (gnus-agent-read-article-number)) (cond ((not art) ;; Bad art num - delete this line (beginning-of-line) (delete-region (point) (progn (forward-line 1) (point)))) ((< art last) ;; Art num out of order - enable sort (setq sort t) (forward-line 1)) ((= art last) ;; Bad repeat of art number - delete this line (beginning-of-line) (delete-region (point) (progn (forward-line 1) (point)))) (t ;; Good art num (setq last art) (forward-line 1)))) (when sort ;; something is seriously wrong as we simply shouldn't see out-of-order data. ;; First, we'll fix the sort. (sort-numeric-fields 1 (point-min) (point-max)) ;; but now we have to consider that we may have duplicate rows... ;; so reset to beginning of file (goto-char (point-min)) (setq last -134217728) ;; and throw a code that restarts this scan (throw 'problems t)) nil)))))) ;; Keeps the compiler from warning about the free variable in ;; gnus-agent-read-agentview. (defvar gnus-agent-read-agentview) (defun gnus-agent-load-alist (group) "Load the article-state alist for GROUP." ;; Bind free variable that's used in `gnus-agent-read-agentview'. (let ((gnus-agent-read-agentview group) (file-name-coding-system nnmail-pathname-coding-system)) (setq gnus-agent-article-alist (gnus-cache-file-contents (gnus-agent-article-name ".agentview" group) 'gnus-agent-file-loading-cache 'gnus-agent-read-agentview)))) (defun gnus-agent-read-agentview (file) "Load FILE and do a `read' there." (with-temp-buffer (condition-case nil (progn (nnheader-insert-file-contents file) (goto-char (point-min)) (let ((alist (read (current-buffer))) (version (condition-case nil (read (current-buffer)) (end-of-file 0))) changed-version) (cond ((= version 0) (let ((inhibit-quit t) entry) (gnus-agent-open-history) (set-buffer (gnus-agent-history-buffer)) (goto-char (point-min)) (while (not (eobp)) (if (and (looking-at "[^\t\n]+\t\\([0-9]+\\)\t\\([^ \n]+\\) \\([0-9]+\\)") (string= (match-string 2) gnus-agent-read-agentview) (setq entry (assoc (string-to-number (match-string 3)) alist))) (setcdr entry (string-to-number (match-string 1)))) (forward-line 1)) (gnus-agent-close-history) (setq changed-version t))) ((= version 1) (setq changed-version (not (= 1 gnus-agent-article-alist-save-format)))) ((= version 2) (let (state sequence uncomp) (while alist (setq state (caar alist) sequence (inline (gnus-uncompress-range (cdar alist))) alist (cdr alist)) (while sequence (push (cons (pop sequence) state) uncomp))) (setq alist (sort uncomp 'car-less-than-car))) (setq changed-version (not (= 2 gnus-agent-article-alist-save-format))))) (when changed-version (let ((gnus-agent-article-alist alist)) (gnus-agent-save-alist gnus-agent-read-agentview))) alist)) ((end-of-file file-error) ;; The agentview file is missing. (condition-case nil ;; If the agent directory exists, attempt to perform a brute-force ;; reconstruction of its contents. (let* (alist (file-name-coding-system nnmail-pathname-coding-system) (file-attributes (directory-files-and-attributes (gnus-agent-article-name "" gnus-agent-read-agentview) nil "^[0-9]+$" t))) (while file-attributes (let ((fa (pop file-attributes))) (unless (nth 1 fa) (push (cons (string-to-number (nth 0 fa)) (time-to-days (nth 5 fa))) alist)))) alist) (file-error nil)))))) (defun gnus-agent-save-alist (group &optional articles state) "Save the article-state alist for GROUP." (let* ((file-name-coding-system nnmail-pathname-coding-system) (prev (cons nil gnus-agent-article-alist)) (all prev) print-level print-length item article) (while (setq article (pop articles)) (while (and (cdr prev) (< (caadr prev) article)) (setq prev (cdr prev))) (cond ((not (cdr prev)) (setcdr prev (list (cons article state)))) ((> (caadr prev) article) (setcdr prev (cons (cons article state) (cdr prev)))) ((= (caadr prev) article) (setcdr (cadr prev) state))) (setq prev (cdr prev))) (setq gnus-agent-article-alist (cdr all)) (gnus-agent-set-local group (caar gnus-agent-article-alist) (caar (last gnus-agent-article-alist))) (gnus-make-directory (gnus-agent-article-name "" group)) (with-temp-file (gnus-agent-article-name ".agentview" group) (cond ((eq gnus-agent-article-alist-save-format 1) (princ gnus-agent-article-alist (current-buffer))) ((eq gnus-agent-article-alist-save-format 2) (let ((alist gnus-agent-article-alist) article-id day-of-download comp-list compressed) (while alist (setq article-id (caar alist) day-of-download (cdar alist) comp-list (assq day-of-download compressed) alist (cdr alist)) (if comp-list (setcdr comp-list (cons article-id (cdr comp-list))) (push (list day-of-download article-id) compressed))) (setq alist compressed) (while alist (setq comp-list (pop alist)) (setcdr comp-list (gnus-compress-sequence (nreverse (cdr comp-list))))) (princ compressed (current-buffer))))) (insert "\n") (princ gnus-agent-article-alist-save-format (current-buffer)) (insert "\n")) (gnus-agent-update-view-total-fetched-for group nil))) (defvar gnus-agent-article-local nil) (defvar gnus-agent-file-loading-local nil) (defun gnus-agent-load-local (&optional method) "Load the METHOD'S local file. The local file contains min/max article counts for each of the method's subscribed groups." (let ((gnus-command-method (or method gnus-command-method))) (setq gnus-agent-article-local (gnus-cache-file-contents (gnus-agent-lib-file "local") 'gnus-agent-file-loading-local 'gnus-agent-read-and-cache-local)))) (defun gnus-agent-read-and-cache-local (file) "Load and read FILE then bind its contents to gnus-agent-article-local. If that variable had `dirty' (also known as modified) original contents, they are first saved to their own file." (if (and gnus-agent-article-local (symbol-value (intern "+dirty" gnus-agent-article-local))) (gnus-agent-save-local)) (gnus-agent-read-local file)) (defun gnus-agent-read-local (file) "Load FILE and do a `read' there." (let ((my-obarray (gnus-make-hashtable (count-lines (point-min) (point-max)))) (line 1)) (with-temp-buffer (condition-case nil (let ((nnheader-file-coding-system gnus-agent-file-coding-system)) (nnheader-insert-file-contents file)) (file-error)) (goto-char (point-min)) ;; Skip any comments at the beginning of the file (the only place where they may appear) (while (= (following-char) ?\;) (forward-line 1) (setq line (1+ line))) (while (not (eobp)) (condition-case err (let (group min max (cur (current-buffer)) (obarray my-obarray)) (setq group (read cur) min (read cur) max (read cur)) (when (stringp group) (setq group (intern group my-obarray))) ;; NOTE: The '+ 0' ensure that min and max are both numerics. (set group (cons (+ 0 min) (+ 0 max)))) (error (gnus-message 3 "Warning - invalid agent local: %s on line %d: %s" file line (error-message-string err)))) (forward-line 1) (setq line (1+ line)))) (set (intern "+dirty" my-obarray) nil) (set (intern "+method" my-obarray) gnus-command-method) my-obarray)) (defun gnus-agent-save-local (&optional force) "Save gnus-agent-article-local under it method's agent.lib directory." (let ((my-obarray gnus-agent-article-local)) (when (and my-obarray (or force (symbol-value (intern "+dirty" my-obarray)))) (let* ((gnus-command-method (symbol-value (intern "+method" my-obarray))) ;; NOTE: gnus-command-method is used within gnus-agent-lib-file. (dest (gnus-agent-lib-file "local"))) (gnus-make-directory (gnus-agent-lib-file "")) (let ((coding-system-for-write gnus-agent-file-coding-system) (file-name-coding-system nnmail-pathname-coding-system)) (with-temp-file dest (let ((gnus-command-method (symbol-value (intern "+method" my-obarray))) print-level print-length item article (standard-output (current-buffer))) (mapatoms (lambda (symbol) (cond ((not (boundp symbol)) nil) ((member (symbol-name symbol) '("+dirty" "+method")) nil) (t (let ((range (symbol-value symbol))) (when range (prin1 symbol) (princ " ") (princ (car range)) (princ " ") (princ (cdr range)) (princ "\n")))))) my-obarray)))))))) (defun gnus-agent-get-local (group &optional gmane method) (let* ((gmane (or gmane (gnus-group-real-name group))) (gnus-command-method (or method (gnus-find-method-for-group group))) (local (gnus-agent-load-local)) (symb (intern gmane local)) (minmax (and (boundp symb) (symbol-value symb)))) (unless minmax ;; Bind these so that gnus-agent-load-alist doesn't change the ;; current alist (i.e. gnus-agent-article-alist) (let* ((gnus-agent-article-alist gnus-agent-article-alist) (gnus-agent-file-loading-cache gnus-agent-file-loading-cache) (alist (gnus-agent-load-alist group))) (when alist (setq minmax (cons (caar alist) (caar (last alist)))) (gnus-agent-set-local group (car minmax) (cdr minmax) gmane gnus-command-method local)))) minmax)) (defun gnus-agent-set-local (group min max &optional gmane method local) (let* ((gmane (or gmane (gnus-group-real-name group))) (gnus-command-method (or method (gnus-find-method-for-group group))) (local (or local (gnus-agent-load-local))) (symb (intern gmane local)) (minmax (and (boundp symb) (symbol-value symb)))) (if (cond ((and minmax (or (not (eq min (car minmax))) (not (eq max (cdr minmax)))) min max) (setcar minmax min) (setcdr minmax max) t) (minmax nil) ((and min max) (set symb (cons min max)) t) (t (unintern symb local))) (set (intern "+dirty" local) t)))) (defun gnus-agent-article-name (article group) (expand-file-name article (file-name-as-directory (gnus-agent-group-pathname group)))) (defun gnus-agent-batch-confirmation (msg) "Show error message and return t." (gnus-message 1 msg) t) ;;;###autoload (defun gnus-agent-batch-fetch () "Start Gnus and fetch session." (interactive) (gnus) (let ((gnus-agent-confirmation-function 'gnus-agent-batch-confirmation)) (gnus-agent-fetch-session)) (gnus-group-exit)) (defun gnus-agent-fetch-session () "Fetch all articles and headers that are eligible for fetching." (interactive) (unless gnus-agent-covered-methods (error "No servers are covered by the Gnus agent")) (unless gnus-plugged (error "Can't fetch articles while Gnus is unplugged")) (let ((methods (gnus-agent-covered-methods)) groups group gnus-command-method) (save-excursion (while methods (setq gnus-command-method (car methods)) (when (and (or (gnus-server-opened gnus-command-method) (gnus-open-server gnus-command-method)) (gnus-online gnus-command-method)) (setq groups (gnus-groups-from-server (car methods))) (gnus-agent-with-fetch (while (setq group (pop groups)) (when (<= (gnus-group-level group) gnus-agent-handle-level) (if (or debug-on-error debug-on-quit) (gnus-agent-fetch-group-1 group gnus-command-method) (condition-case err (gnus-agent-fetch-group-1 group gnus-command-method) (error (unless (funcall gnus-agent-confirmation-function (format "Error %s while fetching session. Should gnus continue? " (error-message-string err))) (error "Cannot fetch articles into the Gnus agent"))) (quit (gnus-agent-regenerate-group group) (unless (funcall gnus-agent-confirmation-function (format "%s while fetching session. Should gnus continue? " (error-message-string err))) (signal 'quit "Cannot fetch articles into the Gnus agent"))))))))) (setq methods (cdr methods))) (gnus-run-hooks 'gnus-agent-fetched-hook) (gnus-message 6 "Finished fetching articles into the Gnus agent")))) (defun gnus-agent-fetch-group-1 (group method) "Fetch GROUP." (let ((gnus-command-method method) (gnus-newsgroup-name group) (gnus-newsgroup-dependencies gnus-newsgroup-dependencies) (gnus-newsgroup-headers gnus-newsgroup-headers) (gnus-newsgroup-scored gnus-newsgroup-scored) (gnus-use-cache gnus-use-cache) (gnus-summary-expunge-below gnus-summary-expunge-below) (gnus-summary-mark-below gnus-summary-mark-below) (gnus-orphan-score gnus-orphan-score) ;; Maybe some other gnus-summary local variables should also ;; be put here. gnus-headers gnus-score articles arts category predicate info marks score-param ) (unless (gnus-check-group group) (error "Can't open server for %s" group)) ;; Fetch headers. (when (or gnus-newsgroup-active (gnus-active group) (gnus-activate-group group)) (let ((marked-articles gnus-newsgroup-downloadable)) ;; Identify the articles marked for download (unless gnus-newsgroup-active ;; The variable gnus-newsgroup-active was selected as I need ;; a gnus-summary local variable that is NOT bound to any ;; value (its global value should default to nil). (dolist (mark gnus-agent-download-marks) (let ((arts (cdr (assq mark (gnus-info-marks (setq info (gnus-get-info group))))))) (when arts (setq marked-articles (nconc (gnus-uncompress-range arts) marked-articles)) )))) (setq marked-articles (sort marked-articles '<)) ;; Fetch any new articles from the server (setq articles (gnus-agent-fetch-headers group)) ;; Merge new articles with marked (setq articles (sort (append marked-articles articles) '<)) (when articles ;; Parse them and see which articles we want to fetch. (setq gnus-newsgroup-dependencies (or gnus-newsgroup-dependencies (make-vector (length articles) 0))) (setq gnus-newsgroup-headers (or gnus-newsgroup-headers (gnus-get-newsgroup-headers-xover articles nil nil group))) ;; `gnus-agent-overview-buffer' may be killed for ;; timeout reason. If so, recreate it. (gnus-agent-create-buffer) ;; Figure out how to select articles in this group (setq category (gnus-group-category group)) (setq predicate (gnus-get-predicate (gnus-agent-find-parameter group 'agent-predicate))) ;; If the selection predicate requires scoring, score each header (unless (memq predicate '(gnus-agent-true gnus-agent-false)) (let ((score-param (gnus-agent-find-parameter group 'agent-score-file))) ;; Translate score-param into real one (cond ((not score-param)) ((eq score-param 'file) (setq score-param (gnus-all-score-files group))) ((stringp (car score-param))) (t (setq score-param (list (list score-param))))) (when score-param (gnus-score-headers score-param)))) (unless (and (eq predicate 'gnus-agent-false) (not marked-articles)) (let ((arts (list nil))) (let ((arts-tail arts) (alist (gnus-agent-load-alist group)) (marked-articles marked-articles) (gnus-newsgroup-headers gnus-newsgroup-headers)) (while (setq gnus-headers (pop gnus-newsgroup-headers)) (let ((num (mail-header-number gnus-headers))) ;; Determine if this article is already in the cache (while (and alist (> num (caar alist))) (setq alist (cdr alist))) (unless (and (eq num (caar alist)) (cdar alist)) ;; Determine if this article was marked for download. (while (and marked-articles (> num (car marked-articles))) (setq marked-articles (cdr marked-articles))) ;; When this article is marked, or selected by the ;; predicate, add it to the download list (when (or (eq num (car marked-articles)) (let ((gnus-score (or (cdr (assq num gnus-newsgroup-scored)) gnus-summary-default-score)) (gnus-agent-long-article (gnus-agent-find-parameter group 'agent-long-article)) (gnus-agent-short-article (gnus-agent-find-parameter group 'agent-short-article)) (gnus-agent-low-score (gnus-agent-find-parameter group 'agent-low-score)) (gnus-agent-high-score (gnus-agent-find-parameter group 'agent-high-score)) (gnus-agent-expire-days (gnus-agent-find-parameter group 'agent-days-until-old))) (funcall predicate))) (gnus-agent-append-to-list arts-tail num)))))) (let (fetched-articles) ;; Fetch all selected articles (setq gnus-newsgroup-undownloaded (gnus-sorted-ndifference gnus-newsgroup-undownloaded (setq fetched-articles (if (cdr arts) (gnus-agent-fetch-articles group (cdr arts)) nil)))) (let ((unfetched-articles (gnus-sorted-ndifference (cdr arts) fetched-articles))) (if gnus-newsgroup-active ;; Update the summary buffer (progn (dolist (article marked-articles) (gnus-summary-set-agent-mark article t)) (dolist (article fetched-articles) (when gnus-agent-mark-unread-after-downloaded (setq gnus-newsgroup-downloadable (delq article gnus-newsgroup-downloadable)) (gnus-summary-mark-article article gnus-unread-mark)) (when (gnus-summary-goto-subject article nil t) (gnus-summary-update-download-mark article))) (dolist (article unfetched-articles) (gnus-summary-mark-article article gnus-canceled-mark))) ;; Update the group buffer. ;; When some, or all, of the marked articles came ;; from the download mark. Remove that mark. I ;; didn't do this earlier as I only want to remove ;; the marks after the fetch is completed. (dolist (mark gnus-agent-download-marks) (when (eq mark 'download) (let ((marked-arts (assq mark (gnus-info-marks (setq info (gnus-get-info group)))))) (when (cdr marked-arts) (setq marks (delq marked-arts (gnus-info-marks info))) (gnus-info-set-marks info marks))))) (let ((read (gnus-info-read (or info (setq info (gnus-get-info group)))))) (gnus-info-set-read info (gnus-add-to-range read unfetched-articles))) (gnus-group-update-group group t) (sit-for 0) (gnus-dribble-enter (concat "(gnus-group-set-info '" (gnus-prin1-to-string info) ")")))))))))))) ;;; ;;; Agent Category Mode ;;; (defvar gnus-category-mode-hook nil "Hook run in `gnus-category-mode' buffers.") (defvar gnus-category-line-format " %(%20c%): %g\n" "Format of category lines. Valid specifiers include: %c Topic name (string) %g The number of groups in the topic (integer) General format specifiers can also be used. See Info node `(gnus)Formatting Variables'.") (defvar gnus-category-mode-line-format "Gnus: %%b" "The format specification for the category mode line.") (defvar gnus-agent-predicate 'false "The selection predicate used when no other source is available.") (defvar gnus-agent-short-article 100 "Articles that have fewer lines than this are short.") (defvar gnus-agent-long-article 200 "Articles that have more lines than this are long.") (defvar gnus-agent-low-score 0 "Articles that have a score lower than this have a low score.") (defvar gnus-agent-high-score 0 "Articles that have a score higher than this have a high score.") ;;; Internal variables. (defvar gnus-category-buffer "*Agent Category*") (defvar gnus-category-line-format-alist `((?c gnus-tmp-name ?s) (?g gnus-tmp-groups ?d))) (defvar gnus-category-mode-line-format-alist `((?u user-defined ?s))) (defvar gnus-category-line-format-spec nil) (defvar gnus-category-mode-line-format-spec nil) (defvar gnus-category-mode-map nil) (put 'gnus-category-mode 'mode-class 'special) (unless gnus-category-mode-map (setq gnus-category-mode-map (make-sparse-keymap)) (suppress-keymap gnus-category-mode-map) (gnus-define-keys gnus-category-mode-map "q" gnus-category-exit "k" gnus-category-kill "c" gnus-category-copy "a" gnus-category-add "e" gnus-agent-customize-category "p" gnus-category-edit-predicate "g" gnus-category-edit-groups "s" gnus-category-edit-score "l" gnus-category-list "\C-c\C-i" gnus-info-find-node "\C-c\C-b" gnus-bug)) (defvar gnus-category-menu-hook nil "*Hook run after the creation of the menu.") (defun gnus-category-make-menu-bar () (gnus-turn-off-edit-menu 'category) (unless (boundp 'gnus-category-menu) (easy-menu-define gnus-category-menu gnus-category-mode-map "" '("Categories" ["Add" gnus-category-add t] ["Kill" gnus-category-kill t] ["Copy" gnus-category-copy t] ["Edit category" gnus-agent-customize-category t] ["Edit predicate" gnus-category-edit-predicate t] ["Edit score" gnus-category-edit-score t] ["Edit groups" gnus-category-edit-groups t] ["Exit" gnus-category-exit t])) (gnus-run-hooks 'gnus-category-menu-hook))) (defun gnus-category-mode () "Major mode for listing and editing agent categories. All normal editing commands are switched off. \\ For more in-depth information on this mode, read the manual \(`\\[gnus-info-find-node]'). The following commands are available: \\{gnus-category-mode-map}" (interactive) (when (gnus-visual-p 'category-menu 'menu) (gnus-category-make-menu-bar)) (kill-all-local-variables) (gnus-simplify-mode-line) (setq major-mode 'gnus-category-mode) (setq mode-name "Category") (gnus-set-default-directory) (setq mode-line-process nil) (use-local-map gnus-category-mode-map) (buffer-disable-undo) (setq truncate-lines t) (setq buffer-read-only t) (gnus-run-mode-hooks 'gnus-category-mode-hook)) (defalias 'gnus-category-position-point 'gnus-goto-colon) (defun gnus-category-insert-line (category) (let* ((gnus-tmp-name (format "%s" (car category))) (gnus-tmp-groups (length (gnus-agent-cat-groups category)))) (beginning-of-line) (gnus-add-text-properties (point) (prog1 (1+ (point)) ;; Insert the text. (eval gnus-category-line-format-spec)) (list 'gnus-category gnus-tmp-name)))) (defun gnus-enter-category-buffer () "Go to the Category buffer." (interactive) (gnus-category-setup-buffer) (gnus-configure-windows 'category) (gnus-category-prepare)) (defun gnus-category-setup-buffer () (unless (get-buffer gnus-category-buffer) (save-excursion (set-buffer (gnus-get-buffer-create gnus-category-buffer)) (gnus-category-mode)))) (defun gnus-category-prepare () (gnus-set-format 'category-mode) (gnus-set-format 'category t) (let ((alist gnus-category-alist) (buffer-read-only nil)) (erase-buffer) (while alist (gnus-category-insert-line (pop alist))) (goto-char (point-min)) (gnus-category-position-point))) (defun gnus-category-name () (or (intern (get-text-property (point-at-bol) 'gnus-category)) (error "No category on the current line"))) (defun gnus-category-read () "Read the category alist." (setq gnus-category-alist (or (with-temp-buffer (ignore-errors (nnheader-insert-file-contents (nnheader-concat gnus-agent-directory "lib/categories")) (goto-char (point-min)) ;; This code isn't temp, it will be needed so long as ;; anyone may be migrating from an older version. ;; Once we're certain that people will not revert to an ;; earlier version, we can take out the old-list code in ;; gnus-category-write. (let* ((old-list (read (current-buffer))) (new-list (ignore-errors (read (current-buffer))))) (if new-list new-list ;; Convert from a positional list to an alist. (mapcar (lambda (c) (setcdr c (delq nil (gnus-mapcar (lambda (valu symb) (if valu (cons symb valu))) (cdr c) '(agent-predicate agent-score-file agent-groups)))) c) old-list))))) (list (gnus-agent-cat-make 'default 'short))))) (defun gnus-category-write () "Write the category alist." (setq gnus-category-predicate-cache nil gnus-category-group-cache nil) (gnus-make-directory (nnheader-concat gnus-agent-directory "lib")) (with-temp-file (nnheader-concat gnus-agent-directory "lib/categories") ;; This prin1 is temporary. It exists so that people can revert ;; to an earlier version of gnus-agent. (prin1 (mapcar (lambda (c) (list (car c) (cdr (assoc 'agent-predicate c)) (cdr (assoc 'agent-score-file c)) (cdr (assoc 'agent-groups c)))) gnus-category-alist) (current-buffer)) (newline) (prin1 gnus-category-alist (current-buffer)))) (defun gnus-category-edit-predicate (category) "Edit the predicate for CATEGORY." (interactive (list (gnus-category-name))) (let ((info (assq category gnus-category-alist))) (gnus-edit-form (gnus-agent-cat-predicate info) (format "Editing the select predicate for category %s" category) `(lambda (predicate) ;; Avoid run-time execution of setf form ;; (setf (gnus-agent-cat-predicate (assq ',category gnus-category-alist)) ;; predicate) ;; use its expansion instead: (gnus-agent-cat-set-property (assq ',category gnus-category-alist) 'agent-predicate predicate) (gnus-category-write) (gnus-category-list))))) (defun gnus-category-edit-score (category) "Edit the score expression for CATEGORY." (interactive (list (gnus-category-name))) (let ((info (assq category gnus-category-alist))) (gnus-edit-form (gnus-agent-cat-score-file info) (format "Editing the score expression for category %s" category) `(lambda (score-file) ;; Avoid run-time execution of setf form ;; (setf (gnus-agent-cat-score-file (assq ',category gnus-category-alist)) ;; score-file) ;; use its expansion instead: (gnus-agent-cat-set-property (assq ',category gnus-category-alist) 'agent-score-file score-file) (gnus-category-write) (gnus-category-list))))) (defun gnus-category-edit-groups (category) "Edit the group list for CATEGORY." (interactive (list (gnus-category-name))) (let ((info (assq category gnus-category-alist))) (gnus-edit-form (gnus-agent-cat-groups info) (format "Editing the group list for category %s" category) `(lambda (groups) ;; Avoid run-time execution of setf form ;; (setf (gnus-agent-cat-groups (assq ',category gnus-category-alist)) ;; groups) ;; use its expansion instead: (gnus-agent-set-cat-groups (assq ',category gnus-category-alist) groups) (gnus-category-write) (gnus-category-list))))) (defun gnus-category-kill (category) "Kill the current category." (interactive (list (gnus-category-name))) (let ((info (assq category gnus-category-alist)) (buffer-read-only nil)) (gnus-delete-line) (setq gnus-category-alist (delq info gnus-category-alist)) (gnus-category-write))) (defun gnus-category-copy (category to) "Copy the current category." (interactive (list (gnus-category-name) (intern (read-string "New name: ")))) (let ((info (assq category gnus-category-alist))) (push (let ((newcat (gnus-copy-sequence info))) (setf (gnus-agent-cat-name newcat) to) (setf (gnus-agent-cat-groups newcat) nil) newcat) gnus-category-alist) (gnus-category-write) (gnus-category-list))) (defun gnus-category-add (category) "Create a new category." (interactive "SCategory name: ") (when (assq category gnus-category-alist) (error "Category %s already exists" category)) (push (gnus-agent-cat-make category) gnus-category-alist) (gnus-category-write) (gnus-category-list)) (defun gnus-category-list () "List all categories." (interactive) (gnus-category-prepare)) (defun gnus-category-exit () "Return to the group buffer." (interactive) (kill-buffer (current-buffer)) (gnus-configure-windows 'group t)) ;; To avoid having 8-bit characters in the source file. (defvar gnus-category-not (list '! 'not (intern (format "%c" 172)))) (defvar gnus-category-predicate-alist '((spam . gnus-agent-spam-p) (short . gnus-agent-short-p) (long . gnus-agent-long-p) (low . gnus-agent-low-scored-p) (high . gnus-agent-high-scored-p) (read . gnus-agent-read-p) (true . gnus-agent-true) (false . gnus-agent-false)) "Mapping from short score predicate symbols to predicate functions.") (defun gnus-agent-spam-p () "Say whether an article is spam or not." (unless gnus-agent-spam-hashtb (setq gnus-agent-spam-hashtb (gnus-make-hashtable 1000))) (if (not (equal (mail-header-references gnus-headers) "")) nil (let ((string (gnus-simplify-subject (mail-header-subject gnus-headers)))) (prog1 (gnus-gethash string gnus-agent-spam-hashtb) (gnus-sethash string t gnus-agent-spam-hashtb))))) (defun gnus-agent-short-p () "Say whether an article is short or not." (< (mail-header-lines gnus-headers) gnus-agent-short-article)) (defun gnus-agent-long-p () "Say whether an article is long or not." (> (mail-header-lines gnus-headers) gnus-agent-long-article)) (defun gnus-agent-low-scored-p () "Say whether an article has a low score or not." (< gnus-score gnus-agent-low-score)) (defun gnus-agent-high-scored-p () "Say whether an article has a high score or not." (> gnus-score gnus-agent-high-score)) (defun gnus-agent-read-p () "Say whether an article is read or not." (gnus-member-of-range (mail-header-number gnus-headers) (gnus-info-read (gnus-get-info gnus-newsgroup-name)))) (defun gnus-category-make-function (predicate) "Make a function from PREDICATE." (let ((func (gnus-category-make-function-1 predicate))) (if (and (= (length func) 1) (symbolp (car func))) (car func) (gnus-byte-compile `(lambda () ,func))))) (defun gnus-agent-true () "Return t." t) (defun gnus-agent-false () "Return nil." nil) (defun gnus-category-make-function-1 (predicate) "Make a function from PREDICATE." (cond ;; Functions are just returned as is. ((or (symbolp predicate) (functionp predicate)) `(,(or (cdr (assq predicate gnus-category-predicate-alist)) predicate))) ;; More complex predicate. ((consp predicate) `(,(cond ((memq (car predicate) '(& and)) 'and) ((memq (car predicate) '(| or)) 'or) ((memq (car predicate) gnus-category-not) 'not)) ,@(mapcar 'gnus-category-make-function-1 (cdr predicate)))) (t (error "Unknown predicate type: %s" predicate)))) (defun gnus-get-predicate (predicate) "Return the function implementing PREDICATE." (or (cdr (assoc predicate gnus-category-predicate-cache)) (let ((func (gnus-category-make-function predicate))) (setq gnus-category-predicate-cache (nconc gnus-category-predicate-cache (list (cons predicate func)))) func))) (defun gnus-predicate-implies-unread (predicate) "Say whether PREDICATE implies unread articles only. It is okay to miss some cases, but there must be no false positives. That is, if this predicate returns true, then indeed the predicate must return only unread articles." (eq t (gnus-function-implies-unread-1 (gnus-category-make-function-1 predicate)))) (defun gnus-function-implies-unread-1 (function) "Recursively evaluate a predicate function to determine whether it can select any read articles. Returns t if the function is known to never return read articles, nil when it is known to always return read articles, and t_nil when the function may return both read and unread articles." (let ((func (car function)) (args (mapcar 'gnus-function-implies-unread-1 (cdr function)))) (cond ((eq func 'and) (cond ((memq t args) ; if any argument returns only unread articles ;; then that argument constrains the result to only unread articles. t) ((memq 't_nil args) ; if any argument is indeterminate ;; then the result is indeterminate 't_nil))) ((eq func 'or) (cond ((memq nil args) ; if any argument returns read articles ;; then that argument ensures that the results includes read articles. nil) ((memq 't_nil args) ; if any argument is indeterminate ;; then that argument ensures that the results are indeterminate 't_nil) (t ; if all arguments return only unread articles ;; then the result returns only unread articles t))) ((eq func 'not) (cond ((eq (car args) 't_nil) ; if the argument is indeterminate ; then the result is indeterminate (car args)) (t ; otherwise ; toggle the result to be the opposite of the argument (not (car args))))) ((eq func 'gnus-agent-read-p) nil) ; The read predicate NEVER returns unread articles ((eq func 'gnus-agent-false) t) ; The false predicate returns t as the empty set excludes all read articles ((eq func 'gnus-agent-true) nil) ; The true predicate ALWAYS returns read articles ((catch 'found-match (let ((alist gnus-category-predicate-alist)) (while alist (if (eq func (cdar alist)) (throw 'found-match t) (setq alist (cdr alist)))))) 't_nil) ; All other predicates return read and unread articles (t (error "Unknown predicate function: %s" function))))) (defun gnus-group-category (group) "Return the category GROUP belongs to." (unless gnus-category-group-cache (setq gnus-category-group-cache (gnus-make-hashtable 1000)) (let ((cs gnus-category-alist) groups cat) (while (setq cat (pop cs)) (setq groups (gnus-agent-cat-groups cat)) (while groups (gnus-sethash (pop groups) cat gnus-category-group-cache))))) (or (gnus-gethash group gnus-category-group-cache) (assq 'default gnus-category-alist))) (defun gnus-agent-expire-group (group &optional articles force) "Expire all old articles in GROUP. If you want to force expiring of certain articles, this function can take ARTICLES, and FORCE parameters as well. The articles on which the expiration process runs are selected as follows: if ARTICLES is null, all read and unmarked articles. if ARTICLES is t, all articles. if ARTICLES is a list, just those articles. FORCE is equivalent to setting the expiration predicates to true." (interactive (list (gnus-agent-read-group))) (if (not group) (gnus-agent-expire articles group force) (let ( ;; Bind gnus-agent-expire-stats to enable tracking of ;; expiration statistics of this single group (gnus-agent-expire-stats (list 0 0 0.0))) (if (or (not (eq articles t)) (yes-or-no-p (concat "Are you sure that you want to " "expire all articles in " group "? "))) (let ((gnus-command-method (gnus-find-method-for-group group)) (overview (gnus-get-buffer-create " *expire overview*")) orig) (unwind-protect (let ((active-file (gnus-agent-lib-file "active"))) (when (file-exists-p active-file) (with-temp-buffer (nnheader-insert-file-contents active-file) (gnus-active-to-gnus-format gnus-command-method (setq orig (gnus-make-hashtable (count-lines (point-min) (point-max)))))) (save-excursion (gnus-agent-expire-group-1 group overview (gnus-gethash-safe group orig) articles force)))) (kill-buffer overview)))) (gnus-message 4 (gnus-agent-expire-done-message))))) (defun gnus-agent-expire-group-1 (group overview active articles force) ;; Internal function - requires caller to have set ;; gnus-command-method, initialized overview buffer, and to have ;; provided a non-nil active (let ((dir (gnus-agent-group-pathname group)) (file-name-coding-system nnmail-pathname-coding-system) (decoded (gnus-agent-decoded-group-name group))) (gnus-agent-with-refreshed-group group (when (boundp 'gnus-agent-expire-current-dirs) (set 'gnus-agent-expire-current-dirs (cons dir (symbol-value 'gnus-agent-expire-current-dirs)))) (if (and (not force) (eq 'DISABLE (gnus-agent-find-parameter group 'agent-enable-expiration))) (gnus-message 5 "Expiry skipping over %s" decoded) (gnus-message 5 "Expiring articles in %s" decoded) (gnus-agent-load-alist group) (let* ((bytes-freed 0) (size-files-deleted 0.0) (files-deleted 0) (nov-entries-deleted 0) (info (gnus-get-info group)) (alist gnus-agent-article-alist) (day (- (time-to-days (current-time)) (gnus-agent-find-parameter group 'agent-days-until-old))) (specials (if (and alist (not force)) ;; This could be a bit of a problem. I need to ;; keep the last article to avoid refetching ;; headers when using nntp in the backend. At ;; the same time, if someone uses a backend ;; that supports article moving then I may have ;; to remove the last article to complete the ;; move. Right now, I'm going to assume that ;; FORCE overrides specials. (list (caar (last alist))))) (unreads ;; Articles that are excluded from the ;; expiration process (cond (gnus-agent-expire-all ;; All articles are marked read by global decree nil) ((eq articles t) ;; All articles are marked read by function ;; parameter nil) ((not articles) ;; Unread articles are marked protected from ;; expiration Don't call ;; gnus-list-of-unread-articles as it returns ;; articles that have not been fetched into the ;; agent. (ignore-errors (gnus-agent-unread-articles group))) (t ;; All articles EXCEPT those named by the caller ;; are protected from expiration (gnus-sorted-difference (gnus-uncompress-range (cons (caar alist) (caar (last alist)))) (sort articles '<))))) (marked ;; More articles that are excluded from the ;; expiration process (cond (gnus-agent-expire-all ;; All articles are unmarked by global decree nil) ((eq articles t) ;; All articles are unmarked by function ;; parameter nil) (articles ;; All articles may as well be unmarked as the ;; unreads list already names the articles we are ;; going to keep nil) (t ;; Ticked and/or dormant articles are excluded ;; from expiration (nconc (gnus-uncompress-range (cdr (assq 'tick (gnus-info-marks info)))) (gnus-uncompress-range (cdr (assq 'dormant (gnus-info-marks info)))))))) (nov-file (concat dir ".overview")) (cnt 0) (completed -1) dlist type) ;; The normal article alist contains elements that look like ;; (article# . fetch_date) I need to combine other ;; information with this list. For example, a flag indicating ;; that a particular article MUST BE KEPT. To do this, I'm ;; going to transform the elements to look like (article# ;; fetch_date keep_flag NOV_entry_position) Later, I'll reverse ;; the process to generate the expired article alist. ;; Convert the alist elements to (article# fetch_date nil ;; nil). (setq dlist (mapcar (lambda (e) (list (car e) (cdr e) nil nil)) alist)) ;; Convert the keep lists to elements that look like (article# ;; nil keep_flag nil) then append it to the expanded dlist ;; These statements are sorted by ascending precidence of the ;; keep_flag. (setq dlist (nconc dlist (mapcar (lambda (e) (list e nil 'unread nil)) unreads))) (setq dlist (nconc dlist (mapcar (lambda (e) (list e nil 'marked nil)) marked))) (setq dlist (nconc dlist (mapcar (lambda (e) (list e nil 'special nil)) specials))) (set-buffer overview) (erase-buffer) (buffer-disable-undo) (when (file-exists-p nov-file) (gnus-message 7 "gnus-agent-expire: Loading overview...") (nnheader-insert-file-contents nov-file) (goto-char (point-min)) (let (p) (while (< (setq p (point)) (point-max)) (condition-case nil ;; If I successfully read an integer (the plus zero ;; ensures a numeric type), append the position ;; to the list (push (list (+ 0 (read (current-buffer))) nil nil p) dlist) (error (gnus-message 1 "gnus-agent-expire: read error \ occurred when reading expression at %s in %s. Skipping to next \ line." (point) nov-file))) ;; Whether I succeeded, or failed, it doesn't matter. ;; Move to the next line then try again. (forward-line 1))) (gnus-message 7 "gnus-agent-expire: Loading overview... Done")) (set-buffer-modified-p nil) ;; At this point, all of the information is in dlist. The ;; only problem is that much of it is spread across multiple ;; entries. Sort then MERGE!! (gnus-message 7 "gnus-agent-expire: Sorting entries... ") ;; If two entries have the same article-number then sort by ;; ascending keep_flag. (let ((special 0) (marked 1) (unread 2)) (setq dlist (sort dlist (lambda (a b) (cond ((< (nth 0 a) (nth 0 b)) t) ((> (nth 0 a) (nth 0 b)) nil) (t (let ((a (or (symbol-value (nth 2 a)) 3)) (b (or (symbol-value (nth 2 b)) 3))) (<= a b)))))))) (gnus-message 7 "gnus-agent-expire: Sorting entries... Done") (gnus-message 7 "gnus-agent-expire: Merging entries... ") (let ((dlist dlist)) (while (cdr dlist) ; I'm not at the end-of-list (if (eq (caar dlist) (caadr dlist)) (let ((first (cdr (car dlist))) (secnd (cdr (cadr dlist)))) (setcar first (or (car first) (car secnd))) ; fetch_date (setq first (cdr first) secnd (cdr secnd)) (setcar first (or (car first) (car secnd))) ; Keep_flag (setq first (cdr first) secnd (cdr secnd)) (setcar first (or (car first) (car secnd))) ; NOV_entry_position (setcdr dlist (cddr dlist))) (setq dlist (cdr dlist))))) ;; Check the order of the entry positions. They should be in ;; ascending order. If they aren't, the positions must be ;; converted to markers. (when (catch 'sort-results (let ((dlist dlist) (prev-pos -1) pos) (while dlist (if (setq pos (nth 3 (pop dlist))) (if (< pos prev-pos) (throw 'sort-results 'unsorted) (setq prev-pos pos)))))) (gnus-message 7 "gnus-agent-expire: Unsorted overview; inserting markers to compensate.") (mapc (lambda (entry) (let ((pos (nth 3 entry))) (if pos (setf (nth 3 entry) (set-marker (make-marker) pos))))) dlist)) (gnus-message 7 "gnus-agent-expire: Merging entries... Done") (let* ((len (float (length dlist))) (alist (list nil)) (tail-alist alist) (position-offset 0) ) (while dlist (let ((new-completed (truncate (* 100.0 (/ (setq cnt (1+ cnt)) len)))) message-log-max) (when (> new-completed completed) (setq completed new-completed) (gnus-message 7 "%3d%% completed..." completed))) (let* ((entry (car dlist)) (article-number (nth 0 entry)) (fetch-date (nth 1 entry)) (keep (nth 2 entry)) (marker (nth 3 entry))) (cond ;; Kept articles are unread, marked, or special. (keep (gnus-agent-message 10 "gnus-agent-expire: %s:%d: Kept %s article%s." decoded article-number keep (if fetch-date " and file" "")) (when fetch-date (unless (file-exists-p (concat dir (number-to-string article-number))) (setf (nth 1 entry) nil) (gnus-agent-message 3 "gnus-agent-expire cleared \ download flag on %s:%d as the cached article file is missing." decoded (caar dlist))) (unless marker (gnus-message 1 "gnus-agent-expire detected a \ missing NOV entry. Run gnus-agent-regenerate-group to restore it."))) (gnus-agent-append-to-list tail-alist (cons article-number fetch-date))) ;; The following articles are READ, UNMARKED, and ;; ORDINARY. See if they can be EXPIRED!!! ((setq type (cond ((not (integerp fetch-date)) 'read) ;; never fetched article (may expire ;; right now) ((not (file-exists-p (concat dir (number-to-string article-number)))) (setf (nth 1 entry) nil) 'externally-expired) ;; Can't find the cached ;; article. Handle case ;; as though this article ;; was never fetched. ;; We now have the arrival day, so we see ;; whether it's old enough to be expired. ((< fetch-date day) 'expired) (force 'forced))) ;; I found some reason to expire this entry. (let ((actions nil)) (when (memq type '(forced expired)) (ignore-errors ; Just being paranoid. (let* ((file-name (nnheader-concat dir (number-to-string article-number))) (size (float (nth 7 (file-attributes file-name))))) (incf bytes-freed size) (incf size-files-deleted size) (incf files-deleted) (delete-file file-name)) (push "expired cached article" actions)) (setf (nth 1 entry) nil) ) (when marker (push "NOV entry removed" actions) (goto-char (if (markerp marker) marker (- marker position-offset))) (incf nov-entries-deleted) (let* ((from (point-at-bol)) (to (progn (forward-line 1) (point))) (freed (- to from))) (incf bytes-freed freed) (incf position-offset freed) (delete-region from to))) ;; If considering all articles is set, I can only ;; expire article IDs that are no longer in the ;; active range (That is, articles that preceed the ;; first article in the new alist). (if (and gnus-agent-consider-all-articles (>= article-number (car active))) ;; I have to keep this ID in the alist (gnus-agent-append-to-list tail-alist (cons article-number fetch-date)) (push (format "Removed %s article number from \ article alist" type) actions)) (when actions (gnus-agent-message 8 "gnus-agent-expire: %s:%d: %s" decoded article-number (mapconcat 'identity actions ", "))))) (t (gnus-agent-message 10 "gnus-agent-expire: %s:%d: Article kept as \ expiration tests failed." decoded article-number) (gnus-agent-append-to-list tail-alist (cons article-number fetch-date))) ) ;; Remove markers as I intend to reuse this buffer again. (when (and marker (markerp marker)) (set-marker marker nil)) (setq dlist (cdr dlist)))) (setq alist (cdr alist)) (let ((inhibit-quit t)) (unless (equal alist gnus-agent-article-alist) (setq gnus-agent-article-alist alist) (gnus-agent-save-alist group)) (when (buffer-modified-p) (let ((coding-system-for-write gnus-agent-file-coding-system)) (gnus-make-directory dir) (write-region (point-min) (point-max) nov-file nil 'silent) ;; clear the modified flag as that I'm not confused by ;; its status on the next pass through this routine. (set-buffer-modified-p nil) (gnus-agent-update-view-total-fetched-for group t))) (when (eq articles t) (gnus-summary-update-info)))) (when (boundp 'gnus-agent-expire-stats) (let ((stats (symbol-value 'gnus-agent-expire-stats))) (incf (nth 2 stats) bytes-freed) (incf (nth 1 stats) files-deleted) (incf (nth 0 stats) nov-entries-deleted))) (gnus-agent-update-files-total-fetched-for group (- size-files-deleted))))))) (defun gnus-agent-expire (&optional articles group force) "Expire all old articles. If you want to force expiring of certain articles, this function can take ARTICLES, GROUP and FORCE parameters as well. The articles on which the expiration process runs are selected as follows: if ARTICLES is null, all read and unmarked articles. if ARTICLES is t, all articles. if ARTICLES is a list, just those articles. Setting GROUP will limit expiration to that group. FORCE is equivalent to setting the expiration predicates to true." (interactive) (if group (gnus-agent-expire-group group articles force) (if (or (not (eq articles t)) (yes-or-no-p "Are you sure that you want to expire all \ articles in every agentized group? ")) (let ((methods (gnus-agent-covered-methods)) ;; Bind gnus-agent-expire-current-dirs to enable tracking ;; of agent directories. (gnus-agent-expire-current-dirs nil) ;; Bind gnus-agent-expire-stats to enable tracking of ;; expiration statistics across all groups (gnus-agent-expire-stats (list 0 0 0.0)) gnus-command-method overview orig) (setq overview (gnus-get-buffer-create " *expire overview*")) (unwind-protect (while (setq gnus-command-method (pop methods)) (let ((active-file (gnus-agent-lib-file "active"))) (when (file-exists-p active-file) (with-temp-buffer (nnheader-insert-file-contents active-file) (gnus-active-to-gnus-format gnus-command-method (setq orig (gnus-make-hashtable (count-lines (point-min) (point-max)))))) (dolist (expiring-group (gnus-groups-from-server gnus-command-method)) (let* ((active (gnus-gethash-safe expiring-group orig))) (when active (save-excursion (gnus-agent-expire-group-1 expiring-group overview active articles force)))))))) (kill-buffer overview)) (gnus-agent-expire-unagentized-dirs) (gnus-message 4 (gnus-agent-expire-done-message)))))) (defun gnus-agent-expire-done-message () (if (and (> gnus-verbose 4) (boundp 'gnus-agent-expire-stats)) (let* ((stats (symbol-value 'gnus-agent-expire-stats)) (size (nth 2 stats)) (units '(B KB MB GB))) (while (and (> size 1024.0) (cdr units)) (setq size (/ size 1024.0) units (cdr units))) (format "Expiry recovered %d NOV entries, deleted %d files,\ and freed %f %s." (nth 0 stats) (nth 1 stats) size (car units))) "Expiry...done")) (defun gnus-agent-expire-unagentized-dirs () (when (and gnus-agent-expire-unagentized-dirs (boundp 'gnus-agent-expire-current-dirs)) (let* ((keep (gnus-make-hashtable)) ;; Formally bind gnus-agent-expire-current-dirs so that the ;; compiler will not complain about free references. (gnus-agent-expire-current-dirs (symbol-value 'gnus-agent-expire-current-dirs)) dir (file-name-coding-system nnmail-pathname-coding-system)) (gnus-sethash gnus-agent-directory t keep) (while gnus-agent-expire-current-dirs (setq dir (pop gnus-agent-expire-current-dirs)) (when (and (stringp dir) (file-directory-p dir)) (while (not (gnus-gethash dir keep)) (gnus-sethash dir t keep) (setq dir (file-name-directory (directory-file-name dir)))))) (let* (to-remove checker (checker (function (lambda (d) "Given a directory, check it and its subdirectories for membership in the keep hash. If it isn't found, add it to to-remove." (let ((files (directory-files d)) file) (while (setq file (pop files)) (cond ((equal file ".") ; Ignore self nil) ((equal file "..") ; Ignore parent nil) ((equal file ".overview") ;; Directory must contain .overview to be ;; agent's cache of a group. (let ((d (file-name-as-directory d)) r) ;; Search ancestor's for last directory NOT ;; found in keep hash. (while (not (gnus-gethash (setq d (file-name-directory d)) keep)) (setq r d d (directory-file-name d))) ;; if ANY ancestor was NOT in keep hash and ;; it it's already in to-remove, add it to ;; to-remove. (if (and r (not (member r to-remove))) (push r to-remove)))) ((file-directory-p (setq file (nnheader-concat d file))) (funcall checker file))))))))) (funcall checker (expand-file-name gnus-agent-directory)) (when (and to-remove (or gnus-expert-user (gnus-y-or-n-p "gnus-agent-expire has identified local directories that are\ not currently required by any agentized group. Do you wish to consider\ deleting them?"))) (while to-remove (let ((dir (pop to-remove))) (if (gnus-y-or-n-p (format "Delete %s? " dir)) (let* (delete-recursive files f (delete-recursive (function (lambda (f-or-d) (ignore-errors (if (file-directory-p f-or-d) (condition-case nil (delete-directory f-or-d) (file-error (setq files (directory-files f-or-d)) (while files (setq f (pop files)) (or (member f '("." "..")) (funcall delete-recursive (nnheader-concat f-or-d f)))) (delete-directory f-or-d))) (delete-file f-or-d))))))) (funcall delete-recursive dir)))))))))) ;;;###autoload (defun gnus-agent-batch () "Start Gnus, send queue and fetch session." (interactive) (let ((init-file-user "") (gnus-always-read-dribble-file t)) (gnus)) (let ((gnus-agent-confirmation-function 'gnus-agent-batch-confirmation)) (gnus-group-send-queue) (gnus-agent-fetch-session))) (defun gnus-agent-unread-articles (group) (let* ((read (gnus-info-read (gnus-get-info group))) (known (gnus-agent-load-alist group)) (unread (list nil)) (tail-unread unread)) (while (and known read) (let ((candidate (car (pop known)))) (while (let* ((range (car read)) (min (if (numberp range) range (car range))) (max (if (numberp range) range (cdr range)))) (cond ((or (not min) (< candidate min)) (gnus-agent-append-to-list tail-unread candidate) nil) ((> candidate max) (setq read (cdr read)) ;; return t so that I always loop one more ;; time. If I just iterated off the end of ;; read, min will become nil and the current ;; candidate will be added to the unread list. t)))))) (while known (gnus-agent-append-to-list tail-unread (car (pop known)))) (cdr unread))) (defun gnus-agent-uncached-articles (articles group &optional cached-header) "Restrict ARTICLES to numbers already fetched. Returns a sublist of ARTICLES that excludes those article ids in GROUP that have already been fetched. If CACHED-HEADER is nil, articles are only excluded if the article itself has been fetched." ;; Logically equivalent to: (gnus-sorted-difference articles (mapcar ;; 'car gnus-agent-article-alist)) ;; Functionally, I don't need to construct a temp list using mapcar. (if (and (or gnus-agent-cache (not gnus-plugged)) (gnus-agent-load-alist group)) (let* ((ref gnus-agent-article-alist) (arts articles) (uncached (list nil)) (tail-uncached uncached)) (while (and ref arts) (let ((v1 (car arts)) (v2 (caar ref))) (cond ((< v1 v2) ; v1 does not appear in the reference list (gnus-agent-append-to-list tail-uncached v1) (setq arts (cdr arts))) ((= v1 v2) (unless (or cached-header (cdar ref)) ; v1 is already cached (gnus-agent-append-to-list tail-uncached v1)) (setq arts (cdr arts)) (setq ref (cdr ref))) (t ; reference article (v2) preceeds the list being filtered (setq ref (cdr ref)))))) (while arts (gnus-agent-append-to-list tail-uncached (pop arts))) (cdr uncached)) ;; if gnus-agent-load-alist fails, no articles are cached. articles)) (defun gnus-agent-retrieve-headers (articles group &optional fetch-old) (save-excursion (gnus-agent-create-buffer) (let ((gnus-decode-encoded-word-function 'identity) (gnus-decode-encoded-address-function 'identity) (file (gnus-agent-article-name ".overview" group)) cached-articles uncached-articles (file-name-coding-system nnmail-pathname-coding-system)) (gnus-make-directory (nnheader-translate-file-chars (file-name-directory file) t)) ;; Populate temp buffer with known headers (when (file-exists-p file) (with-current-buffer gnus-agent-overview-buffer (erase-buffer) (let ((nnheader-file-coding-system gnus-agent-file-coding-system)) (nnheader-insert-nov-file file (car articles))))) (if (setq uncached-articles (gnus-agent-uncached-articles articles group t)) (progn ;; Populate nntp-server-buffer with uncached headers (set-buffer nntp-server-buffer) (erase-buffer) (cond ((not (eq 'nov (let (gnus-agent) ; Turn off agent (gnus-retrieve-headers uncached-articles group fetch-old)))) (nnvirtual-convert-headers)) ((eq 'nntp (car gnus-current-select-method)) ;; The author of gnus-get-newsgroup-headers-xover ;; reports that the XOVER command is commonly ;; unreliable. The problem is that recently ;; posted articles may not be entered into the ;; NOV database in time to respond to my XOVER ;; query. ;; ;; I'm going to use his assumption that the NOV ;; database is updated in order of ascending ;; article ID. Therefore, a response containing ;; article ID N implies that all articles from 1 ;; to N-1 are up-to-date. Therefore, missing ;; articles in that range have expired. (set-buffer nntp-server-buffer) (let* ((fetched-articles (list nil)) (tail-fetched-articles fetched-articles) (min (cond ((numberp fetch-old) (max 1 (- (car articles) fetch-old))) (fetch-old 1) (t (car articles)))) (max (car (last articles)))) ;; Get the list of articles that were fetched (goto-char (point-min)) (let ((pm (point-max)) art) (while (< (point) pm) (when (setq art (gnus-agent-read-article-number)) (gnus-agent-append-to-list tail-fetched-articles art)) (forward-line 1))) ;; Clip this list to the headers that will ;; actually be returned (setq fetched-articles (gnus-list-range-intersection (cdr fetched-articles) (cons min max))) ;; Clip the uncached articles list to exclude ;; IDs after the last FETCHED header. The ;; excluded IDs may be fetchable using HEAD. (if (car tail-fetched-articles) (setq uncached-articles (gnus-list-range-intersection uncached-articles (cons (car uncached-articles) (car tail-fetched-articles))))) ;; Create the list of articles that were ;; "successfully" fetched. Success, in this ;; case, means that the ID should not be ;; fetched again. In the case of an expired ;; article, the header will not be fetched. (setq uncached-articles (gnus-sorted-nunion fetched-articles uncached-articles)) ))) ;; Erase the temp buffer (set-buffer gnus-agent-overview-buffer) (erase-buffer) ;; Copy the nntp-server-buffer to the temp buffer (set-buffer nntp-server-buffer) (copy-to-buffer gnus-agent-overview-buffer (point-min) (point-max)) ;; Merge the temp buffer with the known headers (found on ;; disk in FILE) into the nntp-server-buffer (when uncached-articles (gnus-agent-braid-nov group uncached-articles file)) ;; Save the new set of known headers to FILE (set-buffer nntp-server-buffer) (let ((coding-system-for-write gnus-agent-file-coding-system)) (gnus-agent-check-overview-buffer) (write-region (point-min) (point-max) file nil 'silent)) (gnus-agent-update-view-total-fetched-for group t) ;; Update the group's article alist to include the newly ;; fetched articles. (gnus-agent-load-alist group) (gnus-agent-save-alist group uncached-articles nil) ) ;; Copy the temp buffer to the nntp-server-buffer (set-buffer nntp-server-buffer) (erase-buffer) (insert-buffer-substring gnus-agent-overview-buffer))) (if (and fetch-old (not (numberp fetch-old))) t ; Don't remove anything. (nnheader-nov-delete-outside-range (if fetch-old (max 1 (- (car articles) fetch-old)) (car articles)) (car (last articles))) t) 'nov)) (defun gnus-agent-request-article (article group) "Retrieve ARTICLE in GROUP from the agent cache." (when (and gnus-agent (or gnus-agent-cache (not gnus-plugged)) (numberp article)) (let* ((gnus-command-method (gnus-find-method-for-group group)) (file (gnus-agent-article-name (number-to-string article) group)) (buffer-read-only nil) (file-name-coding-system nnmail-pathname-coding-system)) (when (and (file-exists-p file) (> (nth 7 (file-attributes file)) 0)) (erase-buffer) (gnus-kill-all-overlays) (let ((coding-system-for-read gnus-cache-coding-system)) (insert-file-contents file)) t)))) (defun gnus-agent-regenerate-group (group &optional reread) "Regenerate GROUP. If REREAD is t, all articles in the .overview are marked as unread. If REREAD is a list, the specified articles will be marked as unread. In addition, their NOV entries in .overview will be refreshed using the articles' current headers. If REREAD is not nil, downloaded articles are marked as unread." (interactive (list (gnus-agent-read-group) (catch 'mark (while (let (c (cursor-in-echo-area t) (echo-keystrokes 0)) (message "Mark as unread: (n)one / (a)ll / all (d)ownloaded articles? (n) ") (setq c (read-char-exclusive)) (cond ((or (eq c ?\r) (eq c ?n) (eq c ?N)) (throw 'mark nil)) ((or (eq c ?a) (eq c ?A)) (throw 'mark t)) ((or (eq c ?d) (eq c ?D)) (throw 'mark 'some))) (gnus-message 3 "Ignoring unexpected input") (sit-for 1) t))))) (when group (gnus-message 5 "Regenerating in %s" group) (let* ((gnus-command-method (or gnus-command-method (gnus-find-method-for-group group))) (file (gnus-agent-article-name ".overview" group)) (dir (file-name-directory file)) point (file-name-coding-system nnmail-pathname-coding-system) (downloaded (if (file-exists-p dir) (sort (delq nil (mapcar (lambda (name) (and (not (file-directory-p (nnheader-concat dir name))) (string-to-number name))) (directory-files dir nil "^[0-9]+$" t))) '>) (progn (gnus-make-directory dir) nil))) dl nov-arts alist header regenerated) (mm-with-unibyte-buffer (if (file-exists-p file) (let ((nnheader-file-coding-system gnus-agent-file-coding-system)) (nnheader-insert-file-contents file))) (set-buffer-modified-p nil) ;; Load the article IDs found in the overview file. As a ;; side-effect, validate the file contents. (let ((load t)) (while load (setq load nil) (goto-char (point-min)) (while (< (point) (point-max)) (cond ((and (looking-at "[0-9]+\t") (<= (- (match-end 0) (match-beginning 0)) 9)) (push (read (current-buffer)) nov-arts) (forward-line 1) (let ((l1 (car nov-arts)) (l2 (cadr nov-arts))) (cond ((and (listp reread) (memq l1 reread)) (gnus-delete-line) (setq nov-arts (cdr nov-arts)) (gnus-message 4 "gnus-agent-regenerate-group: NOV\ entry of article %s deleted." l1)) ((not l2) nil) ((< l1 l2) (gnus-message 3 "gnus-agent-regenerate-group: NOV\ entries are NOT in ascending order.") ;; Don't sort now as I haven't verified ;; that every line begins with a number (setq load t)) ((= l1 l2) (forward-line -1) (gnus-message 4 "gnus-agent-regenerate-group: NOV\ entries contained duplicate of article %s. Duplicate deleted." l1) (gnus-delete-line) (setq nov-arts (cdr nov-arts)))))) (t (gnus-message 1 "gnus-agent-regenerate-group: NOV\ entries contained line that did not begin with an article number. Deleted\ line.") (gnus-delete-line)))) (when load (gnus-message 5 "gnus-agent-regenerate-group: Sorting NOV\ entries into ascending order.") (sort-numeric-fields 1 (point-min) (point-max)) (setq nov-arts nil)))) (gnus-agent-check-overview-buffer) ;; Construct a new article alist whose nodes match every header ;; in the .overview file. As a side-effect, missing headers are ;; reconstructed from the downloaded article file. (while (or downloaded nov-arts) (cond ((and downloaded (or (not nov-arts) (> (car downloaded) (car nov-arts)))) ;; This entry is missing from the overview file (gnus-message 3 "Regenerating NOV %s %d..." group (car downloaded)) (let ((file (concat dir (number-to-string (car downloaded))))) (mm-with-unibyte-buffer (nnheader-insert-file-contents file) (nnheader-remove-body) (setq header (nnheader-parse-naked-head))) (mail-header-set-number header (car downloaded)) (if nov-arts (let ((key (concat "^" (int-to-string (car nov-arts)) "\t"))) (or (re-search-backward key nil t) (re-search-forward key)) (forward-line 1)) (goto-char (point-min))) (nnheader-insert-nov header)) (setq nov-arts (cons (car downloaded) nov-arts))) ((eq (car downloaded) (car nov-arts)) ;; This entry in the overview has been downloaded (push (cons (car downloaded) (time-to-days (nth 5 (file-attributes (concat dir (number-to-string (car downloaded))))))) alist) (setq downloaded (cdr downloaded)) (setq nov-arts (cdr nov-arts))) (t ;; This entry in the overview has not been downloaded (push (cons (car nov-arts) nil) alist) (setq nov-arts (cdr nov-arts))))) ;; When gnus-agent-consider-all-articles is set, ;; gnus-agent-regenerate-group should NOT remove article IDs from ;; the alist. Those IDs serve as markers to indicate that an ;; attempt has been made to fetch that article's header. ;; When gnus-agent-consider-all-articles is NOT set, ;; gnus-agent-regenerate-group can remove the article ID of every ;; article (with the exception of the last ID in the list - it's ;; special) that no longer appears in the overview. In this ;; situtation, the last article ID in the list implies that it, ;; and every article ID preceeding it, have been fetched from the ;; server. (if gnus-agent-consider-all-articles ;; Restore all article IDs that were not found in the overview file. (let* ((n (cons nil alist)) (merged n) (o (gnus-agent-load-alist group))) (while o (let ((nID (caadr n)) (oID (caar o))) (cond ((not nID) (setq n (setcdr n (list (list oID)))) (setq o (cdr o))) ((< oID nID) (setcdr n (cons (list oID) (cdr n))) (setq o (cdr o))) ((= oID nID) (setq o (cdr o)) (setq n (cdr n))) (t (setq n (cdr n)))))) (setq alist (cdr merged))) ;; Restore the last article ID if it is not already in the new alist (let ((n (last alist)) (o (last (gnus-agent-load-alist group)))) (cond ((not o) nil) ((not n) (push (cons (caar o) nil) alist)) ((< (caar n) (caar o)) (setcdr n (list (car o))))))) (let ((inhibit-quit t)) (if (setq regenerated (buffer-modified-p)) (let ((coding-system-for-write gnus-agent-file-coding-system)) (write-region (point-min) (point-max) file nil 'silent))) (setq regenerated (or regenerated (and reread gnus-agent-article-alist) (not (equal alist gnus-agent-article-alist)))) (setq gnus-agent-article-alist alist) (when regenerated (gnus-agent-save-alist group) ;; I have to alter the group's active range NOW as ;; gnus-make-ascending-articles-unread will use it to ;; recalculate the number of unread articles in the group (let ((group (gnus-group-real-name group)) (group-active (or (gnus-active group) (gnus-activate-group group)))) (gnus-agent-possibly-alter-active group group-active))))) (when (and reread gnus-agent-article-alist) (gnus-agent-synchronize-group-flags group (list (list (if (listp reread) reread (delq nil (mapcar (function (lambda (c) (cond ((eq reread t) (car c)) ((cdr c) (car c))))) gnus-agent-article-alist))) 'del '(read))) gnus-command-method) (when regenerated (gnus-agent-update-files-total-fetched-for group nil))) (gnus-message 5 "") regenerated))) ;;;###autoload (defun gnus-agent-regenerate (&optional clean reread) "Regenerate all agent covered files. If CLEAN, obsolete (ignore)." (interactive "P") (let (regenerated) (gnus-message 4 "Regenerating Gnus agent files...") (dolist (gnus-command-method (gnus-agent-covered-methods)) (dolist (group (gnus-groups-from-server gnus-command-method)) (setq regenerated (or (gnus-agent-regenerate-group group reread) regenerated)))) (gnus-message 4 "Regenerating Gnus agent files...done") regenerated)) (defun gnus-agent-go-online (&optional force) "Switch servers into online status." (interactive (list t)) (dolist (server gnus-opened-servers) (when (eq (nth 1 server) 'offline) (if (if (eq force 'ask) (gnus-y-or-n-p (format "Switch %s:%s into online status? " (caar server) (cadar server))) force) (setcar (nthcdr 1 server) 'close))))) (defun gnus-agent-toggle-group-plugged (group) "Toggle the status of the server of the current group." (interactive (list (gnus-group-group-name))) (let* ((method (gnus-find-method-for-group group)) (status (cadr (assoc method gnus-opened-servers)))) (if (eq status 'offline) (gnus-server-set-status method 'closed) (gnus-close-server method) (gnus-server-set-status method 'offline)) (message "Turn %s:%s from %s to %s." (car method) (cadr method) (if (eq status 'offline) 'offline 'online) (if (eq status 'offline) 'online 'offline)))) (defun gnus-agent-group-covered-p (group) (gnus-agent-method-p (gnus-group-method group))) (defun gnus-agent-update-files-total-fetched-for (group delta &optional method path) "Update, or set, the total disk space used by the articles that the agent has fetched." (when gnus-agent-total-fetched-hashtb (gnus-agent-with-refreshed-group group ;; if null, gnus-agent-group-pathname will calc method. (let* ((gnus-command-method method) (path (or path (gnus-agent-group-pathname group))) (entry (or (gnus-gethash path gnus-agent-total-fetched-hashtb) (gnus-sethash path (make-list 3 0) gnus-agent-total-fetched-hashtb))) (file-name-coding-system nnmail-pathname-coding-system)) (when (listp delta) (if delta (let ((sum 0.0) file) (while (setq file (pop delta)) (incf sum (float (or (nth 7 (file-attributes (nnheader-concat path (if (numberp file) (number-to-string file) file)))) 0)))) (setq delta sum)) (let ((sum (- (nth 2 entry))) (info (directory-files-and-attributes path nil "^-?[0-9]+$" t)) file) (while (setq file (pop info)) (incf sum (float (or (nth 8 file) 0)))) (setq delta sum)))) (setq gnus-agent-need-update-total-fetched-for t) (incf (nth 2 entry) delta))))) (defun gnus-agent-update-view-total-fetched-for (group agent-over &optional method path) "Update, or set, the total disk space used by the .agentview and .overview files. These files are calculated separately as they can be modified." (when gnus-agent-total-fetched-hashtb (gnus-agent-with-refreshed-group group ;; if null, gnus-agent-group-pathname will calc method. (let* ((gnus-command-method method) (path (or path (gnus-agent-group-pathname group))) (entry (or (gnus-gethash path gnus-agent-total-fetched-hashtb) (gnus-sethash path (make-list 3 0) gnus-agent-total-fetched-hashtb))) (file-name-coding-system nnmail-pathname-coding-system) (size (or (nth 7 (file-attributes (nnheader-concat path (if agent-over ".overview" ".agentview")))) 0))) (setq gnus-agent-need-update-total-fetched-for t) (setf (nth (if agent-over 1 0) entry) size))))) (defun gnus-agent-total-fetched-for (group &optional method no-inhibit) "Get the total disk space used by the specified GROUP." (unless (equal group "dummy.group") (unless gnus-agent-total-fetched-hashtb (setq gnus-agent-total-fetched-hashtb (gnus-make-hashtable 1024))) ;; if null, gnus-agent-group-pathname will calc method. (let* ((gnus-command-method method) (path (gnus-agent-group-pathname group)) (entry (gnus-gethash path gnus-agent-total-fetched-hashtb))) (if entry (apply '+ entry) (let ((gnus-agent-inhibit-update-total-fetched-for (not no-inhibit))) (+ (gnus-agent-update-view-total-fetched-for group nil method path) (gnus-agent-update-view-total-fetched-for group t method path) (gnus-agent-update-files-total-fetched-for group nil method path))))))) (provide 'gnus-agent) ;; arch-tag: b0ba4afc-5229-4cee-ad25-9956daa4e91e ;;; gnus-agent.el ends here gnus-5.11+v0.10.dfsg/lisp/score-mode.el0000644000175000017500000001004211004005110017575 0ustar tvainikatvainika;;; score-mode.el --- mode for editing Gnus score files ;; Copyright (C) 1996, 2001, 2002, 2003, 2004, ;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; Keywords: news, mail ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 3, or (at your option) ;; any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Commentary: ;;; Code: (eval-when-compile (require 'cl)) (require 'mm-util) ; for mm-universal-coding-system (require 'gnus-util) ; for gnus-pp, gnus-run-mode-hooks (defvar gnus-score-edit-done-hook nil "*Hook run at the end of closing the score buffer.") (defvar gnus-score-mode-hook nil "*Hook run in score mode buffers.") (defvar gnus-score-menu-hook nil "*Hook run after creating the score mode menu.") (defvar gnus-score-edit-exit-function nil "Function run on exit from the score buffer.") (defvar gnus-score-mode-map nil) (unless gnus-score-mode-map (setq gnus-score-mode-map (make-sparse-keymap)) (set-keymap-parent gnus-score-mode-map emacs-lisp-mode-map) (define-key gnus-score-mode-map "\C-c\C-c" 'gnus-score-edit-exit) (define-key gnus-score-mode-map "\C-c\C-d" 'gnus-score-edit-insert-date) (define-key gnus-score-mode-map "\C-c\C-p" 'gnus-score-pretty-print)) (defvar score-mode-syntax-table (let ((table (copy-syntax-table lisp-mode-syntax-table))) (modify-syntax-entry ?| "w" table) table) "Syntax table used in score-mode buffers.") ;; We need this to cope with non-ASCII scoring. (defvar score-mode-coding-system mm-universal-coding-system) ;;;###autoload (defun gnus-score-mode () "Mode for editing Gnus score files. This mode is an extended emacs-lisp mode. \\{gnus-score-mode-map}" (interactive) (kill-all-local-variables) (use-local-map gnus-score-mode-map) (gnus-score-make-menu-bar) (set-syntax-table score-mode-syntax-table) (setq major-mode 'gnus-score-mode) (setq mode-name "Score") (lisp-mode-variables nil) (make-local-variable 'gnus-score-edit-exit-function) (gnus-run-mode-hooks 'emacs-lisp-mode-hook 'gnus-score-mode-hook)) (defun gnus-score-make-menu-bar () (unless (boundp 'gnus-score-menu) (easy-menu-define gnus-score-menu gnus-score-mode-map "" '("Score" ["Exit" gnus-score-edit-exit t] ["Insert date" gnus-score-edit-insert-date t] ["Format" gnus-score-pretty-print t])) (run-hooks 'gnus-score-menu-hook))) (defun gnus-score-edit-insert-date () "Insert date in numerical format." (interactive) (princ (time-to-days (current-time)) (current-buffer))) (defun gnus-score-pretty-print () "Format the current score file." (interactive) (goto-char (point-min)) (let ((form (read (current-buffer)))) (erase-buffer) (let ((emacs-lisp-mode-syntax-table score-mode-syntax-table)) (gnus-pp form))) (goto-char (point-min))) (defun gnus-score-edit-exit () "Stop editing the score file." (interactive) (unless (file-exists-p (file-name-directory (buffer-file-name))) (make-directory (file-name-directory (buffer-file-name)) t)) (let ((coding-system-for-write score-mode-coding-system)) (save-buffer)) (bury-buffer (current-buffer)) (let ((buf (current-buffer))) (when gnus-score-edit-exit-function (funcall gnus-score-edit-exit-function)) (when (eq buf (current-buffer)) (switch-to-buffer (other-buffer (current-buffer)))))) (provide 'score-mode) ;; arch-tag: a74a416b-2505-4ad4-bc4e-a418c96b8845 ;;; score-mode.el ends here gnus-5.11+v0.10.dfsg/lisp/nnimap.el0000644000175000017500000020367111004005110017036 0ustar tvainikatvainika;;; nnimap.el --- imap backend for Gnus ;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, ;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc. ;; Author: Simon Josefsson ;; Jim Radford ;; Keywords: mail ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 3, or (at your option) ;; any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Commentary: ;; Todo, major things: ;; ;; o Fix Gnus to view correct number of unread/total articles in group buffer ;; o Fix Gnus to handle leading '.' in group names (fixed?) ;; o Finish disconnected mode (moving articles between mailboxes unplugged) ;; o Sieve ;; o MIME (partial article fetches) ;; o Split to other backends, different split rules for different ;; servers/inboxes ;; ;; Todo, minor things: ;; ;; o Don't require half of Gnus -- backends should be standalone ;; o Verify that we don't use IMAP4rev1 specific things (RFC2060 App B) ;; o Dont uid fetch 1,* in nnimap-retrive-groups (slow) ;; o Split up big fetches (1,* header especially) in smaller chunks ;; o What do I do with gnus-newsgroup-*? ;; o Tell Gnus about new groups (how can we tell?) ;; o Respooling (fix Gnus?) (unnecessary?) ;; o Add support for the following: (if applicable) ;; request-list-newsgroups, request-regenerate ;; list-active-group, ;; request-associate-buffer, request-restore-buffer, ;; o Do The Right Thing when UIDVALIDITY changes (what's the right thing?) ;; o Support RFC2221 (Login referrals) ;; o IMAP2BIS compatibility? (RFC2061) ;; o ACAP stuff (perhaps a different project, would be nice to ACAPify ;; .newsrc.eld) ;; o What about Gnus's article editing, can we support it? NO! ;; o Use \Draft to support the draft group?? ;; o Duplicate suppression ;; o Rewrite UID SEARCH UID X as UID FETCH X (UID) for those with slow servers ;;; Code: (require 'imap) (require 'nnoo) (require 'nnmail) (require 'nnheader) (require 'mm-util) (require 'gnus) (require 'gnus-range) (require 'gnus-start) (require 'gnus-int) (eval-when-compile (require 'cl)) (nnoo-declare nnimap) (defconst nnimap-version "nnimap 1.0") (defgroup nnimap nil "Reading IMAP mail with Gnus." :group 'gnus) (defvoo nnimap-address nil "Address of physical IMAP server. If nil, use the virtual server's name.") (defvoo nnimap-server-port nil "Port number on physical IMAP server. If nil, defaults to 993 for TLS/SSL connections and 143 otherwise.") ;; Splitting variables (defcustom nnimap-split-crosspost t "If non-nil, do crossposting if several split methods match the mail. If nil, the first match found will be used." :group 'nnimap :type 'boolean) (defcustom nnimap-split-inbox nil "Name of mailbox to split mail from. Mail is read from this mailbox and split according to rules in `nnimap-split-rule'. This can be a string or a list of strings." :group 'nnimap :type '(choice (string) (repeat string))) (define-widget 'nnimap-strict-function 'function "This widget only matches values that are functionp. Warning: This means that a value that is the symbol of a not yet loaded function will not match. Use with care." :match 'nnimap-strict-function-match) (defun nnimap-strict-function-match (widget value) "Ignoring WIDGET, match if VALUE is a function." (functionp value)) (defcustom nnimap-split-rule nil "Mail will be split according to these rules. Mail is read from mailbox(es) specified in `nnimap-split-inbox'. If you'd like, for instance, one mail group for mail from the \"gnus-imap\" mailing list, one group for junk mail and leave everything else in the incoming mailbox, you could do something like this: \(setq nnimap-split-rule '((\"INBOX.gnus-imap\" \"From:.*gnus-imap\") (\"INBOX.junk\" \"Subject:.*buy\"))) As you can see, `nnimap-split-rule' is a list of lists, where the first element in each \"rule\" is the name of the IMAP mailbox (or the symbol `junk' if you want to remove the mail), and the second is a regexp that nnimap will try to match on the header to find a fit. The second element can also be a function. In that case, it will be called narrowed to the headers with the first element of the rule as the argument. It should return a non-nil value if it thinks that the mail belongs in that group. This variable can also have a function as its value, the function will be called with the headers narrowed and should return a group where it thinks the article should be splitted to. See `nnimap-split-fancy'. To allow for different split rules on different virtual servers, and even different split rules in different inboxes on the same server, the syntax of this variable have been extended along the lines of: \(setq nnimap-split-rule '((\"my1server\" (\".*\" ((\"ding\" \"ding@gnus.org\") (\"junk\" \"From:.*Simon\"))) (\"my2server\" (\"INBOX\" nnimap-split-fancy)) (\"my[34]server\" (\".*\" ((\"private\" \"To:.*Simon\") (\"junk\" my-junk-func))))) The virtual server name is in fact a regexp, so that the same rules may apply to several servers. In the example, the servers \"my3server\" and \"my4server\" both use the same rules. Similarly, the inbox string is also a regexp. The actual splitting rules are as before, either a function, or a list with group/regexp or group/function elements." :group 'nnimap :type '(choice :tag "Rule type" (repeat :menu-tag "Single-server" :tag "Single-server list" (list (string :tag "Mailbox") (choice :tag "Predicate" (regexp :tag "A regexp") (nnimap-strict-function :tag "A function")))) (choice :menu-tag "A function" :tag "A function" (function-item nnimap-split-fancy) (function-item nnmail-split-fancy) (nnimap-strict-function :tag "User-defined function")) (repeat :menu-tag "Multi-server (extended)" :tag "Multi-server list" (list (regexp :tag "Server regexp") (list (regexp :tag "Incoming Mailbox regexp") (repeat :tag "Rules for matching server(s) and mailbox(es)" (list (string :tag "Destination mailbox") (choice :tag "Predicate" (regexp :tag "A Regexp") (nnimap-strict-function :tag "A Function"))))))))) (defcustom nnimap-split-predicate "UNSEEN UNDELETED" "The predicate used to find articles to split. If you use another IMAP client to peek on articles but always would like nnimap to split them once it's started, you could change this to \"UNDELETED\". Other available predicates are available in RFC2060 section 6.4.4." :group 'nnimap :type 'string) (defcustom nnimap-split-fancy nil "Like the variable `nnmail-split-fancy'." :group 'nnimap :type 'sexp) (defvar nnimap-split-download-body-default nil "Internal variable with default value for `nnimap-split-download-body'.") (defcustom nnimap-split-download-body 'default "Whether to download entire articles during splitting. This is generally not required, and will slow things down considerably. You may need it if you want to use an advanced splitting function that analyzes the body before splitting the article. If this variable is nil, bodies will not be downloaded; if this variable is the symbol `default' the default behavior is used (which currently is nil, unless you use a statistical spam.el test); if this variable is another non-nil value bodies will be downloaded." :version "22.1" :group 'nnimap :type '(choice (const :tag "Let system decide" deault) boolean)) ;; Performance / bug workaround variables (defcustom nnimap-close-asynchronous t "Close mailboxes asynchronously in `nnimap-close-group'. This means that errors caught by nnimap when closing the mailbox will not prevent Gnus from updating the group status, which may be harmful. However, it increases speed." :version "22.1" :type 'boolean :group 'nnimap) (defcustom nnimap-dont-close t "Never close mailboxes. This increases the speed of closing mailboxes (quiting group) but may decrease the speed of selecting another mailbox later. Re-selecting the same mailbox will be faster though." :version "22.1" :type 'boolean :group 'nnimap) (defcustom nnimap-retrieve-groups-asynchronous t "Send asynchronous STATUS commands for each mailbox before checking mail. If you have mailboxes that rarely receives mail, this speeds up new mail checking. It works by first sending STATUS commands for each mailbox, and then only checking groups which has a modified UIDNEXT more carefully for new mail. In summary, the default is O((1-p)*k+p*n) and changing it to nil makes it O(n). If p is small, then the default is probably faster." :version "22.1" :type 'boolean :group 'nnimap) (defvoo nnimap-need-unselect-to-notice-new-mail t "Unselect mailboxes before looking for new mail in them. Some servers seem to need this under some circumstances.") (defvoo nnimap-logout-timeout nil "Close server immediately if it can't logout in this number of seconds. If it is nil, never close server until logout completes. This variable overrides `imap-logout-timeout' on a per-server basis.") ;; Authorization / Privacy variables (defvoo nnimap-auth-method nil "Obsolete.") (defvoo nnimap-stream nil "How nnimap will connect to the server. The default, nil, will try to use the \"best\" method the server can handle. Change this if 1) you want to connect with TLS/SSL. The TLS/SSL integration with IMAP is suboptimal so you'll have to tell it specifically. 2) your server is more capable than your environment -- i.e. your server accept Kerberos login's but you haven't installed the `imtest' program or your machine isn't configured for Kerberos. Possible choices: gssapi, kerberos4, starttls, tls, ssl, network, shell. See also `imap-streams' and `imap-stream-alist'.") (defvoo nnimap-authenticator nil "How nnimap authenticate itself to the server. The default, nil, will try to use the \"best\" method the server can handle. There is only one reason for fiddling with this variable, and that is if your server is more capable than your environment -- i.e. you connect to a server that accept Kerberos login's but you haven't installed the `imtest' program or your machine isn't configured for Kerberos. Possible choices: gssapi, kerberos4, digest-md5, cram-md5, login, anonymous. See also `imap-authenticators' and `imap-authenticator-alist'") (defvoo nnimap-directory (nnheader-concat gnus-directory "overview/") "Directory to keep NOV cache files for nnimap groups. See also `nnimap-nov-file-name'.") (defvoo nnimap-nov-file-name "nnimap." "NOV cache base filename. The group name and `nnimap-nov-file-name-suffix' will be appended. A typical complete file name would be ~/News/overview/nnimap.pdc.INBOX.ding.nov, or ~/News/overview/nnimap/pdc/INBOX/ding/nov if `nnmail-use-long-file-names' is nil") (defvoo nnimap-nov-file-name-suffix ".novcache" "Suffix for NOV cache base filename.") (defvoo nnimap-nov-is-evil gnus-agent "If non-nil, never generate or use a local nov database for this backend. Using nov databases should speed up header fetching considerably. However, it will invoke a UID SEARCH UID command on the server, and some servers implement this command inefficiently by opening each and every message in the group, thus making it quite slow. Unlike other backends, you do not need to take special care if you flip this variable.") (defvoo nnimap-search-uids-not-since-is-evil nil "If non-nil, avoid \"UID SEARCH UID ... NOT SINCE\" queries when expiring. Instead, use \"UID SEARCH SINCE\" to prune the list of expirable articles within Gnus. This seems to be faster on Courier in some cases.") (defvoo nnimap-expunge-on-close 'always ; 'ask, 'never "Whether to expunge a group when it is closed. When a IMAP group with articles marked for deletion is closed, this variable determine if nnimap should actually remove the articles or not. If always, nnimap always perform a expunge when closing the group. If never, nnimap never expunges articles marked for deletion. If ask, nnimap will ask you if you wish to expunge marked articles. When setting this variable to `never', you can only expunge articles by using `G x' (gnus-group-nnimap-expunge) from the Group buffer.") (defvoo nnimap-list-pattern "*" "A string LIMIT or list of strings with mailbox wildcards used to limit available groups. See below for available wildcards. The LIMIT string can be a cons cell (REFERENCE . LIMIT), where REFERENCE will be passed as the first parameter to LIST/LSUB. The semantics of this are server specific, on the University of Washington server you can specify a directory. Example: '(\"INBOX\" \"mail/*\" (\"~friend/mail/\" . \"list/*\")) There are two wildcards * and %. * matches everything, % matches everything in the current hierarchy.") (defvoo nnimap-news-groups nil "IMAP support a news-like mode, also known as bulletin board mode, where replies is sent via IMAP instead of SMTP. This variable should contain a regexp matching groups where you wish replies to be stored to the mailbox directly. Example: '(\"^[^I][^N][^B][^O][^X].*$\") This will match all groups not beginning with \"INBOX\". Note that there is nothing technically different between mail-like and news-like mailboxes. If you wish to have a group with todo items or similar which you wouldn't want to set up a mailing list for, you can use this to make replies go directly to the group.") (defvoo nnimap-expunge-search-string "UID %s NOT SINCE %s" "IMAP search command to use for articles that are to be expired. The first %s is replaced by a UID set of articles to search on, and the second %s is replaced by a date criterium. One useful (and perhaps the only useful) value to change this to would be `UID %s NOT SENTSINCE %s' to make nnimap use the Date: header instead of the internal date of messages. See section 6.4.4 of RFC 2060 for more information on valid strings. However, if `nnimap-search-uids-not-since-is-evil' is true, this variable has no effect since the search logic is reversed.") (defvoo nnimap-importantize-dormant t "If non-nil, mark \"dormant\" articles as \"ticked\" for other IMAP clients. Note that within Gnus, dormant articles will still (only) be marked as ticked. This is to make \"dormant\" articles stand out, just like \"ticked\" articles, in other IMAP clients.") (defvoo nnimap-server-address nil "Obsolete. Use `nnimap-address'.") (defcustom nnimap-authinfo-file "~/.authinfo" "Authorization information for IMAP servers. In .netrc format." :type '(choice file (repeat :tag "Entries" :menu-tag "Inline" (list :format "%v" :value ("" ("login" . "") ("password" . "")) (string :tag "Host") (checklist :inline t (cons :format "%v" (const :format "" "login") (string :format "Login: %v")) (cons :format "%v" (const :format "" "password") (string :format "Password: %v")))))) :group 'nnimap) (defcustom nnimap-prune-cache t "If non-nil, nnimap check whether articles still exist on server before using data stored in NOV cache." :type 'boolean :group 'nnimap) (defvar nnimap-request-list-method 'imap-mailbox-list "Method to use to request a list of all folders from the server. If this is 'imap-mailbox-lsub, then use a server-side subscription list to restrict visible folders.") (defcustom nnimap-id nil "Plist with client identity to send to server upon login. Nil means no information is sent, symbol `no' to disable ID query alltogheter, or plist with identifier-value pairs to send to server. RFC 2971 describes the list as follows: Any string may be sent as a field, but the following are defined to describe certain values that might be sent. Implementations are free to send none, any, or all of these. Strings are not case-sensitive. Field strings MUST NOT be longer than 30 octets. Value strings MUST NOT be longer than 1024 octets. Implementations MUST NOT send more than 30 field-value pairs. name Name of the program version Version number of the program os Name of the operating system os-version Version of the operating system vendor Vendor of the client/server support-url URL to contact for support address Postal address of contact/vendor date Date program was released, specified as a date-time in IMAP4rev1 command Command used to start the program arguments Arguments supplied on the command line, if any if any environment Description of environment, i.e., UNIX environment variables or Windows registry settings Implementations MUST NOT send the same field name more than once. An example plist would be '(\"name\" \"Gnus\" \"version\" gnus-version-number \"os\" system-configuration \"vendor\" \"GNU\")." :group 'nnimap :type '(choice (const :tag "No information" nil) (const :tag "Disable ID query" no) (plist :key-type string :value-type string))) (defcustom nnimap-debug nil "If non-nil, random debug spews are placed in *nnimap-debug* buffer. Note that username, passwords and other privacy sensitive information (such as e-mail) may be stored in the *nnimap-debug* buffer. It is not written to disk, however. Do not enable this variable unless you are comfortable with that." :group 'nnimap :type 'boolean) ;; Internal variables: (defvar nnimap-debug-buffer "*nnimap-debug*") (defvar nnimap-mailbox-info (gnus-make-hashtable 997)) (defvar nnimap-current-move-server nil) (defvar nnimap-current-move-group nil) (defvar nnimap-current-move-article nil) (defvar nnimap-length) (defvar nnimap-progress-chars '(?| ?/ ?- ?\\)) (defvar nnimap-progress-how-often 20) (defvar nnimap-counter) (defvar nnimap-server-buffer-alist nil) ;; Map server name to buffers. (defvar nnimap-current-server nil) ;; Current server (defvar nnimap-server-buffer nil) ;; Current servers' buffer (nnoo-define-basics nnimap) ;; Utility functions: (defsubst nnimap-get-server-buffer (server) "Return buffer for SERVER, if nil use current server." (cadr (assoc (or server nnimap-current-server) nnimap-server-buffer-alist))) (defun nnimap-remove-server-from-buffer-alist (server list) "Remove SERVER from LIST." (let (l) (dolist (e list) (unless (equal server (car-safe e)) (push e l))) l)) (defun nnimap-possibly-change-server (server) "Return buffer for SERVER, changing the current server as a side-effect. If SERVER is nil, uses the current server." (setq nnimap-current-server (or server nnimap-current-server) nnimap-server-buffer (nnimap-get-server-buffer nnimap-current-server))) (defun nnimap-verify-uidvalidity (group server) "Verify stored uidvalidity match current one in GROUP on SERVER." (let* ((gnusgroup (gnus-group-prefixed-name group (gnus-server-to-method (format "nnimap:%s" server)))) (new-uidvalidity (imap-mailbox-get 'uidvalidity)) (old-uidvalidity (gnus-group-get-parameter gnusgroup 'uidvalidity)) (dir (file-name-as-directory (expand-file-name nnimap-directory))) (nameuid (nnheader-translate-file-chars (concat nnimap-nov-file-name (if (equal server "") "unnamed" server) "." group "." old-uidvalidity nnimap-nov-file-name-suffix) t)) (file (if (or nnmail-use-long-file-names (file-exists-p (expand-file-name nameuid dir))) (expand-file-name nameuid dir) (expand-file-name (mm-encode-coding-string (nnheader-replace-chars-in-string nameuid ?. ?/) nnmail-pathname-coding-system) dir)))) (if old-uidvalidity (if (not (equal old-uidvalidity new-uidvalidity)) ;; uidvalidity clash (gnus-delete-file file) (gnus-group-set-parameter gnusgroup 'uidvalidity new-uidvalidity) t) (gnus-group-add-parameter gnusgroup (cons 'uidvalidity new-uidvalidity)) t))) (defun nnimap-before-find-minmax-bugworkaround () "Function called before iterating through mailboxes with `nnimap-find-minmax-uid'." (when nnimap-need-unselect-to-notice-new-mail ;; XXX this is for UoW imapd problem, it doesn't notice new mail in ;; currently selected mailbox without a re-select/examine. (or (null (imap-current-mailbox nnimap-server-buffer)) (imap-mailbox-unselect nnimap-server-buffer)))) (defun nnimap-find-minmax-uid (group &optional examine) "Find lowest and highest active article number in GROUP. If EXAMINE is non-nil the group is selected read-only." (with-current-buffer nnimap-server-buffer (when (or (string= group (imap-current-mailbox)) (imap-mailbox-select group examine)) (let (minuid maxuid) (when (> (imap-mailbox-get 'exists) 0) (imap-fetch (if imap-enable-exchange-bug-workaround "1,*:*" "1,*") "UID" nil 'nouidfetch) (imap-message-map (lambda (uid Uid) (setq minuid (if minuid (min minuid uid) uid) maxuid (if maxuid (max maxuid uid) uid))) 'UID)) (list (imap-mailbox-get 'exists) minuid maxuid))))) (defun nnimap-possibly-change-group (group &optional server) "Make GROUP the current group, and SERVER the current server." (when (nnimap-possibly-change-server server) (with-current-buffer nnimap-server-buffer (if (or (null group) (imap-current-mailbox-p group)) imap-current-mailbox (if (imap-mailbox-select group) (if (or (nnimap-verify-uidvalidity group (or server nnimap-current-server)) (zerop (imap-mailbox-get 'exists group)) t ;; for OGnus to see if ignoring uidvalidity ;; changes has any bad effects. (yes-or-no-p (format "nnimap: Group %s is not uidvalid. Continue? " group))) imap-current-mailbox (imap-mailbox-unselect) (error "nnimap: Group %s is not uid-valid" group)) (nnheader-report 'nnimap (imap-error-text))))))) (defun nnimap-replace-whitespace (string) "Return STRING with all whitespace replaced with space." (when string (while (string-match "[\r\n\t]+" string) (setq string (replace-match " " t t string))) string)) ;; Required backend functions (defun nnimap-retrieve-headers-progress () "Hook to insert NOV line for current article into `nntp-server-buffer'." (and (numberp nnmail-large-newsgroup) (zerop (% (incf nnimap-counter) nnimap-progress-how-often)) (> nnimap-length nnmail-large-newsgroup) (nnheader-message 6 "nnimap: Retrieving headers... %c" (nth (/ (% nnimap-counter (* (length nnimap-progress-chars) nnimap-progress-how-often)) nnimap-progress-how-often) nnimap-progress-chars))) (with-current-buffer nntp-server-buffer (let (headers lines chars uid mbx) (with-current-buffer nnimap-server-buffer (setq uid imap-current-message mbx imap-current-mailbox headers (nnimap-demule (if (imap-capability 'IMAP4rev1) ;; xxx don't just use car? alist doesn't contain ;; anything else now, but it might... (nth 2 (car (imap-message-get uid 'BODYDETAIL))) (imap-message-get uid 'RFC822.HEADER))) lines (imap-body-lines (imap-message-body imap-current-message)) chars (imap-message-get imap-current-message 'RFC822.SIZE))) (nnheader-insert-nov ;; At this stage, we only have bytes, so let's use unibyte buffers ;; to make it more clear. (mm-with-unibyte-buffer (buffer-disable-undo) (insert headers) (let ((head (nnheader-parse-naked-head uid))) (mail-header-set-number head uid) (mail-header-set-chars head chars) (mail-header-set-lines head lines) (mail-header-set-xref head (format "%s %s:%d" (system-name) mbx uid)) head)))))) (defun nnimap-retrieve-which-headers (articles fetch-old) "Get a range of articles to fetch based on ARTICLES and FETCH-OLD." (with-current-buffer nnimap-server-buffer (if (numberp (car-safe articles)) (imap-search (concat "UID " (imap-range-to-message-set (gnus-compress-sequence (append (gnus-uncompress-sequence (and fetch-old (cons (if (numberp fetch-old) (max 1 (- (car articles) fetch-old)) 1) (1- (car articles))))) articles))))) (mapcar (lambda (msgid) (imap-search (format "HEADER Message-Id \"%s\"" msgid))) articles)))) (defun nnimap-group-overview-filename (group server) "Make file name for GROUP on SERVER." (let* ((dir (file-name-as-directory (expand-file-name nnimap-directory))) (uidvalidity (gnus-group-get-parameter (gnus-group-prefixed-name group (gnus-server-to-method (format "nnimap:%s" server))) 'uidvalidity)) (name (nnheader-translate-file-chars (concat nnimap-nov-file-name (if (equal server "") "unnamed" server) "." group nnimap-nov-file-name-suffix) t)) (nameuid (nnheader-translate-file-chars (concat nnimap-nov-file-name (if (equal server "") "unnamed" server) "." group "." uidvalidity nnimap-nov-file-name-suffix) t)) (oldfile (if (or nnmail-use-long-file-names (file-exists-p (expand-file-name name dir))) (expand-file-name name dir) (expand-file-name (mm-encode-coding-string (nnheader-replace-chars-in-string name ?. ?/) nnmail-pathname-coding-system) dir))) (newfile (if (or nnmail-use-long-file-names (file-exists-p (expand-file-name nameuid dir))) (expand-file-name nameuid dir) (expand-file-name (mm-encode-coding-string (nnheader-replace-chars-in-string nameuid ?. ?/) nnmail-pathname-coding-system) dir)))) (when (and (file-exists-p oldfile) (not (file-exists-p newfile))) (message "nnimap: Upgrading novcache filename...") (sit-for 1) (gnus-make-directory (file-name-directory newfile)) (unless (ignore-errors (rename-file oldfile newfile) t) (if (ignore-errors (copy-file oldfile newfile) t) (delete-file oldfile) (error "Can't rename `%s' to `%s'" oldfile newfile)))) newfile)) (defun nnimap-retrieve-headers-from-file (group server) (with-current-buffer nntp-server-buffer (let ((nov (nnimap-group-overview-filename group server))) (when (file-exists-p nov) (mm-insert-file-contents nov) (set-buffer-modified-p nil) (let ((min (ignore-errors (goto-char (point-min)) (read (current-buffer)))) (max (ignore-errors (goto-char (point-max)) (forward-line -1) (read (current-buffer))))) (if (and (numberp min) (numberp max)) (cons min max) ;; junk, remove it, it's saved later (erase-buffer) nil)))))) (defun nnimap-retrieve-headers-from-server (articles group server) (with-current-buffer nnimap-server-buffer (let ((imap-fetch-data-hook '(nnimap-retrieve-headers-progress)) (nnimap-length (gnus-range-length articles)) (nnimap-counter 0)) (imap-fetch (imap-range-to-message-set articles) (concat "(UID RFC822.SIZE BODY " (let ((headers (append '(Subject From Date Message-Id References In-Reply-To Xref) (copy-sequence nnmail-extra-headers)))) (if (imap-capability 'IMAP4rev1) (format "BODY.PEEK[HEADER.FIELDS %s])" headers) (format "RFC822.HEADER.LINES %s)" headers))))) (with-current-buffer nntp-server-buffer (sort-numeric-fields 1 (point-min) (point-max))) (and (numberp nnmail-large-newsgroup) (> nnimap-length nnmail-large-newsgroup) (nnheader-message 6 "nnimap: Retrieving headers...done"))))) (defun nnimap-dont-use-nov-p (group server) (or gnus-nov-is-evil nnimap-nov-is-evil (unless (and (gnus-make-directory (file-name-directory (nnimap-group-overview-filename group server))) (file-writable-p (nnimap-group-overview-filename group server))) (message "nnimap: Nov cache not writable, %s" (nnimap-group-overview-filename group server))))) (deffoo nnimap-retrieve-headers (articles &optional group server fetch-old) (when (nnimap-possibly-change-group group server) (with-current-buffer nntp-server-buffer (erase-buffer) (if (nnimap-dont-use-nov-p group server) (nnimap-retrieve-headers-from-server (gnus-compress-sequence articles) group server) (let (uids cached low high) (when (setq uids (nnimap-retrieve-which-headers articles fetch-old) low (car uids) high (car (last uids))) (if (setq cached (nnimap-retrieve-headers-from-file group server)) (progn ;; fetch articles with uids before cache block (when (< low (car cached)) (goto-char (point-min)) (nnimap-retrieve-headers-from-server (cons low (1- (car cached))) group server)) ;; fetch articles with uids after cache block (when (> high (cdr cached)) (goto-char (point-max)) (nnimap-retrieve-headers-from-server (cons (1+ (cdr cached)) high) group server)) (when nnimap-prune-cache ;; remove nov's for articles which has expired on server (goto-char (point-min)) (dolist (uid (gnus-set-difference articles uids)) (when (re-search-forward (format "^%d\t" uid) nil t) (gnus-delete-line))))) ;; nothing cached, fetch whole range from server (nnimap-retrieve-headers-from-server (cons low high) group server)) (when (buffer-modified-p) (nnmail-write-region (point-min) (point-max) (nnimap-group-overview-filename group server) nil 'nomesg)) (nnheader-nov-delete-outside-range low high)))) 'nov))) (defun nnimap-open-connection (server) ;; Note: `nnimap-open-server' that calls this function binds ;; `imap-logout-timeout' to `nnimap-logout-timeout'. (if (not (imap-open nnimap-address nnimap-server-port nnimap-stream nnimap-authenticator nnimap-server-buffer)) (nnheader-report 'nnimap "Can't open connection to server %s" server) (unless (or (imap-capability 'IMAP4 nnimap-server-buffer) (imap-capability 'IMAP4rev1 nnimap-server-buffer)) (imap-close nnimap-server-buffer) (nnheader-report 'nnimap "Server %s is not IMAP4 compliant" server)) (let* ((list (progn (gnus-message 7 "Parsing authinfo file `%s'." nnimap-authinfo-file) (netrc-parse nnimap-authinfo-file))) (port (if nnimap-server-port (int-to-string nnimap-server-port) "imap")) (user (netrc-machine-user-or-password "login" list (list server (or nnimap-server-address nnimap-address)) (list port) (list "imap" "imaps" "143" "993"))) (passwd (netrc-machine-user-or-password "password" list (list server (or nnimap-server-address nnimap-address)) (list port) (list "imap" "imaps" "143" "993")))) (if (imap-authenticate user passwd nnimap-server-buffer) (prog2 (setq nnimap-server-buffer-alist (nnimap-remove-server-from-buffer-alist server nnimap-server-buffer-alist)) (push (list server nnimap-server-buffer) nnimap-server-buffer-alist) (imap-id nnimap-id nnimap-server-buffer) (nnimap-possibly-change-server server)) (imap-close nnimap-server-buffer) (kill-buffer nnimap-server-buffer) (nnheader-report 'nnimap "Could not authenticate to %s" server))))) (deffoo nnimap-open-server (server &optional defs) (nnheader-init-server-buffer) (if (nnimap-server-opened server) t (unless (assq 'nnimap-server-buffer defs) (push (list 'nnimap-server-buffer (concat " *nnimap* " server)) defs)) ;; translate `nnimap-server-address' to `nnimap-address' in defs ;; for people that configured nnimap with a very old version (unless (assq 'nnimap-address defs) (if (assq 'nnimap-server-address defs) (push (list 'nnimap-address (cadr (assq 'nnimap-server-address defs))) defs) (push (list 'nnimap-address server) defs))) (nnoo-change-server 'nnimap server defs) (or nnimap-server-buffer (setq nnimap-server-buffer (cadr (assq 'nnimap-server-buffer defs)))) (with-current-buffer (get-buffer-create nnimap-server-buffer) (nnoo-change-server 'nnimap server defs)) (let ((imap-logout-timeout nnimap-logout-timeout)) (or (and nnimap-server-buffer (imap-opened nnimap-server-buffer) (if (with-current-buffer nnimap-server-buffer (memq imap-state '(auth selected examine))) t (imap-close nnimap-server-buffer) (nnimap-open-connection server))) (nnimap-open-connection server))))) (deffoo nnimap-server-opened (&optional server) "Whether SERVER is opened. If SERVER is the current virtual server, and the connection to the physical server is alive, this function return a non-nil value. If SERVER is nil, it is treated as the current server." ;; clean up autologouts?? (and (or server nnimap-current-server) (nnoo-server-opened 'nnimap (or server nnimap-current-server)) (imap-opened (nnimap-get-server-buffer server)))) (deffoo nnimap-close-server (&optional server) "Close connection to server and free all resources connected to it. Return nil if the server couldn't be closed for some reason." (let ((server (or server nnimap-current-server)) (imap-logout-timeout nnimap-logout-timeout)) (when (or (nnimap-server-opened server) (imap-opened (nnimap-get-server-buffer server))) (imap-close (nnimap-get-server-buffer server)) (kill-buffer (nnimap-get-server-buffer server)) (setq nnimap-server-buffer nil nnimap-current-server nil nnimap-server-buffer-alist (nnimap-remove-server-from-buffer-alist server nnimap-server-buffer-alist))) (nnoo-close-server 'nnimap server))) (deffoo nnimap-request-close () "Close connection to all servers and free all resources that the backend have reserved. All buffers that have been created by that backend should be killed. (Not the nntp-server-buffer, though.) This function is generally only called when Gnus is shutting down." (mapc (lambda (server) (nnimap-close-server (car server))) nnimap-server-buffer-alist) (setq nnimap-server-buffer-alist nil)) (deffoo nnimap-status-message (&optional server) "This function returns the last error message from server." (when (nnimap-possibly-change-server server) (nnoo-status-message 'nnimap server))) (defun nnimap-demule (string) ;; BEWARE: we used to use string-as-multibyte here which is braindead ;; because it will turn accidental emacs-mule-valid byte sequences ;; into multibyte chars. --Stef ;; Reverted, braindead got 7.5 out of 10 on imdb, so it can't be ;; that bad. --Simon (funcall (if (and (fboundp 'string-as-multibyte) (subrp (symbol-function 'string-as-multibyte))) 'string-as-multibyte 'identity) (or string ""))) (defun nnimap-make-callback (article gnus-callback buffer) "Return a callback function." `(lambda () (nnimap-callback ,article ,gnus-callback ,buffer))) (defun nnimap-callback (article gnus-callback buffer) (when (eq article (imap-current-message)) (remove-hook 'imap-fetch-data-hook (nnimap-make-callback article gnus-callback buffer)) (with-current-buffer buffer (insert (with-current-buffer nnimap-server-buffer (nnimap-demule (if (imap-capability 'IMAP4rev1) ;; xxx don't just use car? alist doesn't contain ;; anything else now, but it might... (nth 2 (car (imap-message-get article 'BODYDETAIL))) (imap-message-get article 'RFC822))))) (nnheader-ms-strip-cr) (funcall gnus-callback t)))) (defun nnimap-request-article-part (article part prop &optional group server to-buffer detail) (when (nnimap-possibly-change-group group server) (let ((article (if (stringp article) (car-safe (imap-search (format "HEADER Message-Id \"%s\"" article) nnimap-server-buffer)) article))) (when article (gnus-message 10 "nnimap: Fetching (part of) article %d from %s..." article (or group imap-current-mailbox gnus-newsgroup-name)) (if (not nnheader-callback-function) (with-current-buffer (or to-buffer nntp-server-buffer) (erase-buffer) (let ((data (imap-fetch article part prop nil nnimap-server-buffer))) (insert (nnimap-demule (if detail (nth 2 (car data)) data)))) (nnheader-ms-strip-cr) (gnus-message 10 "nnimap: Fetching (part of) article %d from %s...done" article (or group imap-current-mailbox gnus-newsgroup-name)) (if (bobp) (nnheader-report 'nnimap "No such article %d in %s: %s" article (or group imap-current-mailbox gnus-newsgroup-name) (imap-error-text nnimap-server-buffer)) (cons group article))) (add-hook 'imap-fetch-data-hook (nnimap-make-callback article nnheader-callback-function nntp-server-buffer)) (imap-fetch-asynch article part nil nnimap-server-buffer) (cons group article)))))) (deffoo nnimap-asynchronous-p () t) (deffoo nnimap-request-article (article &optional group server to-buffer) (if (imap-capability 'IMAP4rev1 nnimap-server-buffer) (nnimap-request-article-part article "BODY.PEEK[]" 'BODYDETAIL group server to-buffer 'detail) (nnimap-request-article-part article "RFC822.PEEK" 'RFC822 group server to-buffer))) (deffoo nnimap-request-head (article &optional group server to-buffer) (if (imap-capability 'IMAP4rev1 nnimap-server-buffer) (nnimap-request-article-part article "BODY.PEEK[HEADER]" 'BODYDETAIL group server to-buffer 'detail) (nnimap-request-article-part article "RFC822.HEADER" 'RFC822.HEADER group server to-buffer))) (deffoo nnimap-request-body (article &optional group server to-buffer) (if (imap-capability 'IMAP4rev1 nnimap-server-buffer) (nnimap-request-article-part article "BODY.PEEK[TEXT]" 'BODYDETAIL group server to-buffer 'detail) (nnimap-request-article-part article "RFC822.TEXT.PEEK" 'RFC822.TEXT group server to-buffer))) (deffoo nnimap-request-group (group &optional server fast) (nnimap-request-update-info-internal group (gnus-get-info (gnus-group-prefixed-name group (gnus-server-to-method (format "nnimap:%s" server)))) server) (when (nnimap-possibly-change-group group server) (nnimap-before-find-minmax-bugworkaround) (let (info) (cond (fast group) ((null (setq info (nnimap-find-minmax-uid group t))) (nnheader-report 'nnimap "Could not get active info for %s" group)) (t (nnheader-insert "211 %d %d %d %s\n" (or (nth 0 info) 0) (max 1 (or (nth 1 info) 1)) (or (nth 2 info) 0) group) (nnheader-report 'nnimap "Group %s selected" group) t))))) (defun nnimap-update-unseen (group &optional server) "Update the unseen count in `nnimap-mailbox-info'." (gnus-sethash (gnus-group-prefixed-name group server) (let ((old (gnus-gethash-safe (gnus-group-prefixed-name group server) nnimap-mailbox-info))) (list (nth 0 old) (nth 1 old) (imap-mailbox-status group 'unseen nnimap-server-buffer) (nth 3 old))) nnimap-mailbox-info)) (defun nnimap-close-group (group &optional server) (with-current-buffer nnimap-server-buffer (when (and (imap-opened) (nnimap-possibly-change-group group server)) (nnimap-update-unseen group server) (case nnimap-expunge-on-close (always (progn (imap-mailbox-expunge nnimap-close-asynchronous) (unless nnimap-dont-close (imap-mailbox-close nnimap-close-asynchronous)))) (ask (if (and (imap-search "DELETED") (gnus-y-or-n-p (format "Expunge articles in group `%s'? " imap-current-mailbox))) (progn (imap-mailbox-expunge nnimap-close-asynchronous) (unless nnimap-dont-close (imap-mailbox-close nnimap-close-asynchronous))) (imap-mailbox-unselect))) (t (imap-mailbox-unselect))) (not imap-current-mailbox)))) (defun nnimap-pattern-to-list-arguments (pattern) (mapcar (lambda (p) (cons (car-safe p) (or (cdr-safe p) p))) (if (and (listp pattern) (listp (cdr pattern))) pattern (list pattern)))) (deffoo nnimap-request-list (&optional server) (when (nnimap-possibly-change-server server) (with-current-buffer nntp-server-buffer (erase-buffer)) (gnus-message 5 "nnimap: Generating active list%s..." (if (> (length server) 0) (concat " for " server) "")) (nnimap-before-find-minmax-bugworkaround) (with-current-buffer nnimap-server-buffer (dolist (pattern (nnimap-pattern-to-list-arguments nnimap-list-pattern)) (dolist (mbx (funcall nnimap-request-list-method (cdr pattern) (car pattern))) (or (member "\\NoSelect" (imap-mailbox-get 'list-flags mbx)) (let ((info (nnimap-find-minmax-uid mbx 'examine))) (when info (with-current-buffer nntp-server-buffer (insert (format "\"%s\" %d %d y\n" mbx (or (nth 2 info) 0) (max 1 (or (nth 1 info) 1))))))))))) (gnus-message 5 "nnimap: Generating active list%s...done" (if (> (length server) 0) (concat " for " server) "")) t)) (deffoo nnimap-request-post (&optional server) (let ((success t)) (dolist (mbx (message-unquote-tokens (message-tokenize-header (message-fetch-field "Newsgroups") ", ")) success) (let ((to-newsgroup (gnus-group-prefixed-name mbx gnus-command-method))) (or (gnus-active to-newsgroup) (gnus-activate-group to-newsgroup) (if (gnus-y-or-n-p (format "No such group: %s. Create it? " to-newsgroup)) (or (and (gnus-request-create-group to-newsgroup gnus-command-method) (gnus-activate-group to-newsgroup nil nil gnus-command-method)) (error "Couldn't create group %s" to-newsgroup))) (error "No such group: %s" to-newsgroup)) (unless (nnimap-request-accept-article mbx (nth 1 gnus-command-method)) (setq success nil)))))) ;; Optional backend functions (defun nnimap-string-lessp-numerical (s1 s2) "Return t if first arg string is less than second in numerical order." (cond ((string= s1 s2) nil) ((> (length s1) (length s2)) nil) ((< (length s1) (length s2)) t) ((< (string-to-number (substring s1 0 1)) (string-to-number (substring s2 0 1))) t) ((> (string-to-number (substring s1 0 1)) (string-to-number (substring s2 0 1))) nil) (t (nnimap-string-lessp-numerical (substring s1 1) (substring s2 1))))) (deffoo nnimap-retrieve-groups (groups &optional server) (when (nnimap-possibly-change-server server) (gnus-message 5 "nnimap: Checking mailboxes...") (with-current-buffer nntp-server-buffer (erase-buffer) (nnimap-before-find-minmax-bugworkaround) (let (asyncgroups slowgroups) (if (null nnimap-retrieve-groups-asynchronous) (setq slowgroups groups) (dolist (group groups) (gnus-message 9 "nnimap: Quickly checking mailbox %s" group) (add-to-list (if (gnus-gethash-safe (gnus-group-prefixed-name group server) nnimap-mailbox-info) 'asyncgroups 'slowgroups) (list group (imap-mailbox-status-asynch group '(uidvalidity uidnext unseen) nnimap-server-buffer)))) (dolist (asyncgroup asyncgroups) (let ((group (nth 0 asyncgroup)) (tag (nth 1 asyncgroup)) new old) (when (imap-ok-p (imap-wait-for-tag tag nnimap-server-buffer)) (if (or (not (string= (nth 0 (gnus-gethash (gnus-group-prefixed-name group server) nnimap-mailbox-info)) (imap-mailbox-get 'uidvalidity group nnimap-server-buffer))) (not (string= (nth 1 (gnus-gethash (gnus-group-prefixed-name group server) nnimap-mailbox-info)) (imap-mailbox-get 'uidnext group nnimap-server-buffer)))) (push (list group) slowgroups) (insert (nth 3 (gnus-gethash (gnus-group-prefixed-name group server) nnimap-mailbox-info)))))))) (dolist (group slowgroups) (if nnimap-retrieve-groups-asynchronous (setq group (car group))) (gnus-message 7 "nnimap: Mailbox %s modified" group) (imap-mailbox-put 'uidnext nil group nnimap-server-buffer) (or (member "\\NoSelect" (imap-mailbox-get 'list-flags group nnimap-server-buffer)) (let* ((info (nnimap-find-minmax-uid group 'examine)) (str (format "\"%s\" %d %d y\n" group (or (nth 2 info) 0) (max 1 (or (nth 1 info) 1))))) (when (> (or (imap-mailbox-get 'recent group nnimap-server-buffer) 0) 0) (push (list (cons group 0)) nnmail-split-history)) (insert str) (when nnimap-retrieve-groups-asynchronous (gnus-sethash (gnus-group-prefixed-name group server) (list (or (imap-mailbox-get 'uidvalidity group nnimap-server-buffer) (imap-mailbox-status group 'uidvalidity nnimap-server-buffer)) (or (imap-mailbox-get 'uidnext group nnimap-server-buffer) (imap-mailbox-status group 'uidnext nnimap-server-buffer)) (or (imap-mailbox-get 'unseen group nnimap-server-buffer) (imap-mailbox-status group 'unseen nnimap-server-buffer)) str) nnimap-mailbox-info))))))) (gnus-message 5 "nnimap: Checking mailboxes...done") 'active)) (deffoo nnimap-request-update-info-internal (group info &optional server) (when (nnimap-possibly-change-group group server) (when info ;; xxx what does this mean? should we create a info? (with-current-buffer nnimap-server-buffer (gnus-message 5 "nnimap: Updating info for %s..." (gnus-info-group info)) (when (nnimap-mark-permanent-p 'read) (let (seen unseen) ;; read info could contain articles marked unread by other ;; imap clients! we correct this (setq unseen (gnus-compress-sequence (imap-search "UNSEEN UNDELETED")) seen (gnus-range-difference (gnus-info-read info) unseen) seen (gnus-range-add seen (gnus-compress-sequence (imap-search "SEEN"))) seen (if (and (integerp (car seen)) (null (cdr seen))) (list (cons (car seen) (car seen))) seen)) (gnus-info-set-read info seen))) (dolist (pred gnus-article-mark-lists) (when (or (eq (cdr pred) 'recent) (and (nnimap-mark-permanent-p (cdr pred)) (member (nnimap-mark-to-flag (cdr pred)) (imap-mailbox-get 'flags)))) (gnus-info-set-marks info (gnus-update-alist-soft (cdr pred) (gnus-compress-sequence (imap-search (nnimap-mark-to-predicate (cdr pred)))) (gnus-info-marks info)) t))) (when nnimap-importantize-dormant ;; nnimap mark dormant article as ticked too (for other clients) ;; so we remove that mark for gnus since we support dormant (gnus-info-set-marks info (gnus-update-alist-soft 'tick (gnus-remove-from-range (cdr-safe (assoc 'tick (gnus-info-marks info))) (cdr-safe (assoc 'dormant (gnus-info-marks info)))) (gnus-info-marks info)) t)) (gnus-message 5 "nnimap: Updating info for %s...done" (gnus-info-group info)) info)))) (deffoo nnimap-request-type (group &optional article) (if (and nnimap-news-groups (string-match nnimap-news-groups group)) 'news 'mail)) (deffoo nnimap-request-set-mark (group actions &optional server) (when (nnimap-possibly-change-group group server) (with-current-buffer nnimap-server-buffer (let (action) (gnus-message 7 "nnimap: Setting marks in %s..." group) (while (setq action (pop actions)) (let ((range (nth 0 action)) (what (nth 1 action)) (cmdmarks (nth 2 action)) marks) ;; bookmark can't be stored (not list/range (setq cmdmarks (delq 'bookmark cmdmarks)) ;; killed can't be stored (not list/range (setq cmdmarks (delq 'killed cmdmarks)) ;; unsent are for nndraft groups only (setq cmdmarks (delq 'unsent cmdmarks)) ;; cache flags are pointless on the server (setq cmdmarks (delq 'cache cmdmarks)) ;; seen flags are local to each gnus (setq cmdmarks (delq 'seen cmdmarks)) ;; recent marks can't be set (setq cmdmarks (delq 'recent cmdmarks)) (when nnimap-importantize-dormant ;; flag dormant articles as ticked (if (memq 'dormant cmdmarks) (setq cmdmarks (cons 'tick cmdmarks)))) ;; remove stuff we are forbidden to store (mapc (lambda (mark) (if (imap-message-flag-permanent-p (nnimap-mark-to-flag mark)) (setq marks (cons mark marks)))) cmdmarks) (when (and range marks) (cond ((eq what 'del) (imap-message-flags-del (imap-range-to-message-set range) (nnimap-mark-to-flag marks nil t))) ((eq what 'add) (imap-message-flags-add (imap-range-to-message-set range) (nnimap-mark-to-flag marks nil t))) ((eq what 'set) (imap-message-flags-set (imap-range-to-message-set range) (nnimap-mark-to-flag marks nil t))))))) (gnus-message 7 "nnimap: Setting marks in %s...done" group)))) nil) (defun nnimap-split-fancy () "Like the function `nnmail-split-fancy', but uses `nnimap-split-fancy'." (let ((nnmail-split-fancy nnimap-split-fancy)) (nnmail-split-fancy))) (defun nnimap-split-to-groups (rules) ;; tries to match all rules in nnimap-split-rule against content of ;; nntp-server-buffer, returns a list of groups that matched. (with-current-buffer nntp-server-buffer ;; Fold continuation lines. (goto-char (point-min)) (while (re-search-forward "\\(\r?\n[ \t]+\\)+" nil t) (replace-match " " t t)) (if (functionp rules) (funcall rules) (let (to-groups regrepp) (catch 'split-done (dolist (rule rules to-groups) (let ((group (car rule)) (regexp (cadr rule))) (goto-char (point-min)) (when (and (if (stringp regexp) (progn (if (not (stringp group)) (setq group (eval group)) (setq regrepp (string-match "\\\\[0-9&]" group))) (re-search-forward regexp nil t)) (funcall regexp group)) ;; Don't enter the article into the same group twice. (not (assoc group to-groups))) (push (if regrepp (nnmail-expand-newtext group) group) to-groups) (or nnimap-split-crosspost (throw 'split-done to-groups)))))))))) (defun nnimap-assoc-match (key alist) (let (element) (while (and alist (not element)) (if (string-match (car (car alist)) key) (setq element (car alist))) (setq alist (cdr alist))) element)) (defun nnimap-split-find-rule (server inbox) (if (and (listp nnimap-split-rule) (listp (car nnimap-split-rule)) (list (cdar nnimap-split-rule)) (listp (cadar nnimap-split-rule))) ;; extended format (cadr (nnimap-assoc-match inbox (cdr (nnimap-assoc-match server nnimap-split-rule)))) nnimap-split-rule)) (defun nnimap-split-find-inbox (server) (if (listp nnimap-split-inbox) nnimap-split-inbox (list nnimap-split-inbox))) (defun nnimap-split-articles (&optional group server) (when (nnimap-possibly-change-server server) (with-current-buffer nnimap-server-buffer (let (rule inbox removeorig (inboxes (nnimap-split-find-inbox server))) ;; iterate over inboxes (while (and (setq inbox (pop inboxes)) (nnimap-possibly-change-group inbox)) ;; SELECT ;; find split rule for this server / inbox (when (setq rule (nnimap-split-find-rule server inbox)) ;; iterate over articles (dolist (article (imap-search nnimap-split-predicate)) (when (if (if (eq nnimap-split-download-body 'default) nnimap-split-download-body-default nnimap-split-download-body) (and (nnimap-request-article article) (with-current-buffer nntp-server-buffer (mail-narrow-to-head))) (nnimap-request-head article)) ;; copy article to right group(s) (setq removeorig nil) (dolist (to-group (nnimap-split-to-groups rule)) (cond ((eq to-group 'junk) (message "IMAP split removed %s:%s:%d" server inbox article) (setq removeorig t)) ((imap-message-copy (number-to-string article) to-group nil 'nocopyuid) (message "IMAP split moved %s:%s:%d to %s" server inbox article to-group) (setq removeorig t) (when nnmail-cache-accepted-message-ids (with-current-buffer nntp-server-buffer (let (msgid) (and (setq msgid (nnmail-fetch-field "message-id")) (nnmail-cache-insert msgid to-group (nnmail-fetch-field "subject")))))) ;; Add the group-art list to the history list. (push (list (cons to-group 0)) nnmail-split-history)) (t (message "IMAP split failed to move %s:%s:%d to %s" server inbox article to-group)))) (if (if (eq nnimap-split-download-body 'default) nnimap-split-download-body-default nnimap-split-download-body) (widen)) ;; remove article if it was successfully copied somewhere (and removeorig (imap-message-flags-add (format "%d" article) "\\Seen \\Deleted"))))) (when (imap-mailbox-select inbox) ;; just in case ;; todo: UID EXPUNGE (if available) to remove splitted articles (imap-mailbox-expunge) (imap-mailbox-close))) (when nnmail-cache-accepted-message-ids (nnmail-cache-close)) t)))) (deffoo nnimap-request-scan (&optional group server) (nnimap-split-articles group server)) (deffoo nnimap-request-newgroups (date &optional server) (when (nnimap-possibly-change-server server) (with-current-buffer nntp-server-buffer (gnus-message 5 "nnimap: Listing subscribed mailboxes%s%s..." (if (> (length server) 0) " on " "") server) (erase-buffer) (nnimap-before-find-minmax-bugworkaround) (dolist (pattern (nnimap-pattern-to-list-arguments nnimap-list-pattern)) (dolist (mbx (imap-mailbox-lsub (cdr pattern) (car pattern) nil nnimap-server-buffer)) (or (catch 'found (dolist (mailbox (imap-mailbox-get 'list-flags mbx nnimap-server-buffer)) (if (string= (downcase mailbox) "\\noselect") (throw 'found t))) nil) (let ((info (nnimap-find-minmax-uid mbx 'examine))) (when info (insert (format "\"%s\" %d %d y\n" mbx (or (nth 2 info) 0) (max 1 (or (nth 1 info) 1))))))))) (gnus-message 5 "nnimap: Listing subscribed mailboxes%s%s...done" (if (> (length server) 0) " on " "") server)) t)) (deffoo nnimap-request-create-group (group &optional server args) (when (nnimap-possibly-change-server server) (or (imap-mailbox-status group 'uidvalidity nnimap-server-buffer) (imap-mailbox-create group nnimap-server-buffer) (nnheader-report 'nnimap "%S" (imap-error-text nnimap-server-buffer))))) (defun nnimap-time-substract (time1 time2) "Return TIME for TIME1 - TIME2." (let* ((ms (- (car time1) (car time2))) (ls (- (nth 1 time1) (nth 1 time2)))) (if (< ls 0) (list (- ms 1) (+ (expt 2 16) ls)) (list ms ls)))) (eval-when-compile (require 'parse-time)) (defun nnimap-date-days-ago (daysago) "Return date, in format \"3-Aug-1998\", for DAYSAGO days ago." (require 'parse-time) (let* ((time (nnimap-time-substract (current-time) (days-to-time daysago))) (date (format-time-string (format "%%d-%s-%%Y" (capitalize (car (rassoc (nth 4 (decode-time time)) parse-time-months)))) time))) (if (eq ?0 (string-to-char date)) (substring date 1) date))) (defun nnimap-request-expire-articles-progress () (gnus-message 5 "nnimap: Marking article %d for deletion..." imap-current-message)) (defun nnimap-expiry-target (arts group server) (unless (eq nnmail-expiry-target 'delete) (with-temp-buffer (dolist (art arts) (nnimap-request-article art group server (current-buffer)) ;; hints for optimization in `nnimap-request-accept-article' (let ((nnimap-current-move-article art) (nnimap-current-move-group group) (nnimap-current-move-server server)) (nnmail-expiry-target-group nnmail-expiry-target group)))) ;; It is not clear if `nnmail-expiry-target' somehow cause the ;; current group to be changed or not, so we make sure here. (nnimap-possibly-change-group group server))) ;; Notice that we don't actually delete anything, we just mark them deleted. (deffoo nnimap-request-expire-articles (articles group &optional server force) (let ((artseq (gnus-compress-sequence articles))) (when (and artseq (nnimap-possibly-change-group group server)) (with-current-buffer nnimap-server-buffer (let ((days (or (and nnmail-expiry-wait-function (funcall nnmail-expiry-wait-function group)) nnmail-expiry-wait))) (cond ((or force (eq days 'immediate)) (let ((oldarts (imap-search (concat "UID " (imap-range-to-message-set artseq))))) (when oldarts (nnimap-expiry-target oldarts group server) (when (imap-message-flags-add (imap-range-to-message-set (gnus-compress-sequence oldarts)) "\\Deleted") (setq articles (gnus-set-difference articles oldarts)))))) ((and nnimap-search-uids-not-since-is-evil (numberp days)) (let* ((all-new-articles (gnus-compress-sequence (imap-search (format "SINCE %s" (nnimap-date-days-ago days))))) (oldartseq (gnus-range-difference artseq all-new-articles)) (oldarts (gnus-uncompress-range oldartseq))) (when oldarts (nnimap-expiry-target oldarts group server) (when (imap-message-flags-add (imap-range-to-message-set oldartseq) "\\Deleted") (setq articles (gnus-set-difference articles oldarts)))))) ((numberp days) (let ((oldarts (imap-search (format nnimap-expunge-search-string (imap-range-to-message-set artseq) (nnimap-date-days-ago days)))) (imap-fetch-data-hook '(nnimap-request-expire-articles-progress))) (when oldarts (nnimap-expiry-target oldarts group server) (when (imap-message-flags-add (imap-range-to-message-set (gnus-compress-sequence oldarts)) "\\Deleted") (setq articles (gnus-set-difference articles oldarts))))))))))) ;; return articles not deleted articles) (deffoo nnimap-request-move-article (article group server accept-form &optional last move-is-internal) (when (nnimap-possibly-change-server server) (save-excursion (let ((buf (get-buffer-create " *nnimap move*")) (nnimap-current-move-article article) (nnimap-current-move-group group) (nnimap-current-move-server nnimap-current-server) result) (gnus-message 10 "nnimap-request-move-article: this is an %s move" (if move-is-internal "internal" "external")) ;; request the article only when the move is NOT internal (and (or move-is-internal (nnimap-request-article article group server)) (with-current-buffer buf (buffer-disable-undo (current-buffer)) (insert-buffer-substring nntp-server-buffer) (setq result (eval accept-form)) (kill-buffer buf) result) (nnimap-possibly-change-group group server) (imap-message-flags-add (imap-range-to-message-set (list article)) "\\Deleted" 'silent nnimap-server-buffer)) result)))) (deffoo nnimap-request-accept-article (group &optional server last) (when (nnimap-possibly-change-server server) (let (uid) (if (setq uid (if (string= nnimap-current-server nnimap-current-move-server) ;; moving article within same server, speed it up... (and (nnimap-possibly-change-group nnimap-current-move-group) (imap-message-copy (number-to-string nnimap-current-move-article) group 'dontcreate nil nnimap-server-buffer)) (with-current-buffer (current-buffer) (goto-char (point-min)) ;; remove any 'From blabla' lines, some IMAP servers ;; reject the entire message otherwise. (when (looking-at "^From[^:]") (delete-region (point) (progn (forward-line) (point)))) ;; turn into rfc822 format (\r\n eol's) (while (search-forward "\n" nil t) (replace-match "\r\n")) (when nnmail-cache-accepted-message-ids (nnmail-cache-insert (nnmail-fetch-field "message-id") group (nnmail-fetch-field "subject")))) (when (and last nnmail-cache-accepted-message-ids) (nnmail-cache-close)) ;; this 'or' is for Cyrus server bug (or (null (imap-current-mailbox nnimap-server-buffer)) (imap-mailbox-unselect nnimap-server-buffer)) (imap-message-append group (current-buffer) nil nil nnimap-server-buffer))) (cons group (nth 1 uid)) (nnheader-report 'nnimap (imap-error-text nnimap-server-buffer)))))) (deffoo nnimap-request-delete-group (group force &optional server) (when (nnimap-possibly-change-server server) (with-current-buffer nnimap-server-buffer (if force (or (null (imap-mailbox-status group 'uidvalidity)) (imap-mailbox-delete group)) ;; UNSUBSCRIBE? t)))) (deffoo nnimap-request-rename-group (group new-name &optional server) (when (nnimap-possibly-change-server server) (imap-mailbox-rename group new-name nnimap-server-buffer))) (defun nnimap-expunge (mailbox server) (when (nnimap-possibly-change-group mailbox server) (imap-mailbox-expunge nil nnimap-server-buffer))) (defun nnimap-acl-get (mailbox server) (when (nnimap-possibly-change-server server) (and (imap-capability 'ACL nnimap-server-buffer) (imap-mailbox-acl-get mailbox nnimap-server-buffer)))) (defun nnimap-acl-edit (mailbox method old-acls new-acls) (when (nnimap-possibly-change-server (cadr method)) (unless (imap-capability 'ACL nnimap-server-buffer) (error "Your server does not support ACL editing")) (with-current-buffer nnimap-server-buffer ;; delete all removed identifiers (mapc (lambda (old-acl) (unless (assoc (car old-acl) new-acls) (or (imap-mailbox-acl-delete (car old-acl) mailbox) (error "Can't delete ACL for %s" (car old-acl))))) old-acls) ;; set all changed acl's (mapc (lambda (new-acl) (let ((new-rights (cdr new-acl)) (old-rights (cdr (assoc (car new-acl) old-acls)))) (unless (and old-rights new-rights (string= old-rights new-rights)) (or (imap-mailbox-acl-set (car new-acl) new-rights mailbox) (error "Can't set ACL for %s to %s" (car new-acl) new-rights))))) new-acls) t))) ;;; Internal functions ;; ;; This is confusing. ;; ;; mark => read, tick, draft, reply etc ;; flag => "\\Seen", "\\Flagged", "\\Draft", "gnus-expire" etc ;; predicate => "SEEN", "FLAGGED", "DRAFT", "KEYWORD gnus-expire" etc ;; ;; Mark should not really contain 'read since it's not a "mark" in the Gnus ;; world, but we cheat. Mark == gnus-article-mark-lists + '(read . read). ;; (defconst nnimap-mark-to-predicate-alist (mapcar (lambda (pair) ; cdr is the mark (or (assoc (cdr pair) '((read . "SEEN") (tick . "FLAGGED") (draft . "DRAFT") (recent . "RECENT") (reply . "ANSWERED"))) (cons (cdr pair) (format "KEYWORD gnus-%s" (symbol-name (cdr pair)))))) (cons '(read . read) gnus-article-mark-lists))) (defun nnimap-mark-to-predicate (pred) "Convert a Gnus mark (a symbol such as read, tick, expire) to a IMAP predicate. This is a string such as \"SEEN\", \"FLAGGED\", \"KEYWORD gnus-expire\", to be used within a IMAP SEARCH query." (cdr (assq pred nnimap-mark-to-predicate-alist))) (defconst nnimap-mark-to-flag-alist (mapcar (lambda (pair) (or (assoc (cdr pair) '((read . "\\Seen") (tick . "\\Flagged") (draft . "\\Draft") (recent . "\\Recent") (reply . "\\Answered"))) (cons (cdr pair) (format "gnus-%s" (symbol-name (cdr pair)))))) (cons '(read . read) gnus-article-mark-lists))) (defun nnimap-mark-to-flag-1 (preds) (if (and (not (null preds)) (listp preds)) (cons (nnimap-mark-to-flag (car preds)) (nnimap-mark-to-flag (cdr preds))) (cdr (assoc preds nnimap-mark-to-flag-alist)))) (defun nnimap-mark-to-flag (preds &optional always-list make-string) "Convert a Gnus mark (a symbol such as read, tick, expire) to a IMAP flag. This is a string such as \"\\Seen\", \"\\Flagged\", \"gnus-expire\", to be used in a STORE FLAGS command." (let ((result (nnimap-mark-to-flag-1 preds))) (setq result (if (and (or make-string always-list) (not (listp result))) (list result) result)) (if make-string (mapconcat (lambda (flag) (if (listp flag) (mapconcat 'identity flag " ") flag)) result " ") result))) (defun nnimap-mark-permanent-p (mark &optional group) "Return t if MARK can be permanently (between IMAP sessions) saved on articles, in GROUP." (imap-message-flag-permanent-p (nnimap-mark-to-flag mark))) (when nnimap-debug (require 'trace) (buffer-disable-undo (get-buffer-create nnimap-debug-buffer)) (mapc (lambda (f) (trace-function-background f nnimap-debug-buffer)) '( nnimap-possibly-change-server nnimap-verify-uidvalidity nnimap-find-minmax-uid nnimap-before-find-minmax-bugworkaround nnimap-possibly-change-group ;;nnimap-replace-whitespace nnimap-retrieve-headers-progress nnimap-retrieve-which-headers nnimap-group-overview-filename nnimap-retrieve-headers-from-file nnimap-retrieve-headers-from-server nnimap-retrieve-headers nnimap-open-connection nnimap-open-server nnimap-server-opened nnimap-close-server nnimap-request-close nnimap-status-message ;;nnimap-demule nnimap-request-article-part nnimap-request-article nnimap-request-head nnimap-request-body nnimap-request-group nnimap-close-group nnimap-pattern-to-list-arguments nnimap-request-list nnimap-request-post nnimap-retrieve-groups nnimap-request-update-info-internal nnimap-request-type nnimap-request-set-mark nnimap-split-to-groups nnimap-split-find-rule nnimap-split-find-inbox nnimap-split-articles nnimap-request-scan nnimap-request-newgroups nnimap-request-create-group nnimap-time-substract nnimap-date-days-ago nnimap-request-expire-articles-progress nnimap-request-expire-articles nnimap-request-move-article nnimap-request-accept-article nnimap-request-delete-group nnimap-request-rename-group gnus-group-nnimap-expunge gnus-group-nnimap-edit-acl gnus-group-nnimap-edit-acl-done nnimap-group-mode-hook nnimap-mark-to-predicate nnimap-mark-to-flag-1 nnimap-mark-to-flag nnimap-mark-permanent-p ))) (provide 'nnimap) ;; arch-tag: 2b001f20-3ff9-4094-a0ad-46807c1ba70b ;;; nnimap.el ends here gnus-5.11+v0.10.dfsg/lisp/ChangeLog.10000644000175000017500000114055011004006123017145 0ustar tvainikatvainika2000-10-27 Jason Rumney * gnus-art.el (gnus-signature-face): Use italic on any frame that supports it. 2000-10-27 14:19:53 ShengHuo ZHU * gnus-mlspl.el: Require cl when compiling. * messagexmas.el: Ditto. * mm-util.el: Ditto. * rfc2047.el: Ditto. * rfc2231.el: Ditto. * smiley-ems.el: Ditto. * uudecode.el: Ditto. * smiley-ems.el (smiley-region): Use mapcar. 2000-10-27 Stefan Monnier * ietf-drums.el: Require cl when compiling. 2000-10-27 Dave Love * mm-decode.el (mm-valid-and-fit-image-p): Don't test window-system here. * gnus-art.el (gnus-article-x-face-command): Check gnus-article-compface-xbm. (gnus-treat-display-xface): Check for uncompface. * nnheader.el (nnheader-translate-file-chars): Only kludge things under Doze with XEmacs. 2000-10-26 Simon Josefsson * mail-source.el (mail-sources): IMAP predicate is a string. (mail-sources): Add default values for IMAP mailbox, predicate and fetchflag. 2000-10-26 Dave Love * flow-fill.el: Require cl when compiling. * mail-source.el: Require imap when compiling and defvar display-time-mail-function. Require mm-util. (nnheader-cancel-timer): Autoload. (mail-source-imap-authenticators, mail-source-imap-streams): New variables. (mail-sources): Use them. 2000-10-25 20:13:02 ShengHuo ZHU * mm-decode.el (mm-viewer-completion-map): New. (mm-interactively-view-part): Use it. 2000-10-25 18:51:12 ShengHuo ZHU * rfc2047.el (rfc2047-q-encode-region): Don't break if a QP-word could be fitted in one line. 2000-10-25 Dirk Meyer * gnus-demon.el (gnus-demon-time-to-step): theHour was set to seconds instead of hour. 2000-10-25 Per Abrahamsen * mail-source.el (mail-sources): Better `:type'. 2000-10-24 18:31:29 ShengHuo ZHU * gnus-art.el (gnus-request-article-this-buffer): gnus-refer-article-method might be a single method. * gnus-sum.el (gnus-refer-article-methods): The second could be a named method. 2000-10-23 Simon Josefsson * flow-fill.el (fill-flowed): Don't flow "-- " lines. (fill-flowed): Make "quote-depth wins" rule work when first line is at level 0. 2000-10-21 11:23:21 ShengHuo ZHU * mm-util.el (mm-multibyte-p): Test (featurep 'xemacs). 2000-10-21 10:54:57 ShengHuo ZHU * gnus-art.el (gnus-article-mime-total-parts): New function. (gnus-mm-display-part): Use it. (gnus-mime-display-single): Ditto. (gnus-mime-display-alternative): Ditto. 2000-10-21 09:38:27 ShengHuo ZHU * mailcap.el (mailcap-parse-mailcaps): Don't use parse-colon-path, because they are files, not directories. (mailcap-parse-mimetypes): Ditto. 2000-10-20 19:55:59 ShengHuo ZHU * gnus-art.el (gnus-mime-inline-part): Check validity of charset. 2000-10-18 Dave Love * mail-source.el (mm-util): Require. (defvar): Use rmail-spool-directory unconditionally. * gnus-nocem.el (gnus-nocem-issuers): Update. (gnus-nocem-check-from): New option. (gnus-nocem-scan-groups): Use it. (gnus-nocem-check-article): Bind gnus-newsgroup-name. 2000-10-18 Miles Bader * gnus-nocem.el (gnus-nocem-check-article-limit): New variable. (gnus-nocem-scan-groups): Obey `gnus-nocem-check-article-limit'. 2000-10-18 Simon Josefsson * nnheader.el (nnheader-parse-head): Try both "from:" and "from: ". * gnus-sum.el (gnus-get-newsgroup-headers): Ditto. 2000-10-17 Simon Josefsson * gnus-sum.el (gnus-get-newsgroup-headers): Search for "from:" instead of "from: " for rfc822 compliance. * gnus-uu.el (gnus-uu-digest-mail-forward): Ditto. Insert SPC. * nnheader.el (nnheader-parse-head): Ditto. 2000-10-13 Kai Gro,A_(Bjohann * mail-source.el (mail-source-keyword-map): Use `rmail-spool-directory' as a default directory for the `file' source, if the variable is defined. Fall back to hardcoded "/usr/spool/mail/", as before. Suggestion by Steven E. Harris . 2000-10-13 12:01:15 ShengHuo ZHU * message.el (message-send-mail-partially): Replace the header delimiter with a blank line. 2000-10-13 Kai Gro,A_(Bjohann * gnus-sum.el (gnus-get-split-value): Use first match only (Ed L Cashin ). 2000-10-13 10:52:00 ShengHuo ZHU * gnus-ems.el (gnus-article-compface-xbm): Ignore errors. 2000-10-11 John Wiegley * gnus-topic.el (gnus-topic-mode): Use `setq' to clear `gnus-group-change-level-function', instead of `remove-hook', because it's not a hook! * gnus-mlspl.el (gnus-group-split-update): Check the value of `nnmail-crosspost', and use it to set the `no-crosspost' argument when calling `gnus-group-split-fancy'. Otherwise, it assumes that cross-posting is always OK, no matter what `nmail-crosspost' is set to. (gnus-group-split-fancy): The argument order in the second-to-last `push' call was wrong, but since `no-crosspost' was always nil, it was never being triggered. * gnus-art.el (gnus-treat-hide-citation-maybe): Added this variable to correspond with `gnus-article-hide-citation-maybe'. (gnus-treatment-function-alist): Added entry for the above correlation. 2000-10-12 08:26:30 ShengHuo ZHU * mm-util.el (mm-with-unibyte-current-buffer): Revert to old. (mm-with-unibyte-current-buffer-mule4): New function. * qp.el (quoted-printable-encode-region): Use it. * rfc2047.el (rfc2047-decode): Ditto. * webmail.el (webmail-init): Revert to use mm-disable-multibyte. 2000-10-10 08:44:13 ShengHuo ZHU * rfc2047.el (rfc2047-fold-region): "=?=" is not a break point. 2000-10-10 00:00:28 ShengHuo ZHU * webmail.el (webmail-init): Use mm-disable-multibyte-mule4. 2000-10-09 22:50:05 ShengHuo ZHU * base64.el (base64-decode-region): Just give a message if the end is not sane. 2000-10-09 20:09:11 ShengHuo ZHU * rfc2047.el (rfc2047-encode-message-header): Move fold into encode-region. (rfc2047-dissect-region): Rewrite. (rfc2047-encode-region): Rewrite. (rfc2047-fold-region): Fold any line longer than 76. (rfc2047-unfold-region): New function. (rfc2047-decode-region): Use it. (rfc2047-q-encode-region): Don't break at bob. 2000-10-09 17:12:00 ShengHuo ZHU * nntp.el (nntp-open-connection): Kill process buffer when quit. (nntp-connection-timeout): Add a note. SIGALRM is ignored in both FSF Emacs 20 and XEmacs 21. * gnus-agent.el (gnus-agent-fetch-session): Catch quit. 2000-10-09 Dave Love * gnus-audio.el: Don't require cl. (gnus-audio): New custom group. (gnus-audio-inline-sound): Change to work with Emacs. (gnus-audio-directory, gnus-audio-directory) (gnus-audio-au-player): Customize. (gnus-audio-play): Try external player if play-sound-file fails. Use file-name-extension, not string-match. * gnus-art.el (article-de-quoted-unreadable) (article-de-base64-unreadable): Fold search case rather than downcasing string. Apply mm-charset-to-coding-system to arg of quoted-printable-decode-region. (gnus-article-dumbquotes-map): Fix dashes. (gnus-button-mailto, gnus-button-embedded-url): Doc fix. (gnus-button-reply): Just alias it. 2000-10-09 Stefan Monnier * mm-encode.el: Require CL. At least, for `incf'. * nnfolder.el (nnfolder-ignore-active-file): Typos. * gnus-mh.el (gnus-summary-save-in-folder): Obey mh-lib-progs. * gnus-kill.el (gnus-kill): Typo. 2000-10-09 Gerd Moellmann * smiley-ems.el (smiley-update-cache): Use `:ascent center'. 2000-10-09 Simon Josefsson * nnimap.el (nnimap-group-overview-filename): Create directory for newfile (when use long filenames is nil). Copy+delete file if rename didn't work. (nnimap-group-overview-filename): `rename-file' and `copy-file' doesn't return anything useful, use ignore-errors instead. 2000-10-08 13:05:11 ShengHuo ZHU * dgnushack.el (dgnushack-compile): Delete old elc files first. 2000-10-08 10:59:13 ShengHuo ZHU * gnus-ems.el (gnus-kill-all-overlays): Move here. * gnus-util.el (gnus-kill-all-overlays): Move out. * gnus-sum.el (gnus-cache-write-active): Auto load. * lpath.el: Shut up. * nnweb.el (nnweb-url-retrieve-asynch): url-retrieve is asynchronous in Exp version. 2000-10-08 08:57:13 ShengHuo ZHU * gnus-art.el, gnus-ems.el, gnus-start.el: Remove gnus-xemacs. * gnus-ems.el: Autoload smiley. * gnus-art.el (gnus-treat-display-smileys): Default value in Emacs 21. 2000-10-08 08:45:48 ShengHuo ZHU * gnus-sum.el (gnus-summary-display-article): Enable multibyte. (gnus-summary-select-article): Don't enable multibyte here. (gnus-summary-goto-article): Ditto. 2000-10-08 Christoph Conrad * gnus-draft.el (gnus-draft-send-message): Typo. 2000-10-08 Simon Josefsson * nnimap.el (nnimap-verify-uidvalidity): Delete overview file when uid validity changes. (nnimap-group-overview-filename): Store uidvalidity in filenames. Rename old files into new format. 2000-10-07 15:49:39 ShengHuo ZHU * mm-util.el (mm-enable-multibyte-mule4): New. (mm-disable-multibyte-mule4): New. * gnus-sum.el (gnus-summary-mode): Use it. (gnus-summary-select-article): Ditto. (gnus-summary-goto-article): Use enable multibyte. * rfc2047.el (rfc2047-decode): Use unibyte. 2000-10-07 15:42:59 ShengHuo ZHU * gnus-logic.el (gnus-advanced-string): Use "" if nil. 2000-10-07 10:31:05 ShengHuo ZHU * rfc2047.el (rfc2047-q-encode-region): Better calculation of break point. (rfc2047-fold-region): Don't break the first non-LWSP characters. 2000-10-07 09:18:53 ShengHuo ZHU * gnus.el (gnus-agent-fetching): New variable. * gnus-agent.el (gnus-agent-with-fetch): Bind it. * gnus-score.el (gnus-score-body): Don't score body when agent-fetching. (gnus-score-followup): Don't score followup either. 2000-10-07 08:19:17 ShengHuo ZHU * gnus-art.el: Define dynamic variables in eval-when-compile. * message.el (message-sending-message): New variable. (message-send): Use it. * gnus-draft.el (gnus-draft-send-message): Ditto. (gnus-group-send-drafts): Ditto. 2000-10-06 Dave Love * gnus-audio.el: Don't require cl. (gnus-audio): New custom group. (gnus-audio-inline-sound): Change to work with Emacs. (gnus-audio-directory, gnus-audio-directory) (gnus-audio-au-player): Customize. (gnus-audio-play): Try external player if play-sound-file fails. Use file-name-extension, not string-match. 2000-10-06 17:38:03 ShengHuo ZHU * gnus-art.el (gnus-article-prepare): Configure it again. 2000-10-06 15:11:07 ShengHuo ZHU * message.el (message-default-charset): Default value for non-Mule Emacsen. 2000-10-06 14:28:50 ShengHuo ZHU * message.el (message-alternative-emails): New. (message-use-alternative-email-as-from): New. (message-setup): Use them. 2000-10-06 13:46:47 ShengHuo ZHU * base64.el, dgnushack.el, gnus-spec.el, messagexmas.el * gnus-xmas.el, nnheaderxm.el, nndraft.el: Use defalias. * gnus-xmas.el (gnus-xmas-define): Defalias gnus-overlay-buffer, gnus-overlay-start. * gnus.el: Ditto. * gnus-art.el (gnus-insert-mime-button): Use them. 2000-10-06 10:01:08 ShengHuo ZHU * mm-util.el (mm-with-unibyte-current-buffer): Don't set unibyte if eight-bit-control is a charset, e.g. Mule 5.0 in Emacs 21. 2000-10-06 09:38:54 ShengHuo ZHU * qp.el (quoted-printable-encode-region): Use mm-with-unibyte-current-buffer within narrowed region. 2000-10-06 08:56:33 ShengHuo ZHU * webmail.el (webmail-type-definition): Fix my-deja open url. 2000-10-06 Emerick Rogul * message.el (message-setup-fill-variables): New variable. (message-mode): Use it. 2000-10-05 Dave Love * rfc2047.el (rfc2047-fold-region): Use gnus-point-at-bol. (rfc2047-charset-encoding-alist): Add iso-8859-1[45]. * binhex.el: Use defalias, not fset. * rfc1843.el: Require cl when compiling. 2000-10-05 12:25:08 ShengHuo ZHU * gnus-agent.el (gnus-agent-fetch-group-1): Score-param could be nil. 2000-10-05 11:43:25 ShengHuo ZHU * rfc2047.el (rfc2047-encode-region): Merge only if regions are adjacent. 2000-10-05 09:41:33 ShengHuo ZHU * mm-util.el (mm-multibyte-p): In XEmacs, it is (feature 'mule). (mm-find-charset-region): Merge conditions, delete ascii. (mm-charset-after): Rewrite. * mm-bodies.el (mm-encode-body): Use it. 2000-10-05 09:04:32 ShengHuo ZHU * webmail.el (webmail-hotmail-list): Fix. 2000-10-05 Stefan Monnier * nnimap.el (require): cl. 2000-10-04 15:24:46 ShengHuo ZHU * gnus-art.el (gnus-article-prepare): Configure windows before gnus-article-prepare-display is called. Otherwise, BBDB's popup window might be overrided. 2000-10-04 Dave Love * gnus-ems.el (gnus-article-display-xface) [gnus-article-compface-xbm]: Fix. (gnus-x-splash): Bind width, height. 2000-10-04 11:45:04 ShengHuo ZHU * gnus-art.el (gnus-mime-inline-part): Use prefix argument only when it is called interactively. 2000-10-03 21:20:31 ShengHuo ZHU * gnus-art.el (gnus-mime-action-alist): New variable. (gnus-mime-action-on-part): Use it. (gnus-mime-button-commands): Add command ".". 2000-10-03 20:37:42 ShengHuo ZHU * gnus-art.el (gnus-mime-inline-part): Support prefix argument. 2000-10-03 Katsumi Yamaoka * lpath.el: "." is in the load-path because dgnushack.el. 2000-10-03 Bjorn Torkelsson * uudecode.el: xemacs cleanup (use featurep ' xemacs) * nnheader.el: ditto * mm-util.el: ditto * message.el: ditto * binhex.el: ditto * gnus-audio.el: removed unnecessary xemacs test * earcon.el: ditto 2000-10-03 19:55:55 Lars Magne Ingebrigtsen * nnweb.el (nnweb-decode-entities): Work for non-character entities. 2000-09-26 09:20:08 Lars Magne Ingebrigtsen * gnus.el: Message the quit parts. 2000-10-03 08:08:29 ShengHuo ZHU * mail-source.el (mail-source-fetch-maildir): Don't insert newlines. 2000-10-02 20:14:27 ShengHuo ZHU * dgnushack.el (dgnushack-compile): Don't compile dgnushack.el, lpath.el. Don't compile base64.el if there is builtin base64. 2000-10-02 Bj,Av(Brn Torkelsson * base64.el (Repository): Use featurep for XEmacs test. 2000-10-02 17:38:12 ShengHuo ZHU * nntp.el (nntp-retrieve-data): Don't ignore quit. 2000-10-02 14:43:13 ShengHuo ZHU * gnus-art.el (gnus-article-banner-alist): New variable. (article-strip-banner): Use it. * gnus-cus.el (gnus-group-parameters): Allow symbol. 2000-10-02 Dave Love * smiley-ems.el: New file. * gnus-ems.el (gnus-smiley-display): Autoload. (mouse-set-point, set-face-foreground, set-face-background) (x-popup-menu): Don't clobber these. (gnus-article-compface-xbm): New variable. (gnus-article-display-xface): Move graphic test. Use unibyte. Obey gnus-article-compface-xbm. Use pbm, not xbm. * mml.el (require): Fix typo. (mml-parse-1): Modify unknown encoding prompt. * mail-source.el (mail-sources): Revert to nil. * nnmail.el (nnmail-spool-file): Revert previous change. * gnus.el: Don't require custom, message. (gnus-message-archive-method): Wrap initializer in progn and require message here. 2000-10-02 Gerd Moellmann * gnus.el (gnus-mode-line-buffer-identification) [Emacs]: Change image's :ascent to 80. That gives a mode-line which is approx. as tall as the normal one. 2000-10-02 08:04:48 ShengHuo ZHU * webmail.el (webmail-hotmail-list): Fix. 2000-10-01 20:55:53 ShengHuo ZHU Don't postpone GCC if none of GCC methods is agent-covered. This fix presumes that the post-method must be agent-covered if any Gcc method is agent-covered. * gnus-msg.el (gnus-inews-group-method): New function. (gnus-inews-do-gcc): Use it. * gnus-agent.el (gnus-agent-any-covered-gcc): New function. (gnus-agent-possibly-save-gcc): Use it. (gnus-agent-possibly-do-gcc): Ditto. 2000-10-01 17:08:50 ShengHuo ZHU * mailcap.el (mailcap-mime-types): Use mailcap-mime-data. * mml.el (mml-minibuffer-read-type): Use mailcap-mime-types. 2000-10-01 13:07:21 ShengHuo ZHU * webmail.el (webmail-netscape-open, webmail-hotmail-article, webmail-hotmail-list): Update. 2000-10-01 08:36:09 ShengHuo ZHU * mail-source.el (mail-source-report-new-mail): Use nnheader-cancel-timer. 2000-10-01 08:35:38 ShengHuo ZHU * lpath.el (overlay-*): Shut up. * dgnushack.el: Two implementations of smiley. 2000-10-01 08:32:42 ShengHuo ZHU * gnus-ml.el: Usage. (gnus-mailing-list-archive, gnus-mailing-list-owner, gnus-mailing-list-post, gnus-mailing-list-unsubscribe, gnus-mailing-list-subscribe, gnus-mailing-list-help): Bind list-*. (gnus-mailing-list-menu): Define it. (turn-on-gnus-mailing-list-mode, gnus-mailing-list-mode): Autoload. * gnus-xmas.el (gnus-xmas-mailing-list-menu-add): Move here. 2000-09-30 18:52:51 ShengHuo ZHU * webmail.el (webmail-my-deja-*): Rewrite. 2000-09-30 Simon Josefsson * nnimap.el (nnimap-request-accept-article): Remove \n's from From_ lines. 2000-08-05 Simon Josefsson Make GCC to remote groups work when unplugged (postpone GCC until message is actually sent). * gnus-draft.el (gnus-draft-send): Call `gnus-agent-restore-gcc'. * gnus-agent.el (gnus-agent-possibly-do-gcc): (gnus-agent-restore-gcc): (gnus-agent-possibly-save-gcc): New functions. * gnus-msg.el (gnus-inews-add-send-actions): Use `gnus-agent-possibly-do-gcc' if Agentized. (gnus-inews-add-send-actions): Add `gnus-agent-possibly-save-gcc' to `message-header-hook'. * gnus.el (gnus-agent-gcc-header): New variable. 2000-07-13 Simon Josefsson Asks the user to synch flags with server when you plug in. * gnus-agent.el (gnus-agent-synchronize-flags): New variable. (gnus-agent-possibly-synchronize-flags-server): New function, use it. (gnus-agent-toggle-plugged): Call it. (gnus-agent-synchronize-flags): Renamed from `gnus-agent-synchronize'. (gnus-agent-group-mode-map): `g-a-s' -> `g-a-s-flags'. (gnus-agent-possibly-synchronize-flags): New function. (gnus-agent-possibly-synchronize-flags-server): New function. 2000-09-30 Simon Josefsson * starttls.el: New file, by Daiki Ueno. 2000-08-02 Stanislav Shalunov * message.el (message-make-in-reply-to): In-Reply-To is message-id (see DRUMS). 2000-09-29 Simon Josefsson * nntp.el (nntp-async-trigger): Fix authinfo in asynchronous prefetch. 2000-08-09 10:21:20 Katsumi Yamaoka * nntp.el (nntp-open-telnet): Wait for the telnet prompt before sending a command; allow the rtelnet prompt as well. 2000-09-29 Simon Josefsson * message.el (message-send): Make sure error is signalled if no send method is specified. 2000-09-29 Florian Weimer * qp.el (quoted-printable-encode-region): Wrap with `mm-with-unibyte-current-buffer'. 2000-09-29 12:12:49 ShengHuo ZHU * gnus-agent.el (gnus-agent-fetch-group-1): Reimplement Mike McEwan's proposal. 2000-09-29 12:06:40 ShengHuo ZHU * gnus-agent.el: Revoke Mike McEwan's 1998-09-05 patch due to the GNU assignment issue. 2000-09-29 09:56:34 ShengHuo ZHU * nndoc.el (nndoc-dissect-mime-parts-sub): Correctly mark body-begin. 2000-09-29 09:14:08 ShengHuo ZHU * gnus-sum.el (gnus-summary-enter-digest-group): Decode to-address. 2000-09-28 Andrei Elkin (tiny change) * gnus-art.el (article-strip-banner): Use gnus-group-find-parameter rather than gnus-group-get-parameter, to allow inheritance on the banner. 2000-09-26 Richard M. Alderson III * gnus-art.el (gnus-read-save-file-name): expand-file-name. 2000-09-26 Dave Love * gnus-draft.el: Don't require gnus-agent. * mm-view.el: Use featurep for XEmacs test. (mm-inline-message): Test for `remove-specifier'; don't use condition-case. 2000-09-24 Simon Josefsson * nnimap.el (nnimap-request-accept-article): Remove From[^:] lines. * gnus-group.el (gnus-group-nnimap-edit-acl): Check if server support ACL's. * nnimap.el (nnimap-acl-get): Check capability. * mail-source.el (mail-source-imap-file-coding-system): New variable. (mail-source-fetch-imap): Use it. * rfc2104.el (rfc2104-hexstring-to-bitstring): New function. (rfc2104-hash): Use it. * imap.el (imap-starttls-p): Check for starttls binary. (imap-starttls-open): More verbose. (imap-gssapi-auth): Ditto. (imap-kerberos4-auth): Ditto. (imap-cram-md5-auth): Ditto. (imap-login-auth): Ditto. (imap-anonymous-auth): Ditto. (imap-digest-md5-auth): Ditto. (imap-open): Ditto. (imap-digest-md5-p): Check capability first. 2000-09-24 Simon Josefsson * imap.el (imap-parse-flag-list): Correctly parse empty lists. (imap-login-p): Support LOGINDISABLED. 2000-09-23 Simon Josefsson * rfc2104.el: Add SHA-1 example. 2000-09-22 Simon Josefsson * imap.el (imap-parse-body): Work around bug in Sun SIMS. 2000-09-21 21:54:48 ShengHuo ZHU * lpath.el: Bind nnkiboze-score-file. 2000-09-21 16:15:25 ShengHuo ZHU * gnus-score.el (gnus-score-use-all-scores): New variable. (gnus-all-score-files): Use it. * nnkiboze.el (nnkiboze-generate-group): Use it. Inhibit list groups. (nnkiboze-enter-nov): Fix it when there is no xref. (nnkiboze-generate-groups): List groups. * gnus-group.el (gnus-group-make-kiboze-group): Use nnkiboze-score-file. * nnkiboze.el (nnkiboze-request-article): Use gnus-cache-request-article. * gnus-group.el (gnus-group-make-kiboze-group): Fix prompt. 2000-07-16 Dmitry Bely * nnheader.el (nnheader-translate-file-chars): Path splitting on NT. 2000-09-20 18:33:00 ShengHuo ZHU * gnus-score.el (gnus-score-find-bnews): Use directory-sep-char. 2000-09-20 17:37:46 ShengHuo ZHU * message.el (message-default-charset): Set default value in non-MULE XEmacsen as iso-8859-1. 2000-09-20 12:02:24 ShengHuo ZHU * gnus-demon.el: Use (featurep 'xemacs). * gnus-agent.el: timer vs. itimer. * mail-source.el: Ditto. 2000-09-19 10:24:57 ShengHuo ZHU * gnus-group.el (gnus-group-make-kiboze-group): Makedir. * nnheader.el (nnheader-parse-nov): Remove Xref in mail-header-xref. * gnus-sum.el (gnus-nov-parse-line): Ditto. * nnkiboze.el (nnkiboze-file-coding-system): New. (nnkiboze-retrieve-headers): Use it. (nnkiboze-request-group): Ditto. (nnkiboze-close-group): Ditto. (nnkiboze-generate-group): Ditto. (nnkiboze-enter-nov): Insert first Xref properly. 2000-09-19 Dave Love * nnmail.el (nnmail-cache-accepted-message-ids): Default to nil. (nnmail-get-new-mail): Test `sources' in top-level conditional. * mail-source.el (mail-sources): Change default to '((file)). Add useful custom type. 2000-09-18 Kai Gro,A_(Bjohann * gnus-util.el (gnus-time-iso8601): Correct doc string (four digit year). (gnus-date-iso8601): Ditto. 2000-09-18 09:05:46 ShengHuo ZHU * mail-source.el (mail-source-fetch-imap): Disable multibyte. 2000-09-17 01:13:46 ShengHuo ZHU * rfc2047.el (rfc2047-q-encoding-alist): Remove = and _ from the pattern. Avoid using 8 bit chars. * qp.el (quoted-printable-encode-region): Avoid using 8 bit chars. 2000-09-16 15:57:42 ShengHuo ZHU * smiley.el (smiley-buffer-ems, smiley-create-glyph-ems, smiley-toggle-extent-ems, smiley-toggle-extents-ems, smiley-toggle-buffer-ems): New functions for Emacs 21. Toggle functions are not implemented yet. * dgnushack.el (dgnushack-compile): Remove smiley.el and x-overlay.el from the FSF Emacs black list. 2000-09-15 21:10:20 ShengHuo ZHU * mm-decode.el (mm-inlined-types): Add application/emacs-lisp. (mm-inline-media-tests): Ditto. (mm-automatic-display): Ditto. * mm-view.el (mm-display-inline-fontify): Generalize from mm-display-patch-inline. (mm-display-patch-inline): Use it. (mm-display-elisp-inline): Ditto. 2000-09-15 14:03:00 ShengHuo ZHU * gnus-topic.el (gnus-topic-find-groups): Add recursive parameter. (gnus-topic-unmark-topic): Ditto. (gnus-topic-mark-topic): Ditto. (gnus-topic-get-new-news-this-topic): Use it. 2000-09-15 09:01:40 ShengHuo ZHU * gnus-art.el (gnus-treat-display-xface): By default, Emacs 21 display xface. 2000-08-23 02:54:46 Katsumi Yamaoka * gnus-group.el (gnus-group-rename-group): Inhibit renaming of zombie or killed groups. 2000-09-15 00:09:56 ShengHuo ZHU * mml.el (mml-preview): Reinsert unibyte content. (mml-parse-1): Remove with-unibyte-current-buffer. (mml-generate-mime-1): Ditto. * gnus-msg.el (gnus-summary-mail-forward): Ditto. * message.el (message-forward): Ditto. 2000-09-14 23:13:50 ShengHuo ZHU * gnus-art.el (article-de-quoted-unreadable): Guess charset from original article buffer. (article-de-base64-unreadable): Ditto. (article-wash-html): Ditto. 2000-09-14 18:55:30 ShengHuo ZHU * gnus-msg.el (gnus-summary-mail-forward): Disable multibyte unless forward-show-mml. 2000-09-14 14:48:57 ShengHuo ZHU * gnus-sum.el (gnus-summary-save-parts-type-history): New. (gnus-summary-save-parts-last-directory): New. (gnus-summary-save-parts): Save history. 2000-09-14 Ben Gertzfield * gnus-sum.el (gnus-summary-save-parts-default-mime): New variable. (gnus-summary-save-parts): Use it. 2000-09-14 11:31:28 ShengHuo ZHU * gnus-art.el (gnus-article-setup-buffer): Clean handle-alist. * gnus-sum.el (gnus-summary-exit): Ditto. (gnus-summary-exit-no-update): Ditto. (gnus-summary-show-article): Ditto. 2000-09-14 08:42:48 ShengHuo ZHU * nndoc.el (nndoc-dissect-mime-parts-sub): Remove Content-Disposition. 2000-09-13 23:58:40 ShengHuo ZHU * webmail.el: Hotmail updated. Add X-Gnus-Webmail. 2000-09-13 21:41:25 ShengHuo ZHU * gnus-art.el (gnus-article-setup-buffer): Set gnus-article-mime-handles to nil. * gnus-sum.el (gnus-summary-exit): Ditto. (gnus-summary-exit-no-update): Ditto. (gnus-summary-show-article): Ditto. (gnus-summary-save-parts): Use gnus-article-mime-handles if dissected. * mm-partial.el (mm-partial-find-parts): Remove redundancy. 2000-09-13 16:59:33 ShengHuo ZHU * gnus-sum.el (gnus-summary-sort): Sort loose threads too. (gnus-sort-threads-1): New function. Sort threads recursively. (gnus-sort-threads): Use it. (gnus-sort-gathered-threads): Doc fix. 2000-09-13 Dave Love * gnus-salt.el (gnus-binary-mode): Fix call to gnus-add-minor-mode. * gnus-ems.el (gnus-ems-redefine): Don't alias gnus-summary-set-display-table. * message.el (message-user-agent): Don't wrap ignore-errors around it. * mm-encode.el (mm-insert-multipart-headers): Avoid redundant `format'. (mm-content-transfer-encoding): Don't use cadar. * uudecode.el (uudecode-decoder-program) (uudecode-decoder-switches): Customize. * gnus-score.el (gnus-home-score-file): Improve custom type. * gnus-cus.el (gnus-custom-mode): Conditionally set local variables for Emacs 21. (gnus-group-customize): Disable undo while laying out the buffer. 2000-09-13 09:38:26 ShengHuo ZHU * gnus-util.el (gnus-write-active-file): Bind coding-system-for-write. 2000-09-13 09:14:57 ShengHuo ZHU * nnmail.el (nnmail-get-new-mail): Don't test nnmail-spool-file. * gnus-cache.el (gnus-jog-cache): Temporarily disable mail-sources. * gnus-kill.el (gnus-batch-score): Ditto. * gnus-move.el (gnus-change-server): Ditto. * nnkiboze.el (nnkiboze-generate-groups): Ditto. 2000-09-12 Simon Josefsson * gnus-sum.el (gnus-update-read-articles): Undo `gnus-request-set-mark' operation. 2000-09-11 Dave Love * Changelog: Use iso-2022 coding. * gnus-msg.el (gnus-msg-mail): New function. (gnus-user-agent): New mail agent. 2000-09-10 Dave Love * message.el: Require mail-abbrevs for XEmacs for a problem with keybinding despite the autoloads for it. 2000-09-08 Simon Josefsson * imap.el (imap-kerberos4-open): Erase more (fixes race condition?). * nnimap.el (nnimap-request-update-info-internal): Remove tick marks from dormant articles. (See nnimap-request-set-mark.) (nnimap-retrieve-headers-progress): Demule. (nnimap-open-server): Call nnoo-change-server twice, once for getting the nnimap-server-buffer and once for letting n-c-s set the variables in that buffer. 2000-09-08 David Edmondson * gnus.el (gnus-short-group-name): Guess separator. 2000-09-07 Tadashi Watanabe * smiley.el (smiley-buffer, smiley-create-glyph): Work with GTK XEmacs as well. 2000-09-06 Francis Litterio * gnus-group.el (gnus-group-insert-group-line): Fix. 2000-09-04 Dave Love * mm-decode.el (mime-display) : Add `multimedia' group. (mm-get-image): Avoid the losing `make-glyph' from W3. 2000-09-03 Simon Josefsson * gnus-sum.el (gnus-summary-delete-article): Check server. 2000-09-01 Simon Josefsson * imap.el (imap-parse-flag-list): Rewrite. * nnimap.el (nnimap-retrieve-headers-from-file): Ignore errors. * imap.el (imap-parse-flag-list): Hack. 2000-08-29 Dave Love * gnus-mlspl.el (gnus-group-split-fancy): Eschew mapcon. * dgnushack.el (mapcon, union): Remove compiler macros. * gnus-agent.el (gnus-agent-union): new function. (gnus-agent-fetch-headers): Use it. * gnus.el (gnus-group-startup-message): Modifications to last change. 2000-08-29 Katsumi Yamaoka * gnus.el (gnus-group-startup-message): Specify foreground and background for xpm image. Centre image vertically. 2000-08-24 23:49:23 ShengHuo ZHU * message.el (message-send-mail): Narrow-to-headers. 2000-08-24 Dave Love * gnus-art.el (gnus-insert-mime-button): Fix help-echo for Emacs 21. 2000-08-23 Dave Love * dgnushack.el: Remove `member-if' compiler macro. 2000-08-21 Dave Love * nnimap.el (nnimap-request-newgroups): Eschew member-if. 2000-08-21 10:09:47 ShengHuo ZHU * gnus-topic.el (gnus-topic-hide-topic): Use find-topology if permanent is used. (gnus-topic-show-topic): Read topic when to show permanent hidden topic. (gnus-topic-remove-topic): Revert to the old behavior, not using hide. 2000-08-21 Dave Love * gnus-ems.el (gnus-add-minor-mode): Add &rest arg. (gnus-xemacs): Use featurep. * mm-util.el (mm-read-charset): Maybe use builtin. (mm-replace-chars-in-string): Maybe use subst-char-in-string. (mm-multibyte-p, mm-with-unibyte-current-buffer) (mm-with-unibyte): Use featurep, not string-match. (mm-with-unibyte-buffer): Simplify. (mm-quote-arg): Maybe use shell-quote-argument. * mml.el (mml-make-string): Deleted (unused). * gnus.el (gnus-mode-line-buffer-identification): Supply definition for Emacs 21. * gnus-salt.el: Small doc fixes. (gnus-pick-mode, gnus-binary-mode): Supply a toggle-func arg to gnus-add-minor-mode. * gnus-topic.el (gnus-topic-mode): Supply a toggle-func arg to gnus-add-minor-mode. 2000-08-20 Simon Josefsson * nnimap.el (nnimap-before-find-minmax-bugworkaround): New function, thanks to Lloyd Zusman for debugging. (nnimap-request-group): (nnimap-request-list): (nnimap-retrieve-groups): (nnimap-request-newgroups): Use it. * nnimap.el (nnimap-request-article-part): Less verbose. 2000-08-19 Andreas Jaeger * lpath.el ((string-match "XEmacs" emacs-version)): Remove subst-char-in-string since we test elsewhere whether it's bound. 2000-08-18 Dave Love * gnus-score.el (gnus-score-find-score-files-function): Fix doc, custom type. * gnus-xmas.el (gnus-group-icon-create-glyph): Don't test gnus-group-running-xemacs. * nnheader.el (nnheader-replace-chars-in-string): Use subst-char-in-string if available. * gnus-art.el (gnus-read-save-file-name, gnus-plain-save-name) (gnus-request-article-this-buffer): Use expand-file-name. (gnus-mime-view-part-as-type): Simplify interactive spec. (gnus-mime-button-map): Define it all in defvar. 2000-08-17 Dave Love * gnus-group.el (gnus-group-running-xemacs): Deleted. * gnus-demon.el (gnus-demon): Bind use-dialog-box and last-nonmenu-event. * uudecode.el (char-int): Use defalias, not fset. * score-mode.el: Don't require easymenu. Require mm-util. (score-mode-coding-system): Use mm-auto-save-coding-system. * nneething.el (nneething-create-mapping): Don't use cadar & al. (nneething-file-name): Use expand-file-name, not concat. 2000-08-16 13:05:46 ShengHuo ZHU * nnslashdot.el (nnslashdot-threaded-retrieve-headers): Failure proof for email addresses. (nnslashdot-sane-retrieve-headers): Ditto. 2000-08-14 20:08:40 Lars Magne Ingebrigtsen * message.el (message-send-mail): Only insert courtesy message when text/plain. 2000-08-14 19:55:04 Jesper Harder * message.el (message-cancel-news): Copy the From header from the original article. 2000-08-14 19:52:01 Lars Magne Ingebrigtsen * gnus-async.el (gnus-asynchronous): Removed. 2000-08-14 16:12:11 ShengHuo ZHU * mail-source.el (mail-source-fetch-maildir): Use MMDF mail format. 2000-08-14 19:12:22 Rod Whitby * nnmail.el (nnmail-expiry-target-group): Fixed. 2000-08-14 Rod Whitby * nnmail.el (nnmail-expiry-target-group): Fix the call to gnus-request-accept-article so that body encoding is *not* done. Encoding is not done on incoming mail, so why should it be done on expired mail? 2000-08-14 Rod Whitby * nnml.el (nnml-request-expire-articles): Fix the calls to nnml-request-article (the filename was being passed instead of the article number) and nnmail-expiry-target-group (nnml-current-directory is changed by nnml-request-accept-article, causing it to be incorrect for the next article to be expired). 2000-08-14 Rod Whitby * gnus-sum.el (gnus-summary-expire-articles): Fix the handling of expiry-target group parameters. 2000-08-13 18:53:08 Lars Magne Ingebrigtsen * gnus-topic.el (gnus-topic-select-group): Touch the dribble buffer. (gnus-topic-hide-topic): Take a PERMANENT parameter. (gnus-topic-show-topic): Ditto. * gnus-dup.el (gnus-dup-suppress-articles): Do auto-expiry. 2000-08-12 21:48:00 John H. Palmieri * mail-source.el (mail-source-incoming-file-prefix): New variable. 2000-08-12 20:29:53 Lars Magne Ingebrigtsen * gnus-start.el (gnus-check-first-time-used): Clean up a bit. * mailcap.el (mailcap-maybe-eval): Be even more warning. 2000-08-11 Florian Weimer * message.el (message-syntax-checks): New check quotin-style: Text must be written below quoted text. (message-check-news-body-syntax): Check it. 2000-08-11 Simon Josefsson * imap.el (imap-authenticator-alist): Fix typo. (imap-gssapi-open): Copy krb4 fixes for modern imtest's, thanks to Jonas Oberg for debugging. 2000-08-11 Simon Josefsson * gnus-async.el (gnus-asynchronous): Disable by default. 2000-08-10 20:22:09 Lars Magne Ingebrigtsen * mm-view.el (mm-inline-text): Bind fill-column. * nnvirtual.el (nnvirtual-request-expire-articles): Return the list of unexpired articles. * gnus-group.el (gnus-group-expire-articles-1): Return the list of un-expired articles. * gnus-sum.el (gnus-summary-reparent-thread): Narrow to the headers. * gnus-topic.el (gnus-topic-kill-group): Move up one line so that we update the right topic.. * mm-decode.el (mm-display-external): Put point at start. 2000-08-10 Kai Gro,A_(Bjohann * nnmail.el (nnmail-expiry-target): More explicit documentation. * gnus-cus.el (gnus-group-parameters): Add parameter `expiry-wait'. 2000-08-09 Simon Josefsson * imap.el (imap-parse-body): (imap-parse-string-list): Add bug workarounds for Stalker Communigate Pro 3.0 server. (imap-body-lines): Remove bogus comment. * imap.el (imap-range-to-message-set): Move from nnimap.el. * nnimap.el (nnimap-retrieve-which-headers): (nnimap-retrieve-headers-from-server): (nnimap-request-set-mark): (nnimap-request-expire-articles): Use `i-r-t-m-set' instead. 2000-08-08 00:53:41 ShengHuo ZHU * message.el (message-dont-reply-to-names): rmail-dont-reply-to-names may not be defined. 2000-08-07 09:37:01 ShengHuo ZHU * gnus-group.el (gnus-group-iterate): Uncompiled function should not use pop. 2000-07-19 Dave Love * gnus-ems.el: Defalias some dummy funcs to `ignore'. (gnus-x-splash): Use expand-file-name. Remove redundant facep check. (gnus-article-display-xface): Special-case for dark backgrounds. 2000-07-19 Kim-Minh Kaplan * imap.el (imap-calculate-literal-size-first): New variable. (imap-local-variables): Add it. (imap-kerberos4-open): Set it. (imap-send-command): Use it. 2000-07-17 14:18:16 ShengHuo ZHU * mailcap.el (mailcap-mimetypes-parsed-p): New variable. (mailcap-parse-mimetypes): Use it. (mailcap-extension-to-mime): Parse mimetype. (mailcap-mime-types): Ditto. * mml.el (mml-minibuffer-read-type): Ditto. 2000-07-16 18:25:07 ShengHuo ZHU * nndoc.el (nndoc-type-alist): Add outlook. (nndoc-outlook-type-p): New function. (nndoc-outlook-article-begin): Ditto. 2000-07-16 Daiki Ueno * gnus-sum.el (gnus-restore-hidden-threads-configuration): Save excursion. 2000-07-15 Simon Josefsson * gnus-cus.el (gnus-group-parameters, banner): Type is regexp. * imap.el (imap): (imap-kerberos4-program): (imap-gssapi-program): (imap-ssl-program): Customization. (imap-shell-program): (imap-shell-host): New variables. (imap-streams): (imap-stream-alist): Add shell. (imap-shell-p): (imap-shell-open): New functions. (imap-open): Don't call authenticator if preauth. (imap-authenticate): Return t if already authenticated. 2000-07-14 Simon Josefsson * gnus.el (gnus-invalid-group-regexp): New variable. (gnus-read-group): Use it. 2000-07-14 12:40:51 ShengHuo ZHU * gnus-agent.el (gnus-agent-fetch-group-1): mark-below, expunge-below and orphan-score are "group variables". 2000-07-13 Simon Josefsson * gnus-srvr.el (gnus-browse-read-group): Don't pass fully qualified group names to `gnus-group-read-ephemeral-group'. 2000-07-13 07:40:39 Katsumi Yamaoka * dgnushack.el (srcdir): Define it before use it. 2000-07-12 19:37:50 ShengHuo ZHU * gnus-sum.el: `W t' is toggle-header in info. 2000-07-12 16:50:06 ShengHuo ZHU * lpath.el: Fbind subst-char-in-string. 2000-07-12 15:48:29 ShengHuo ZHU * Makefile.in: Use W3DIR and lispdir. * dgnushack.el: Ditto. 2000-07-12 10:12:31 ShengHuo ZHU * gnus-art.el (article-de-base64-unreadable): Typo. 2000-07-12 Simon Josefsson * gnus-agent.el (require): Require timer. 2000-07-11 18:29:50 ShengHuo ZHU * message.el (message-bounce): Call mime-to-mml. 2000-07-11 18:00:49 Lars Magne Ingebrigtsen * nnslashdot.el (nnslashdot-request-close): New function. 2000-07-04 23:23:23 Lars Magne Ingebrigtsen * nnslashdot.el (nnslashdot-threaded-retrieve-headers): Get the right line number for the article. 2000-07-10 22:41:58 ShengHuo ZHU * nnslashdot.el (nnslashdot-threaded-retrieve-headers): Save point. * webmail.el (webmail-fetch): Bind url-http-silence-on-insecure-redirection. 2000-07-10 11:43:22 ShengHuo ZHU * nnslashdot.el (nnslashdot-threaded-retrieve-headers): Use unibyte. (nnslashdot-sane-retrieve-headers): Ditto. (nnslashdot-request-article): Ditto. 2000-07-10 11:12:32 William M. Perry * mailcap.el (mailcap-parse-mimetype-file): 2000-07-07 23:46:22 ShengHuo ZHU * nnweb.el (nnweb-insert): Stricter test. * webmail.el (webmail-refresh-redirect): Ditto. 2000-07-06 14:17:48 ShengHuo ZHU * mm-decode.el (mm-dissect-multipart): Match the EOL of boundary. 2000-07-05 21:19:22 ShengHuo ZHU * nnheader.el (nnheader-insert-nov): Remove EOLs of all fields. 2000-07-05 Dave Love * utf7.el: Doc and header fixes. * gnus-sum.el: Doc fixes. * gnus-util.el (gnus-point-at-eol, gnus-point-at-bol): Use defalias, not fset. * flow-fill.el (fill-flowed-point-at-eol) (fill-flowed-point-at-bol): Use defalias, not fset. * gnus-art.el: Don't alias article-mime-decode-quoted-printable. (gnus-Plain-save-name): Delete -- apparently bogus. 2000-07-03 00:12:26 Lars Magne Ingebrigtsen * nnsoup.el: Use expand-file-name throughout. 2000-07-03 00:07:51 Kjetil Torgrim Homme * nnmail.el (nnmail-read-incoming-hook): New example. 2000-07-02 23:17:23 Lars Magne Ingebrigtsen * mm-view.el (mm-inline-text): Check whether the text has already been decoded. 2000-07-04 15:17:05 ShengHuo ZHU * nnslashdot.el (nnslashdot-sid-strip): To strip or not to strip? 2000-07-03 Stainless Steel Rat * gnus-sum.el (gnus-recenter): Fix horizontal recenter. 2000-07-03 Simon Josefsson * gnus-sum.el (gnus-update-marks): Don't propagate download and unsend flags. 2000-07-03 Simon Josefsson * nnimap.el (nnimap-open-connection): Don't look up virtual server name in authinfo (.authinfo now support ports, no need for the hack). (nnimap-split-find-rule): Fix. (nnimap-open-connection): Look for nnimap-server-address in authinfo. 2000-07-03 Paul Stodghill * message.el (message-unquote-tokens): Remove all quotes. 2000-07-03 00:29:08 Julien Gilles * gnus-ml.el: New file. 2000-07-02 16:11:25 Lars Magne Ingebrigtsen * nnultimate.el (nnultimate-request-close): New function. * gnus-start.el (gnus-clear-system): Clear nnmail-split-history. 2000-06-18 Norbert Koch * Makefile.in: Better support for xemacs builds Sun Jul 2 15:11:35 2000 Lars Magne Ingebrigtsen * gnus.el: Gnus v5.8.7 is released. 2000-05-19 06:32:52 Lars Magne Ingebrigtsen * mm-decode.el (mm-insert-part): Characters doubly decoded. 2000-07-01 10:23:08 Shenghuo ZHU * message.el (message-do-fcc): Encode MIME. 2000-06-28 13:52:57 Shenghuo ZHU * lpath.el: Fbind image-size. 2000-06-28 Simon Josefsson * nnimap.el (nnimap-split-rule): Update doc with extended syntax. (nnimap-assoc-match): New function. (nnimap-split-find-rule): Support extended syntax. 2000-06-28 Simon Josefsson * nnimap.el (nnimap-open-connection): Use port stuff. * gnus-util.el (gnus-netrc-machine): Add defaultport parameter, document port and defaultport. 2000-06-27 Paul Stodghill * gnus-agent.el (gnus-agent-synchronize): Kill flags buffer. 2000-06-26 Dave Love * mm-decode.el (mm-image-fit-p): Use `image-size' in Emacs. * message.el: Remove unnecessary `require'ments. Defvar gnus-list-identifiers when compiling. Don't try to autoload variable `gnus-list-identifiers'. Autoload gnus-group-name-charset. (message-fetch-field): Don't assume `format' removes text properties. (message-strip-list-identifiers, message-reply, message-followup): Require gnus-sum. (message-mode): Tidy XEmacs conditionals. (message-replace-chars-in-string): Use subst-char-in-string when available. * gnus-xmas.el (gnus-xmas-define) : Define if necessary. * gnus-art.el (gnus-article-edit-exit): Don't assume `format' removes text properties. * gnus-srvr.el (gnus-browse-group-name): Likewise. * gnus-msg.el (gnus-copy-article-buffer): Likewise. * gnus-score.el (gnus-summary-score-entry): Likewise. 2000-06-26 11:18:57 Katsumi Yamaoka * nnimap.el (nnimap-request-post): Fix parenthesis. 2000-06-26 Paul Stodghill * message.el (message-unquote-tokens): New function. * gnus-msg.el (gnus-inews-do-gcc): Unquote gcc tokens. * nnimap.el (nnimap-request-post): Ditto. 2000-06-21 Simon Josefsson * gnus.el (gnus-asynchronous): Removed (defined in gnus-async.el). * nnimap.el (nnimap-callback): Update for IMAP4rev1 servers (see patch commited 2000-04-02). 2000-06-20 Simon Josefsson * imap.el (imap-mailbox-examine-1): New function. (imap-message-copyuid-1): (imap-message-appenduid-1): Use it, instead of `imap-mailbox-examine' which would utf-7 encode mailbox name twice. 2000-06-19 Dave Love * mm-uu.el Don't require message. Require cl when compiling. 2000-06-17 18:58:46 Shenghuo ZHU * gnus-sum.el (gnus-summary-local-variables): gnus-orphan-score is a local variable. * gnus-sum.el (gnus-orphan-score): Move here. 2000-06-10 09:33:36 Shenghuo ZHU * message.el (message-forward): Remove show-mml condition. (message-forward-ignored-headers): Remove X-Gnus headers. 2000-06-08 Simon Josefsson * gnus-cus.el (gnus-extra-group-parameters): Add uidvalidity. 2000-06-08 12:34:26 Urban Engberg * gnus-demon.el (gnus-demon-scan-mail): Bind nnmail-fetched-sources. 2000-06-08 12:27:55 Shenghuo ZHU * message.el (message-syntax-checks): Add type. 2000-06-07 Dave Love * mm-view.el (mm-inline-image-emacs): Don't specify string for put-image. (mm-inline-image): Defalias, not fset. * gnus.el (gnus-group-startup-message): Don't specify string for insert-image. * gnus-ems.el (gnus-add-minor-mode): Make it an alias if add-minor-mode is available. (gnus-article-display-xface): Don't specify string for insert-image. 2000-06-06 13:28:53 Shenghuo ZHU * gnus-topic.el (gnus-topic-remove-topic): Set hidden. (gnus-topic-insert-topic-line): Use shownp. (gnus-topic-hide-topic): Don't use hidden. (gnus-topic-show-topic): Don't use hidden. 2000-06-05 22:25:12 Shenghuo ZHU * gnus-cache.el (gnus-cache-possibly-enter-article): Bind coding system. * gnus-soup.el (gnus-soup-write-prefixes): Ditto. * gnus-start.el (gnus-slave-save-newsrc): Ditto. * gnus-util.el (gnus-output-to-rmail): Ditto. (gnus-output-to-mail): Ditto. (gnus-write-buffer): Ditto. * gnus-uu.el (gnus-uu-save-article): Ditto. 2000-06-04 15:05:16 Shenghuo ZHU * message.el (message-read-from-minibuffer): Typo. 2000-06-03 13:36:46 Shenghuo ZHU * gnus-art.el (article-decode-charset): Override non-MIME forward charset. 2000-06-02 12:04:26 Shenghuo ZHU * mml.el (mml-quote-region): Correct the regexp. * gnus-msg.el (gnus-summary-reply): mml-quote it. 2000-06-02 11:57:15 Shenghuo ZHU * message.el (message-forward): Insert raw text. * mml.el (mml-parse-1): Get raw text in unibyte mode. (mml-generate-mime-1): Insert raw text in unibyte mode. 2000-06-01 Florian Weimer * mm-bodies.el (mm-body-encoding): Always encoded if `mm-use-ultra-safe-encoding' is set. 2000-05-31 14:50:52 Shenghuo ZHU * mml.el (ange-ftp-name-format): Typo. 2000-05-30 Simon Josefsson * gnus-start.el (gnus-get-unread-articles): If `gnus-activate-group' and/or `gnus-check-server' return nil, don't try to do anything on that server. 2000-05-25 Simon Josefsson * gnus-group.el (gnus-group-nnimap-edit-acl): Help text updated from latest draft. 2000-05-08 Simon Josefsson * gnus-group.el (gnus-group-expire-articles-1): Make sure server is open. 2000-05-24 Dave Love * mml.el (mml-parse-file-name): Fix ange-ftp part. 2000-05-22 Didier Verna * gnus.el (gnus-redefine-select-method-widget): new function, call it once. Add an "other" entry for unknown but editable backend name symbols. * gnus-start.el (gnus-declare-backend): use it. 2000-05-19 Dave Love * gnus-art.el (gnus-article-next-page): Revert last change. 2000-05-19 09:56:07 Shenghuo ZHU * gnus-agent.el (gnus-agent-open-history): Open history in binary mode. 2000-05-19 Dave Love * gnus-art.el (gnus-mime-externalize-part): Bind mm-inlined-types, not mm-inline-large-images. 2000-05-19 01:45:40 Shenghuo ZHU * mml.el (mml-parse-1): Don't test multiple-charsets within mml tag. 2000-05-18 Dave Love * gnus-art.el: Use defalias, not fset. (gnus-article-x-face-command): Don't test for xbm. (gnus-article-next-page): Redisplay before testing point in window. 2000-05-17 21:16:54 Shenghuo ZHU * gnus-group.el (gnus-group-mode-map): Add M-SPACE. * mml.el (mml-mode-map): Comment out mml-narrow-to-part. 2000-05-17 21:13:38 Jim Davidson * gnus-sum.el (gnus-summary-save-article-rmail): Use gnus-summary-save-in-rmail. * message.el (message-output): Ditto. 2000-05-17 22:37:25 Katsumi Yamaoka * gnus-art.el (gnus-emphasize-whitespace-regexp): Doc fix. 2000-05-17 14:03:49 Shenghuo ZHU * rfc2047.el (rfc2047-encode-message-header): Encode if the method is a charset. * message.el (message-send-news): Check group name charset. * gnus-msg.el (gnus-post-news): Decode group name. (gnus-inews-do-gcc): Encode group name. 2000-05-17 10:16:32 Karl Kleinpaste * gnus-art.el (gnus-emphasize-whitespace-regexp): New variable. * gnus-util.el (gnus-put-text-property-excluding-newlines): Use it. 2000-05-17 02:25:11 Shenghuo ZHU * gnus-group.el (gnus-group-mark-line-p): New function. (gnus-group-goto-group): New parameter. (gnus-group-remove-mark): Use it. * gnus-topic.el (gnus-topic-move-group): Ditto. (gnus-topic-remove-group): Ditto. 2000-05-17 00:49:09 Shenghuo ZHU * gnus-group.el (gnus-group-list-dormant): New function. 2000-05-16 23:20:42 Shenghuo ZHU * gnus-agent.el (gnus-agent-synchronize): Use nnheader-insert-file-contents. (gnus-agent-save-active-1): Ditto. (gnus-agent-write-active): Ditto. (gnus-agent-expire): Ditto. * gnus-cache.el (gnus-cache-read-active): Ditto. * gnus-start.el (gnus-master-read-slave-newsrc): Ditto. * gnus-sum.el (gnus-summary-import-article): Ditto. * gnus-agent.el (gnus-agent-write-servers): Bind coding-system. (gnus-agent-save-group-info): Ditto. (gnus-agent-save-alist): Ditto. * gnus-util.el (gnus-make-directory): Ditto. * gnus-agent.el (gnus-agent-save-group-info): Disable multibyte. 2000-05-16 21:13:24 Shenghuo ZHU * mml.el (mml-generate-mime-preprocess-function): New variable. (mml-generate-mime-postprocess-function): New variable. (mml-generate-mime-1): Use them. 2000-05-16 18:15:24 Shenghuo ZHU * gnus-group.el (gnus-group-apropos): Group name charset. * gnus-sum.el (gnus-set-mode-line): Ditto. * gnus-group.el (gnus-group-decoded-name): New function. (gnus-group-edit-group): Use it. * gnus-cus.el (gnus-group-customize): Use it. 2000-05-16 17:55:57 Karl Kleinpaste * gnus-util.el (gnus-put-text-property-excluding-newlines): Improve. 2000-05-16 16:22:17 Shenghuo ZHU * gnus-group.el (gnus-group-name-charset-method-alist): New variable. (gnus-group-name-charset-group-alist): Ditto. (gnus-group-name-charset): New function. (gnus-group-name-decode): New function. (gnus-group-insert-group-line): Use them. (gnus-group-prepare-flat-list-dead): Ditto. (gnus-group-list-active): Ditto. (gnus-group-describe-all-groups): Ditto. (gnus-group-prepare-flat-list-dead-predicate): Ditto. * gnus-srvr.el: (gnus-browse-foreign-server): Decode group name and add gnus-group property. (gnus-browse-group-name): Read gnus-group property. 2000-05-16 15:27:08 Shenghuo ZHU * nnfolder.el (nnfolder-possibly-change-group): Use file-name-coding-system instead of pathname-coding-system. * nnmail.el (nnmail-find-file): Ditto. (nnmail-write-region): Ditto. * nnmh.el (nnmh-retrieve-headers): Ditto. (nnmh-request-article): Ditto. (nnmh-request-group): Ditto. (nnmh-request-list): Ditto. (nnmh-possibly-change-directory): Ditto. (nnmh-active-number): Ditto. * nnml.el (nnml-possibly-change-directory): Ditto. (nnml-request-list): Ditto. (nnml-request-article): Ditto. (nnml-retrieve-headers): Ditto. 2000-05-16 Simon Josefsson * nnimap.el (nnimap-request-accept-article): Don't unselect mailbox if no mailbox is selected. 2000-05-15 Per Abrahamsen * gnus-art.el (gnus-button-url-regexp): Revert earlier change. Recognize domain names starting with `www.' as starting an URL. 2000-05-15 09:46:47 Shenghuo ZHU * mail-source.el (mail-source-fetch-maildir): Insert "From ". (mail-source-keyword-map): Add "subdirs" for maildir. 2000-05-14 16:19:28 Shenghuo ZHU * nnmail.el (nnmail-scan-directory-mail-source-once): New variable. (nnmail-get-new-mail): Use it. * gnus-start.el (gnus-get-unread-articles): Ditto. 2000-05-14 14:02:12 Shenghuo ZHU * gnus-sum.el (gnus-summary-edit-article): Better support for nndraft:drafts. * nndraft.el (nndraft-request-replace-article): New function, bind nnmail-file-coding-system. 2000-05-14 Dave Love * nnheader.el: Replace uses of `fset' with `defalias'. (jka-compr-compression-info-list): Only defvar when compiling. 2000-05-14 12:30:28 Shenghuo ZHU * webmail.el (webmail-netaddress-article): Refresh redirect. 2000-05-13 20:41:10 Shenghuo ZHU * mm-view.el (mm-inline-text): w3 might not recognize utf-8. 2000-05-13 16:49:41 Shenghuo ZHU * webmail.el: Translate   to SP. 2000-05-13 13:00:17 Robin S. Socha * message.el (message-bounce): Doc typo. 2000-05-13 12:25:21 Shenghuo ZHU * gnus-soup.el (gnus-soup-encoding-type): u is USENET news format. (gnus-soup-store): Ditto. (gnus-soup-send-packet): Ditto. * nnsoup.el (nnsoup-replies-format-type): Ditto. (nnsoup-dissect-buffer): Ditto. (nnsoup-narrow-to-article): Ditto. (nnsoup-make-active): Ditto 2000-05-13 12:03:29 Shenghuo ZHU * message.el (message-mode): Two parameters for local-variable-p. 2000-05-13 00:54:46 Shenghuo ZHU * message.el (message-strip-list-identifiers): New function. (message-reply): Use it and use message-strip-subject-re. (message-followup): Ditto. * gnus-art.el (article-hide-list-identifiers): Remove more. * gnus-sum.el (gnus-summary-remove-list-identifiers): Ditto. 2000-05-12 22:28:54 Shenghuo ZHU * gnus-uu.el (gnus-uu-digest-mail-forward): Bind mail-parset-charset and use non-numeric argument. 2000-05-12 20:54:11 Shenghuo ZHU * mml.el (mml-buffer-list): New variable. (mml-generate-new-buffer): New function. (mml-destroy-buffers): Ditto. (mml-insert-mime): Use them. * gnus-msg.el (gnus-setup-message): mml-buffer leaks. * gnus-sum.el (gnus-summary-edit-article): Ditto. * message.el (message-mode): Ditto. * gnus-uu.el (gnus-uu-digest-headers): Keep MIME headers. (gnus-uu-save-article): Support show-as-mml. * message.el (message-forward): Ditto. 2000-05-12 15:15:55 Shenghuo ZHU * nndoc.el (nndoc-type-alist): mime-digest head-begin. (nndoc-mime-digest-type-p): Locate article head precisely. * mml.el (mml-generate-default-type): New variable. (mml-generate-mime-1): Use it. (mml-insert-mime-headers): Use it. * gnus-uu.el (gnus-uu-digest-buffer): New variable. (gnus-uu-digest-mail-forward): Use it and call message-forward with argument digest. (gnus-uu-save-article): Support message-forward-as-mime. * message.el (message-forward): Add parameter digest. * mm-decode.el (mm-dissect-default-type): New variable. (mm-dissect-buffer): Use it. 2000-05-11 11:08:03 Shenghuo ZHU * mml.el (mml-parse-singlepart-with-multiple-charsets): Set space, newline and paragraph to nil when got a non-ascii character. Test paragraph before newline. 2000-05-10 12:17:58 Shenghuo ZHU * qp.el (quoted-printable-encode-region): Bind tab-width to 1. Set limit to 76. 2000-05-10 09:11:48 Lars Magne Ingebrigtsen * nnslashdot.el (nnslashdot-sid-strip): New function. (nnslashdot-threaded-retrieve-headers): New format. (nnslashdot-sane-retrieve-headers): Ditto. (nnslashdot-request-article): Ditto. (nnslashdot-threaded-retrieve-headers): Thread properly. (nnslashdot-request-article): Be more lenient. (nnslashdot-threaded-retrieve-headers): Regexp search. 2000-05-09 13:23:50 Shenghuo ZHU * gnus-sum.el (gnus-with-article): Define it before use it. 2000-05-08 22:34:19 Shenghuo ZHU * message.el (message-supersede): Use mime-to-mml. * mm-decode.el (mm-insert-part): Test the buffer if no encoding. 2000-05-08 22:34:24 Katsumi Yamaoka * gnus-group.el (gnus-group-list-cached): Don't use `subst-char-in-string'. 2000-05-08 Dave Love * pop3.el (pop3-open-server): Fix creating name of trace buffer. 2000-05-08 01:07:47 Shenghuo ZHU * mm-decode.el (mm-interactively-view-part): Append %s if the method is a single word. * nnwarchive.el (nnwarchive-type-definition): Typo. 2000-05-07 17:24:01 Shenghuo ZHU * gnus-group.el (gnus-group-prepare-flat-list-dead-predicate): New function. (gnus-group-prepare-flat-predicate): Use it. (gnus-group-list-cached): List dead groups. 2000-05-07 10:50:02 Shenghuo ZHU * gnus-art.el (article-decode-charset): Don't decode message with format. 2000-05-07 Florian Weimer * mailcap.el (mailcap-maybe-eval): Honor user request not to evaluate the Lisp code. 2000-05-06 17:40:20 Shenghuo ZHU * gnus-art.el (article-wash-html): New function. (gnus-article-wash-html): Bind. (gnus-article-make-menu-bar): Menu item. * gnus-sum.el (gnus-summary-wash-map): Bind 'h'. (gnus-summary-make-menu-bar): Menu item. * gnus.el: Autoload. 2000-05-06 Florian Weimer * gnus-uu.el (gnus-uu-unshar-warning): New variable. (gnus-uu-unshar-article): Use it. * mailcap.el (mailcap-maybe-eval-warning): New variable. (mailcap-maybe-eval): Use it. * gnus-msg.el (gnus-group-posting-charset-alist): Speling mistake in docstring. * mml.el (mml-generate-mime-1): Small comment. 2000-05-05 12:27:53 Shenghuo ZHU * gnus-art.el (article-de-base64-unreadable): New function. (gnus-article-de-base64-unreadable): Bind. (gnus-article-make-menu-bar): Menu item. * gnus-sum.el (gnus-summary-wash-map): Bind '6' and 'Z'. (gnus-summary-make-menu-bar): Menu item. * gnus.el: Autoload. 2000-05-05 10:32:27 Shenghuo ZHU * gnus-sum.el (gnus-summary-show-article): Remove en/disable multibyte. (gnus-summary-select-article): Add en/disable multibyte. 2000-05-05 02:47:23 Shenghuo ZHU * gnus-sum.el (gnus-summary-edit-article): Enable multibyte. (gnus-summary-edit-article): New feature: editing raw articles. 2000-05-05 00:30:12 Shenghuo ZHU * rfc2047.el (rfc2047-encode-region): Insert a space before encoding. Emacs MULE can not encode adjacent iso-2022-jp and cn-gb-2312. * gnus-msg.el (gnus-summary-mail-forward): Use unibyte buffer. Emacs MULE can not copy some 8bit characters in multibyte buffers. * mm-decode.el (mm-insert-part): Ditto. 2000-05-04 17:49:04 Shenghuo ZHU * nndoc.el (nndoc-type-alist): Extend forward regexp. (nndoc-forward-type-p): Ditto. 2000-05-04 17:13:04 Shenghuo ZHU * mm-util.el (mm-with-unibyte-current-buffer): Set the default value of enable-multibyte-characters. 2000-05-04 10:31:24 Shenghuo ZHU * gnus-sum.el (gnus-summary-show-article): En/disable multibyte. 2000-05-03 Dave Love * gnus-ems.el (gnus-article-xface-ring-internal) (gnus-article-xface-ring-size): New variable. (gnus-article-display-xface): Use them to cache data. Don't try to use XPM. Set up binary coding for PBM's sake. 2000-05-03 14:23:38 Shenghuo ZHU * gnus-msg.el (gnus-inews-do-gcc): Set mail-parse-charset. * gnus-int.el (gnus-request-accept-article): Ditto. (gnus-request-replace-article): Ditto. * mm-util.el (mm-mime-mule-charset-alist): Add a fake mule-charset. 2000-05-03 14:11:23 Shenghuo ZHU * rfc2047.el (rfc2047-encode): Test the validity of coding-system. 2000-05-03 11:35:15 Shenghuo ZHU * rfc2047.el (rfc2047-encode-message-header): Encode field by field. * mml.el (mml-to-mime): Use message-default-charset. (mml-preview): Narrow to headers. * message.el (message-send-mail): Use message-default-charset. (message-send-news): Narrow to headers; use message-default-charset. 2000-05-03 08:09:14 Shenghuo ZHU * mm-bodies.el (mm-decode-content-transfer-encoding): A better junk detect. * mml.el (mml-parse-singlepart-with-multiple-charsets): Save restriction. (mml-parse-1): Warning message. (mml-preview): Disable multibyte. 2000-05-03 Dave Love * gnus.el (gnus-group-startup-message): Add newline before image. 2000-05-02 21:34:10 Shenghuo ZHU * rfc2047.el (rfc2047-encode-message-header): Check the coding-system. * message.el (message-send-mail): Use unibyte-buffer. (message-send-mail): Ditto. Mon May 1 15:09:46 2000 Lars Magne Ingebrigtsen * gnus.el: Gnus v5.8.6 is released. 2000-05-01 07:45:43 Shenghuo ZHU * mml.el (mml-parse-1): Set no-markup-p and warn to nil. 2000-04-28 21:14:21 Shenghuo ZHU * rfc2047.el (rfc2047-q-encoding-alist): Encode HTAB. 2000-04-28 16:37:09 Shenghuo ZHU * message.el (message-send-mail-partially): Use forward-line. 2000-04-28 16:01:09 Shenghuo ZHU * gnus-art.el (gnus-mime-button-menu): Use call-interactively. 2000-04-28 15:30:17 Shenghuo ZHU * mml.el (mml-generate-mime-1): Ignore 0x1b. (mml-insert-mime): No markup only for text/plain. (mime-to-mml): Remove MIME headers. 2000-04-28 14:23:14 Shenghuo ZHU * mml.el (mml-preview): Set gnus-newsgroup-charset. * rfc2047.el (rfc2047-encode-message-header): Encode non-ascii as 8-bit. * lpath.el: Fbind image functions. 2000-04-28 Dave Love * gnus.el (gnus-group-startup-message): Maybe use image in Emacs 21. * mailcap.el (mailcap-parse-mailcaps): Revert last change to search order. Use parse-colon-path and remove some redundancy. Doc fix. (mailcap-parse-mimetypes): Code consistently with mailcap-parse-mailcaps. Doc fix. * gnus-start.el (gnus-unload): Iterate over `features', not `load-history'. 2000-04-28 09:52:21 Shenghuo ZHU * mml.el (mml-parse-1): Don't create blank parts. (mml-read-part): Fix mml tag. (mml-insert-mime): Convert message/rfc822. (mml-insert-mml-markup): Add mmlp parameter. 2000-04-28 01:16:10 Shenghuo ZHU * message.el (message-send-mail-partially): Remove CTE. 2000-04-28 00:31:53 Shenghuo ZHU * lpath.el: Fbind put-image for XEmacs. * mm-view.el (mm-inline-image): Fset it. 2000-04-27 23:23:37 Shenghuo ZHU * nndoc.el (nndoc-type-alist): Change forward regexp. 2000-04-27 21:57:10 Shenghuo ZHU * message.el (message-send-mail-partially-limit): Change the default value. 2000-04-27 21:53:32 Erik Toubro Nielsen * gnus-util.el (gnus-extract-address-components): Name might be "". 2000-04-27 20:32:06 Shenghuo ZHU * gnus-msg.el (gnus-summary-mail-forward): Use ARG. (gnus-summary-post-forward): Ditto. * message.el (message-forward-show-mml): New variable. (message-forward): Use it. * mml.el (mml-parse-1): Add tag mml. (mml-read-part): Ditto. (mml-generate-mime): Support reentance. (mml-generate-mime-1): Support mml tag. 2000-04-27 Dave Love * gnus-art.el: Don't bother to require custom, browse-url. (gnus-article-x-face-command): Include gnus-article-display-xface. * gnus-ems.el: Assume only (X)Emacs 20+. Simplify XEmacs checks. Use defalias, not fset. (gnus-article-display-xface): New function. * mm-view.el (mm-inline-image-emacs): Use put-image, remove-images. * mm-decode.el: Small doc fixes. Require cl when compiling. (mm-xemacs-p): Deleted. (mm-get-image-emacs, mm-get-image-xemacs): Deleted. (mm-get-image): Amalgamate Emacs and XEmacs code here; for Emacs, use create-image and don't special-case xbm. (mm-valid-image-format-p): Use display-graphic-p. 2000-04-27 15:27:54 Shenghuo ZHU * message.el (message-send-mail-partially-limit): New variable. (message-send-mail-partially): New function. (message-send-mail): Use it. * mm-bodies.el (mm-decode-content-transfer-encoding): Remove all blank lines inside of base64. * mm-partial.el (mm-inline-partial): Add an option. Remove tail blank lines. 2000-04-27 10:03:36 Shenghuo ZHU * mml.el (mml-insert-tag): Match more special characters. 2000-04-27 09:06:29 Shenghuo ZHU * gnus-msg.el (gnus-bug): Avoid attaching the external buffer. 2000-04-27 00:58:43 Shenghuo ZHU * mm-decode.el (mm-inline-media-tests): Add message/partial. (mm-inlined-types): Ditto. * mm-partial.el: New file. 2000-04-27 Dave Love * mailcap.el (mailcap-mime-data): Fix octet-stream syntax -- might matter in Emacs 21. 2000-04-26 Florian Weimer * mm-bodies.el (mm-encode-body): Remove reference to mm-default-charset in comment. 2000-04-24 00:56:00 Bj,Av(Brn Torkelsson * rfc2047.el (rfc2047-encode-message-header): Fixing typo. 2000-04-26 12:27:41 Shenghuo ZHU * gnus-draft.el (gnus-draft-send): Move gnus-draft-setup inside of let. 2000-04-26 12:26:10 Pavel Janik ml. * gnus-draft.el (gnus-draft-setup): Fix comments. 2000-04-26 10:06:12 Shenghuo ZHU * nnmbox.el (nnmbox-create-mbox): Use nnmbox-file-coding-system, if nnmbox-file-coding-system-for-write is nil. 2000-04-26 02:17:44 Shenghuo ZHU * gnus-msg.el (gnus-configure-posting-styles): Just remove the header if nil. 2000-04-26 00:23:46 Shenghuo ZHU * mm-view.el (mm-inline-text): Insert directly if decoded. * mml.el (autoload): Typo. 2000-04-25 22:46:36 Shenghuo ZHU * mml.el (mml-preview): Set up posting-charset. * gnus-msg.el (gnus-group-posting-charset-alist): Add koi8-r. 2000-04-25 21:23:54 Shenghuo ZHU * webmail.el: Fix yahoo mail. 2000-04-25 20:12:17 Shenghuo ZHU * rfc2047.el (rfc2047-dissect-region): Don't include LWS ahead of word if not necessary. (rfc2047-encode-region): Put space between encoded words. 2000-04-24 21:11:48 Shenghuo ZHU * gnus-util.el (gnus-netrc-machine): Another default to nntp. 2000-04-24 18:14:12 Shenghuo ZHU * gnus-draft.el (gnus-draft-setup): Restore mml only when required. (gnus-draft-edit-message): Require restoration. 2000-04-24 16:51:04 Shenghuo ZHU * gnus-score.el (gnus-score-headers): Copy gnus-newsgrou-scored back. 2000-04-24 16:01:15 Shenghuo ZHU * gnus-art.el (gnus-treat-article): Make sure that the summary buffer is live. 2000-04-24 15:42:53 Shenghuo ZHU * mailcap.el (mailcap-parse-mailcaps): Reorder. (mailcap-parse-mailcap): Backwards parsing. (mailcap-possible-viewers): Remove nreverse. (mailcap-mime-info): Ditto. (mailcap-add-mailcap-entry): Keep alternative viewer. Mon Apr 24 21:12:06 2000 Lars Magne Ingebrigtsen * gnus.el: Gnus v5.8.5 is released. 2000-04-24 16:29:07 Lars Magne Ingebrigtsen * rfc2047.el (rfc2047-header-encoding-alist): Doc fix. * gnus-util.el (gnus-netrc-machine): Default to nntp. * mml.el (mml-generate-mime-1): Force 8bit on message/rfc822. 2000-04-23 23:27:25 Shenghuo ZHU * mm-view.el (mm-inline-message): Disable prepare-hook. 2000-04-23 00:32:32 Lars Magne Ingebrigtsen * gnus.el: Fix copyright statements. * gnus-sum.el (gnus-alter-articles-to-read-function): New variable. (gnus-articles-to-read): Use it. * message.el (message-get-reply-headers): Bind free variable. 2000-04-23 01:14:28 Shenghuo ZHU * message.el (message-get-reply-headers): Fix to-address. 2000-04-22 22:51:46 Shenghuo ZHU * webmail.el: Hotmail fix. Add a debug function. 2000-04-23 00:32:32 Lars Magne Ingebrigtsen * gnus-sum.el (t): M-down and M-up. 2000-04-22 20:22:03 Kai Gro,A_(Bjohann * gnus-sum.el: Doc fix. 2000-04-22 10:25:56 Shenghuo ZHU * nnwarchive.el (nnwarchive-egroups-article): Remove < and >. 2000-04-22 14:25:05 Lars Magne Ingebrigtsen * nnweb.el (nnweb-dejanews-create-mapping): Remove the context string. (nnweb-request-group): Don't scan twice. (nnweb-request-scan): Don't nix out the hashtb. * message.el (message-get-reply-headers): Return a value. 2000-04-22 14:12:41 David Aspinwall * gnus-art.el (gnus-button-url-regexp): New value to match naked urls. 2000-04-22 01:23:59 Lars Magne Ingebrigtsen * gnus-cache.el (gnus-summary-insert-cached-articles): Reverse the order messages are inserted. * mml.el (mml-generate-mime-1): rfc2047-encode the heads of message/rfc822 parts. * gnus-art.el (gnus-article-read-summary-keys): Check for numerical values. * message.el (message-get-headers): Made into own function. (message-reply): Use it. (message-get-reply-headers): Renamed. (message-widen-reply): New command. 2000-04-21 20:52:09 Shenghuo ZHU * nntp.el (nntp-retrieve-data): Report the error and return nil. 2000-04-21 19:38:43 Shenghuo ZHU * mm-bodies.el (mm-decode-content-transfer-encoding): Don't remove non-base64 text at the end if not found. 2000-03-01 Simon Josefsson * gnus-sum.el (gnus-read-move-group-name): (gnus-summary-move-article): Use `gnus-group-method' to find out what method the manually entered group belong to. `gnus-group-name-to-method' doesn't return any method parameters and `gnus-find-method-for-group' uses `gnus-group-name-to-method' for new groups so they wouldn't work. 2000-04-21 22:27:15 Lars Magne Ingebrigtsen * gnus-msg.el (gnus-configure-posting-styles): Allow nil values to override. 2000-04-21 21:58:20 Kai Gro,A_(Bjohann * nnmail.el (nnmail-cache-insert): Does some stuff that is probably good to do, or something. I dunno. I just write these ChangeLog entries, and my name is Lars. 1999-12-06 Hrvoje Niksic * message.el (message-caesar-region): Use translate-region. 2000-04-21 21:20:32 Mike Fabian * gnus-group.el (gnus-group-catchup-current): Doc fix. 2000-04-21 20:36:21 Lars Magne Ingebrigtsen * gnus-art.el (gnus-article-setup-buffer): Don't kill local variables, because that makes Emacs flash. * gnus-group.el (gnus-group-insert-group-line): Don't call gnus-group-add-icon unconditionally. * gnus-xmas.el (gnus-group-add-icon): Moved here. * gnus-group.el (gnus-group-glyph-directory): Don't depend on xmas. (gnus-group-glyph-directory): Removed. 2000-04-21 20:26:23 Jaap-Henk Hoepman * gnus-msg.el (gnus-inews-insert-archive-gcc): Don't do stuff if gnus-newsgroup-name is "". 2000-04-21 Florian Weimer * mm-util.el (mm-mime-mule-charset-alist): Add support for UTF-8 in conjunction with MULE-UCS. 1999-12-13 Per Abrahamsen * rfc2047.el (rfc2047-fold-region): Don't use the same break twice. 1999-12-14 04:14:44 Katsumi Yamaoka * dgnushack.el (last, mapcon, member-if, union): New compiler macros for emulating cl functions. 1999-12-21 Jan Vroonhof * message.el (message-shorten-references): Only cater to broken INN for news. This caters for broken smtpd. 2000-04-21 18:20:10 Lars Magne Ingebrigtsen * mailcap.el (mailcap-mime-info): Use the first match; not the last. * gnus-agent.el (gnus-category-kill): Save the category list. 2000-04-21 16:41:50 Chris Brierley * gnus-sum.el (gnus-summary-move-article): Do something or other. 2000-04-21 16:07:07 Lars Magne Ingebrigtsen * gnus-group.el (gnus-group-add-icon): Fixed indentation. 2000-04-21 16:07:07 Lars Magne Ingebrigtsen * gnus-group.el (gnus-group-add-icon): Fixed indentation. 2000-04-21 10:43:16 Shenghuo ZHU * gnus-group.el (gnus-group-prepare-flat-predicate): New function. (gnus-group-list-cached): Use it. 2000-04-21 16:07:07 Lars Magne Ingebrigtsen * gnus.el: Update all the copyright notices. 2000-04-21 15:38:06 Vladimir Volovich * mm-bodies.el (mm-decode-content-transfer-encoding): Remove non-base64 text at the end. 2000-04-21 15:21:30 Katsumi Yamaoka * mm-bodies.el (mm-body-charset-encoding-alist): defcustomized. 2000-04-21 15:15:41 Lars Magne Ingebrigtsen * nnheader.el: Don't autoload cancel-function-timers. * message.el (message-fetch-field): Fold case. 2000-04-21 15:11:09 * message.el (message-forward-before-signature): New variable. 2000-04-21 15:10:31 Alexandre Oliva * gnus-mlspl.el: Fix stuff. 2000-04-21 14:41:09 Lars Magne Ingebrigtsen * gnus-sum.el (gnus-summary-update-article-line): Don't hide subjects when unthreaded. 2000-04-21 14:11:39 David S. Goldberg * gnus-art.el (gnus-boring-article-headers): Work on long CCs as well. 2000-04-21 14:06:43 Rui Zhu * gnus-art.el (gnus-article-mode): Fix variable name. 2000-04-21 13:54:51 Lars Magne Ingebrigtsen * mm-view.el: Fix autoload. * flow-fill.el (flow-fill): Fix provide. * gnus-draft.el (gnus-draft-send): Bind message-setup-hook to nil. 2000-04-20 22:24:04 Shenghuo ZHU * gnus-win.el (gnus-configure-windows): Revert to switch-to-buffer. 2000-04-21 05:22:18 Katsumi Yamaoka * gnus-util.el (gnus-netrc-machine): Didn't work. 2000-04-20 21:22:10 Shenghuo ZHU * gnus-draft.el (gnus-draft-setup): Restore to mml. 2000-04-21 01:24:41 Lars Magne Ingebrigtsen * flow-fill.el: Renamed from fill-flowed. * message.el (message-forward-ignored-headers): Default to removing CTE. 2000-04-21 00:48:48 * message.el (message-mode): Don't fill headers. 2000-04-20 23:12:43 Lars Magne Ingebrigtsen * message.el (message-pipe-buffer-body): Use shell 2000-02-21 Yoshiki Hayashi * nnvirtual.el (nnvirtual-request-article): Bind gnus-override-method to nil. (nnvirtual-request-update-mark): Don't update mark when article is not there. 2000-04-20 16:35:41 Shenghuo ZHU * mm-uu.el (mm-uu-dissect): Check forwarded message. 2000-04-20 21:17:48 Lars Magne Ingebrigtsen * gnus-util.el (gnus-parse-netrc): Allow "port". (gnus-netrc-machine): Take a port param. (gnus-netrc-machine): * gnus-art.el (gnus-request-article-this-buffer): Allow re-selecting referenced articles. * message.el (message-cancel-news): Allow editing. (message-cancel-message): Add newline. 2000-04-20 21:03:54 William M. Perry * mm-view.el (mm-inline-image-emacs): New function. 2000-04-20 20:44:55 Lars Magne Ingebrigtsen * mail-source.el (mail-source-delete-incoming): Change default in cvs. 2000-04-20 20:43:34 Kim-Minh Kaplan * gnus-art.el (gnus-mime-view-part-as-type-internal): New function. 2000-04-20 14:45:20 Lars Magne Ingebrigtsen * nnml.el (nnml-request-expire-articles): Use it. * nnmail.el (nnmail-expiry-target): New variable. (nnmail-expiry-target-group): New function. 2000-04-20 02:36:31 Emerick Rogul * message.el (message-forward): Add non-MIME separators. 2000-04-20 02:25:39 Lars Magne Ingebrigtsen * message.el (message-generate-headers): Respect the syntax check spec. * gnus-sum.el (gnus-remove-thread-1): Show thread. (gnus-remove-thread): Don't show all threads. Thu Apr 20 01:39:25 2000 Lars Magne Ingebrigtsen * gnus.el: Pterodactyl Gnus v5.8.4 is released. 2000-04-19 Dave Love * mailcap.el (mailcap-parse-mimetypes): Add ...mime.types. 2000-04-18 12:28:24 Shenghuo ZHU * nnwarchive.el (nnwarchive-type-definition): New egroups html. (nnwarchive-egroups-*): Ditto. (nnwarchive-url): Unibyte buffer and single line cookie. 2000-04-14 18:50:04 Shenghuo ZHU * mm-util.el (mm-char-or-char-int-p): New alias. * nnweb.el (nnweb-decode-entities): Check the validity of numeric entities. 2000-04-10 Daiki Ueno * lisp/imap.el (imap-body-lines): Check Content-Type: of the article case insensitively. 2000-04-10 20:35:46 Shenghuo ZHU * mail-source.el (mail-source-fetch-webmail): Use the default password provided in mail-sources; use webmail:subtype:user as the key. 2000-04-10 20:35:46 John Wiegley * mail-source.el (mail-source-fetch-webmail): Use mail-source-password-cache. 2000-04-09 18:13:47 Shenghuo ZHU * webmail.el: Add netscape mail and fix HotMail mail. 2000-04-08 Simon Josefsson * imap.el (imap-kerberos4-open): Work with recent `imtest's. 2000-04-02 Simon Josefsson * nnimap.el (nnimap-request-article): Use BODY.PEEK[] instead of RFC822.PEEK if server support IMAP4rev1. (nnimap-request-body): Use BODY.PEEK[TEXT] instead of RFC822.TEXT.PEEK if server support IMAP4rev1. (nnimap-request-head): Use BODY.PEEK[HEADER] instead of RFC822.HEADER if server support IMAP4rev1. (nnimap-request-article-part): Support bodydetail in response data. 2000-03-11 Simon Josefsson * fill-flowed.el: New file. * mm-decode.el (mm-dissect-singlepart): Create a MIME handle for text/plain parts with `format' parameters. * mm-view.el (autoload): Autoload fill-flowed. (mm-inline-text): For "plain" parts with a format=flowed parameter, call `fill-flowed'. 2000-03-21 10:32:44 Lars Magne Ingebrigtsen * nnslashdot.el (nnslashdot-request-list): Fudge new-style slashdot ids. 2000-03-20 00:12:42 Lars Magne Ingebrigtsen * nnslashdot.el (nnslashdot-request-list): Use the new slashdot format. 2000-03-16 Simon Josefsson * imap.el: GSSAPI support, support kerberos 4 with Cyrus v1.6.x `imtest' too. (imap-kerberos4-program): Renamed from `imap-imtest-program'. (imap-gssapi-program): New variable. (imap-streams): Add gssapi. (imap-stream-alist): Ditto. (imap-authenticators): Ditto. (imap-authenticator-alist): Ditto. (imap-kerberos4-stream-p): Rename from `imap-kerberos4s-p'. (imap-kerberos4-open): Loop over imtest programs, support Cyrus 1.6.x `imtest' syntax. (imap-gssapi-stream-p): New function. (imap-gssapi-open): Ditto. (imap-gssapi-auth-p): Ditto. (imap-gssapi-auth): Ditto. (imap-kerberos4-auth-p): Renamed from `imap-kerberos4a-p'. (imap-send-command): Use buffer-local `imap-client-eol' value. * nnimap.el (nnimap-retrieve-headers-progress): Fold continuation lines and turn TAB into SPC before parsing. 2000-03-15 Simon Josefsson * nnheader.el (nnheader-group-pathname): Make sure to return a directory. * nnmail.el (nnmail-group-pathname): Ditto. 2000-02-08 Per Abrahamsen * nnmail.el (nnmail-fix-eudora-headers): Fix `In-Reply-To' too, it might split in the middle of a message-id. 2000-03-13 13:51:38 Lars Magne Ingebrigtsen * gnus-srvr.el (gnus-server-kill-server): Offer to kill all the groups from the server. * gnus-sum.el (gnus-summary-save-parts): Fix interactive spec. (gnus-summary-toggle-header): Update the wash status. * gnus-uu.el ((gnus-uu-extract-map "X" gnus-summary-mode-map)): Moved here. * gnus-agent.el (gnus-agent-save-group-info): Respect old setting. * nnmail.el (nnmail-get-active): Use it. (nnmail-parse-active): New function. * mm-view.el (mm-inline-text): Support the new version of vcard.el. * gnus-sum.el (gnus-summary-move-article): Only delete article when moving junk. (gnus-deaden-summary): Bury the buffer. * nnmail.el (nnmail-group-pathname): Ditto. * nnheader.el (nnheader-group-pathname): Use expand-file-name. 2000-03-13 20:23:06 Christoph Rohland * rfc2047.el (rfc2047-encode-message-header): Encode no matter whether Mule. 2000-03-10 14:57:58 Lars Magne Ingebrigtsen * message.el (message-send-mail): Protect against unloaded Gnus. * gnus-topic.el (gnus-topic-update-topic-line): Don't update the parent. (gnus-topic-update-topic-line): Yes, do. (gnus-topic-goto-missing-group): Tally the correct number of unread articles before inserting the topic line. 2000-03-01 09:55:26 Lars Magne Ingebrigtsen * nnultimate.el (nnultimate-retrieve-headers): Ignore errors. 2000-02-13 13:53:08 Lars Magne Ingebrigtsen * mm-decode.el (mm-dissect-buffer): Ditto. * gnus-art.el (article-decode-charset): Strip CTE. * ietf-drums.el (ietf-drums-strip): New function. * gnus-sum.el (gnus-summary-move-article): Don't use the prefix when prompting in read-only groups. 2000-02-23 Simon Josefsson * imap.el (imap-send-command): Change EOL-chars when `imap-client-eol' differs from default, not only for kerberos4. (imap-mailbox-status): Get encoded mailbox's status. 2000-02-19 Simon Josefsson * mail-source.el (mail-source-fetch-imap): Copy `imap-password' into `mail-source-password-cache'. 2000-02-17 Florian Weimer * mm-util.el (mm-mime-charset): Check for presence of `coding-system-get' and `get-charset-property' (recent XEmacs has the former, but not the latter). 2000-01-28 Dave Love * message.el (message-check-news-header-syntax): Fix typo `newsgroyps'. (message-talkative-question): Put temp buffer in fundamental-mode. (message-recover): Use fundamental-mode in the right buffer. * nnmail.el (nnmail-split-history): Use fundamental-mode in the right buffer. 2000-01-26 12:01:18 Shenghuo ZHU * qp.el (quoted-printable-decode-region): Add charset parameter. (quoted-printable-decode-string): Ditto. * gnus-art.el (article-de-quoted-unreadable): Use it. 2000-01-21 Simon Josefsson * nnimap.el (nnimap-split-predicate): New variable. (nnimap-split-articles): Use it. 2000-01-20 Simon Josefsson * utf7.el: Change email address. 2000-01-18 22:03:51 Lars Magne Ingebrigtsen * gnus-group.el (gnus-group-catchup): Purge split history. 2000-01-14 02:43:55 Shenghuo ZHU * nnmail.el (nnmail-generate-active): Support extended group name. (nnmail-get-active): Ditto. 2000-01-13 15:16:10 Shenghuo ZHU * gnus-agent.el (gnus-agent-write-active): Since no prefix in group names, don't remove anything. 2000-01-13 15:10:53 Shenghuo ZHU * webmail.el (webmail-my-deja-open): My-deja changes. 2000-01-13 Simon Josefsson * nnimap.el (nnimap-retrieve-headers-progress): Create xref field. 2000-01-10 23:35:33 Shenghuo ZHU * gnus-agent.el (gnus-agent-fetch-headers): Translate full path. 2000-01-09 22:52:35 Shenghuo ZHU * gnus.el (gnus-other-frame): Fix typo. 1999-06-25 Andreas Jaeger * gnus-cus.el (gnus-group-customize): Fix typo. 2000-01-08 08:36:13 Lars Magne Ingebrigtsen * nnweb.el (nnweb-insert): Simplified. 2000-01-06 18:32:53 Lars Magne Ingebrigtsen * gnus-art.el (gnus-article-mode-map): "e" is gnus-summary-edit-article. 2000-01-06 18:25:37 Jari Aalto * mailcap.el (mailcap-mime-extensions): Add .diff. 2000-01-06 00:06:40 Kim-Minh Kaplan * mm-decode.el (mm-mailcap-command): handle "%%" and the case where there is no "%s" in the method. 2000-01-08 21:01:04 Kim-Minh Kaplan * gnus-sum.el (gnus-summary-select-article): Return 'old. 2000-01-06 13:41:11 Lars Magne Ingebrigtsen * nnfolder.el (nnfolder-read-folder): Use nnfolder-save-buffer. * gnus.el: Really always pop up a new frame. * parse-time.el (parse-time-rules): Allow 100-110 to be 2000-2010. * time-date.el (date-to-time): Don't use timezone. 2000-01-06 Dave Love * time-date.el: Add keywords. (date-to-time): Add autoload cookie. Canonicalize with timezone-make-date-arpa-standard. (time-to-seconds): Avoid caddr. (safe-date-to-time): Add autoload cookie. * base64.el: Require cl when compiling. 2000-01-05 BrYan P. Johnson * gnus-group.el (gnus-group-line-format-alist): Added %E for eyecandy. (gnus-group-insert-group-line): Now groks %E and inserts icon in group line using gnus-group-add-icon. (gnus-group-icons): Added customize group. (gnus-group-icon-list): Added variable. (gnus-group-glyph-directory): Added variable. (gnus-group-icon-cache): Added variable. (gnus-group-running-xemacs): Added variable. (gnus-group-add-icon): Added function. Add an icon to the current line according to gnus-group-icon-list. (gnus-group-icon-create-glyph): Added function. 2000-01-05 17:31:52 Lars Magne Ingebrigtsen * gnus-sum.el (gnus-summary-select-article): Return whether we selected something new. (gnus-summary-search-article): Start searching at the window point. * gnus-group.el (gnus-fetch-group): Complete over gnus-active-hashtb. Wed Jan 5 17:06:41 2000 Lars Magne Ingebrigtsen * gnus.el: Pterodactyl Gnus v5.8.3 is released. 2000-01-05 15:56:02 Lars Magne Ingebrigtsen * gnus-sum.el (gnus-preserve-marks): New variable. (gnus-summary-move-article): Use it. (gnus-group-charset-alist): Added more entries. 2000-01-03 01:18:36 Lars Magne Ingebrigtsen * mm-decode.el (mm-inline-override-types): Removed duplicate. * gnus-uu.el (gnus-uu-mark-over): Use gnus-summary-default-score as the default score. * gnus-score.el (gnus-score-delta-default): Changed name. 2000-01-04 Simon Josefsson * imap.el (imap-parse-literal): (imap-parse-flag-list): Don't care about props. (imap-parse-string): Handle quoted characters. 2000-01-02 08:37:03 Lars Magne Ingebrigtsen * gnus-sum.el (gnus-summary-goto-unread): Doc fix. (gnus-summary-mark-article): Doc fix. (gnus-summary-mark-forward): Doc fix. (t): Changed keystroke for gnus-summary-customize-parameters. * gnus-art.el (gnus-article-mode-map): Use gnus-article-edit for "e". (gnus-article-mode-map): No, don't. * gnus-sum.el (gnus-summary-next-subject): Don't show the thread of the final article. * mm-decode.el (mm-interactively-view-part): Error on no method. 2000-01-02 06:10:32 Stefan Monnier * gnus-score.el (gnus-score-insert-help): Something. * gnus-art.el (gnus-button-alist): Exclude < from * nnwarchive.el: Changed file perms. 1999-12-19 21:42:15 Lars Magne Ingebrigtsen * gnus-group.el (gnus-group-delete-groups): New command. (gnus-group-delete-group): Extra no-prompt parameters. 1999-12-14 10:18:30 Lars Magne Ingebrigtsen * nnslashdot.el (nnslashdot-request-article): Translate
    into

    . 1999-12-28 12:20:18 Shenghuo ZHU * webmail.el (webmail-hotmail-article): Don't insert message id. 1999-12-28 Kai.Grossjohann@CS.Uni-Dortmund.DE (Kai Gro,A_(Bjohann) * nnimap.el (nnimap-split-fancy): New variable. (nnimap-split-fancy): New function. 1999-12-28 Simon Josefsson (nnimap-split-rule): Document symbol value. 1999-12-28 Simon Josefsson * nnimap.el (nnimap-retrieve-headers-progress): Let `nnheader-parse-head' parse article. (nnimap-retrieve-headers-from-server): Don't request ENVELOPE, request headers needed by `nnheader-parse-head'. 1999-12-23 Florian Weimer * gnus-msg.el (gnus-group-posting-charset-alist): Correct default value (crosspostings are handled), improve documentation. * smiley.el: Declare file coding system as iso-8859-1. * nnultimate.el: Dito. * message.el: Dito. * gnus-cite.el: Dito. * gnus-spec.el: Dito. 1999-12-21 Florian Weimer * gnus-msg.el (gnus-group-posting-charset-alist): New layout. (gnus-setup-message): No longer make `message-posting-charset' buffer-local. (gnus-setup-posting-charset): Reflect the new layout of `gnus-group-posting-charset-alist' and `message-posting-charset'. * message.el (message-send-mail): Bind `message-this-is-mail' and `message-posting-charset'. (message-send-news): Dito, and honour new layout of `message-posting-charset'. (message-encode-message-body): Ignore `message-posting-charset'. * mm-bodies.el (mm-body-encoding): Consider `message-posting-charset' when deciding whether to use 8bit. * rfc2047.el (rfc2047-encode-message-header): Back out change. (rfc2047-encodable-p): Now solely for headers; use `message-posting-charset'. 1999-12-20 14:10:39 Shenghuo ZHU * nnwarchive.el (nnwarchive-type-definition): Set default value. 1999-12-19 22:49:13 Shenghuo ZHU * nnagent.el (nnagent-server-opened): Optional. (nnagent-status-message): Optional. 1999-12-19 Simon Josefsson * gnus-cite.el (gnus-article-toggle-cited-text): Restore beg and end (referenced by instructions in `gnus-cited-opened-text-button-line-format-alist'). 1999-12-18 Simon Josefsson * imap.el (imap-starttls-open): Typo. 1999-12-18 16:43:37 Shenghuo ZHU * mm-util.el (mm-charset-after): Non-MULE case. * mail-prsvr.el (mail-parse-mule-charset): New variable. * rfc2047.el (rfc2047-dissect-region): Bind it. 1999-12-18 Florian Weimer * mml.el (mml-generate-multipart-alist): Correct default value. * mm-encode.el (mm-use-ultra-safe-encoding): New variable. (mm-safer-encoding): New function. (mm-content-transfer-encoding): Use both. * mm-bodies.el (mm-body-encoding): Use mm-use-ultra-safe-encoding. * qp.el (quoted-printable-encode-region): Dito. 1999-12-18 14:08:48 Shenghuo ZHU * webmail.el (webmail-hotmail-article): Snarf the raw file. 1999-12-18 14:08:12 Victor S. Miller * webmail.el (webmail-hotmail-list): raw=0. 1999-12-18 11:14:51 Shenghuo ZHU * gnus-agent.el (gnus-agent-enter-history): Back-compatible in group name. 1999-12-18 11:02:00 Shenghuo ZHU * gnus-agent.el (gnus-agent-expire): Convert to symbol if stringp. 1999-12-18 Simon Josefsson * imap.el: Don't autoload digest-md5. (imap-starttls-open): Bind coding-system-for-{read,write}. (imap-starttls-p): Check if we can find starttls.el. (imap-digest-md5-p): Check if we can find digest-md5.el. 1999-12-17 Daiki Ueno * base64.el (base64-encode-string): Accept 2nd argument `no-line-break'. * imap.el: Require `digest-md5' when compiling; add autoload settings for `digest-md5-parse-digest-challenge', `digest-md5-digest-response', `starttls-open-stream' and `starttls-negotiate'. (imap-authenticators): Add `digest-md5'. (imap-authenticator-alist): Setup for `digest-md5'. (imap-digest-md5-p): New function. (imap-digest-md5-auth): New function. (imap-stream-alist): Add STARTTLS entry. (imap-starttls-p): New function. (imap-starttls-open): New function. 1999-12-18 01:08:10 Shenghuo ZHU * gnus-agent.el (gnus-agent-enter-history): Bad group name. 1999-12-17 19:36:47 Shenghuo ZHU * rfc2047.el (rfc2047-dissect-region): Use mapcar instead of string-to-x function. 1999-12-17 13:08:54 Shenghuo ZHU * rfc2047.el (rfc2047-fold-region): Fold a line more than once. 1999-12-17 11:54:41 Shenghuo ZHU * webmail.el: Enhance hotmail-snarf. 1999-12-17 10:38:10 Shenghuo ZHU * rfc2047.el (rfc2047-dissect-region): Rewrite. 1999-12-16 22:59:22 Shenghuo ZHU * webmail.el (webmail-hotmail-list): Search no-error. 1999-12-15 22:07:15 Shenghuo ZHU * nnwarchive.el: Support nov-is-evil. * gnus-bcklg.el (gnus-backlog-request-article): Buffer is optional. Set it if non-nil. * gnus-agent.el (gnus-agent-fetch-articles): Use it. 1999-12-15 08:55:19 Shenghuo ZHU * nnagent.el (nnagent-server-opened): Redefine. (nnagent-status-message): Ditto. 1999-12-14 23:37:44 Shenghuo ZHU * rfc1843.el (rfc1843-decode-region): Use buffer-substring-no-properties. * gnus-art.el (article-decode-HZ): New function. 1999-12-14 22:07:26 Shenghuo ZHU * nnheader.el (nnheader-translate-file-chars): Only in full path. 1999-12-14 16:21:45 Shenghuo ZHU * mm-util.el (mm-find-charset-region): mail-parse-charset is a MIME charset not a MULE charset. 1999-12-14 15:08:03 Shenghuo ZHU * gnus-ems.el: Translate more ugly characters. * nnheader.el (nnheader-translate-file-chars): Don't translate the second ':'. 1999-12-14 10:40:33 Shenghuo ZHU * gnus-art.el (gnus-request-article-this-buffer): Use all refer method if cannot find the article. 1999-12-14 01:13:50 Shenghuo ZHU * gnus-art.el (gnus-request-article-this-buffer): Don't use refer method if overrided. 1999-12-13 23:38:53 Shenghuo ZHU * mail-source.el (mail-source-fetch-webmail): Parameter dontexpunge. 1999-12-13 23:31:17 Shenghuo ZHU * webmail.el: Support my-deja. Better error report. 1999-12-13 18:59:33 Shenghuo ZHU * nnslashdot.el (nnslashdot-date-to-date): Error proof when input is bad. * gnus-sum.el (gnus-list-of-unread-articles): When (car read) is not 1. 1999-12-13 18:22:08 Shenghuo ZHU * nnslashdot.el (nnslashdot-request-article): A space. 1999-12-13 17:20:25 Shenghuo ZHU * nnagent.el: Support different backend with same name. 1999-12-13 13:14:42 Shenghuo ZHU * nnslashdot.el (nnslashdot-threaded-retrieve-headers): Support archived group. (nnslashdot-sane-retrieve-headers): Ditto. (nnslashdot-request-article): Ditto. 1999-12-13 11:41:32 Shenghuo ZHU * nnweb.el (nnweb-insert): Narrow to point. 1999-12-13 10:59:42 Shenghuo ZHU * nnweb.el (nnweb-insert): Follow refresh url. * nnslashdot.el: Use it. 1999-12-13 10:39:53 Shenghuo ZHU * nnweb.el (nnweb-decode-entities): Decode numerical entities. (nnweb-decode-entities-string): New function. * nnwarchive.el (nnwarchive-decode-entities-string): Rename to nnweb-* and move to nnweb.el. * nnwarchive.el: Use nnweb-decode-entities, etc. * webmail.el: Ditto. * nnslashdot.el: Use nnweb-decode-entities-string. (nnslashdot-decode-entities): Remove. 1999-12-13 10:40:56 Eric Marsden * nnslashdot.el: Decode entities. 1999-12-12 Dave Love * gnus-agent.el (gnus-category-edit-groups) (gnus-category-edit-score, gnus-category-edit-predicate): Replace expansion of setf, fixed. 1999-12-12 12:50:30 Shenghuo ZHU * gnus-agent.el: Revoke last Dave Love's patch, because of incompatibility of XEmacs. 1999-12-12 12:27:03 Shenghuo ZHU * mm-uu.el: Change headers. * rfc1843.el: Ditto. * uudecode.el: Ditto. 1999-12-07 Dave Love * gnus-agent.el (gnus-category-edit-predicate) (gnus-category-edit-score, gnus-category-edit-score): Expand setf inside backquote to avoid it at runtime. 1999-12-07 Dave Love * binhex.el: Require cl when compiling. 1999-12-04 Dave Love * gnus-cus.el (gnus-group-parameters): Allow nil for banner. 1999-12-04 Dave Love * mm-util.el (mm-delete-duplicates): New function. (mm-write-region): Use it. * mml.el (mml-minibuffer-read-type): Use mm-delete-duplicates. * mailcap.el (mailcap-mime-types): Require mm-util. Use mm-delete-duplicates. * imap.el (imap-open, imap-debug): Avoid mapc. * nnvirtual.el (nnvirtual-create-mapping): Likewise. * gnus-sum.el (gnus-summary-exit-no-update): Avoid copy-list. (gnus-multi-decode-encoded-word-string): Avoid mapc. * gnus-start.el (gnus-site-init-file): Avoid ignore-errors at runtime. * gnus.el (gnus-select-method): Likewise. * nnheader.el (nnheader-nov-read-integer): Likewise. * mm-view.el (mm-inline-message): Require cl when compiling. Avoid ignore-errors at runtime. (mm-inline-text): Avoid mapc. 1999-12-12 10:36:51 Shenghuo ZHU * gnus-art.el (article-decode-charset): Widen is bad. 1999-12-12 10:17:42 Shenghuo ZHU * mm-util.el (mm-charset-after): `charset-after' may not be defined. 1999-12-12 Florian Weimer * rfc2047.el (rfc2047-encodable-p): New parameter header used to indicate that only US-ASCII is permitted. (rfc2047-encode-message-header): Use it. Now, Gnus should never use unencoded 8-bit characters in message headers. 1999-12-12 03:08:15 Shenghuo ZHU * ietf-drums.el (ietf-drums-narrow-to-header): Make it work with CRLF. 1999-12-11 14:42:26 Shenghuo ZHU * webmail.el: Require url-cookie. 1999-12-11 14:21:23 Shenghuo ZHU * nnwarchive.el (nnwarchive-make-caesar-translation-table): A new function to make modified caesar table. (nnwarchive-from-r13): Use it. (nnwarchive-mail-archive-article): Improved. 1999-12-11 12:30:20 Shenghuo ZHU * webmail.el (webmail-url): Use mm-with-unibyte-current-buffer. 1999-12-10 16:22:24 Shenghuo ZHU * nnweb.el (nnweb-request-article): Return cons. 1999-12-10 16:06:04 Shenghuo ZHU * gnus-sum.el (gnus-summary-setup-default-charset): Typo. 1999-12-10 12:14:04 Shenghuo ZHU * mm-util.el (mm-with-unibyte): New macro. * nnweb.el (nnweb-init): Use it. 1999-12-09 20:39:49 Shenghuo ZHU * mm-util.el (mm-charset-after): New function. (mm-find-mime-charset-region): Set charsets after delete-duplicates and use find-coding-systems-region. (mm-find-charset-region): Remove composition. * mm-bodies.el (mm-encode-body): Use mm-charset-after. * mml.el (mml-parse-singlepart-with-multiple-charsets): Ditto. 1999-12-09 17:47:56 Shenghuo ZHU * mm-util.el (mm-find-mime-charset-region): Revoke last change. * mml.el (mml-confirmation-set): New variable. (mml-parse-1): Ask user to confirm. 1999-12-09 Simon Josefsson * gnus-start.el (gnus-get-unread-articles): Make sure all methods are scanned when we have directory mail-sources (the mail source is modified in that case, so we must scan it for all groups/methods). 1999-12-09 12:05:28 Shenghuo ZHU * nnml.el (nnml-request-move-article): Save nnml-current-directory and nnml-article-file-alist. 1999-12-09 10:20:07 Shenghuo ZHU * gnus-group.el (gnus-group-get-new-news-this-group): Binding nnmail-fetched-sources. 1999-12-09 10:19:01 Shenghuo ZHU * mm-util.el (mm-find-charset-region): Use the last charset. 1999-12-08 Per Abrahamsen * gnus.el (gnus-select-method): Made the option list prettier. 1999-12-08 Florian Weimer * gnus-msg.el (gnus-group-posting-charset-alist): Use iso-8859-1 for the `de' newsgroups hierarchy, as it is common practice there. 1999-12-07 16:17:12 Shenghuo ZHU * nnwarchive.el (nnwarchive-mail-archive-article): Fix buffer-string arguments. Fix references. 1999-12-07 15:04:18 Shenghuo ZHU * gnus-agent.el (gnus-agent-confirmation-function): New variable. (gnus-agent-batch-fetch): Use it. (gnus-agent-fetch-session): Use it. 1999-12-07 12:32:43 Shenghuo ZHU * mm-util.el (mm-find-mime-charset-region): Delete nil. 1999-12-07 11:45:10 Shenghuo ZHU * mm-util.el (mm-find-charset-region): Don't capitalize. Delete nil. 1999-12-07 Per Abrahamsen * nnslashdot.el (nnslashdot-request-list): There were two top-level body-forms. Put a `progn' around them. * gnus.el (gnus-select-method): Use `condition-case' instead of `ignore-errors', since cl may not be loaded when the form is evaluated. 1999-12-06 23:57:47 Shenghuo ZHU * nnwarchive.el: Support www.mail-archive.com. 1999-12-06 23:55:55 Shenghuo ZHU * nnmail.el (nnmail-get-new-mail): Remove fetched sources before do anything. 1999-12-06 Simon Josefsson * utf7.el: New file, written by Jon K Hellan. * imap.el (imap-use-utf7): Renamed from `imap-utf7-p', change default to t. 1999-12-06 04:40:24 Lars Magne Ingebrigtsen * nnslashdot.el (nnslashdot-request-delete-group): New function. * gnus-sum.el (gnus-summary-refer-article): Work for lists with current. (gnus-refer-article-methods): New function. (gnus-summary-refer-article): Use it. 1999-11-13 Simon Josefsson * nnimap.el (nnimap-retrieve-groups): Return active format. * nnimap.el (nnimap-replace-in-string): Removed. (nnimap-request-list): (nnimap-retrieve-groups): (nnimap-request-newgroups): Quote group instead of escaping SPC. 1999-12-05 Simon Josefsson * imap.el: Use format-spec for ssl program. * imap.el (imap-ssl-arguments): Removed. (imap-ssl-open-{1,2}): Removed. 1999-12-04 Per Abrahamsen * gnus-start.el (gnus-site-init-file): Use `condition-case' instead of `ignore-errors', since cl may not be loaded when the form is evaluated. 1999-12-04 11:34:22 Shenghuo ZHU * mm-bodies.el (mm-8bit-char-regexps): Removed. (mm-7bit-chars): New variable. (mm-body-7-or-8): Use it in both cases. 1999-12-04 Michael Welsh Duggan * gnus-start.el (gnus-site-init-file): Don't use cl macros in defcustom definitions. 1999-12-04 Simon Josefsson * mm-decode.el (mm-display-part): Let mm-display-external return inline or external. (mm-display-external): For copiousoutput methods, insert output in buffer. 1999-12-04 03:29:13 Shenghuo ZHU * nntp.el (nntp-retrieve-headers-with-xover): Goto the end of buffer. 1999-12-04 08:31:10 Lars Magne Ingebrigtsen * gnus-audio.el: An M too far. * gnus-msg.el (gnus-setup-message): One backtick too many. * gnus-art.el (gnus-mime-view-part-as-type): mailcap-mime-types is a function, not a variable. 1999-12-04 08:14:08 Max Froumentin * gnus-score.el (gnus-score-body): Widen before requesting. 1999-12-04 08:06:13 Lars Magne Ingebrigtsen * gnus-group.el (gnus-group-prepare-flat): Comment fix. 1999-12-04 03:01:55 Shenghuo ZHU * mail-source.el (mail-source-fetch-webmail): Bind mail-source-string. 1999-12-04 07:18:23 Matt Swift * gnus-uu.el (gnus-uu-mark-by-regexp): Doc fix. (gnus-uu-unmark-by-regexp): Ditto. * gnus-group.el (gnus-group-catchup-current): Would bug out on dead groups. 1999-12-04 01:34:31 Lars Magne Ingebrigtsen * gnus-msg.el (gnus-setup-message): Allow the charset setting to do their real thing. * nnmh.el (nnmh-be-safe): Doc fix. * gnus-sum.el (gnus-summary-exit): Write cache active file. * nntp.el (nntp-retrieve-headers-with-xover): Make sure the entire status line has arrived before we count it. * mailcap.el (mailcap-mime-data): Removed save-file from audio/*. * gnus-sum.el (gnus-thread-header): Fixed after indent. Whitespace problems. * gnus-win.el (gnus-configure-windows): Error fix. * gnus-demon.el (gnus-demon-add-nntp-close-connection): Add the right function. * gnus.el: Fixed all the doc strings to match the FSF convetions. Indent all functions. Fix all comments to match the comment conventions. Double-space after full stop. 1999-12-04 01:14:55 YAMAMOTO Kouji * nnmail.el (nnmail-split-it): I redefined nnmail-split-fancy's value to divide received mails into my favorite groups and I met an error. It takes place if the length of a element "VALUE" in nnmail-split-fancy is less than two. 1999-10-10 Robert Bihlmeyer * mml.el (mml-insert-part): New function. 1999-09-29 04:48:14 Katsumi Yamaoka * lpath.el: Add `sc-cite-regexp'. 1999-12-02 Dave Love * mm-decode.el: Customize. 1999-12-03 Dave Love * nnslashdot.el, nnultimate.el: Don't lose at compile time when the W3 stuff isn't available. 1999-12-03 Dave Love * imap.el, mailcap.el, nnvirtual.el, rfc2104.el: Don't require cl at runtime. 1999-12-04 00:47:35 Dan Christensen * gnus-score.el (gnus-score-headers): Fix orphan scoring. 1999-12-01 Andrew Innes * nnmbox.el (nnmbox-read-mbox): Count messages correctly, and don't be fooled by "From nobody" lines added by respooling. * pop3.el (pop3-movemail): Write crashbox in binary. (pop3-get-message-count): New function. * mail-source.el (mail-source-primary-source): New variable. (mail-source-report-new-mail-interval): New variable. (mail-source-idle-time-delay): New variable. (mail-source-new-mail-available): New internal variable. (mail-source-fetch-pop): Clear new mail flag, when mail from primary source has been fetched. (mail-source-check-pop): New function. (mail-source-new-mail-p): New function. (mail-source-start-idle-timer): New function. (mail-source-report-new-mail): New function. (mail-source-report-new-mail): New internal variable. (mail-source-report-new-mail-timer): New internal variable. (mail-source-report-new-mail-idle-timer): New internal variables. 1999-12-04 00:39:34 Andreas Schwab * gnus-cus.el (gnus-group-customize): Customize fix. 1999-12-04 00:38:24 Andrea Arcangeli * message.el (message-send-mail-with-sendmail): Use message-make-address. Fri Dec 3 20:34:11 1999 Lars Magne Ingebrigtsen * gnus.el: Pterodactyl Gnus v5.8.2 is released. Fri Dec 3 20:09:41 1999 Lars Magne Ingebrigtsen * gnus.el: Pterodactyl Gnus v5.8.1 is released. 1999-11-11 Hrvoje Niksic * mml.el (mml-insert-tag): Don't close the tag. (mml-insert-empty-tag): New function. (mml-attach-file): Use mml-insert-empty-tag instead of mml-insert-tag. (mml-attach-buffer): Ditto. (mml-attach-external): Ditto. (mml-insert-multipart): Ditto. 1999-12-03 08:49:53 Shenghuo ZHU * nnfolder.el (nnfolder-request-article): Return -1 if not find the article number. 1999-12-03 01:12:41 Shenghuo ZHU * gnus.el (gnus-find-method-for-group): The method of a new group is not the native one. 1999-12-03 01:26:55 Lars Magne Ingebrigtsen * gnus-art.el (gnus-button-embedded-url): Always call browse-url. 1999-12-02 18:00:15 Lars Magne Ingebrigtsen * nnultimate.el (nnultimate-retrieve-headers): Use mm-with-unibyte-current-buffer. (nnultimate-request-article): Ditto. 1999-12-02 14:57:46 Shenghuo ZHU * nntp.el (nntp-retrieve-groups): Set to process buffer. 1999-12-02 11:14:50 Shenghuo ZHU * mm-util.el (mm-with-unibyte-current-buffer): New macro. * nnweb.el (nnweb-retrieve-headers): Use it. (nnweb-request-article): Use it. * nnweb.el (nnweb-dejanews-create-mapping): Set a default date in case matching failed. 1999-12-02 John Wiegley * mail-source.el (mail-source-keyword-map): Add backslash to Delete-flag. 1999-12-02 07:24:35 Lars Magne Ingebrigtsen * gnus-sum.el (gnus-group-charset-alist): Default nnweb groups to Latin-1. (gnus-group-charset-alist): No, don't. * nnweb.el (nnweb-init): Make the buffer unibyte. 1999-12-01 23:02:48 Shenghuo ZHU * mail-source.el (mail-source-set-common-1): Fix to get the default value. 1999-12-02 00:27:46 Lars Magne Ingebrigtsen * nnslashdot.el (nnslashdot-read-groups): Unibyte. * nnultimate.el (nnultimate-request-list): Use unibyte. * gnus-uu.el (gnus-uu-grab-articles): Bind gnus-display-mime-function to nil. * message.el (message-send-mail-with-sendmail): Use the user-mail-address variable. * gnus-art.el (gnus-ignored-headers): More headers. * message.el (message-shorten-1): Use list. 1999-12-01 21:59:36 Lars Magne Ingebrigtsen * gnus-msg.el (gnus-configure-posting-styles): Ignore nil signatures. * nnweb.el (nnweb-dejanews-create-mapping): Get the data. (nnweb-dejanews-create-mapping): Do the properish date. 1999-12-01 17:41:21 Shenghuo ZHU * mail-source.el (mail-source-common-keyword-map): New variable. (mail-source-bind-common): New macro. (mail-source-fetch): Support plugged mail source. * gnus-int.el (gnus-request-scan): Use them. 1999-12-01 21:59:36 Lars Magne Ingebrigtsen * mm-view.el (mm-inline-message): Check whether charset is a string. * nnslashdot.el (nnslashdot-request-post): Insert

    's. * message.el (message-mode-map): Changed keystroke for message-yank-buffer. 1999-11-26 Hrvoje Niksic * message.el (message-shorten-references): Cut references to 31 elements, then either fold them or shorten them to 988 characters. (message-shorten-1): New function. (message-cater-to-broken-inn): New variable. 1999-12-01 21:47:10 Eric Marsden * nnslashdot.el (nnslashdot-lose): New function. 1999-12-01 21:08:48 Lars Magne Ingebrigtsen * mm-view.el (mm-inline-message): Not the right type of charset is being fetched here. Let the group charset rule. (mm-inline-message): Ignore us-ascii. 1999-11-24 Carsten Leonhardt * mail-source.el (mail-source-fetch-maildir): work around the ommitted "file-regular-p" in efs/ange-ftp 1999-12-01 19:59:25 Lars Magne Ingebrigtsen * mml.el (mml-generate-mime-1): Don't insert extra empty line. (mml-generate-mime-1): Use the encoding param. * gnus-sum.el (gnus-summary-show-article): Don't bind gnus-visual. * gnus-cache.el (gnus-cache-possibly-enter-article): Require gnus-art before binding its variables. * gnus-art.el (gnus-article-prepare-display): Run the prepare after the MIME. 1999-12-01 19:48:14 Rupa Schomaker * message.el (message-clone-locals): Use it. * gnus-msg.el (gnus-configure-posting-styles): Make user-mail-address local. 1999-11-20 Simon Josefsson * gnus-start.el (gnus-get-unread-articles): Scan each method only once. 1999-12-01 17:37:18 Lars Magne Ingebrigtsen * message.el (message-generate-new-buffer-clone-locals): Use varstr. (message-clone-locals): Ditto. * gnus-sum.el (gnus-summary-enter-digest-group): Have the digest group inherit reply-to or from. 1999-12-01 13:04:09 Shenghuo ZHU * gnus-sum.el (gnus-summary-show-article): Support numbered ARG for charset. (gnus-summary-show-article-charset-alist): New variable. * mm-bodies.el (mm-decode-string): Support gnus-all and gnus-unknown. (mm-decode-body): Ditto. * rfc2047.el (rfc2047-decode): Ditto. 1999-12-01 17:37:18 Lars Magne Ingebrigtsen * mail-source.el (mail-source-delete-incoming): Change default to t. Wed Dec 1 16:31:31 1999 Lars Magne Ingebrigtsen * gnus.el: Pterodactyl Gnus v0.99 is released. 1999-12-01 14:28:49 Lars Magne Ingebrigtsen * dgnushack.el (dgnushack-compile): No webmail under Emacs. * gnus-sum.el (gnus-summary-refer-article): Wrong interactive spec. * gnus-msg.el (gnus-configure-posting-styles): Eval `eval'. (gnus-configure-posting-styles): No, don't. (gnus-configure-posting-styles): Allow overriding files. * gnus-art.el (gnus-header-button-alist): Use browse-url directly. * mm-decode.el (mm-inline-media-tests): Check feature vcard. * gnus-msg.el (gnus-summary-yank-message): New command and keystroke. * message.el (message-yank-buffer): New command. (message-buffers): New function. * gnus-sum.el (gnus-summary-catchup-and-goto-next-group): Select next group in a more normal fasion. * mml.el (mml-boundary-function): New variable. (mml-compute-boundary): Use it. * nnmh.el (nnmh-active-number): Skip past files that have buffers that exist for them. * gnus-async.el (gnus-async-prefetch-next): Cancel timers. (gnus-async-timer): New variable. 1999-11-30 02:07:18 Lars Magne Ingebrigtsen * nnultimate.el (nnultimate-request-list): Be more lenient with root addresses. 1999-11-28 20:22:37 Lars Magne Ingebrigtsen * gnus-art.el (gnus-treatment-function-alist): Do gnus-treat-capitalize-sentences. 1999-11-30 09:07:53 Shenghuo ZHU * webmail.el (webmail-hotmail-article): Hotmail changes the format. 1999-11-29 Simon Josefsson * mm-decode.el (mm-display-external): For `copiousoutput' methods, switch to buffer after calling program. (mm-display-external): Use `shell-command-switch' instead of "-c". 1999-11-27 15:21:25 Lars Magne Ingebrigtsen * nnultimate.el (nnultimate-possibly-change-server): Don't always read groups file. * nnslashdot.el (nnslashdot-request-article): Convert

    to

    . 1999-11-24 20:18:24 Lars Magne Ingebrigtsen * message.el (message-mode): Doc fix. 1999-11-24 09:25:00 Shenghuo ZHU * gnus-art.el (article-emphasize): Check group variable. * rfc1843.el (rfc1843-decode-article-body): Ditto. 1999-11-24 00:11:27 Shenghuo ZHU * mm-decode.el (mm-save-part-to-file): Inhibit jka-compr for any type. 1999-11-23 17:21:05 Shenghuo ZHU * webmail.el: Support www.netaddress.com, i.e. usa.net. 1999-11-23 Hrvoje Niksic * mml.el (mml-quote-region): Insert ! after the hash. 1999-11-23 05:08:23 Shenghuo ZHU * gnus-group.el (gnus-group-warchive-address-history): Change to nil. 1999-11-23 02:33:13 Shenghuo ZHU * webmail.el: Support mail.yahoo.com. * mail-source.el (mail-source-fetch-webmail): Add password check. (mail-source-keyword-map): Use `subtype'. 1999-11-22 04:35:43 Shenghuo ZHU * mail-source.el (mail-source-keyword-map): Add webmail. (mail-source-fetcher-alist): Ditto. (mail-source-fetch-webmail): New function. * webmail.el: New file. 1999-11-21 12:20:02 Shenghuo ZHU * nnwarchive.el (nnwarchive-request-group): Print 0 if it is nil. 1999-11-21 12:19:11 Shenghuo ZHU * mailcap.el (mailcap-parse-mailcap): Don't skip double semicolon. 1999-11-20 12:54:25 Lars Magne Ingebrigtsen * nnultimate.el (nnultimate-request-list): Add fetch-time slot. (nnultimate-prune-days): New function. (nnultimate-create-mapping): Use it. (nnultimate-request-group): Only fetch the groups list if it has not been done before. (nnultimate-retrieve-headers): Don't write groups. (nnultimate-create-mapping): Off-by-one error. 1999-11-19 12:17:25 Lars Magne Ingebrigtsen * nnslashdot.el (nnslashdot-sane-retrieve-headers): Fix to match threaded subjects. 1999-11-20 02:22:52 Shenghuo ZHU * nnwarchive.el: Lots of changes make agent happy. 1999-11-19 21:37:41 Shenghuo ZHU * gnus-start.el (gnus-get-unread-articles): Assert group is in hashtb. 1999-11-19 19:53:08 Shenghuo ZHU * mm-decode.el (mm-display-external): Write region with binary mode. 1999-11-18 14:52:05 Shenghuo ZHU * nnweb.el (nnweb-dejanews-create-mapping): Bind `text'. 1999-11-18 14:35:01 Shenghuo ZHU * mm-uu.el (mm-uu-dissect): Use fake charset `gnus-decoded'. (mm-uu-test): Now it is in restricted region. * gnus-art.el (article-decode-charset): Don't mm-uu-test. * mm-view.el (mm-view-message): Fix buffer leak. (mm-inline-message): Support 'gnus-decoded. * mm-bodies.el (mm-decode-body): Ditto. * rfc2047.el (rfc2047-decode-region): Ditto. 1999-11-18 Matthias Andree * imap.el (require): Added autoload for base64-encode-string. 1999-11-17 Per Abrahamsen * gnus.el (gnus-refer-article-method): Made list value customizable. 1999-11-17 13:09:37 Shenghuo ZHU * gnus-sum.el (gnus-summary-recenter): set-window-start with NOFORCE in Emacs case. 1999-11-17 13:04:01 Shenghuo ZHU * gnus-art.el (gnus-request-article-this-buffer): Set gnus-newsgroup-name. 1999-11-16 23:53:22 Shenghuo ZHU * gnus-xmas.el (gnus-xmas-summary-recenter): set-window-start with NOFORCE. 1999-11-17 Simon Josefsson * gnus-start.el (gnus-get-unread-articles): Check server before scanning. 1999-11-16 10:01:03 Lars Magne Ingebrigtsen * gnus.el (gnus-valid-select-methods): nnslashdot is news. * nnslashdot.el (nnslashdot-login-name): New variable. (nnslashdot-password): Ditto. (nnslashdot-request-post): New function. * gnus-art.el (gnus-treat-buttonize): More testing. * mm-encode.el: Another CVS test. * gnus-art.el (gnus-treat-emphasize): Change default. (gnus-treat-buttonize): Ditto. (gnus-treat-buttonize): This is a test. * gnus-sum.el (gnus-build-old-threads): Bind mail-parse-charset. (gnus-build-sparse-threads): Ditto. (gnus-build-all-threads): Ditto. * nnheader.el (make-full-mail-header): Make into a subst. * dgnushack.el (dgnushack-compile): Skip all w3-dependent files unless w3 is supplied. * gnus.el (gnus-refer-article-method): Doc fix. * gnus-sum.el: Do not accept a prefix. (gnus-summary-refer-article): Accept a list of select methods. 1999-11-15 21:28:40 Shenghuo ZHU * Makefile.in: Change `^ *' to `\t'. 1999-11-11 Matt Pharr * message.el (message-forward): Pay attention to prefix argument again and forward all headers when it is set, regardless of the value of message-forward-ignored-headers. 1999-11-15 20:44:50 William M. Perry * dgnushack.el (dgnushack-compile): Vpath file. * Makefile.in (SHELL): VPATH support. 1999-11-15 20:37:17 Lars Magne Ingebrigtsen * gnus-ems.el: Check for cygwin32. 1999-11-14 18:15:28 Shenghuo ZHU * mm-decode.el (mm-display-external): Use 'non-viewer. 1999-11-14 15:21:06 Shenghuo ZHU * base64.el (base64-encode-string): An alias for base64-encode for compatibility. 1999-11-14 01:58:18 Shenghuo ZHU * nntp.el (nntp-retrieve-groups): Erase nntp-sever-buffer before nntp-inhibit-erase. 1999-11-13 Simon Josefsson * gnus-start.el (gnus-get-unread-articles): Use nnfoo-retrieve-groups to find new news, if available. (gnus-read-active-file-2): New function. (gnus-get-unread-articles): Use it. (gnus-read-active-file-1): Ditto. 1999-11-13 17:59:18 Lars Magne Ingebrigtsen * mm-util.el (mm-find-mime-charset-region): Make sure find-coding-systems-for-charsets is fbound. * gnus-ems.el: Typo fix. 1999-11-13 Florian Weimer * mm-util.el (mm-find-mime-charset-region): Use UTF-8 if it's available and makes sense. 1999-11-12 19:56:23 Fabrice POPINEAU * gnus-score.el (gnus-score-save): Translate score file. 1999-11-13 Simon Josefsson * mail-source.el (mail-source-keyword-map): For IMAP mail source, added fetchflag and dontexpunge keywords. (mail-source-fetch-imap): Use them. 1999-11-12 Per Abrahamsen * gnus-start.el (gnus-level-subscribed, gnus-level-unsubscribed, gnus-level-zombie, gnus-level-killed): Changed from `defcustom' to `defconst'. * gnus-cus.el (gnus-group-parameters): Changed from `defcustom' to `defconst'. Mention that it is both for group and topic parameters. (gnus-extra-topic-parameters): New constant, including `subscribe' parameter. (gnus-extra-group-parameters): New constant. (gnus-group-customize): Use them. * gnus.el (gnus-select-method): Added default value and tag. (gnus-refer-article-method): Added `DejaNews' customization option. 1999-11-12 05:04:43 Lars Magne Ingebrigtsen * gnus-int.el (gnus-server-opened): Ignore denied servers. * gnus-ems.el (gnus-mule-max-width-function): New backquote syntax. * nndoc.el (nndoc-mime-digest-type-p): Reinstated. * nnslashdot.el (nnslashdot-group-number): Changed default. * nnweb.el (nnweb-dejanews-create-mapping): Work with new deja. (nnweb-dejanews-wash-article): Removed. (nnweb-type-definition): Fetch by id. * gnus-msg.el (gnus-configure-posting-styles): Don't insert unless we mean it. * nnslashdot.el (nnslashdot-group-number): Doc fix. (nnslashdot-request-list): Use Ultramode as well. (nnslashdot-date-to-date): Be more lenient. (nnslashdot-threaded): New function. 1999-11-11 17:40:54 Lars Magne Ingebrigtsen * gnus-art.el (gnus-mime-internalize-part): Doc fix. 1999-11-11 14:32:48 Steinar Bang * nnweb.el (nnweb-type-definition): /=dnc 1999-11-11 10:58:38 Lars Magne Ingebrigtsen * nnultimate.el (nnultimate-retrieve-headers): Work with american dates. (nnultimate-retrieve-headers): Wrong ordering. 1999-11-11 07:31:51 Matt Pharr * message.el (message-forward-as-mime): New variable. 1999-11-11 05:24:13 Lars Magne Ingebrigtsen * gnus-util.el (gnus-dd-mmm): Beware buggy dates. 1999-11-10 16:50:01 Shenghuo ZHU * mail-source.el (mail-source-movemail-and-remove): New function. (mail-source-keyword-map): Add `function' for `maildir'. (mail-source-fetch-maildir): Use it. 1999-11-10 13:48:10 Shenghuo ZHU * nnwarchive.el: New file. * gnus-group.el (gnus-group-make-warchive-group): New function. * gnus.el (gnus-valid-select-methods): Add `nnwarchive'. 1999-11-10 12:13:30 Lars Magne Ingebrigtsen * nnultimate.el (nnultimate-retrieve-headers): Work for multi-page subjects. 1999-11-10 11:33:23 Rajappa Iyer * gnus-salt.el (gnus-pick-article-or-thread): Don't move point. 1999-11-10 05:22:56 Lars Magne Ingebrigtsen * nnultimate.el (nnultimate-open-server): Do address. (nnultimate-forum-table-p): New function. * nnweb.el (nnweb-insert-html): Renamed. (nnweb-insert): New function. * nnultimate.el (nnultimate-insert-html): New function. * nnslashdot.el (nnslashdot-retrieve-headers): Don't do anything if nov is evil. (nnslashdot-retrieve-headers): use the sane version instead. 1999-11-09 00:13:25 Lars Magne Ingebrigtsen * nnslashdot.el (nnslashdot-request-article): Fold case. * nnultimate.el: New file. * nnslashdot.el (nnslashdot-retrieve-headers): Skip the article unless wanted. * gnus-start.el (gnus-active-to-gnus-format): Catch errors. (gnus-read-active-file-1): Separated into own function. (gnus-read-active-file): Catch quits. * nnslashdot.el (nnslashdot-request-article): Search better on first article. (nnslashdot-request-list): Fold case. (nnslashdot-retrieve-headers): Ditto. 1999-11-08 05:33:15 Lars Magne Ingebrigtsen * gnus.el: Autoload gnus-subscribe-topics. 1999-11-07 22:56:46 Shenghuo ZHU * gnus-agent.el (gnus-agent-save-group-info): Remove backslash before dot. * gnus-util.el (gnus-write-active-file): Ditto. 1999-11-07 22:31:10 Shenghuo ZHU * nnheader.el (nnheader-replace-duplicate-chars-in-string): New function. * gnus-cache.el (gnus-cache-file-name): Use it. * gnus-agent.el (gnus-agent-group-path): Use it. * nnmail.el (nnmail-group-pathname): Use it. 1999-11-07 21:07:55 Shenghuo ZHU * gnus-start.el (gnus-active-to-gnus-format): Don't insert backslash if cooked. * gnus-util.el (gnus-write-active-file): Write cooked active file. * gnus-agent.el (gnus-agent-save-group-info): Ditto. * gnus.el (gnus-short-group-name): "..." proof. 1999-11-07 20:03:16 Shenghuo ZHU * gnus-srvr.el (gnus-browse-foreign-server): Keep using `read' to support nnslashdot. 1999-11-08 00:06:02 Lars Magne Ingebrigtsen * nnslashdot.el (nnslashdot-retrieve-headers): Don't fetch too many articles. (nnslashdot-generate-active): New function. (nnslashdot-request-newgroups): Use it. * gnus-start.el (gnus-active-to-gnus-format): Intern strings group names. * nnslashdot.el (nnslashdot-request-newgroups): New function. (nnslashdot-request-list): Not moderated. 1999-11-07 Simon Josefsson * nnimap.el (nnimap-open-server): Remove error signal if nnimap-server-buffer is nil (the check should've been `boundp'). * imap.el (imap-log): * nnimap.el (nnimap-debug): Disable debugging by default. 1999-11-07 01:17:53 Lars Magne Ingebrigtsen * gnus-start.el (gnus-subscribe-newsgroup-method): Doc fix. * gnus-topic.el (gnus-subscribe-topic): New function. * nnslashdot.el (nnslashdot-request-list): Give out extended group names. * gnus-start.el (gnus-ignored-newsgroups): Disregard bogus chars if starting with a quote. 1999-11-07 13:06:11 Shenghuo ZHU * gnus-srvr.el (gnus-browse-foreign-server): Support backslash in group name. 1999-11-07 01:17:53 Lars Magne Ingebrigtsen * nnslashdot.el: New file. * nnheader.el (nnheader-insert-header): New function. * gnus-art.el (gnus-mime-internalize-part): Bind mm-inlined-types. * nndraft.el (nndraft-request-expire-articles): Do all the backup files. 1999-10-29 David S. Goldberg * emacs-mime.texi (Customization): Document mm-inline-override-types 1999-10-29 David S. Goldberg * emacs-mime.texi (Customization): Document mm-inline-override-types 1999-10-29 David S. Goldberg * emacs-mime.texi (Customization): Document mm-inline-override-types 1999-10-26 Katsumi Yamaoka * smiley.el (gnus-smiley-display): Use `smiley-toggle-buffer'. (smiley-toggle-buffer): New function. (smiley-buffer): Don't quote the function. (smiley-toggle-extents): Ditto. 1999-11-07 01:00:32 Lars Magne Ingebrigtsen * gnus-topic.el (gnus-topic-goto-missing-topic): Work even in empty buffers. 1999-11-06 23:16:24 Lars Magne Ingebrigtsen * gnus-art.el (gnus-article-mode-map): Use the summary article edit. 1999-11-06 22:56:49 Jens-Ulrik Petersen * gnus-group.el (gnus-group-read-ephemeral-group): Doc fix. 1999-11-06 21:40:30 Lars Magne Ingebrigtsen * gnus-uu.el (gnus-uu-mark-thread): Don't move point around. 1999-10-07 Katsumi Yamaoka * gnus-art.el (gnus-treat-predicate): Examine whether the argument is list or not before condition. 1999-10-07 Yoshiki Hayashi * gnus-art.el (gnus-treat-predicate): Work for (typep "something"). 1999-11-06 19:18:14 Kevin the Bandicoot * gnus-art.el (gnus-emphasis-alist): New value. 1999-11-06 13:57:13 Shenghuo ZHU * gnus-srvr.el (gnus-browse-foreign-server): Use both `read' and `buffer-substring'. 1999-11-06 04:24:30 Lars Magne Ingebrigtsen * gnus-art.el (article-date-ut): Keep the updated timer. (gnus-emphasis-underline-italic): Doc fix. * gnus-msg.el (gnus-post-method): Doc fix. (gnus-post-method): Change default. 1999-11-06 04:12:13 Francisco Solsona * message.el (message-newline-and-reformat): Improvements. 1999-11-06 03:51:24 Lars Magne Ingebrigtsen * message.el (message-newline-and-reformat): Don't insert too many newlines. (message-newline-and-reformat): Work even if not sc. * mm-view.el (mm-inline-message): Insert a delimiter at the end. * mm-decode.el (mm-inline-media-tests): Only if diff mode. 1999-11-06 03:48:02 Toby Speight * mm-view.el (mm-display-patch-inline): New function. 1999-11-06 03:47:54 Robert Bihlmeyer * mm-view.el (mm-display-patch-inline): New function. 1999-11-06 02:17:54 Lars Magne Ingebrigtsen * gnus-sum.el (gnus-read-move-group-name): Subscribe to the group. * message.el (message-forward): Narrow to the right header. * gnus-sum.el (gnus-summary-limit-to-age): Protect against bogus dates. * gnus-msg.el (gnus-configure-posting-styles): Use the user-full-name function. * mm-bodies.el (mm-body-encoding): Use the choosing function. (mm-body-charset-encoding-alist): Default to nil. * message.el (message-elide-ellipsis): Fix typo. (message-elide-region): Ditto. (message-elide-region): Don't insert a newline first. 1999-11-05 20:28:27 Lars Magne Ingebrigtsen * gnus-sum.el (gnus-cut-thread): Also cut for numberp gnus-fetch-old-headers. (gnus-cut-threads): Ditto. (gnus-summary-initial-limit): Ditto. (gnus-summary-limit-children): Ditto. * gnus-msg.el (gnus-configure-posting-styles): Allow `header' matches. 1999-11-06 Simon Josefsson * gnus-art.el (article-decode-encoded-words): (gnus-mime-display-single): Don't assume gnus-summary-buffer is live. * gnus.el (gnus-read-method): Add methods from `gnus-opened-servers' to completion. Map entered method/address into existing methods if possible. * gnus-group.el (gnus-group-make-group): Simplify method. * gnus-srvr.el (gnus-browse-unsubscribe-group): Simplify method. * mml.el (mml-preview): Remove mail-header-separator before encoding. 1999-11-05 20:28:27 Lars Magne Ingebrigtsen * message.el (message-read-from-minibuffer): New function. Fri Nov 5 19:10:02 1999 Lars Magne Ingebrigtsen * gnus.el: Pterodactyl Gnus v0.98 is released. 1999-11-05 01:27:49 Shenghuo ZHU * gnus-agent.el (gnus-agent-expire): Remove bad line in NOV. 1999-11-04 22:20:35 Shenghuo ZHU * mml.el (mml-generate-mime-1): Read attached binary file in binary mode. 1999-11-03 16:08:56 Shenghuo ZHU * gnus-sum.el (gnus-summary-toggle-header): Fix arg bug. 1999-11-03 15:27:38 Shenghuo ZHU * mailcap.el (mailcap-viewer-lessp): Fix bug. 1999-11-02 17:28:33 Shenghuo ZHU * gnus-sum.el (gnus-summary-search-article): Fix loop search bug. 1999-10-31 21:24:59 Shenghuo ZHU * gnus-art.el (gnus-article-mime-match-handle-first): New function. (gnus-article-mime-match-handle-function): New variable. (gnus-article-view-part): Make `b' customizable. 1999-10-29 14:30:07 Shenghuo ZHU * gnus-sum.el (gnus-article-get-xrefs): Test eobp. 1999-09-27 Hrvoje Niksic * mm-decode.el (mm-attachment-override-types): Exclude text/plain. 1999-10-26 23:27:44 Shenghuo ZHU * mm-decode.el (mm-dissect-buffer): CTE may come without CTL. 1999-10-26 21:44:05 Shenghuo ZHU * gnus-srvr.el (gnus-browse-foreign-server): Use `buffer-substring' instead of `read'. 1999-10-23 Simon Josefsson * nnimap.el, imap.el, rfc2104.el: New files. * gnus.el (gnus-valid-select-methods): Add nnimap. * gnus-group.el (gnus-group-group-map): Add gnus-group-nnimap-edit-acl, gnus-group-nnimap-expunge. (gnus-group-nnimap-expunge): New function. (gnus-group-nnimap-edit-acl): New function. * gnus-agent.el (gnus-agent-group-mode-map): Add gnus-agent-synchronize. (gnus-agent-synchronize): New function. (gnus-agent-fetch-group-1): Check if server is open. * nnagent.el (nnagent-request-set-mark): Save marks. * mail-source.el (mail-source-keyword-map): New imap mail-source. (mail-source-fetcher-alist): Map to imap fetcher function. (mail-source-fetch-imap): New function. * gnus-art.el (article-hide-pgp): Hide all headers, not just Hash:. 1999-10-22 11:03:00 Shenghuo ZHU * gnus-topic.el (gnus-topic-sort-topics-1): New function. (gnus-topic-sort-topics): New function. (gnus-topic-make-menu-bar): Add sort-topics. (gnus-topic-move): New function. (gnus-topic-move-group): Move the topic if no group selected. 1999-10-13 21:31:50 Shenghuo ZHU * gnus-art.el (gnus-article-setup-buffer): Fix buffer leak. 1999-10-13 12:52:18 Shenghuo ZHU * mm-view.el (mm-inline-message): Fix leaving group bug. 1999-10-07 17:59:49 Shenghuo ZHU * gnus-msg.el (gnus-post-method): Use normal method if current is not available. 1999-10-07 17:09:34 Shenghuo ZHU * nnmail.el (nnmail-insert-xref): Dealing with empty articles. (nnmail-insert-lines): Ditto. 1999-10-07 Shenghuo ZHU * nnfolder.el (nnfolder-insert-newsgroup-line): Insert a blank line. * message.el (message-unsent-separator): One more separator. 1999-10-06 Shenghuo ZHU * nnfolder.el (nnfolder-request-move-article): For empty article, search till (point-max). (nnfolder-retrieve-headers): Ditto. (nnfolder-request-accept-article): Ditto. (nnfolder-save-mail): Ditto. (nnfolder-insert-newsgroup-line): Ditto. 1999-10-05 Shenghuo ZHU * qp.el (quoted-printable-encode-region): Check eobp. 1999-10-03 Shenghuo ZHU * nntp.el (nntp-retrieve-headers-with-xover): Fix hanging problem. 1999-10-02 Shenghuo ZHU * nntp.el (nntp-send-xover-command): Wait for nothing if not wait-for-reply. 1999-09-29 Shenghuo ZHU * mm-uu.el (mm-uu-forward-begin-line): Change the regexp. (mm-uu-forward-end-line): Ditto. 1999-09-29 Didier Verna * binhex.el (binhex-decode-region): don't consider the value of `enable-multibyte-characters' in XEmacs. * gnus-start.el (gnus-read-descriptions-file): ditto. * mm-util.el (mm-multibyte-p): ditto. (mm-with-unibyte-buffer): ditto. (mm-find-charset-region): use `mm-multibyte-p'. * mm-bodies.el (mm-decode-body): ditto. (mm-decode-string): ditto. * lpath.el ((string-match "XEmacs" emacs-version)): Don't define `enable-multibyte-characters' in XEmacs. 1999-09-29 Shenghuo ZHU * mm-util.el (mm-binary-coding-system): Try binary first. 1999-09-14 Shenghuo ZHU * rfc1843.el (rfc1843-decode-article-body): Don't decode twice. 1999-09-10 Shenghuo ZHU * gnus-art.el (article-make-date-line): Add time-zone in iso8601 format. (article-date-ut): Find correct insert position. 1999-09-03 Shenghuo ZHU * mm-uu.el (mm-uu-dissect): Do not dissect quoted-printable forwarded message. 1999-09-27 20:33:41 Lars Magne Ingebrigtsen * gnus-topic.el (gnus-topic-find-groups): Work for unactivated groups. * message.el (message-resend): Use message mode when prompting. * gnus-art.el (article-hide-headers): Mark wash. (article-emphasize): Ditto. 1999-09-27 19:52:14 Vladimir Volovich * message.el (message-newline-and-reformat): Work for SC. 1999-09-27 19:38:33 Lars Magne Ingebrigtsen * gnus-msg.el (gnus-group-posting-charset-alist): 2047 in de.*. * gnus-sum.el (gnus-newsgroup-ignored-charsets): Add x-unknown. 1999-10-20 David S. Goldberg * mm-decode.el mm-inline-override-types: New variable * mm-decode.el (mm-inline-override-p): New function * mm-decode.el (mm-inlined-p): Use it 1999-10-20 David S. Goldberg * mm-decode.el mm-inline-override-types: New variable * mm-decode.el (mm-inline-override-p): New function * mm-decode.el (mm-inlined-p): Use it Mon Sep 27 15:18:05 1999 Lars Magne Ingebrigtsen * gnus.el: Pterodactyl Gnus v0.97 is released. 1999-09-01 Brendan Kehoe * gnus-sum.el (gnus-summary-catchup-and-goto-next-group): Use gnus-summary-next-group, not gnus-summary-next-article. Only give 3 args. 1999-09-25 08:07:57 Lars Magne Ingebrigtsen * gnus-agent.el (gnus-agent-fetch-group-1): Look in the group buffer for params. * gnus-xmas.el (gnus-xmas-summary-recenter): Display one more line. * message.el (message-forward-ignored-headers): New variable. * gnus-art.el (gnus-article-prepare-display): Nix out gnus-article-wash-types. * gnus-agent.el (gnus-agent-create-buffer): New function. (gnus-agent-fetch-group-1): Use it. (gnus-agent-start-fetch): Ditto. * gnus-sum.el (gnus-summary-exit): Don't use `gnus-use-adaptive-scoring'. * mail-source.el (mail-source-fetch-pop): Only store password when successful. * gnus-nocem.el (gnus-nocem-scan-groups): Message better. 1999-09-24 18:43:23 Lars Magne Ingebrigtsen * message.el (message-reply): Use it. (message-dont-reply-to-names): New variable. * nntp.el (nntp-open-telnet): Don't erase-buffer. * mm-util.el (mm-preferred-coding-system): Typo fix. * message.el (message-bounce): Work for non-MIME. * gnus.el (gnus-short-group-name): Short the right parts of the name. 1999-09-24 18:17:48 Johan Kullstam * mm-encode.el (mm-qp-or-base64): New version. 1999-09-10 Shenghuo ZHU * gnus-art.el (article-make-date-line): Fix time-zone bug. 1999-09-09 Shenghuo ZHU * gnus-art.el (gnus-article-add-buttons): Don't delete markers out of restricted region. (gnus-mime-display-single): Set beg at correct point. 1999-09-09 Shenghuo ZHU * nnmail.el (nnmail-process-maildir-mail-format): Typo. 1999-09-09 Jens-Ulrik Petersen * gnus-msg.el (gnus-configure-posting-styles): Let `gnus-posting-styles' have its say in posting-style: local variable `styles' is already bound to `gnus-posting-styles' so don't rebind it to nil. 1999-09-24 18:10:56 Robert Bihlmeyer * gnus-score.el (gnus-summary-increase-score): Allow editing of Message-ID. 1999-09-08 Shenghuo ZHU * mm-encode.el (mm-encode-content-transfer-encoding): Fold quoted-printable-encode-region. * qp.el (quoted-printable-encode-region): Assume charset encoded. Fold every line in the region. 1999-09-02 Shenghuo ZHU * gnus-srvr.el (gnus-browse-foreign-server): Read the first line of active file. 1999-09-01 Didier Verna * message.el (message-mode): allows whitespaces between multiple instances of the fill character ">". 1999-09-24 18:02:50 Kim-Minh Kaplan * mm-encode.el (mm-qp-or-base64): Fix. 1999-09-01 12:18:01 Katsumi Yamaoka * message.el (message-send): Too much and. 1999-09-24 17:58:07 Andreas Schwab * gnus-art.el (gnus-mime-view-part-as-type): Renamed. 1999-08-28 12:44:20 Lars Magne Ingebrigtsen * gnus-score.el (gnus-score-headers): Work for nil scores. 1999-08-27 20:46:11 Lars Magne Ingebrigtsen * gnus-cache.el (gnus-cache-write-active): Write full names. * gnus-util.el (gnus-write-active-file): Accept full name. * mm-decode.el (mm-inlinable-p): Use string-match on the types. (mm-assoc-string-match): New function. (mm-display-inline): Use it. * gnus-group.el (gnus-group-set-info): Work for nil group params. * gnus-msg.el (gnus-configure-posting-styles): Allow eval. 1999-08-27 19:08:10 Florian Weimer * mml.el (mml-generate-multipart-alist): New variable. 1999-08-27 15:30:02 Lars Magne Ingebrigtsen * gnus-art.el (gnus-treat-predicate): Work for (not 5). 1999-08-27 Peter von der Ahe * message.el (message-send): More helpful error message if sending fails 1999-09-06 Robert Bihlmeyer * gnus-score.el (gnus-summary-increase-score): "Lars" was broken in newer emacsen, where ?r isn't equal 114. Fri Aug 27 13:17:48 1999 Lars Magne Ingebrigtsen * gnus.el: Pterodactyl Gnus v0.96 is released. 1999-08-17 Simon Josefsson * gnus-start.el (gnus-groups-to-gnus-format): Only use agent to get active info if method is covered by agent, otherwise active info is lost. 1999-08-17 Simon Josefsson * gnus-sum.el (gnus-summary-move-article): Report backend errors. 1999-08-09 Dave Love * mm-util.el: Use `defalias', not `fset' for dummy functions. 1999-08-09 Simon Josefsson * gnus-art.el (gnus-ignored-headers): Remove "X-Pgp-*" (already matched by "^X-Pgp"), removed duplicate X-Mailing-List, added several new junk headers. 1999-08-01 Simon Josefsson * gnus-art.el (article-decode-charset): Don't assume gnus-summary-buffer is live. 1999-08-27 15:07:43 Paul Flinders * smiley.el (smiley-deformed-regexp-alist): Fix % smileys. 1999-08-27 15:02:58 Florian Weimer * gnus-score.el (gnus-home-score-file): Work with absolute path names. 1999-07-17 Shenghuo ZHU * gnus-sum.el (gnus-articles-to-read): Return cached articles if nothing else in the group. 1999-07-16 Shenghuo ZHU * gnus-bcklg.el (gnus-backlog-enter-article): Check the size of the article. 1999-07-15 Shenghuo ZHU * mm-uu.el (mm-uu-dissect): Fix for base64 message. 1999-07-15 Shenghuo ZHU * mm-uu.el (mm-uu-forward-end-line): Support forwarded message from mutt. 1999-07-14 Shenghuo ZHU * mm-bodies.el (mm-decode-content-transfer-encoding): Delete whitespace. 1999-07-14 Shenghuo ZHU * mm-util.el (mm-text-coding-system-for-write): New variable. (mm-append-to-file): New function. (mm-write-region): New function. * gnus-art.el (gnus-output-to-file): Use it. * gnus-util.el (gnus-output-to-rmail): Ditto. (gnus-output-to-mail): Ditto. * gnus-uu.el (gnus-uu-binhex-article): Ditto. 1999-07-14 Shenghuo ZHU * nnmail.el (nnmail-find-file): Use mm-auto-mode-alist. * nnheader.el (nnheader-insert-file-contents): Revert and use mm-insert-file-contents. (nnheader-find-file-noselect): Use mm-auto-mode-alist. (nnheader-auto-mode-alist): Removed. * mm-util.el (mm-inhibit-file-name-handlers): New variable. (mm-insert-file-contents): Add a new parameter for inserting compressed file literally. * mml.el (mml-generate-mime-1): Insert non-text literally. * gnus.el: Change most mm-insert-file-contents back to nnheader. 1999-07-13 Hrvoje Niksic * gnus-art.el (gnus-unbuttonized-mime-types): Fix docstring. 1999-08-27 14:53:42 Oleg S. Tihonov * gnus-sum.el (gnus-group-charset-alist): Default fido7 to koi8-r. 1999-07-11 Shenghuo ZHU * mml.el (mml-insert-mime): Decode text. (mml-to-mime): Narrow to headers-or-head. 1999-07-11 Shenghuo ZHU * mm-view.el (mm-inline-text): Check w3-meta-content-type-charset-regexp. 1999-07-10 Simon Josefsson * gnus-agent.el (gnus-agent-fetch-group-1): Search topics for predicate. 1999-07-10 Alexandre Oliva * gnus-mlspl.el: Documentation fixes. 1999-08-27 14:42:14 Rui Zhu * gnus-sum.el (gnus-summary-limit-to-age): Prompt better. 1999-08-27 14:40:52 Michael Cook * gnus-art.el (gnus-article-setup-buffer): Kill all local variables. 1999-08-27 14:39:34 Hrvoje Niksic * nnmail.el (nnmail-get-new-mail): "Done". 1999-08-27 14:38:14 Lars Magne Ingebrigtsen * gnus-group.el (gnus-group-kill-all-zombies): Only prompt when interactive. 1999-07-12 Shenghuo ZHU * gnus-art.el (article-decode-charset): Fix broken CT. 1999-07-12 Shenghuo ZHU * gnus-agent.el (gnus-agent-fetch-group-1): Recreate agent overview buffer if it is killed. 1999-08-27 14:26:03 Eric Marsden * gnus-art.el (article-babel): New version. 1999-08-27 14:22:39 Jon Kv * nnfolder.el (nnfolder-request-list-newsgroups): Faster expiry. 1999-07-10 Mike McEwan * gnus.texi (More Threading): Document new variable `gnus-sort-gathered-threads-function'. 1999-07-10 Mike McEwan * gnus.texi (More Threading): Document new variable `gnus-sort-gathered-threads-function'. 1999-07-11 Andreas Jaeger * gnus-uu.el (gnus-uu-digest-mail-forward): Delete file after usage. 1999-07-10 Shenghuo ZHU * mm-util.el (mm-running-xemacs): Removed. (mm-coding-system-p): New function. (mm-binary-coding-system): Safe guess. (mm-text-coding-system): Ditto. (mm-auto-save-coding-system): Ditto. 1999-07-11 11:02:03 Lars Magne Ingebrigtsen * mm-encode.el (mm-qp-or-base64): Also consider control chars. (mm-qp-or-base64): Reversed logic. * mm-decode.el (mm-save-part-to-file): Let coding system be binary. 1999-07-15 Mike McEwan * gnus-agent.el (gnus-agent-fetch-group-1): Allow 'agent-score' to be set in topic parameters. 1999-07-10 Mike McEwan * gnus-sum.el (gnus-sort-gathered-threads-function): New variable. (gnus-sort-gathered-threads): Allow the user to specify the function to use when sorting gathered threads. * gnus-agent.el (gnus-agent-get-undownloaded-list): Don't mark cached articles as `undownloaded'. Tue Jul 20 02:39:56 1999 Peter von der Ahe * gnus-sum.el (gnus-summary-exit): Allow gnus-use-adaptive-scoring to have buffer local values. 1999-07-25 Matt Pharr * gnus-group.el (gnus-group-make-doc-group): Notice when user types 'g' for 'guess group type. 1999-07-30 Simon Josefsson * nnmail.el (nnmail-remove-list-identifiers): Remove whitespace after each regexp in nnmail-list-identifiers, not just after last one. * gnus-sum.el (gnus-list-identifiers): New variable. (gnus-summary-remove-list-identifiers): New function. (gnus-select-newsgroup): Use it. (gnus-summary-wash-hide-map): Bind `gnus-article-hide-list-identifiers' to W W l. (gnus-summary-make-menu-bar): Add list-identifiers command. * gnus-art.el (gnus-treat-strip-list-identifiers): New variable. (gnus-treatment-function-alist): Add variable. (article-hide-list-identifiers): New function. (mapcar): Add function. (gnus-article-hide): Use it. Fri Jul 9 22:21:16 1999 Lars Magne Ingebrigtsen * gnus.el: Pterodactyl Gnus v0.95 is released. 1999-07-09 21:46:05 Lars Magne Ingebrigtsen * mm-decode.el (mm-mailcap-command): New function. (mm-display-external): Use it. * gnus-art.el (article-make-date-line): Work for India. * mm-encode.el (mm-qp-or-base64): Typo. * gnus-topic.el (gnus-topic-goto-topic): Made into command. Fri Jul 9 19:28:29 1999 Lars Magne Ingebrigtsen * gnus.el: Pterodactyl Gnus v0.94 is released. 1999-07-09 21:19:23 Stainless Steel Rat * pop3.el: New version. 1999-07-09 20:01:44 Lars Magne Ingebrigtsen * mm-encode.el (mm-qp-or-base64): New function. (mm-content-transfer-encoding): Use it. * gnus-util.el (gnus-parse-netrc): Allow quoted names. 1999-07-08 Shenghuo ZHU * mm-decode.el (mm-display-external): Fix typo and use 'non-viewer. * mailcap.el (mailcap-mailcap-entry-passes-test): Add needsterminal. 1999-07-09 18:52:22 Lars Magne Ingebrigtsen * gnus-art.el (gnus-mime-view-part-as-media): New command and keystroke. * mailcap.el (mailcap-mime-types): New function. * nnmh.el (nnmh-request-group): Update nnmh-group-alist. * message.el (message-goto-eoh): Really go to the end. 1999-07-09 18:40:23 Puneet Goel * message.el (message-make-date): Do the right thing in with sub-hour time zones. 1999-07-09 18:36:21 Lars Magne Ingebrigtsen * gnus-group.el (gnus-group-make-menu-bar): Removed double bug report. 1999-07-08 Shenghuo ZHU * nnfolder.el (nnfolder-request-rename-group): Create directory. 1999-07-08 Shenghuo ZHU * mailcap.el (mailcap-parse-mailcap): Skip \;. (mailcap-parse-mailcap-extras): Fix "nonterminal;" and empty name, and use t as default value. Wed Jul 7 18:40:30 1999 Shenghuo ZHU * gnus-sum.el (gnus-get-newsgroup-headers): Don't assume gnus-summary-buffer is live. 1999-07-09 17:44:03 Robert Pluim * mm-util.el (mm-enable-multibyte): Check whether var bound. 1999-07-09 17:31:39 Lars Magne Ingebrigtsen * message.el (message-bounce): Do MIME bounces MIMEy. * gnus-sum.el (gnus-summary-read-group-1): Update mark positions. 1999-07-08 08:41:10 Lars Magne Ingebrigtsen * mailcap.el (mailcap-mime-extensions): Changed patch to text/x-patch. * mm-decode.el (mm-display-external): Wrong placement of paren. Wed Jul 7 13:09:51 1999 Lars Magne Ingebrigtsen * gnus.el: Pterodactyl Gnus v0.93 is released. 1999-07-08 Alexandre Oliva * gnus-cus.el (gnus-group-parameters): New entries for gnus-group-split. * gnus-mlspl.el: Renamed functions and variables so as to start with gnus-group-split. * gnus.el: Adjust autoload entries. 1999-07-07 Alexandre Oliva * gnus-mlspl.el: Removed trailing t from comment and provide. Renamed functions and variables to start with gnus-mlsplit. Added autoload comments. * gnus.el: Added autoload entries. 1999-07-06 05:37:46 Alexandre Oliva * nnmail.el (nnmail-split-it): Search the regexp multiple times, so that matches excluded by RESTRICTs do not cause the whole split to be ignored. This also fixes a long-standing bug in which a split with \N substitutions wouldn't cause cross-posting as expected. * nnmail.el (nnmail-split-fancy): Document RESTRICT clauses. (nnmail-split-it): Implement them. * nnmail.el (nnmail-split-fancy): Document ! splits. 1999-07-07 10:41:11 Stainless Steel Rat * pop3.el: New version. 1999-07-05 Simon Josefsson * gnus-srvr.el (gnus-browse-foreign-server): Use read. 1999-07-07 10:37:26 Lars Magne Ingebrigtsen * gnus-art.el (gnus-mime-display-alternative): Do treatment. 1999-07-06 Shenghuo ZHU * gnus-util.el (gnus-write-active-file): Use real name. * gnus-agent.el (gnus-agent-expire): Update active file method by method. 1999-07-06 Shenghuo ZHU * nndraft.el (nndraft-request-article): Use difference coding-systems for queue and drafts. * gnus-sum.el (gnus-summary-setup-default-charset): Special-case nndraft:drafts. * mm-util.el (mm-auto-save-coding-system): New coding system. * message.el (message-draft-coding-system): Use it. 1999-07-06 Shenghuo ZHU * mm-uu.el: More customizable and less aggressive. 1999-07-07 07:53:23 Lars Magne Ingebrigtsen * gnus-start.el (gnus-groups-to-gnus-format): Only gnus-active when plugged. * mml.el (mml-generate-mime-1): Don't insert nofile files. (mml-insert-mml-markup): Accept a nofile. (mml-insert-mime): Insert nofile. * gnus-art.el (gnus-treat-strip-blank-lines): Removed. * mm-decode.el (mm-handle-media-type): New function. (mm-handle-media-supertype): New function. (mm-handle-media-subtype): New function. Use new functions throughout. "/")) 1999-05-18 03:03:50 Katsumi Yamaoka * gnus-art.el (gnus-treat-predicate): Typo. 1999-07-07 06:21:36 Lars Magne Ingebrigtsen * gnus-score.el (gnus-summary-score-entry): Made un-interactive. 1999-07-06 17:57:16 Lars Magne Ingebrigtsen * gnus-art.el (article-date-ut): UT! Default it! Tue Jul 6 10:59:24 1999 Lars Magne Ingebrigtsen * gnus.el: Pterodactyl Gnus v0.92 is released. 1999-07-06 12:30:59 Johannes Weinert * gnus-sum.el (gnus-summary-catchup-and-exit): Doc fix. 1999-07-06 07:41:07 Lars Magne Ingebrigtsen * nntp.el (nntp-retrieve-groups): Don't do anything when not connected. * gnus-start.el (gnus-active-to-gnus-format): Only save active when plugged. * mm-view.el (mm-inline-message): Ignore remove-spec. * gnus-agent.el (gnus-agent-write-active): Check whether orig sym is bound. * gnus-msg.el (gnus-summary-mail-forward): Rename From_ lines. * nndoc.el (nndoc-guess-type): Remove blank lines at the start. * nnfolder.el (nnfolder-read-folder): Remove blank lines at the start. * message.el (message-fill-yanked-message): Remove `t' arg. * gnus-group.el (gnus-group-kill-group): Message killing of groups. * mm-util.el (mm-preferred-coding-system): New function. (mm-mime-charset): Use it. * mml.el (mml-generate-mime-1): Charset-encode message parts. 1999-07-06 07:03:31 Alexandre Oliva * gnus-mlsplt.el: New file. 1999-07-06 05:47:57 Lars Magne Ingebrigtsen * mm-decode.el (mm-inline-Media-tests): Changed from forms to functions. (mm-attachment-override-p): Take a handle instead of a type. (mm-inlined-p): Ditto. (mm-automatic-display-p): Ditto, (mm-inlinable-p): Ditto. * nndraft.el (nndraft-request-expire-articles): Delete backup files. * mailcap.el (mailcap-parse-mailcap): Regexp-quote stuff. * gnus-sum.el (gnus-summary-limit-to-extra): Typo. 1999-07-06 05:37:46 Alexandre Oliva * nnmail.el (nnmail-split-it): Allow .*. 1999-07-05 05:04:57 Lars Magne Ingebrigtsen * mm-decode.el (mm-inline-large-images-p): Renamed. * gnus-art.el (article-date-ut): Always look in the current buffer for the Date header. * mml.el (mml-validate): New command. * mailcap.el (mailcap-possible-viewers): Revert to string-match since we are dealing with regexps. Sun Jul 4 06:31:01 1999 Lars Magne Ingebrigtsen * gnus.el: Pterodactyl Gnus v0.91 is released. 1999-07-04 04:35:28 Lars Magne Ingebrigtsen * gnus-agent.el (gnus-agent-save-active-1): New function. (gnus-agent-save-active): use it. (gnus-agent-save-groups): Ditto. * gnus-cache.el (gnus-cache-write-active): Use it. * gnus-agent.el (gnus-agent-write-active): Use it. * gnus-util.el (gnus-write-active-file): New function. * gnus-agent.el (gnus-agent-write-active): New function to keep lower boundaries and canceled groups. (gnus-agent-save-groups): Use it. (gnus-agent-save-active): Use it. (gnus-agent-save-group-info): Only write active files. (gnus-agent-expire): Update active file. * mm-decode.el (mm-inlinable-part-p): Removed. (mm-user-display-methods): Default to nil. (mm-user-display-methods): Removed. (add-mime-display-method): Removed. (mm-automatic-display): Renamed. (mm-automatic-display-p): Use it. (mm-inlined-types): New variable. (mm-inlined-p): New function. * message.el (message-reply): Bind message-this-is-mail. 1999-07-03 13:16:31 Michael Klingbeil * smiley.el (smiley-buffer): Fix for NT. 1999-07-03 11:26:47 Lars Magne Ingebrigtsen * mm-encode.el (mm-encode-buffer): Check whether we have 7bit. * message.el (message-check-news-header-syntax): Protect against nil froms. * mm-util.el (mm-auto-mode-alist): New. * mml.el (mml-generate-mime-1): Ditto. * gnus.el: Use mm-insert-file-contents throughout instead of nnheader. * mm-util.el (mm-insert-file-contents): New function. Sat Jul 3 07:35:35 1999 Lars Magne Ingebrigtsen * gnus.el: Pterodactyl Gnus v0.90 is released. 1999-07-03 09:31:10 Sven Fischer * mailcap.el (mailcap-possible-viewers): Use string=. 1999-07-01 Shenghuo ZHU * mm-uu.el (mm-uu-forward-begin-line): New variable. (mm-uu-forward-end-line): New variable. (mm-uu-begin-line): Handle forwarded message. (mm-uu-identifier-alist): Ditto. (mm-uu-dissect): Ditto. 1999-06-29 Shenghuo ZHU * lpath.el: Two free variables. 1999-07-02 Shenghuo ZHU * nnheader.el (nnheader-file-coding-system): Use raw-text. * gnus-agent.el (gnus-agent-file-coding-system): Ditto. * gnus-cache.el (gnus-cache-coding-system): Ditto. * nnfolder.el (nnfolder-file-coding-system): Use mm-text-coding-system. (nnfolder-file-coding-system-for-write): New variable. (nnfolder-active-file-coding-system): New variable. (nnfolder-active-file-coding-system-for-write): New variable. (nnfolder-save-active): New function. (nnfolder-save-buffer): Use them. (nnfolder-possibly-change-group): Ditto. (nnfolder-request-list-newsgroups): Ditto. (nnfolder-request-create-group): Ditto. (nnfolder-request-expire-articles): Ditto. (nnfolder-request-move-article): Ditto. (nnfolder-request-accept-article): Ditto. (nnfolder-request-delete-group): Ditto. (nnfolder-request-rename-group): Ditto. (nnfolder-possibly-change-folder): Ditto. (nnfolder-read-folder): Ditto. (nnfolder-request-list): Remove pathname-coding-system. (nnfolder-possibly-change-group): Use nnmail-pathname-coding-system. * nnmail.el (nnmail-file-coding-system): Use raw-text. (nnmail-file-coding-system-1): Removed. (nnmail-find-file): Use nnmail-pathname-coding-system. (nnmail-write-region): Ditto. * nnmbox.el (nnmbox-file-coding-system): New variable. (nnmbox-file-coding-system-for-write): New variable. (nnmbox-active-file-coding-system): New variable. (nnmbox-active-file-coding-system-for-write): New variable. (nnmbox-save-buffer): New function. (nnmbox-save-active): New function. (nnmbox-request-scan): Use them. (nnmbox-request-expire-articles): Ditto. (nnmbox-request-move-article): Ditto. (nnmbox-request-accept-article): Ditto. (nnmbox-request-replace-article): Ditto. (nnmbox-request-delete-group): Ditto. (nnmbox-request-rename-group): Ditto. (nnmbox-request-create-group): Ditto. * mm-util.el (mm-text-coding-system): raw-text or -dos. (mm-running-ntemacs): Removed. * nnml.el (nnml-file-coding-system): Use nnmail-file-coding-system. 1999-07-02 Shenghuo ZHU * nnfolder.el (nnfolder-read-folder): Use nnheader-file-coding-system. 1999-07-01 Shenghuo ZHU * qp.el (quoted-printable-encoding-characters): Support lower case. 1999-07-01 Shenghuo ZHU * rfc2047.el (rfc2047-encode): Fold before B-encoding. (rfc2047-b-encode-region): Encode line by line. 1999-07-03 09:20:16 Lars Magne Ingebrigtsen * mm-util.el (mm-find-mime-charset-region): Fix. 1999-06-30 KOSEKI Yoshinori * mm-util.el (mm-mime-mule-charset-alist): Fix iso-2022-jp(-2) bug. (mm-find-mime-charset-region): Ditto. 1999-07-03 09:15:35 Simon Josefsson * gnus-sum.el (gnus-summary-move-article): Fix something or other. 1999-06-29 Shenghuo ZHU * gnus-sum.el (gnus-newsgroup-ephemeral-charset): New variable. (gnus-newsgroup-ephemeral-ignored-charsets): New variable. (gnus-summary-enter-digest-group): Use them. (gnus-summary-setup-default-charset): Ditto. 1999-06-15 Shenghuo ZHU * base64.el (base64-run-command-on-region): Use unibyte buffer. 1999-06-15 Shenghuo ZHU * gnus-msg.el (gnus-configure-posting-styles): Fix bug when gnus-newsgroup-name is nil. 1999-06-15 Shenghuo ZHU * rfc2047.el (rfc2047-encode): Chop the tail newline. 1999-06-15 Shenghuo ZHU * gnus-art.el (article-emphasize): Use correct gnus-article-emphasis-alist. 1999-06-15 Shenghuo ZHU * mm-view.el (mm-inline-text): Fix text/html bug. Mon Jun 28 17:54:01 1999 Lars Magne Ingebrigtsen * gnus.el: Pterodactyl Gnus v0.89 is released. 1999-06-24 Shenghuo ZHU * nnmail.el (nnmail-file-coding-system-1): For NTEmacs in Windows. * message.el (message-draft-coding-system): Ditto. * mm-util.el (mm-running-ntemacs): Ditto. 1999-06-23 Shenghuo ZHU * gnus-xmas.el (gnus-xmas-summary-recenter): A blank line may cause problem. 1999-06-23 Shenghuo ZHU * mm-view.el (mm-inline-text): Ignore error in w3-region. 1999-06-23 Shenghuo ZHU * mml.el: require mm-decode. 1999-06-23 Shenghuo ZHU * gnus-art.el (gnus-display-mime): Treat as head only if necessary. 1999-06-23 Shenghuo ZHU * mm-view.el (mm-inline-image): Fix image undisplayer. 1999-06-22 Shenghuo ZHU * mml.el (mml-insert-multipart): Error in compeling-read. (mml-insert-tag): Match tags. 1999-06-19 Shenghuo ZHU * gnus-cache.el (gnus-cache-braid-nov): Fix coding-system bug. (gnus-cache-braid-heads): Ditto. (gnus-cache-retrieve-headers): Ditto. 1999-06-16 Shenghuo ZHU * gnus-draft.el (gnus-draft-send): Fix encoding bug. 1999-06-16 10:17:29 Katsumi Yamaoka * gnus-art.el (gnus-article-read-summary-keys): Convert key events to string under XEmacs. 1999-06-28 19:34:03 Petersen Jens-Ulrik * gnus-start.el (gnus-find-new-newsgroups): Doc fix. 1999-06-22 Shenghuo ZHU * mm-view.el (mm-inline-message): Fix message view bug. * gnus-art.el (gnus-article-prepare): Ditto. 1999-06-16 Shenghuo ZHU * gnus-cache.el (gnus-cache-possibly-enter-article): Fetch headers. Tue Jun 15 04:13:01 1999 Lars Magne Ingebrigtsen * gnus.el: Pterodactyl Gnus v0.88 is released. 1999-06-15 04:13:45 Lars Magne Ingebrigtsen * gnus-sum.el (gnus-summary-save-parts): Destroy handles after usage. * nnmail.el (nnmail-get-new-mail): Save info. Mon Jun 14 01:15:59 1999 Lars Magne Ingebrigtsen * gnus.el: Pterodactyl Gnus v0.87 is released. 1999-06-14 02:46:05 Lars Magne Ingebrigtsen * mail-source.el (mail-source-fetch-file): Use prescript-delay. (mail-source-run-script): New function. (mail-source-fetch-pop): Use it. 1999-06-13 09:52:11 Lars Magne Ingebrigtsen * gnus-art.el (gnus-article-setup-highlight-words): Moved here. Sun Jun 13 07:30:40 1999 Lars Magne Ingebrigtsen * gnus.el: Pterodactyl Gnus v0.86 is released. 1999-06-13 08:51:25 Lars Magne Ingebrigtsen * gnus-art.el (gnus-treat-translate): New variable. (gnus-treat-predicate): Accept a list of regexps. (gnus-article-treat-custom): Allow a list of regexps. 1999-06-09 Markus Rost * gnus-group.el (gnus-permanently-visible-groups): Fix custom type. 1999-06-13 05:15:52 Lars Magne Ingebrigtsen * gnus-art.el (article-babel): Narrow a bit. * gnus-agent.el (gnus-agent-get-undownloaded-list): Was too slow. 1999-06-12 Simon Josefsson (gnus-agent-get-undownloaded-list): Operate on all articles, not only unread ones. (gnus-agent-fetch-headers): Fetch headers from unread and marked articles, not only unread ones. 1999-06-13 03:01:35 Lars Magne Ingebrigtsen * gnus-sum.el (gnus-summary-limit-to-extra): New command and keystroke. * gnus-art.el (gnus-article-x-face-command): Ditto. * gnus-uu.el (gnus-uu-default-view-rules): Default to "display". * gnus.el (gnus-method-simplify): Accept server names. 1999-06-13 02:36:15 Per Abrahamsen * gnus-art.el (article-babel-prompt): New function. (article-babel): New command. 1999-06-13 01:01:52 Lars Magne Ingebrigtsen * gnus-art.el (gnus-article-part-wrapper): Go to part. * mml.el (mml-generate-mime-1): Don't insert literally. * gnus-util.el (gnus-parse-netrc): Skip lines with #'s. (gnus-netrc-syntax-table): Removed. (gnus-parse-netrc): Don't use syntax table; just use whitespace. Wed May 5 13:51:13 1999 Shenghuo ZHU * mm-view.el (mm-inline-text): Fix charset for text/html. Wed May 5 01:15:08 1999 Shenghuo ZHU * message.el (message-draft-coding-system): Use emacs-mule-dos. 1999-06-12 07:29:39 Lars Magne Ingebrigtsen * nnmail.el (nnmail-split-incoming): Return the number of split mails. (nnmail-process-babyl-mail-format): Ditto. (nnmail-process-unix-mail-format): Ditto. (nnmail-process-mmdf-mail-format): Ditto. (nnmail-process-maildir-mail-format): Ditto. * mail-source.el (mail-source-callback): Return the number from the callback. * message.el (message-send-mail): Generate Lines. * mail-source.el (mail-source-call-script): New function. (mail-source-call-script): New function. Sun May 2 02:00:27 1999 Shenghuo ZHU * gnus-sum.el (gnus-summary-setup-highlight-words): New function. (gnus-select-newsgroup): Use it. (gnus-group-highlight-words-alist): New variable. (gnus-newsgroup-emphasis-alist): New variable. (gnus-summary-local-variables): Use it. * lpath.el: Use it. * gnus-art.el (article-emphasize): Use it. (gnus-emphasis-highlight-words): New face. * gnus-cus.el (gnus-group-parameters): New parameter. Sun May 2 01:00:02 1999 Shenghuo ZHU * gnus-cache.el (gnus-cache-possibly-enter-article): Remove parameter `headers'. (gnus-cache-enter-article): Ditto. (gnus-cache-update-article): Ditto. * gnus-sum.el (gnus-summary-move-article): Ditto. (gnus-summary-mark-article-as-unread): Ditto. (gnus-summary-mark-article): Ditto. 1999-06-12 03:59:56 Lars Magne Ingebrigtsen * gnus-msg.el (gnus-message-insert-stylings): Removed. (gnus-posting-style-alist): Removed. (gnus-message-style-insertions): Ditto. (gnus-configure-posting-styles): Reimplementation. * mail-source.el (mail-source-fetch): Error the message. * gnus-msg.el (gnus-inews-do-gcc): Do mml and encoding. Sat Jun 12 00:19:57 1999 Lars Magne Ingebrigtsen * gnus.el: Pterodactyl Gnus v0.85 is released. 1999-04-20 Michael Cook * gnus-cite.el (gnus-cite-attribution-prefix): Tweak for MS Outlook citation regex. 1999-06-12 02:09:49 Lars Magne Ingebrigtsen * nndoc.el (nndoc-mime-parts-type-p): Accept space before semicolon. 1999-05-24 Simon Josefsson * gnus-range.el (gnus-remove-from-range): Document range1 modification, protect range2. 1999-05-24 Simon Josefsson * gnus-sum.el (gnus-update-marks): Protect lists from gnus-remove-from-range, don't sort twice. 1999-05-21 Simon Josefsson * gnus-start.el (gnus-read-descriptions-file): Protect if no function in backend. 1999-05-15 Simon Josefsson * gnus-sum.el (gnus-valid-move-group-p): Check for a request-accept-article function in the backend instead of using the 'respool capability. 1999-04-18 Hrvoje Niksic * mm-bodies.el (mm-decode-content-transfer-encoding): Handle spurious whitespace at eob. 1999-06-12 02:02:06 Adrian Aichner * nnmail.el (nnmail-get-new-mail): Check right variable. 1999-06-12 01:57:39 Karl Kleinpaste * mailcap.el (mailcap-mime-data): Fix rfc822. 1999-06-11 23:48:50 TOZAWA Akihiko * nndoc.el (nndoc-nsmail-type-p): New function. (nndoc-type-alist): Recognize nsmail. 1999-05-12 Mike McEwan * gnus-art.el (gnus-treatment-function-alist): Display `x-face' *before* `article-hide-headers' deletes the information. 1999-05-22 00:26:46 Lars Magne Ingebrigtsen * gnus-sum.el (gnus-summary-save-parts): New command and keystroke. (gnus-summary-save-parts-1): New function. (gnus-summary-iterate): Buggy. * mm-decode.el (mm-save-part-to-file): Made into own function. 1999-05-11 05:53:16 Lars Magne Ingebrigtsen * gnus-group.el (gnus-group-set-info): Resist nils. 1999-05-04 19:26:08 Lars Magne Ingebrigtsen * mailcap.el (mailcap-mime-data): Ditto. * gnus-uu.el (gnus-uu-default-view-rules): Ditto. * gnus-art.el (gnus-article-x-face-command): Default to ee. 1999-05-02 Gareth Jones * gnus-art.el (article-make-date-line): Put X-Sent below Date if gnus-article-date-lapsed-new-header is t. Sat May 1 20:27:43 1999 Lars Magne Ingebrigtsen * gnus.el: Pterodactyl Gnus v0.84 is released. 1999-05-01 22:23:21 Lars Magne Ingebrigtsen * gnus-msg.el (gnus-bug-message): Mime change. 1999-04-22 Simon Josefsson * gnus-sum.el (gnus-update-marks): Process null mark lists. 1999-04-21 Hrvoje Niksic * mm-bodies.el (mm-decode-content-transfer-encoding): Recognize `x-uue'. 1999-03-04 Aaron M. Ucko * mail-source.el (mail-source-fetch-pop): Only prompt for password when authentication is 'password. 1999-05-01 22:17:55 * gnus-win.el (gnus-configure-windows): Accept a setting. 1999-04-21 20:51:13 Lars Magne Ingebrigtsen * mm-util.el (mm-quote-arg): Moved here. * mm-decode.el (mm-quote-arg): Quote more chars. 1999-04-18 20:12:49 Lars Magne Ingebrigtsen * nnheader.el (nnheader-parse-head): Message-ID in In-Reply-To with newlines would create buggy .nov files. * gnus-art.el (gnus-article-date-lapsed-new-header): Default to nil. * qp.el (quoted-printable-encode-region): Encode whitespace at the end of lines. * message.el (message-mode): Doc fix. * gnus-art.el (article-hide-headers): Delete the hidden headers. * gnus-msg.el (gnus-setup-posting-charset): Default group to "". * gnus-art.el (article-date-ut): Rewrite. * mm-decode.el (mm-preferred-alternative-precedence): Reverse the order. * gnus-msg.el (gnus-message-insert-stylings): Remove duplicate headers. * gnus-art.el (gnus-article-date-lapsed-new-header): Doc fix. 1999-04-18 Didier Verna * gnus-art.el (gnus-article-date-lapsed-new-header): new variable. (article-date-ut): use it. 1999-04-18 20:06:20 Lars Magne Ingebrigtsen * mail-source.el (mail-source-fetch-pop): Call script asynchronously. Sun Apr 18 12:40:04 1999 Lars Magne Ingebrigtsen * gnus.el: Pterodactyl Gnus v0.83 is released. 1999-04-18 10:55:57 Lars Magne Ingebrigtsen * gnus-draft.el (gnus-draft-mode): Use mml minor mode. * gnus-cite.el (gnus-dissect-cited-text): Off-by-one error. * gnus-uu.el (gnus-uu-mark-thread): Save hidden threads. * gnus-art.el (gnus-mime-inline-part): Don't do a charset param. * gnus-msg.el (gnus-bug): Use application/x-emacs-lisp. * message.el (message-generate-headers): Accept continuation headers. 1999-04-18 10:48:57 Renaud Rioboo * gnus-demon.el (gnus-demon-time-to-step): Not strings. 1999-04-18 08:21:52 Lars Magne Ingebrigtsen * gnus-art.el (gnus-treatment-function-alist): use maybe-hide-headers. * message.el (message-inhibit-body-encoding): Typo. (message-resend): Inhibit encoding. * gnus-sum.el (gnus-summary-toggle-header): Decode rfc2047. * gnus-art.el (article-remove-cr): Use re-search. * rfc2231.el (rfc2231-parse-string): Allow broken elm MIME headers. * mm-decode.el (mm-quote-arg): Quote '. * gnus-ems.el (gnus-x-splash): Would place splash wrongly. * mm-decode.el (mm-insert-part): Use multibyte for text. * gnus-start.el (gnus-read-newsrc-file): New variable. (gnus-read-newsrc-file): Use it. 1999-04-17 18:51:54 Lars Magne Ingebrigtsen * nnvirtual.el (nnvirtual-request-expire-articles): New function. * gnus-group.el (gnus-group-expire-articles-1): Made into own function. Sat Apr 17 16:41:30 1999 Lars Magne Ingebrigtsen * gnus.el: Pterodactyl Gnus v0.82 is released. 1999-04-15 Hrvoje Niksic * gnus-sum.el (gnus-group-charset-alist): Include Croatian groups for iso8859-2. 1999-04-17 18:23:50 Lars Magne Ingebrigtsen * mm-util.el (mm-charset-synonym-alist): Remove iso-2022-jp-2 from synonym alist. 1999-04-17 18:03:38 Adam P. Jenkins * gnus-sum.el (gnus-summary-local-variables): Mark as global. 1999-04-17 18:02:05 Ettore Perazzoli * mail-source.el (mail-source-fetch): Ask before bugging out. 1999-03-19 Hrvoje Niksic * uudecode.el (uudecode-decode-region-external): Don't assume uudecode-temporary-file-directory ends with a slash. 1999-03-18 Simon Josefsson * gnus-sum.el (gnus-update-marks): (gnus-update-read-articles): (gnus-summary-expire-articles): Check server. 1999-03-16 Simon Josefsson * mml.el (mml-preview): New function. 1999-04-17 17:10:21 William M. Perry * mail-source.el (mail-source-fetch-file): Return the right value. 1999-04-17 07:52:17 Lars Magne Ingebrigtsen * mml.el (mml-insert-parameter): New function. (mml-insert-parameter-string): New function. * nnmail.el (nnmail-get-new-mail): Say how many new articles. * gnus-art.el (gnus-mime-multipart-functions): New variable. (gnus-mime-display-part): Use it. * mm-decode.el (mm-alternative-precedence): Removed. (mm-discouraged-alternatives): New variable. (mm-preferred-alternative-precedence): New function. * nnmail.el (nnmail-get-new-mail): Use mail-sources. * mail-source.el (mail-sources): New variable. * gnus-art.el (article-remove-cr): Remove several trailing CRs. * mm-decode.el (mm-valid-image-format-p): New function. (mm-inline-media-tests): Use it. (mm-valid-and-fit-image-p): New function. * gnus-agent.el (gnus-agent-fetch-groups): Error when unplugged. (gnus-agent-fetch-group): Ditto. 1999-04-12 Didier Verna * nnmail.el (nnmail-article-group): in case of a group name containing "\\n" constructs, be sure to pass the expanded value to nn*-save-mail. Sat Apr 17 05:40:45 1999 Lars Magne Ingebrigtsen * gnus.el: Pterodactyl Gnus v0.81 is released. 1999-04-16 15:54:02 Lars Magne Ingebrigtsen * gnus-sum.el (gnus-get-split-value): Reverse result. 1999-04-03 00:17:24 Lars Magne Ingebrigtsen * gnus-start.el (gnus-always-read-dribble-file): Doc fix. 1999-04-02 15:33:43 Lars Magne Ingebrigtsen * mml.el (mml-insert-tag): Insert concluding part. * message.el (message-send-mail): Encode later. (message-send-news): Ditto. * nnfolder.el: Don't use mail delim. 1999-03-28 19:14:27 Lars Magne Ingebrigtsen * gnus-cus.el (gnus-group-customize): Put point at min. * mm-view.el (mm-inline-text): Allow toggling html. 1999-03-28 17:11:15 William M. Perry * mail-source.el: Added prescript and postscript to file. 1999-03-28 13:46:00 Lars Magne Ingebrigtsen * nnmail.el: Reverted. * gnus-msg.el (gnus-setup-posting-charset): Didn't work. (gnus-setup-posting-charset): Did work. 1999-03-28 13:19:50 Jae-you Chung * gnus.el (gnus-short-group-name): Use gnus-group-uncollapsed-levels. 1999-03-28 13:11:43 Lars Magne Ingebrigtsen * gnus-cite.el (gnus-dissect-cited-text): Don't remove overlays. 1999-03-26 13:18:45 Lars Magne Ingebrigtsen * gnus-art.el (gnus-treat-strip-headers-in-body): New variable. (article-strip-headers-from-body): New command and keystroke. 1999-03-14 16:09:10 Lars Magne Ingebrigtsen * mail-source.el (mail-source-fetch-pop): Check for symbol first. * nnheader.el (nnheader-insert-file-contents): Bind enable-local-eval to nil. (nnheader-find-file-noselect): Ditto. * nnmail.el (nnmail-article-group): Don't remove long lines. (nnmail-remove-long-lines): New function. (nnmail-split-header-length-limit): Removed. * mml.el (mml-generate-mime-1): Use unibyte buffers. * gnus-group.el (gnus-group-kill-all-zombies): Query user. 1999-03-06 07:20:05 Lars Magne Ingebrigtsen * gnus-sum.el (gnus-summary-generic-mark): New function. * nnmail.el (nnmail-split-header-length-limit): Increased. (nnmail-article-group): Allow nil. * gnus-cite.el (gnus-cite-parse-wrapper): Inhibit point-motion. * nndoc.el (nndoc-generate-mime-parts-head): Insert real headers first. * mml.el (mml-minibuffer-read-type): Include types from mailcap-mime-data. * nndraft.el (nndraft-request-article): Would clobber Japanese. 1999-03-05 Hrvoje Niksic * mml.el (mml-insert-tag): New function. (mml-read-file): Renamed to mml-minibuffer-read-file to avoid confusion with functions like `mml-read-tag'. (mml-read-type): Ditto with `mml-minibuffer-read-type'. (mml-minibuffer-read-description): Ditto with `mml-minibuffer-read-description'. (mml-attach-buffer): New function. (mml-mode-map): New entry for /. (mml-minibuffer-read-type): Accept DEFAULT. * mml.el (mml-quote-region): Narrow the region. * message.el (message-mode-menu): message-mime-attach-file is now mml-attach-file. 1999-03-05 21:24:23 Lars Magne Ingebrigtsen * gnus-art.el (gnus-treatment-function-alist): Do emphasis earlier. 1999-03-05 21:08:10 Robert Bihlmeyer * mml.el (mml-attach-buffer): New command. 1999-02-27 Simon Josefsson * gnus-sum.el (gnus-update-marks): Call gnus-remove-from-range with a proper range. Compress range. * gnus-range.el (gnus-remove-from-range): Protect arguments. 1999-03-05 20:59:54 Lars Magne Ingebrigtsen * mm-decode.el (mm-get-image): Create a temporary file for xbms. 1999-03-04 04:20:25 Lars Magne Ingebrigtsen * gnus-picon.el (gnus-picons-x-face-file-name): Removed. (gnus-picons-convert-x-face): Removed. (gnus-picons-article-display-x-face): Removed. (gnus-picons-x-face-sentinel): Ditto. (gnus-picons-display-x-face): Ditto. Thu Mar 4 01:38:00 1999 Lars Magne Ingebrigtsen * gnus.el: Pterodactyl Gnus v0.80 is released. 1999-03-02 16:04:30 Lars Magne Ingebrigtsen * gnus-art.el (gnus-mm-display-part): Narrow to the part itself. * gnus-sum.el (gnus-with-article): Moved here. * mail-source.el (mail-source-fetch-pop): Ask for password even when program. 1999-02-28 13:16:12 Lars Magne Ingebrigtsen * gnus-msg.el (gnus-bug): Add description. * mml.el (mml-insert-mml-markup): Insert disposition. * message.el (message-send-mail): Always encode mail headers. * smiley.el (gnus-smiley-display): Goto body. 1999-02-28 13:15:47 Petr Konecny * smiley.el (gnus-smiley-display): Don't search to blank line. 1999-02-28 00:38:40 Lars Magne Ingebrigtsen * gnus-art.el (gnus-treat-article): Only run the highlight stuff when requested. * nnmail.el (nnmail-current-spool): Removed. * gnus-salt.el (gnus-tree-inhibit): New varible. * gnus.el (mm-util): Required. 1999-02-27 23:44:52 paul stevenson * gnus-sum.el (gnus-summary-toggle-header): Narrow to head first. 1999-02-27 17:17:47 Lars Magne Ingebrigtsen * mail-source.el (mail-source-bind): Doc fix. 1999-02-26 20:35:57 Lars Magne Ingebrigtsen * message.el (message-mode): Doc fix. * mm-encode.el (mm-content-transfer-encoding-defaults): Use 8bit encoding. * gnus.el (gnus-methods-equal-p): Moved here. * mail-source.el: pop at 110. * pop3.el (pop3-movemail): Use write-region instead of append-to-file to avoid excessive messaging. 1999-02-27 lantz moore * nnmail.el (nnmail-get-new-mail): honor suffix for spool-files of type directory. 1999-03-04 Robert Bihlmeyer * gnus-art.el (article-hide-boring-headers): Field names must not contain whitespace. Fri Feb 26 18:54:16 1999 Lars Magne Ingebrigtsen * gnus.el: Pterodactyl Gnus v0.79 is released. 1999-02-26 18:11:04 Lars Magne Ingebrigtsen * gnus-cite.el (gnus-cite-toggle): Don't remove highlighting. * mml.el (mml-mode): Don't use add-minor-mode. * message.el (messgage-inhibit-body-encoding): New variable. (message-encode-message-body): Use it. Fri Feb 26 17:00:25 1999 Lars Magne Ingebrigtsen * gnus.el: Pterodactyl Gnus v0.78 is released. 1999-02-26 07:45:30 Lars Magne Ingebrigtsen * message.el (message-mode): Switch on MML mode. * mml.el: Included commands and functions. (mml-mode-map): New keymap. * message.el: Removed the insertion commands and functions. * gnus-ems.el (gnus-mule-cite-add-face): Removed. * gnus-sum.el (gnus-summary-sort-by-chars): New command and keystroke. * gnus-art.el (gnus-narrow-to-page): Revert. * gnus-cite.el (gnus-cite-delete-overlays): New function. (gnus-cite-parse-maybe): Always reparse. * message.el (message-encode-message-body): Don't insert "multipart warning". * gnus-art.el (gnus-article-treat-head-custom): New variable. 1999-02-25 Miles Bader * mail-source.el (mail-source-fetch-pop): Return 1 for success. * nnmail.el: Require mm-util. 1999-02-26 07:39:33 Justin Sheehy * nnmail.el (nnmail-get-new-mail): Only get mail for the one group. 1999-02-26 07:38:08 SeokChan LEE * mm-bodies.el (mm-body-charset-encoding-alist): Add euc-kr. 1999-02-21 Simon Josefsson * gnus-msg.el (gnus-extended-version): Better regexp. 1999-02-25 Didier Verna * nnmail.el (nnmail-split-it): new syntax: `(! FUNC SPLIT)'. FUNC is called with the result of SPLIT and should return a new split. * gnus.texi: update the doc. 1999-02-23 Didier Verna * gnus-picon.el (gnus-picons-display-bar-p): when picons are displayed in the article buffer, output bars if `gnus-picons-display-article-move-p'. 1999-02-20 Aaron M. Ucko * mail-source.el (mail-source-fetch-pop): Typo. 1999-02-26 07:15:12 Lars Magne Ingebrigtsen * gnus-sum.el (gnus-summary-toggle-header): Save restriction. 1999-02-23 03:07:58 Lars Magne Ingebrigtsen * gnus-cite.el (gnus-cite-parse-wrapper): Always parse. 1999-02-21 11:11:39 Lars Magne Ingebrigtsen * mml.el (mml-insert-buffer): New function. * message.el (message-forward): Insert the buffer in the buffer. Sun Feb 21 01:20:50 1999 Shenghuo ZHU * mm-view.el (mm-inline-message): Insert part in narrowed region. Sat Feb 20 23:09:40 1999 Shenghuo ZHU * gnus-sum.el (gnus-summary-toggle-header): Save restriction. Sat Feb 20 21:34:28 1999 Lars Magne Ingebrigtsen * gnus.el: Pterodactyl Gnus v0.77 is released. 1999-02-20 17:32:17 Lars Magne Ingebrigtsen * gnus-art.el (gnus-displaying-mime): New variable. (article-narrow-to-head): New function. * mail-source.el (mail-source-fetch-pop): Include pre/postscript. Default to pop instead of pop3. 1999-02-19 16:16:04 Lars Magne Ingebrigtsen * gnus-art.el (article-hide-pgp): Goto body. * gnus-uu.el (gnus-uu-digest-mail-forward): Don't kill buffer. * gnus-cite.el: Don't use goto-line. * gnus-art.el (gnus-article-treat-html): Removed. (gnus-treat-article): Save restriction. 1999-02-17 Per Abrahamsen * message.el (message-send-mail): Don't untabify. (message-mode): Don't use tabs for indentation. 1999-02-19 14:54:13 Lars Magne Ingebrigtsen * message.el (message-send-mail): Don't untabify. * nnml.el (nnml-save-mail): Typo fix. 1999-02-19 Per Abrahamsen * message.el (message-cite-function): Add `message-cite-original-without-signature' customization option. 1999-02-18 Per Abrahamsen * nnmail.el (nnmail-fix-eudora-headers): Mark as option to `nnmail-prepare-incoming-header-hook'. 1999-02-19 14:41:43 Justin Sheehy * gnus-util.el (gnus-make-sort-function-1): Typo fix. 1999-02-19 14:40:37 Lars Magne Ingebrigtsen * gnus-group.el (gnus-group-get-new-news): Require nnmail. 1999-02-18 Michael Cook * Recognize Microsoft Outlook's cite attribution conventions. 1999-02-19 14:33:11 James H. Cloos, Jr. * gnus-sum.el: Bind M. 1999-02-19 14:31:29 Neil Crellin * mail-source.el (mail-source-fetch-pop): Bind pop3-port. 1999-02-15 Didier Verna * gnus-picon.el (gnus-group-display-picons): ensures that `article-goto-body' really goes to the article body. 1999-02-19 12:57:19 Lars Magne Ingebrigtsen * mm-view.el (mm-inline-text): Bind url-standalone-mode. * gnus-msg.el (gnus-summary-mail-forward): Create unique names. * mm-view.el (mm-view-message): Enable multibyte. 1999-02-11 18:37:15 Lars Magne Ingebrigtsen * nnmail.el (nnmail-get-new-mail): Message later. * mm-util.el (mm-find-charset-region): Revert to checking multibyte. 1999-02-11 Matt Pharr * gnus-msg.el (gnus-bug): Encode environment info as a MIME attachment. Thu Feb 11 04:58:51 1999 Lars Magne Ingebrigtsen * gnus.el: Pterodactyl Gnus v0.76 is released. 1999-02-06 Felix Lee * gnus.el (gnus-group-change-level-function): Typo. 1999-02-11 05:47:51 Lars Magne Ingebrigtsen * gnus-sum.el (gnus-nov-skip-field): Removed. (gnus-nov-field): Ditto. (gnus-nov-parse-extra): Ditto. (gnus-nov-read-integer): Ditto. 1999-02-05 09:44:20 Katsumi Yamaoka * nnheader.el (nnheader-nov-read-message-id): New macro. (nnheader-parse-nov): Use it. * gnus-sum.el (gnus-nov-read-message-id): New macro. (gnus-nov-parse-line): Use it; use `(eobp)' instead of `(eq (char-after) ?\n)'. 1999-02-11 05:16:26 Lars Magne Ingebrigtsen * gnus.el (gnus-other-frame): Always pop up a new frame. Wed Feb 10 01:03:43 1999 Shenghuo ZHU * gnus-range.el (gnus-range-add): Rewrite. 1999-02-02 18:12:00 Carsten Leonhardt * nnmail.el (nnmail-split-incoming): Added detection of maildir format. (nnmail-process-maildir-mail-format): New function. * mail-source.el (mail-source-fetch-maildir): New function. (mail-source-keyword-map): Add default for maildir method. (mail-source-fetcher-alist): Changed "qmail" to "maildir". 1999-02-10 02:29:28 Lars Magne Ingebrigtsen * mail-source.el (mail-source-fetcher-alist): Remove apop. * nndoc.el (nndoc-type-alist): Remove MIME-digest. (nndoc-mime-digest-type-p): Removed. 1999-02-09 15:25:52 Lars Magne Ingebrigtsen * gnus-art.el (gnus-article-read-summary-keys): Set the point where it is supposed to be. (gnus-treat-play-sounds): New variable. * gnus-sum.el (gnus-newsgroup-ignored-charsets): New variable. * gnus-art.el (article-display-x-face): Narrow to head. (gnus-article-washed-types): New variable. (article-hide-pgp): Is not a toggle. (gnus-article-hide-text-type): Save types. (article-decode-charset): Use it. * nnmail.el (nnmail-get-new-mail): Ignore procmail. * message.el (message-forward-start-separator): Removed. (message-forward-end-separator): Removed. (message-signature-before-forwarded-message): Removed. (message-included-forward-headers): Removed. (message-check-news-body-syntax): Don't check forward. (message-forward): Use MIME. * nnvirtual.el (nnvirtual-request-article): Bind gnus-article-decode-hook to nil. 1999-02-06 16:55:25 Lars Magne Ingebrigtsen * mml.el (mml-parse-singlepart-with-multiple-charsets): Check for us-ascii. 1999-02-04 00:00:35 Lars Magne Ingebrigtsen * format-spec.el (format-spec): Be more robust. * message.el (message-encode-message-body): Default mail-parse-charset to mail-parse-charset. * gnus-sum.el (gnus-summary-edit-article-done): Don't encode. (gnus-summary-edit-article): Bind mail-parse-charset. * mml.el (mml-read-tag): Ignore white space after end of tag. * message.el (message-goto-body): Also work in separatorless articles. * mml.el (mml-translate-from-mime): New function. (mml-insert-mime): Ditto. (mml-to-mime): New function. (mime-to-mml): New name. * gnus-sum.el (gnus-summary-edit-article): Always select raw article. * gnus-group.el (gnus-group-catchup-current): Unmark groups. * gnus-sum.el (gnus-summary-setup-default-charset): Don't special-case nndraft groups. 1999-02-03 16:44:19 Lars Magne Ingebrigtsen * gnus-sum.el (gnus-get-newsgroup-headers): Bind charset. (gnus-get-newsgroup-headers): Already bound. * message.el (message-encode-message-body): Use posting charset. * mm-bodies.el (mm-encode-body): Use MIME charsets. (mm-body-encoding): Do CTE. (mm-body-7-or-8): New function. * mm-util.el (mm-mime-charset): Always fall back on alist. (mm-mime-mule-charset-alist): Include katakana-jisx0201. (mm-mime-mule-charset-alist): Add arabic-*-column. (mm-find-mime-charset-region): New function. * format-spec.el (format-spec-make): New function. * mail-source.el (format-spec): Required. (mail-source-fetch-with-program): Removed. (mail-source-fetch-with-program): New function. * format-spec.el: New file. 1999-02-03 16:00:41 Tatsuya Ichikawa * mail-source.el (mail-source-fetch-with-program): Take optional parameter. 1999-02-03 00:31:21 Lars Magne Ingebrigtsen * gnus-start.el: Ignore some groups. (gnus-setup-news): Bind nnmail-fetched-sources. * message.el (message-send-mail): Remove all tabs. * mm-util.el (mm-find-charset-region): Just check whether find-charset-region is defined. 1999-02-02 23:35:20 Lars Magne Ingebrigtsen * gnus-group.el (gnus-group-get-new-news): Use nnmail-fetched-sources. * nnmail.el (nnmail-fetched-sources): New variable. (nnmail-get-new-mail): Use it. * mail-source.el (mail-source-fetched-sources): New variable. (mail-source-fetch): Use it. 1999-02-02 23:20:20 Mark W. Eichin * gnus.el (gnus-getenv-nntpserver): if the file that gnus-nntpserver-file names has a trailing newline, the string-match will always match, and thus the file will never be read. (^ matches start of "line", \\` matches start of "buffer", which is what was intended...) 1999-02-02 23:17:40 Kim-Minh Kaplan * gnus-picon.el (gnus-picons-parse-filenames): Quote group names. 1999-01-28 04:15:46 Katsumi Yamaoka * gnus-start.el (gnus-read-active-file): Eliminate duplicated select methods. 1999-01-27 Simon Josefsson * gnus-range.el (gnus-remove-from-range): Sort second argument. 1999-02-02 10:55:23 Scott Hofmann * nntp.el: Use mail-source-read-passwd instead of nnmail-read-passwd. Mon Feb 1 23:23:03 1999 Shenghuo ZHU * gnus-cus.el (gnus-group-parameters): Charset as symbol, and fix a typo. * gnus-sum.el (gnus-summary-setup-default-charset): Set nndraft's charset to nil. * gnus-agent.el (gnus-agent-queue-setup): Remove charset setting. * gnus-start.el (gnus-start-draft-setup): Ditto. 1999-02-02 22:13:14 Lars Magne Ingebrigtsen * mail-source.el (mail-source-fetch-directory): Use the predicate. (mail-source-value): Don't do variables. * nnmail.el (nnmail-get-new-mail): Set the predicate. * gnus-sum.el (gnus-summary-toggle-header): Fix, and bound to t. 1999-02-01 Michael Cook * Defenestrate spurious ?a. 1999-02-02 21:59:51 Lars Magne Ingebrigtsen * mail-source.el (mail-source-fetch-pop): Instead use :authentication. 1999-02-01 Tatsuya Ichikawa * mail-source.el : Support APOP authentication scheme. 1999-02-02 21:56:14 Tatsuya Ichikawa * pop3.el (pop3-movemail): Return t. 1999-02-02 21:48:46 Lars Magne Ingebrigtsen * rfc2047.el (rfc2047-fold-region): New function. (rfc2047-encode-message-header): Use it. 1999-02-02 21:07:27 Hallvard B. Furuseth * gnus-sum.el (gnus-group-charset-alist): Add more. Mon Feb 1 21:18:00 1999 Lars Magne Ingebrigtsen * gnus.el: Pterodactyl Gnus v0.75 is released. 1999-02-01 21:54:26 Lars Magne Ingebrigtsen * gnus-art.el (article-display-x-face): Don't narrow to head. 1999-02-01 21:48:39 Michael Cook * gnus-cite.el (gnus-cited-lines-visible): Accept a cons. 1999-02-01 20:59:38 Lars Magne Ingebrigtsen * mail-source.el (mail-source-fetch-directory): Ignore directories. * gnus-cus.el (gnus-group-parameters): Addition. * gnus-art.el (article-strip-banner): Do symbolic banners. (article-strip-banner): New keystroke. 1999-02-01 20:54:32 Michael Cook * gnus-art.el (article-strip-banner): New command. 1999-02-01 20:53:45 Lars Magne Ingebrigtsen * gnus-art.el (gnus-treat-strip-banners): New variable. 1999-01-28 05:34:56 Katsumi Yamaoka * mail-source.el (mail-source-read-passwd): Use `read-passwd' if it has been exist. Thu Jan 28 01:38:34 1999 Shenghuo ZHU * message.el (message-draft-coding-system): Check coding-system. * mm-util.el (mm-text-coding-system): Ditto. 1999-01-28 12:11:31 Katsumi Yamaoka * mail-source.el (mail-source-fetch-pop): Save excursion. 1999-01-28 08:14:21 Lars Magne Ingebrigtsen * mail-source.el (mail-source-movemail-args): Not constant. (mail-source-movemail-args): Removed. (mail-source-fetch-with-program): New function. (mail-source-fetch-pop): Use program and function. (mail-source-movemail-program): Removed. * gnus-art.el (gnus-treat-date-iso8601): New variable. (gnus-treat-date-user-defined): New variable. 1999-01-28 08:07:12 Per Abrahamsen * nnmail.el (nnmail-fix-eudora-headers): New function. 1999-01-28 08:05:19 Lars Magne Ingebrigtsen * mm-bodies.el (mm-encode-body): Use mail-parse-charset. 1999-01-27 08:06:38 Lars Magne Ingebrigtsen * smiley.el (smiley-deformed-regexp-alist): Removed =>. (smiley-nosey-regexp-alist): Ditto. * gnus-art.el (gnus-treatment-function-alist): Do gnus-article-add-buttons-to-head later. (gnus-treat-capitalize-sentences): New variable. (article-capitalize-sentences): New command and keystroke. * gnus-group.el (gnus-group-catchup-current): Do group. * message.el (message-default-charset): Add group. Wed Jan 27 05:24:53 1999 Lars Magne Ingebrigtsen * gnus.el: Pterodactyl Gnus v0.74 is released. 1999-01-27 05:56:29 Lars Magne Ingebrigtsen * gnus-art.el (article-fill-long-lines): Renamed. (article-fill-long-lines): New keystroke. 1999-01-26 06:35:07 Lars Magne Ingebrigtsen * gnus-msg.el (gnus-setup-posting-charset): Check for group. * gnus-group.el (gnus-group-catchup-current): Skip groups now displayed. (gnus-group-catchup-current): Be more robus. * gnus-sum.el (gnus-summary-select-article): Reselect for showing headers. 1999-01-25 Dave Love * message.el (message-mode-menu): Add message-mime-attach-file. (message-mode): Doc fix. 1999-01-26 05:24:19 Lars Magne Ingebrigtsen * nnmail.el (nnmail-check-duplication): Insert the mail source string. * mail-source.el (mail-source-fetch-pop): Bind mail-source-string. (mail-source-fetch-directory): Ditto. (mail-source-fetch-file): Ditto. (mail-source-string): New variable. * gnus-start.el (gnus-get-unread-articles): Nix out groups over the level. * rfc2047.el (rfc2047-encodable-p): Convert to MIME charsets before handling. * mm-util.el (mm-mime-charset): Use the parameters. (mm-mime-charset): Removed region paremeters. * nnmail.el (nnmail-get-new-mail): Don't message the entire source. 1999-01-25 12:05:16 Lloyd Zusman * nnmail.el (nnmail-get-split-group): Quote right. 1999-01-25 05:55:41 Lars Magne Ingebrigtsen * mail-source.el (mail-source-movemail): Would kill an arbitrary buffer. 1999-01-24 03:02:31 Lars Magne Ingebrigtsen * gnus-group.el (gnus-clear-inboxes-moved): Removed. (gnus-group-mode): Don't hook. * mail-source.el (mail-source-bind): Doc fix. (mail-source-bind): Take only one param. * gnus-art.el (gnus-treat-highlight-signature): typep. * mail-source.el (mail-source-movemail): Ignore empty file. (mail-source-callback): Check before deleting. * message.el (message-mime-attach-file): Include name. 1999-01-23 17:01:12 Lars Magne Ingebrigtsen * mm-util.el (mm-read-charset): Return a symbol. * mm-view.el (mm-inline-text): Insert signature separator. * gnus-art.el (gnus-treat-predicate): New function. (gnus-treat-article): Allow all types to be checked. * gnus-util.el (gnus-or): New function. (gnus-and): Ditto. * gnus-art.el (gnus-mime-display-single): Use override. * mm-decode.el (mm-attachment-override-types): New variable. (mm-attachment-override-p): New function. * gnus-picon.el (gnus-group-display-picons): Don't go backward. 1999-01-23 16:45:06 Andrew J. Cosgriff * mm-view.el (mm-inline-text): Do vcards. Sat Jan 23 14:23:27 1999 Lars Magne Ingebrigtsen * gnus.el: Pterodactyl Gnus v0.73 is released. 1999-01-23 11:38:36 Lars Magne Ingebrigtsen * nnmail.el (nnmail-spool-file): Changed to use mail-source. (nnmail-crash-box, nnmail-use-procmail, nnmail-procmail-directory, nnmail-procmail-suffix, nnmail-resplit-incoming): Removed. (nnmail-movemail-program): Removed. (nnmail-movemail-args): Removed. (nnmail-pop-password-required): Ditto. (nnmail-tmp-directory): Ditto. (nnmail-delete-incoming): Removed. (nnmail-pop-password, nnmail-moved-inboxes, nnmail-internal-password, nnmail-move-inbox): Removed. (nnmail-read-passwd): Ditto. (nnmail-get-spool-files): Removed. (nnmail-resplit-incoming): Reinstated. * mail-source.el: New file. 1999-01-23 09:08:31 James H. Cloos, Jr. * gnus-art.el (gnus-article-mode-map): Bind backspace. 1999-01-23 09:05:04 Lars Magne Ingebrigtsen * gnus-art.el (article-make-date-line): Fix iso8601 display. 1999-01-20 02:53:52 Lars Magne Ingebrigtsen * gnus-art.el (gnus-treat-display-smileys): Check xpm. * gnus-picon.el (gnus-group-display-picons): Goto body. * gnus.el: Indented all functions; broke long lines; changed all instances of illegal/legal to invalid/valid. Yes, I'm bored. Wed Jan 20 00:50:53 1999 Lars Magne Ingebrigtsen * gnus.el: Pterodactyl Gnus v0.72 is released. 1999-01-20 01:39:48 Lars Magne Ingebrigtsen * gnus.el: Cleaned up trailing whitespace. * mm-util.el (mm-read-charset): Work. 1999-01-17 Matt Armstrong * gnus-score.el (gnus-score-find-bnews): Match regexp on the nnheader-translate-file-chars'd group name. 1999-01-20 01:30:30 Lars Magne Ingebrigtsen * message.el (message-encode-message-body): Fold case. 1999-01-20 01:28:16 Alexei V. Barantsev * gnus-xmas.el (gnus-xmas-modeline-glyph): Backquote. 1999-01-20 00:46:15 Lars Magne Ingebrigtsen * mailcap.el (mailcap-add): New function. 1999-01-18 09:40:37 Lars Magne Ingebrigtsen * gnus-art.el (article-goto-body-goes-to-point-min-p): New variable. (article-goto-body): Use it. (gnus-treat-article): Ditto. * gnus-agent.el (gnus-agent-get-undownloaded-list): Remove the downloaded articles from the downloadeble list. 1999-01-16 17:31:08 Lars Magne Ingebrigtsen * message.el (message-encode-message-body): Bind mail-parse-charset. * mm-util.el (mm-charset-synonym-alist): New variable. (mm-charset-to-coding-system): Use it. (mm-charset-coding-system-alist): Removed. (mm-charset-to-coding-system): Don't use it. (mm-find-charset-region): Use mail-parse-charset. * gnus-art.el (gnus-treatment-function-alist): Use gnus-article-display-picons. (gnus-treat-display-xface): Only do if we have xface feature. (gnus-part-display-hook): New function. (gnus-treat-article): Use it. (gnus-treat-article): Use gnus-visual. * gnus-msg.el (gnus-setup-posting-charset): Check elem. * gnus-art.el (gnus-mm-display-part): Fix the MIME button after displaying. * mm-decode.el (mm-insert-part): Use insert-buffer-substring. * gnus-score.el (gnus-score-find-bnews): Protect against invalid regexp file names. Sat Jan 16 03:15:57 1999 Lars Magne Ingebrigtsen * gnus.el: Pterodactyl Gnus v0.71 is released. 1999-01-16 00:13:31 Lars Magne Ingebrigtsen * mm-view.el (mm-inline-image): Don't add a dot. * gnus-art.el (gnus-treat-article): New function. * gnus.el (gnus-article-display-hook): Removed. * gnus-art.el (gnus-article-treat-custom): New variable. * gnus-start.el (gnus-ignored-newsgroups-has-to-p): Removed. * gnus-msg.el (gnus-setup-posting-charset): Allow variables and functions. * message.el (message-posting-charset): New variable. (message-send-mail): Use it. * gnus-msg.el (gnus-group-posting-charset-alist): Moved here. (gnus-setup-posting-charset): New function. (gnus-setup-message): Use it. * message.el (message-encode-message-body): Just look for Content-Type before inserting a new one. 1999-01-15 23:08:47 Lars Magne Ingebrigtsen * rfc2047.el (rfc2047-default-charset): Removed. * mail-prsvr.el: New file. (mail-parse-charset): New variable. * gnus-sum.el (gnus-newsgroup-charset): Changed name. Changed name. * gnus.el (gnus-charset): New group. * nnmail.el (nnmail-pathname-coding-system): Default to binary. * gnus-sum.el (gnus-default-charset): Default to nil. (gnus-newsgroup-iso-8859-1-forced-regexp): Removed. (gnus-newsgroup-iso-8859-1-forced): Removed. * mm-util.el (mm-known-charsets): Removed. (mm-default-coding-system): Removed. (mm-default-charset): Removed. (mm-read-charset): New function. * message.el (message-default-charset): Removed. * rfc2047.el (rfc2047-default-charset): Default to nil. * mm-util.el (mm-charset-iso-8859-1-forced): Removed. Fri Jan 15 20:50:38 1999 Lars Magne Ingebrigtsen * gnus.el: Pterodactyl Gnus v0.70 is released. 1999-01-15 00:06:04 Lars Magne Ingebrigtsen * mm-decode.el (mm-save-part): Use mm-get-part. (mm-insert-part): New function. (mm-get-part): Use it. (mm-get-image): Ditto. (mm-display-external): Ditto. * mm-view.el (mm-inline-text): Ditto. * gnus-move.el (gnus-move-group-to-server): Protect against nil ranges. * mm-decode.el (mm-display-external): Save the buffer. (mm-remove-part): Kill it. * qp.el (quoted-printable-decode-region): Do the right thing at eobp. * nnagent.el (nnagent-request-set-mark): Defined stub. 1999-01-14 23:05:31 Lars Magne Ingebrigtsen * gnus-score.el (gnus-score-load-score-alist): Bind coding-system-for-read. * gnus-sum.el (gnus-summary-exit): Do adaptive scoring before prepare-exit-hook. * mm-view.el (mm-setup-w3): Require w3. 1999-01-13 Kiyokazu SUTO * nnspool.el (nnspool-retrieve-headers): Protect against empty body. 1999-01-14 21:17:35 Lars Magne Ingebrigtsen * mm-encode.el: Ditto. * mm-bodies.el (mm-decode-content-transfer-encoding): Message the error. * mailcap.el (mailcap-mime-data): SAFER ps. * message.el (message-encode-message-body): Always insert a Content-Type header. * mm-decode.el (mm-inline-media-tests): Default all text/* to be shown inline. * mm-view.el (mm-inline-text): Handle all sorts of text. * mailcap.el (mailcap-mime-data): non-viewer for viewers that don't view. * mm-decode.el (mm-display-external): Use it. * gnus-art.el (gnus-visible-headers): Added bcc, gcc, fcc. * mm-decode.el (mm-save-part): Removed double code. 1999-01-12 Dave Love * mm-decode.el (mm-save-part): Avoid doubly-compressed application/octet-stream .gz & al files with jka-compr. 1999-01-12 Dave Love * gnus-ems.el (gnus-down-mouse-3): New variable. * gnus-art.el (gnus-mime-button-map): Use it. (gnus-mime-button-menu): Set the clicked-on buffer initially. 1999-01-13 19:41:57 Lars Magne Ingebrigtsen * mailcap.el (mailcap-mime-data): Added ImageMagic and ee. 1999-01-12 17:34:43 Lars Magne Ingebrigtsen * gnus-picon.el (gnus-picons-kill-buffer): Don't kill article buffers. * gnus-sum.el (gnus-summary-exit): Destroy all MIME. * gnus-cache.el (gnus-cache-read-active): Reversed check. 1999-01-12 17:18:25 Matt Armstrong * mml.el (mml-parameter-string): Strip directory component. 1999-01-12 17:02:58 Lars Magne Ingebrigtsen * gnus.el (gnus-use-demon): Removed. 1999-01-12 05:53:23 Katsumi Yamaoka * nnmail.el (nnmail-article-group): Don't infloop. 1999-01-11 Colin Rafferty * gnus-art.el (article-update-date-lapsed): Made it work with picons, and make it update on all visible frames. (article-date-ut): Get summary-buffer's current-headers. 1999-01-12 07:20:31 Lars Magne Ingebrigtsen * gnus-picon.el (gnus-picons-setup-buffer): Don't set major mode. (gnus-picons-setup-p): New variable. 1999-01-11 02:13:12 Lars Magne Ingebrigtsen * nnmail.el (nnmail-split-header-length-limit): Lowered to 512. 1999-01-04 12:58:13 Lars Magne Ingebrigtsen * gnus-sum.el (gnus-summary-exit-no-update): Don't use run-hooks. (gnus-summary-exit-no-update): Use mapcar. 1999-01-02 14:36:32 Simon Josefsson * gnus-agent.el (gnus-category-write): Make directory. 1998-09-26 19:39:31 Simon Josefsson * gnus-sum.el (gnus-update-read-articles): (gnus-update-marks): Request backend update of mark. 1999-01-03 15:29:52 Lars Magne Ingebrigtsen * mm-bodies.el (mm-body-encoding): Use mm-find. 1999-01-03 15:28:27 Kim-Minh Kaplan * gnus-picon.el (gnus-article-display-picons): Fix. Sun Jan 3 13:32:02 1999 Lars Magne Ingebrigtsen * gnus.el: Pterodactyl Gnus v0.69 is released. 1999-01-03 06:45:10 Lars Magne Ingebrigtsen * gnus-picon.el (gnus-picons-setup-buffer): Run the hook. * gnus-agent.el (gnus-agent-remove-group): New command and keystroke. * rfc2047.el (rfc2047-decode-region): Check for us-ascii. 1999-01-02 14:12:41 Simon Josefsson * gnus-agent.el (gnus-agent-write-servers): Make directory. 1998-12-26 02:38:01 Lars Magne Ingebrigtsen * mm-view.el (mm-inline-text): Bind current id. * mm-decode.el (mm-handle-id): New macro. (mm-make-handle): Accept id. (mm-dissect-singlepart): Use it. 1998-12-23 Matt Pharr * message.el (message-cite-original-without-signature): Use message-signature-separator when searching for signature in message-cite-original-without-signature. 1998-12-24 16:25:38 Simon Josefsson * gnus.el (gnus-server-to-method): Check named methods. 1998-12-24 03:27:02 Lars Magne Ingebrigtsen * mm-view.el (mm-view-message): Goto point-min. * nnmail.el (nnmail-article-group): Don't delete lines, only shorten them. * gnus-msg.el (gnus-configure-posting-styles): Also do nil values. * nnheader.el (nnheader-temp-directory): New variable. (nnheader-temp-directory): Removed. 1998-12-22 Jack Vinson * mailcap.el (mailcap-parse-mailcaps): Add "~/.mailcaps" to the list of files to check for mailcap entries under windows-nt. 1998-12-24 03:02:15 Lars Magne Ingebrigtsen * gnus-art.el (gnus-article-maybe-hide-headers): Check whether the summary buffer exists. 1998-12-22 Aaron M. Ucko * nnsoup.el (nnsoup-store-reply): Remove code to deal with irrelevant Sun sendmail bug. (nnsoup-store-reply): Stop mucking with mail-header-separator. * message.el (message-send-news): Bind mail-header-separator to "" when asking backend to post. 1998-12-22 Karl Kleinpaste * mm-uu.el (mm-dissect-disposition): New variable. (mm-uu-dissect): Use it. 1998-12-21 21:34:22 Lars Magne Ingebrigtsen * mm-view.el (mm-inline-text): Bind url-current-object. 1998-12-06 03:05:41 Simon Josefsson * gnus-range.el (gnus-remove-from-range): Rewrite. 1998-12-09 SL Baur * gnus-picon.el (annotations): Remove bogus require 'xpm. 1998-12-18 Hrvoje Niksic * message.el (message-encode-message-body): Insert `MIME-Version' instead of `Mime-Version'. 1998-12-04 Hrvoje Niksic * message.el (message-insert-mime-part): Add the attachment disposition. (message-insert-mime-part): Make TYPE and DESCRIPTION optional. (message-mime-query-type): New function. (message-mime-query-description): Ditto. (message-mime-query-file): Ditto. (message-insert-mime-part): Use them. (message-mime-insert-external): Use the new stuff. 1998-12-19 23:02:26 Lars Magne Ingebrigtsen * nnmail.el (nnmail-split-header-length-limit): New variable. * mm-decode.el (mm-dissect-buffer): Check syntax. * rfc2231.el (rfc2231-parse-string): Remove check for syntax. * rfc2047.el (rfc2047-encodable-p): Use mm-find-charset-region. (rfc2047-dissect-region): Ditto. 1998-12-17 18:36:43 Lars Magne Ingebrigtsen * mm-view.el (mm-view-message): Decode charset. 1998-12-16 16:01:22 Lars Magne Ingebrigtsen * rfc2231.el (rfc2231-parse-string): Ignore syntactically invalid CT headers. Wed Dec 16 01:44:40 1998 Shenghuo ZHU * mm-bodies.el (mm-decode-content-transfer-encoding): Use mm-uu-*-function. * mm-uu.el (mm-uu-dissect): Use x-uuencode. 1998-12-16 10:20:52 Lars Magne Ingebrigtsen * message.el (message-send-mail): Do MML first. (message-send-news): Ditto. 1998-12-15 20:57:18 Lars Magne Ingebrigtsen * gnus-picon.el (gnus-picons-face): New face. (gnus-picons-try-face): Use it. Tue Dec 15 19:17:43 1998 Lars Magne Ingebrigtsen * gnus.el: Pterodactyl Gnus v0.68 is released. Tue Dec 15 18:28:24 1998 Lars Magne Ingebrigtsen * gnus.el: Pterodactyl Gnus v0.67 is released. Tue Dec 15 17:31:44 1998 Lars Magne Ingebrigtsen * gnus.el: Pterodactyl Gnus v0.66 is released. 1998-12-13 11:00:43 Lars Magne Ingebrigtsen * gnus-art.el (gnus-insert-mime-button): Decode description. Sat Dec 5 16:50:49 1998 Shenghuo ZHU * gnus-art.el (article-decode-encoded-words): Rollback to 0.55. (gnus-decode-header-methods): Ditto. (gnus-decode-with-mail-decode-encoded-word-region): Ditto. 1998-12-13 10:04:39 Lloyd Zusman * gnus-xmas.el (gnus-xmas-summary-recenter): Allow numbers. 1998-12-13 09:32:38 Lars Magne Ingebrigtsen * mml.el (mml-insert-mime-headers): Encode description. * nnfolder.el (nnfolder-request-expire-articles): Go to the date line. * gnus-sum.el (gnus-default-charset): Doc fix. Wed Dec 9 15:18:39 1998 Shenghuo ZHU * mm-decode.el (mm-display-part): Forward a line. Wed Dec 9 13:30:29 1998 Shenghuo ZHU * mm-util.el (mm-running-ntemacs): New variable. (mm-text-coding-system): Ditto. * nnmail.el (nnmail-incoming-coding-system): Ditto. (nnmail-split-incoming): Use nnmail-incoming-coding-system. 1998-12-13 08:52:45 Lars Magne Ingebrigtsen * gnus-picon.el (gnus-picons-network-display-internal): Don't set buffer. * message.el (message-insert-headers): New command and keystroke. 1998-12-07 23:42:14 Lars Magne Ingebrigtsen * mm-decode.el (mm-inline-media-tests): Recognize x-xbitmap. (mm-get-image): Ditto. * mm-bodies.el (mm-decode-content-transfer-encoding): Only for base64, uudecode and binhex. Sun Dec 6 21:58:31 1998 Shenghuo ZHU * mm-bodies.el (mm-decode-content-transfer-encoding): Replace CRLF in text/plain. * mm-uu.el (mm-uu-dissect): Use inline. 1998-12-07 23:19:14 Lars Magne Ingebrigtsen * mm-view.el (mm-view-message): New function. * mm-encode.el (mm-content-transfer-encoding-defaults): Changed to qp. 1998-12-07 Karl Kleinpaste * mm-encode.el (mm-content-transfer-encoding-defaults): Add an entry for message/rfc822 as 8bit. 1998-12-07 23:16:54 Lars Magne Ingebrigtsen * mailcap.el (mailcap-mime-extensions): Add patch. 1998-12-05 Dale Hagglund * gnus-sum.el (gnus-summary-display-buttonized): Use prefix argument to force all multipart/* to look like multipart/mixed. * gnus-art.el (gnus-mime-display-multipart-as-mixed): New variable. (gnus-mime-display-part): Use it. 1998-12-07 22:46:37 Lars Magne Ingebrigtsen * gnus-draft.el (gnus-draft-send): Only disable checks for non-interactive use. (gnus-draft-send-message): Use it. Sun Dec 6 19:36:53 1998 Lars Magne Ingebrigtsen * gnus.el: Pterodactyl Gnus v0.65 is released. 1998-12-06 20:11:02 Lars Magne Ingebrigtsen * gnus-art.el (gnus-article-prepare-display): Don't init w3. * mm-view.el (mm-inline-text): Bind url-standalone-mode here. Sat Dec 5 18:35:42 1998 Lars Magne Ingebrigtsen * gnus.el: Pterodactyl Gnus v0.64 is released. 1998-12-05 18:51:13 Lars Magne Ingebrigtsen * mm-view.el (mm-setup-w3): Don't load. * gnus-msg.el (gnus-setup-message): Set group name. (gnus-group-mail): Avoid leaking local vars. * message.el (message-attach-file): Renamed. (message-mime-attach-file): Renamed again. 1998-12-05 Hrvoje Niksic * gnus-art.el (article-decode-encoded-words): Bind rfc2047-default-charset here. * gnus-art.el (gnus-insert-mime-button): Nix slashes in file name. 1998-12-05 18:33:27 Lars Magne Ingebrigtsen * gnus-picon.el (gnus-picons-setup-buffer): Run picons hook. (gnus-picons-setup-hook): New hook. 1998-12-05 Per Abrahamsen * mailcap.el (mailcap-mime-data): Remove "*" from documentation string. (mailcap-mime-extensions): Ditto. Made first sentense fit a line. 1998-12-05 17:11:04 Lars Magne Ingebrigtsen * gnus-art.el (gnus-article-prepare-display): Setup w3. (gnus-mime-view-part): Ditto. (gnus-mime-inline-part): Dotii. (gnus-mime-externalize-part): Daddo. (gnus-mime-internalize-part): Tutti frutti. (gnus-widget-press-button): Da da do. * mm-view.el (mm-setup-w3): Require url-vars. Fri Dec 4 12:13:12 1998 Shenghuo ZHU * message.el (message-draft-coding-system): Fix for XEmacs-NT. * mm-util.el (mm-find-charset-region): Ditto. 1998-12-05 16:30:01 Lars Magne Ingebrigtsen * message.el (message-send): Don't encode here. (message-send-mail): But here. (message-send-news): And here. 1998-12-04 15:29:02 Lars Magne Ingebrigtsen * gnus-msg.el (gnus-message-insert-stylings): Don't insert twice. Fri Dec 4 04:09:15 1998 Lars Magne Ingebrigtsen * gnus.el: Pterodactyl Gnus v0.63 is released. 1998-12-04 04:59:20 Lars Magne Ingebrigtsen * mml.el (mml-base-boundary): Shorten. * message.el (message-insert-mime-part): Use default. * gnus-art.el (gnus-insert-mime-button): Bind gnus-tmp-type-long. 1998-12-03 Per Abrahamsen * gnus-art.el (gnus-mime-display-alternative): Use (*) for radio buttons, not [*]. 1998-12-04 Hrvoje Niksic * gnus-art.el (gnus-insert-mime-button): Do proper help-echo. 1998-12-04 04:48:37 Hrvoje Niksic * gnus-art.el (gnus-insert-mime-button): Fix. 1998-12-03 Hrvoje Niksic * message.el (message-insert-mime-part): Nicify prompts. (message-insert-mime-part): Really delete duplicates. (message-insert-mime-part): Check against common errors. (message-insert-mime-part): Fix docstring. 1998-12-04 04:41:58 Lars Magne Ingebrigtsen * gnus-art.el (gnus-mime-internalize-part): Bugged out. 1998-12-03 Hrvoje Niksic * gnus-art.el (gnus-mime-button-line-format): Nicify. (gnus-insert-mime-button): Modify accordingly. 1998-12-04 01:50:53 Lars Magne Ingebrigtsen * gnus-art.el (gnus-display-mime): Set window point. * mm-decode.el (mm-display-external): Only decode when not saving. (mm-alternative-precedence): Prefer multiparts. (mm-inline-media-tests): Inline multiparts. * gnus-picon.el (gnus-picons-next-job-internal): Do bar if asked. Ignore errors when requiring url. * mml.el (mml-quote-region): New command. * message.el (message-cite-original): Use it. (message-cite-original-without-signature): Ditto. Thu Dec 3 12:53:58 1998 Lars Magne Ingebrigtsen * gnus.el: Pterodactyl Gnus v0.62 is released. 1998-12-03 13:38:36 Lars Magne Ingebrigtsen * gnus-art.el (gnus-mime-view-all-parts): Work with multiparts. 1998-12-03 Hrvoje Niksic * mm-view.el (mm-inline-text): Use `point-min-marker' and `point-max-marker'. 1998-12-03 13:22:57 Lars Magne Ingebrigtsen * mailcap.el (mailcap-mime-extensions): Use image/xpm for xpms. * gnus-art.el (gnus-mime-display-single): Check for attachment before other tests. 1998-12-03 Didier Verna * gnus-msg.el (gnus-configure-posting-styles): find a posting-style entry in the group parameters, if any, and honor it at the end. 1998-12-03 13:03:37 Felix Lee * nntp.el (nntp-after-change-function): Fix. 1998-12-03 12:44:30 Mike McEwan * mml.el (mml-generate-mime-1): Insert literally. 1998-12-03 00:23:17 Lars Magne Ingebrigtsen * mml.el (mml-insert-mime-headers): Removed debug. 1998-12-02 22:22:03 Lars Magne Ingebrigtsen * gnus-sum.el (gnus-summary-show-article): Destroy parts when prefixed. * mm-encode.el (mm-content-transfer-encoding-defaults): Default application/emacs-lisp to 8bit. 1998-12-03 Dale Hagglund * mm-decode.el (mm-quote-arg): Add quoting of '()', '<>', and '|'. Wed Dec 2 20:24:27 1998 Lars Magne Ingebrigtsen * gnus.el: Pterodactyl Gnus v0.61 is released. 1998-12-02 21:12:56 Lars Magne Ingebrigtsen * mml.el (mml-parse-1): Skipped parts. (mml-insert-mime-headers): Nil is a list. (mml-generate-mime-1): Don't insert literally. (mml-read-tag): Drop text props. (mml-read-part): Ditto. (mml-parse-singlepart-with-multiple-charsets): Ditto. Wed Dec 2 20:07:16 1998 Lars Magne Ingebrigtsen * gnus.el: Pterodactyl Gnus v0.60 is released. 1998-12-02 20:11:28 Lars Magne Ingebrigtsen * mml.el (mml-parse-1): Don't throw contents away. 1998-12-02 Hrvoje Niksic * mml.el (mml-compute-boundary-1): Regexp-quote the boundary. 1998-12-02 18:42:24 Lars Magne Ingebrigtsen * mml.el (mml-parse-singlepart-with-multiple-charsets): New function. (mml-parse-1): Use it. Tue Dec 1 23:04:25 1998 Shenghuo ZHU * gnus-art.el (gnus-decode-with-mail-decode-encoded-word-region): Use gnus-newsgroup-default-charset. (article-decode-encoded-words): Remove charset codes. * gnus-sum.el (gnus-newsgroup-default-charset): Use gnus-default-charset. 1998-12-02 03:14:20 Lars Magne Ingebrigtsen * message.el (message-send-mail): Don't encode here. (message-send-news): Nor here. (message-send): ... but here instead. * gnus-picon.el (gnus-picons-display-article-move-p): Changed default to nil. (gnus-article-display-picons): Replace From line. (gnus-group-display-picons): Replace Newsgroups line. (gnus-picons-display-glyph): Set baseline. (gnus-group-display-picons): Piconize the entire Newsgroups line. (gnus-picons-xbm-face): Revert to old, standard colors. * message.el (message-fetch-field): Remove text props. * gnus-art.el (gnus-article-normalized-header-length): New variable. (article-normalize-headers): New command and keystroke. * gnus-picon.el (gnus-picons-xbm-face): Changed colors. Wed Dec 2 01:43:48 1998 Lars Magne Ingebrigtsen * gnus.el: Pterodactyl Gnus v0.59 is released. 1998-12-02 01:38:31 Lars Magne Ingebrigtsen * mml.el (mml-insert-mime-headers): Beep at multiple charsets. * gnus-art.el (gnus-mime-copy-part): Set buffer-file-name. 1998-11-30 Hrvoje Niksic * mml.el (mml-generate-mime-1): Handle unquoting end-tags. 1998-12-02 00:15:30 Lars Magne Ingebrigtsen * mm-decode.el (mm-all-images-fit): New variable. (mm-image-fit-p): Use it. * gnus-art.el (gnus-mime-display-single): Use it. (gnus-mime-internalize-part): New command and keystroke. * mm-decode.el (mm-user-automatic-external-display): New variable. (mm-automatic-external-display-p): New function. * gnus-picon.el (gnus-picons-xbm-face): Default to sensible colors. 1998-12-01 23:52:05 Lars Magne Ingebrigtsen * gnus-sum.el (gnus-summary-repair-multipart): Reselect article. * gnus-art.el (gnus-with-article): Work in the original article buffer. (gnus-with-article): Work in read-only groups. Tue Dec 1 00:15:36 1998 Shenghuo ZHU * mm-bodies.el (mm-decode-string): Return original string if not decode. Mon Nov 30 23:38:02 1998 Shenghuo ZHU * mm-uu.el (mm-uu-dissect): Use mm-make-handle. 1998-12-01 01:53:49 Francois Pinard * nndoc.el (nndoc-mime-parts-type-p): Do related. Tue Dec 1 00:46:20 1998 Lars Magne Ingebrigtsen * gnus.el: Pterodactyl Gnus v0.58 is released. 1998-11-30 Hrvoje Niksic * mm-decode.el (mm-get-image): Return a glyph, not an image specifier. 1998-11-29 Hrvoje Niksic * rfc2047.el (rfc2047-decode): Bind mm-default-charset. 1998-12-01 01:23:35 Lars Magne Ingebrigtsen * mail-parse.el (rfc2045): Required. 1998-12-01 00:59:53 William M. Perry * mm-view.el (mm-inline-text): Remove props. 1998-12-01 00:18:47 Lars Magne Ingebrigtsen * mm-view.el (mm-setup-w3): Protect url-misc. * message.el (message-ignored-resent-headers): Remove Gnus-Warning. * mml.el (mml-insert-mime-headers): Use encoding. (mml-parameter-string): Ditto. * rfc2045.el: New file. (rfc2045-encode-string): New function. 1998-11-30 23:11:22 Lars Magne Ingebrigtsen * mail-parse.el (mail-header-encode-parameter): New function. * rfc2231.el (rfc2231-encode-string): New function. Mon Nov 30 13:52:50 1998 Shenghuo ZHU * mm-bodies.el (mm-decode-string): New function. * mm-view.el (mm-inline-text): Use mm-decode-string. Mon Nov 30 21:57:00 1998 Lars Magne Ingebrigtsen * gnus.el: Pterodactyl Gnus v0.57 is released. 1998-11-23 Felix Lee * nntp.el (nntp-async-needs-kluge): new setting. (nntp-async-timer): new var. (nntp-async-process-list): new var. (nntp-async-kluge): new function. (nntp-async-timer-handler): new function. (nntp-async-wait): new function. (nntp-async-stop): new function. (nntp-after-change-function): renamed, and split apart. (nntp-async-trigger): new function. (nntp-do-callback): new function. (nntp-accept-process-output): add optional timeout arg. * gnus-async.el (gnus-async-request-fetched-article): fixed. (gnus-async-wait-for-article): new function. (gnus-async-with-semaphore): s/asynch/async/. 1998-11-30 16:54:56 Lars Magne Ingebrigtsen * gnus-art.el (gnus-with-article): Don't encode. (gnus-insert-mime-button): Fall back on filename from C-D. (gnus-mime-display-single): Have dots right on text/plain attachments. * mm-decode.el (mm-dissect-buffer): Respect Content-Disposition in broken parts. * gnus-art.el (gnus-with-article): Flush cache and backlog. * mm-bodies.el (mm-decode-content-transfer-encoding): Also do binhex. * gnus-sum.el (gnus-summary-reparent-thread): Use new macro. (gnus-summary-repair-multipart): New command and keystroke. * gnus-art.el (gnus-with-article-buffer): New macro. Sun Nov 29 23:51:57 1998 Shenghuo ZHU * gnus-art.el (gnus-mime-inline-part): Do not get part when undisplay the part. 1998-11-30 03:38:35 Lars Magne Ingebrigtsen * gnus-util.el (gnus-make-sort-function-1): Allow lambdas. * mml.el (mml-read-part): Partition right. * mm-decode.el (mm-handle-set-cache): New macro. (mm-handle-cache): Ditto. (mm-make-handle): Ditto. (mm-dissect-singlepart): Use it. (mm-get-image): Use the cache. 1998-11-29 23:44:44 Lars Magne Ingebrigtsen * gnus-art.el (gnus-mime-display-mixed): Rewrite. (gnus-mime-display-single): Don't insert lines between parts. Sun Nov 29 04:55:40 1998 Shenghuo ZHU * nnmail.el (nnmail-file-coding-system-1): New variable. * nnfolder.el (nnfolder-file-coding-system): Ditto. (nnfolder-read-folder): Use nnfolder-file-coding-system. * nnml.el (nnml-file-coding-system): New variable. (nnml-request-article): Use nnml-file-coding-system. Sun Nov 29 15:12:52 1998 Lars Magne Ingebrigtsen * gnus.el: Pterodactyl Gnus v0.56 is released. 1998-11-29 00:52:53 Lars Magne Ingebrigtsen * gnus-art.el (gnus-mime-display-part): New function. (gnus-mime-display-mixed): Use it. * mm-view.el (mm-setup-w3): Don't register. * message.el (message-cite-original): Cite parts. 1998-11-28 23:51:25 Lars Magne Ingebrigtsen * mml.el (mml-parameter-string): New function. (mml-insert-mime-headers): Separated into new function. 1998-11-28 Hrvoje Niksic * mml.el (mml-make-boundary): Use `make-string'. 1998-11-27 Hrvoje Niksic * binhex.el (binhex-insert-char): Ditto. * base64.el (base64-insert-char): Ditto. * uudecode.el (uudecode-insert-char): Code correctly. 1998-11-28 01:08:19 Lars Magne Ingebrigtsen * mml.el (mml-generate-mime): Don't generate multiparts for empties. * gnus-art.el (gnus-display-mime): Save excursion. * message.el (message-remove-first-header): New function. (message-encode-message-body): Use it. Fri Nov 27 12:26:10 1998 Lars Magne Ingebrigtsen * gnus.el: Pterodactyl Gnus v0.55 is released. 1998-11-27 12:38:52 Lars Magne Ingebrigtsen * mm-view.el (mm-setup-w3): New function. * mm-decode.el (mm-content-id-get-contents): New function. (mm-content-id-get-type): Ditto. (mm-content-id-get-encoding): Ditto. (mm-get-handle-by-content-id): Removed. 1998-11-25 Colin Rafferty * message.el (message-generate-new-buffers): Fix tag. 1998-11-25 10:43:28 Lars Magne Ingebrigtsen * message.el (message-buffer-name): Check for unique first. * gnus-art.el (gnus-unbuttonized-mime-type-p): use gnus-inhibit-mime-unbuttonizing. * gnus-sum.el (t): Bind M-t. (gnus-inhibit-unbuttonizing): New variable. (gnus-summary-toggle-display-buttonized): New command. * gnus-art.el (gnus-display-mime): Select article window. (article-strip-trailing-space): New command and keystroke. * nneething.el (nneething-include-files): New variable. (nneething-create-mapping): Use it. * nntp.el (nntp-possibly-change-group): Use nntp-send-command. * nnvirtual.el (nnvirtual-request-update-mark): Only yodate ayto-expirable marks. 1998-11-24 21:00:02 Lars Magne Ingebrigtsen * gnus-art.el (gnus-mime-view-all-parts): Set buffer. * gnus-sum.el (gnus-summary-display-buttonized): Don't pass on ARG. * gnus-art.el (gnus-article-mode-line-format): Doc fix. Tue Nov 24 14:57:41 1998 Shenghuo ZHU * mm-util.el (mm-binary-coding-system): New variable. (mm-with-unibyte-buffer): Use mm-binary-coding-system. * mm-decode.el (mm-display-external): Ditto. Tue Nov 24 10:43:06 1998 Lars Magne Ingebrigtsen * gnus.el: Pterodactyl Gnus v0.54 is released. 1998-11-24 11:21:32 Katsumi Yamaoka * gnus-sum.el (gnus-newsgroup-default-charset-alist): Note fj. 1998-11-24 11:14:54 Lars Magne Ingebrigtsen * mm-decode.el (mm-save-part): Unquote. 1998-11-24 11:14:39 Matt Armstrong * mm-decode.el (mm-save-part): Bind coding system for write. 1998-11-24 10:42:30 Lars Magne Ingebrigtsen * gnus-art.el (gnus-article-mode-line-format): New default. (gnus-article-mime-part-status): New function. * message.el (message-send-news): Check the body syntax before encoding. * gnus-art.el (gnus-unbuttonized-mime-type): New function. (gnus-mime-display-single): Use it. (gnus-mime-display-alternative): Ditto. * mm-decode.el: Check for whether we are running under a term. 1998-11-22 08:12:25 Lars Magne Ingebrigtsen * mm-decode.el (mm-preferred-alternative): Default to first alternative. (mm-preferred-alternative): No, we dont. Tue Nov 24 03:01:48 1998 Shenghuo ZHU * mm-decode.el (mm-display-external): Use binary instead of no-conversion. * gnus-agent.el (gnus-agent-file-coding-system): Ditto. * nnheader.el (nnheader-file-coding-system): Ditto. * mm-util.el (mm-with-unibyte-buffer): Use binary instead of nil. Mon Nov 23 01:51:57 1998 Shenghuo ZHU * gnus-sum.el (gnus-newsgroup-setup-default-charset): Use group name without method. Mon Nov 23 01:26:40 1998 Shenghuo ZHU * gnus-sum.el (gnus-newsgroup-default-charset): Rename coding-system -> default-charset. (gnus-newsgroup-default-charset-alist): Ditto. (gnus-summary-local-variables): Ditto. (gnus-set-global-variables): Ditto. (gnus-get-newsgroup-headers): Ditto. (gnus-summary-from-or-to-or-newsgroups): Ditto. (gnus-get-newsgroup-headers-xover): Ditto. (gnus-newsgroup-setup-default-charset): Ditto. (article-decode-mime-words): Ditto. (article-decode-charset): Ditto. (article-decode-encoded-words): Ditto. (article-de-quoted-unreadable): Ditto. (gnus-mime-view-all-parts): Ditto. (gnus-mime-externalize-part): Ditto. (gnus-mm-display-part): Ditto. (gnus-mime-display-single): Ditto. (gnus-mime-display-alternative): Ditto. * lpath.el : Ditto. Mon Nov 23 00:54:33 1998 Shenghuo ZHU * rfc2047.el (rfc2047-decode-region): Do not decode nil charset. * gnus-art.el (article-decode-charset): Overlay rfc2047-default-charset. * message.el (message-draft-coding-system): New variable. (message-set-auto-save-file-name): Use message-draft-coding-system. * nndraft.el (nndraft-request-article): Ditto. * gnus-start.el (gnus-start-draft-setup): Set charset nil. * gnus-agent.el (gnus-agent-queue-setup): Ditto. Sun Nov 22 04:42:22 1998 Shenghuo ZHU * mm-uu.el (mm-uu-test): New function. (mm-uu-dissect): Inherit charset and cte from head. * gnus-art.el (article-decode-charset): Use mm-uu-test. Sat Nov 21 09:57:01 1998 Lars Magne Ingebrigtsen * gnus.el: Pterodactyl Gnus v0.53 is released. 1998-11-21 05:54:19 Lars Magne Ingebrigtsen * mm-decode.el (mm-get-image): New function. (mm-image-fit-p): New function. * gnus-xmas.el (gnus-xmas-annotation-in-region-p): Ditto. * gnus-util.el (gnus-annotation-in-region-p): New definition. * gnus-art.el (gnus-article-insert-newline): New function. (article-goto-body): New function. 1998-11-20 10:34:04 Lars Magne Ingebrigtsen * gnus-art.el (gnus-mime-display-single): Insert blank line before buttons. * gnus-sum.el (gnus-summary-display-buttonized): New command and keystroke. * gnus-art.el (gnus-mime-display-single): Don't insert a blank line between parts. * message.el (message-remove-header): Go to end if wanted. 1998-11-20 Karl Kleinpaste * gnus-art.el (gnus-mime-display-alternative): Avoid window movement with save-window-excursion. Fri Nov 20 03:50:30 1998 Shenghuo ZHU * gnus-art.el (gnus-mime-inline-part): Use argument as charset. Fri Nov 20 03:37:53 1998 Shenghuo ZHU * mm-bodies.el (mm-decode-body): Remove buffer-file-coding-system. Fri Nov 20 01:20:38 1998 Shenghuo ZHU * gnus-sum.el (gnus-summary-from-or-to-or-newsgroups): Use gnus-newsgroup-coding-system. (gnus-get-newsgroup-headers): Ditto. (gnus-get-newsgroup-headers-xover): Ditto. (gnus-set-global-variables): Ditto. * gnus-art.el (article-decode-mime-words): Ditto. (article-decode-charset): Ditto. (article-decode-encoded-words): Ditto. (article-de-quoted-unreadable): Ditto. (gnus-mime-view-all-parts): Ditto. (gnus-mime-externalize-part): Ditto. (gnus-mm-display-part): Ditto. (gnus-mime-display-alternative): Ditto. (gnus-mime-display-single): Ditto. * mm-view.el (mm-inline-text): Use default coding system. Fri Nov 20 00:54:37 1998 Shenghuo ZHU * gnus-sum.el (gnus-newsgroup-coding-system-alist): New variable. (gnus-newsgroup-iso-8859-1-forced-regexp): New variable. (gnus-newsgroup-coding-system): New local variable. (gnus-newsgroup-iso-8859-1-forced): New local variable. (gnus-summary-local-variables): Add two new local variables. (gnus-newsgroup-setup-coding-system): New function. (gnus-select-newsgroup): Setup coding system. * lpath.el: Add two new variables. * mm-util.el (mm-charset-iso-8859-1-forced): New variable. (mm-charset-to-coding-system): Use mm-charset-iso-8859-1-forced. * gnus-cus.el (gnus-group-parameters): Customizable iso-8859-1-forced. Fri Nov 20 05:30:26 1998 Lars Magne Ingebrigtsen * gnus.el: Pterodactyl Gnus v0.52 is released. 1998-11-20 04:32:23 Lars Magne Ingebrigtsen * rfc2047.el (rfc2047-encode-message-header): Encode the default encoding. * gnus-art.el (gnus-mime-display-single): Insert buttons for undisplayed text types. * mm-decode.el (mm-automatic-display-p): Only prefer inlinable types. 1998-11-19 Felix Lee * nntp.el (nntp-after-change-function-callback): recover from C-g. 1998-11-19 Felix Lee * gnus-async.el (gnus-asynch-obarray): rename to gnus-async-hashtb, and don't buffer-local it. (gnus-async-article-callback): new function. (gnus-make-async-article-function): use it. (gnus-async-current-prefetch-group): new var. (gnus-async-current-prefetch-article): new var. (gnus-async-request-fetched-article): are we fetching it already? (gnus-async-delete-prefected-entry): s/prefected/prefetched/ 1998-11-20 02:49:21 Lars Magne Ingebrigtsen * gnus-sum.el (gnus-summary-show-article): Require. * message.el: Provide before hooks. (message-send-news): Do MIME before headers. * gnus-art.el (gnus-article-check-buffer): New function. (gnus-article-read-summary-keys): Use it. * mm-decode.el (mm-user-automatic-display): Display all inline images. * gnus-art.el (gnus-mime-display-single): Don't buttonize so much. (gnus-unbuttonized-mime-types): New variable. 1998-11-19 06:29:03 Lars Magne Ingebrigtsen * gnus-sum.el (gnus-inhibit-user-auto-expire): Changed to t. * mm-decode.el (mm-quote-arg): Quote semicolons. * gnus-art.el (gnus-mime-display-single): Don't display attachments. (gnus-mime-externalize-part): New command and keystroke. * mm-decode.el (mm-dissect-buffer): Pass on the description info. (mm-alternative-precedence): Changed order. 1998-11-07 17:41:47 Simon Josefsson * gnus.el (gnus-method-simplify): New function. (gnus-native-method-p): New function. (gnus-secondary-method-p): Use gnus-method-equal. * gnus-start.el (gnus-group-change-level): Shorten select method. Thu Nov 19 04:48:42 1998 Lars Magne Ingebrigtsen * gnus.el: Pterodactyl Gnus v0.51 is released. 1998-11-19 04:02:34 Lars Magne Ingebrigtsen * gnus.el: Applied patches from 5.6.45. * gnus-score.el (gnus-score-find-trace): Print complete file paths. (gnus-score-find-trace): Truncate lines. * gnus.el (gnus-message-archive-group): Allow function. * message.el (message-encode-message-body): Remove Mime-Version before inserting. * gnus-cus.el (gnus-group-customize): Optional topic. * gnus-sum.el (gnus-summary-customize-parameters): New command and keystroke. Wed Nov 18 13:46:08 1998 Shenghuo ZHU * message.el (message-encode-message-body): Rewrite. 1998-11-18 07:37:47 Lars Magne Ingebrigtsen * mml.el (mml-base-boundary): New variable. (mml-make-boundary): New function. * gnus-cache.el (gnus-cache-coding-system): New variable. (gnus-cache-request-article): Use it. * message.el (message-insert-mime-part): Delete duplicates. Wed Nov 18 11:52:19 1998 Shenghuo ZHU * gnus-art.el (gnus-mime-display-alternative): Set end of multipart and display even when nothing is preferred. Wed Nov 18 05:06:44 1998 Lars Magne Ingebrigtsen * gnus.el: Pterodactyl Gnus v0.50 is released. 1998-11-18 04:42:01 Lars Magne Ingebrigtsen * mm-decode.el (mm-inline-media-tests): Check that device-type is fbound. * gnus-sum.el (gnus-summary-sort): Didn't do reverse. 1998-11-07 23:39:48 Simon Josefsson * gnus.el (gnus-similar-server-opened): Compare backend. 1998-11-08 03:37:42 Simon Josefsson * gnus-topic.el (gnus-topic-expire-articles): New function. (gnus-topic-mode-map): Bind it. * gnus.texi (Topic Commands): New expiry command. Reordered. 1998-11-10 Miles Bader * gnus-sum.el (gnus-auto-expirable-marks): New variable. (gnus-inhibit-user-auto-expire): New variable. (gnus-summary-mark-article-as-read, gnus-summary-mark-article): When looking to see if we should expire instead, check gnus-auto-expirable-marks instead of using a hard-wired list. (gnus-summary-mark-as-read-forward, gnus-summary-mark-as-read-backward): Pass gnus-inhibit-user-auto-expire for the no-expire argument to gnus-summary-mark-forward, instead of `t'. 1998-11-18 03:30:26 Lars Magne Ingebrigtsen * mml.el (mml-compute-boundary): New function. (mml-compute-boundary-1): New function. (mml-generate-mime-1): Use it. 1998-11-18 Hrvoje Niksic * mml.el (mml-generate-mime-1): Always precede closing boundary with newline. 1998-11-18 02:36:37 Lars Magne Ingebrigtsen * mml.el (mml-generate-mime-1): Do right boundaries when several multiparts. * mm-decode.el (mm-user-automatic-display): Default to inline jpeg. * mml.el (mml-generate-mime-1): Encode non-text parts. Wed Nov 18 02:22:23 1998 Lars Magne Ingebrigtsen * gnus.el: Pterodactyl Gnus v0.49 is released. 1998-11-18 00:37:43 Lars Magne Ingebrigtsen * mm-view.el (mm-inline-text): Require w3-vars. * gnus-setup.el (gnus-use-tm): Removed. * gnus-art.el (gnus-article-goto-part): Don't beep. (gnus-article-view-part): Check return value. (gnus-mime-display-alternative): Don't display when there is nothing to display. * mml.el (mml-generate-mime-1): Don't use a unibyte buffer. (mml-generate-mime-1): Use unibyte for binaries. * gnus-art.el (gnus-display-mime): Call gnus-article-mime-part-function. (gnus-mime-part-function): New function. (gnus-article-mime-part-function): New function. * mml.el (mml-generate-mime-1): Don't insert so many newlines. 1998-11-16 06:44:19 Lars Magne Ingebrigtsen * mml.el (mml-generate-mime-1): Do it in unibyte buffers. * message.el (message-font-lock-keywords): Highlight MML. (message-mml-face): New font. Mon Nov 16 23:34:12 1998 Shenghuo ZHU * gnus-art.el (gnus-display-mime): Clean up even when no handles. (gnus-mm-display-part): Do not select-window if the article window is not found. Mon Nov 16 02:26:40 1998 Shenghuo ZHU * gnus-sum.el (gnus-summary-move-article): Use no-encode for B m. Mon Nov 16 02:00:05 1998 Lars Magne Ingebrigtsen * gnus.el: Pterodactyl Gnus v0.48 is released. 1998-11-15 23:18:56 Lars Magne Ingebrigtsen * mm-bodies.el (mm-encode-body): Disbabled for nonmule. * mm-util.el (mm-find-charset-region): Bogus change for non-Mule. * message.el (message-cite-original-without-signature): Ditto. (message-cite-original): Quote parts. Sun Nov 15 22:01:55 1998 Lars Magne Ingebrigtsen * gnus.el: Pterodactyl Gnus v0.47 is released. 1998-11-15 20:11:33 Lars Magne Ingebrigtsen * message.el (message-encode-message-body): Insert MIME warning. * mml.el (mml-read-tag): Look for #tag. * mm-util.el (mm-find-charset-region): Check whether enable-multibyte-characters is bound. Sun Nov 15 02:01:31 1998 Lars Magne Ingebrigtsen * gnus.el: Pterodactyl Gnus v0.46 is released. 1998-11-15 01:54:40 Lars Magne Ingebrigtsen * message.el (message-encode-message-body): Insert headers at the right spot. Sun Nov 15 01:13:41 1998 Lars Magne Ingebrigtsen * gnus.el: Pterodactyl Gnus v0.45 is released. 1998-11-15 00:28:49 Lars Magne Ingebrigtsen * nndraft.el (nndraft-save-mime-part): Removed. (nndraft-get-mime-part): Ditto. * message.el (message-format-mime-old): Removed. (message-encode-message-body): Removed. (message-encode-message-body): Renamed. 1998-11-14 18:27:19 Lars Magne Ingebrigtsen * gnus-sum.el (gnus-get-newsgroup-headers): Translate \r's. * message.el (message-format-mime): Check message-mime-part. * mm-encode.el (mm-mime-file-types): Removed. (mm-default-file-encoding): New definition. Sat Nov 14 01:29:39 1998 Shenghuo ZHU * mm-view.el (mm-inline-image): Use mm-insert-inline. * gnus-art.el (gnus-mm-display-part): Go to correct position. Sat Nov 14 05:47:57 1998 Lars Magne Ingebrigtsen * gnus.el: Pterodactyl Gnus v0.44 is released. 1998-11-14 03:59:14 Lars Magne Ingebrigtsen * message.el (message-format-mime): New function. * nndraft.el (nndraft-save-mime-part): New function. (nndraft-get-mime-part): New function. * mm-encode.el (mm-default-file-encoding): New function. (mm-content-transfer-encoding): New function. (mm-encode-buffer): New function. * message.el: New command. (message-mime-part): New variable. (message-insert-mime-part): New command. * mm-encode.el (mm-encode-content-transfer-encoding): New function. * mm-util.el (mm-content-transfer-encoding-defaults): New variable. (mm-mime-file-types): Taken from TM. Sat Nov 14 01:51:06 1998 Lars Magne Ingebrigtsen * gnus.el: Pterodactyl Gnus v0.43 is released. 1998-11-07 Karl Kleinpaste * gnus-cus.el (gnus-score-customize): Add "Extra" element. * gnus-score.el (gnus-score-default-header): Ditto. (gnus-header-index): Ditto. (gnus-summary-increase-score): Ditto, & process "extra" requests. (gnus-summary-header): Handle extra headers. (gnus-summary-score-entry): Ditto, & provide new score element. (gnus-summary-score-effect): Ditto. (gnus-score-string): Avoid "extra" string sort, & modify match in "extra" case. * gnus-sum.el (gnus-make-score-map): Add "extra" element. 1998-11-13 20:30:40 Lars Magne Ingebrigtsen * message.el (message-resend): Bind message-required-mail-headers to nil. * mm-view.el (mm-inline-text): Bind w3-strict-width. * nngateway.el (require): Require cl. * gnus-art.el (gnus-button-alist): Exclude more chars from news: things. Wed Nov 11 02:15:06 1998 Shenghuo ZHU * gnus-agent.el (gnus-agent-fetch-headers): Create directory even when no articles. 1998-11-13 19:25:10 Lars Magne Ingebrigtsen * message.el (message-ignored-resent-headers): Remove X-Gnus. 1998-11-10 Colin Rafferty * gnus-sum.el (gnus-ignored-from-addresses): Only quote user-mail-address if non-nil. 1998-11-13 18:50:18 Lars Magne Ingebrigtsen * gnus-util.el (gnus-make-sort-function): Do `reverse'. (gnus-make-sort-function-1): Ditto. * gnus-art.el (gnus-mm-display-part): Switch to mm in right window. 1998-11-12 22:31:58 Lars Magne Ingebrigtsen * mm-util.el (mm-with-unibyte-buffer): Ditto. * binhex.el (binhex-decode-region): Quote. 1998-11-10 05:32:28 Lars Magne Ingebrigtsen * gnus-art.el (article-decode-charset): Don't downcase charset. * gnus-sum.el (gnus-get-newsgroup-headers-xover): Translate CR's. Sun Nov 8 23:17:24 1998 Lars Magne Ingebrigtsen * gnus.el: Pterodactyl Gnus v0.42 is released. Sun Nov 8 02:36:33 1998 Shenghuo ZHU * gnus-art.el (gnus-display-mime): Add id for alternative part. 1998-11-08 02:24:47 Simon Josefsson * nntp.el (nntp-send-mode-reader): Revert. Sun Nov 8 00:45:13 1998 Shenghuo ZHU * gnus-agent.el (gnus-agent-fetch-articles): Use with-temp-buffer. Sat Nov 7 23:07:24 1998 Shenghuo ZHU * message.el (message-make-date): Fix for negative time zones. Sun Nov 8 01:00:16 1998 Lars Magne Ingebrigtsen * gnus.el: Pterodactyl Gnus v0.41 is released. 1998-11-08 00:52:38 Hrvoje Niksic * mm-decode.el (mm-dissect-multipart): Quote regexp. 1998-10-29 Sudish Joseph * gnus.el (gnus-short-group-name): When shortening foreign select methods, do not scan for plusses beyond the first colon. 1998-11-07 Mike McEwan * gnus-agent.el (gnus-agent-save-group-info): Cater for group info lines where `group' is the last thing on the line. 1998-11-08 00:35:09 Lars Magne Ingebrigtsen * gnus-art.el (gnus-article-view-part): Do alternative. (gnus-mime-display-alternative): Insert marker. 1998-11-07 14:33:46 Lars Magne Ingebrigtsen * mm-decode.el (mm-dissect-multipart): Quote regexp. * nnmail.el (nnmail-expired-article-p): Protect against bogus dates. * gnus-cus.el (gnus-topic): Required. * nnheader.el (nnheader-parse-nov): Parse extra. (nnheader-nov-parse-extra): New macro. 1998-10-31 12:33:22 Lars Magne Ingebrigtsen * gnus-art.el (gnus-article-view-part): Internal move. 1998-10-28 Per Abrahamsen * gnus-cus-new.el (gnus-custom-topic): New free variable. (gnus-group-customize): Support editing topic parameters. 1998-10-29 12:09:20 Karl Kleinpaste * gnus-sum.el (gnus-summary-from-or-to-or-newsgroups): Add indicators. 1998-10-29 11:31:11 Lars Magne Ingebrigtsen * gnus-art.el (gnus-mm-display-part): Return. (gnus-article-view-part): Only go if external. (gnus-article-dumbquotes-map): Do 205. * mm-decode.el (mm-display-part): Return what was done. * message.el (message-buffer-naming-style): New variable. (message-generate-new-buffers): Extended. (message-buffer-naming-style): Removed. (message-buffer-name): Use it. (message-do-send-housekeeping): Rename new styling. * gnus-sum.el (gnus-summary-recenter): Allow gnus-auto-center-summary to be a number. Wed Nov 4 02:24:39 1998 Shenghuo ZHU * pop3.el (pop3-open-server): Use "binary" instead of "no-conversion". Sun Nov 1 01:26:42 1998 Shenghuo ZHU * gnus-srvr.el (gnus-browse-foreign-server): Set gnus-browse-current-method to the result of gnus-server-to-method. Thu Oct 29 01:47:44 1998 Shenghuo ZHU * gnus-util.el (gnus-pull): Another optional argument. * nnweb.el (nnweb-request-delete-group): Delete from nnweb-group-alist and update active file. Thu Oct 29 01:05:08 1998 Shenghuo ZHU * gnus-group.el (gnus-group-make-group): Accept group of new method. Wed Oct 28 02:19:16 1998 Shenghuo ZHU * gnus-agent.el (gnus-agent-fetch-group-1): Update dribble. Tue Oct 27 11:59:31 1998 Shenghuo ZHU * mm-view.el (mm-inline-text): Postion of html portion. 1998-10-29 10:26:54 Lars Magne Ingebrigtsen * nntp.el (nntp-list-active-group): Waited for short strings. (nntp-send-mode-reader): Ditto. (nntp-open-connection): Ditto. * gnus-int.el (gnus-request-group-articles): New function. * nntp.el (nntp-request-listgroup): New function. (nntp-request-group-articles): Renamed. 1998-10-27 10:37:52 Karl Kleinpaste * nnheader.el (nnheader-parse-nov): Supply extra. 1998-10-26 23:03:48 Lars Magne Ingebrigtsen * gnus-art.el (gnus-button-push): Don't go to gnus-article-buffer. * mm-view.el (mm-inline-image): Add a newline. * gnus-start.el (gnus-check-first-time-used): Check more. 1998-10-26 23:03:29 Francois Felix Ingrand * gnus-start.el (gnus-check-first-time-used): Check current. 1998-10-26 22:07:52 Lars Magne Ingebrigtsen * mm-util.el (mm-find-charset-region): New function. * ietf-drums.el (ietf-drums-narrow-to-header): Work when no header. * gnus-art.el (gnus-mime-button-menu): Fix. 1998-10-26 22:07:43 Michael Welsh Duggan * gnus-art.el (gnus-mime-button-menu): New definition. 1998-10-26 01:46:11 Lars Magne Ingebrigtsen * gnus-art.el (article-decode-charset): Downcase charset. (article-decode-charset): Pass on type. (article-decode-charset): Check nil charsets. (article-remove-cr): Translate CR to LF. (gnus-ignored-mime-types): Default to nil. * nnheader.el (nnheader-insert-nov): Work when not Xref. * gnus-sum.el (gnus-ignored-from-addresses): Default to user-mail-address. (gnus-nov-parse-extra): Didn't return right thing. 1998-10-25 23:25:27 Lars Magne Ingebrigtsen * gnus-xmas.el: Use compiled-function-p. Mon Oct 26 14:37:19 1998 Shenghuo ZHU * mm-decode.el (mm-copy-Yo-buffer): Make it works when no header. Sun Oct 25 23:11:44 1998 Lars Magne Ingebrigtsen * gnus.el: Pterodactyl Gnus v0.40 is released. 1998-10-25 21:41:05 Lars Magne Ingebrigtsen * gnus-sum.el (gnus-summary-mark-forward): Show thread. * gnus-start.el (gnus-check-first-time-used): Ignore dribble. * gnus-agent.el (gnus-agent-fetch-group-1): Bind name. * nnml.el (nnml-possibly-create-directory): Check before making. 1998-10-25 19:43:08 Kai Grossjohann * nnheader.el (nnheader-insert-nov): Don't infloop. 1998-10-25 19:26:11 Lars Magne Ingebrigtsen * gnus-sum.el (gnus-set-mode-line): Check that the spec has been set up. 1998-10-25 19:22:03 Joerg Lenneis * nneething.el (nneething-file-name): New definition. 1998-10-25 17:56:23 Lars Magne Ingebrigtsen * gnus-art.el (gnus-treatment-function-alist): Fix. (gnus-summary-save-in-rmail): Use gnus-output-to-rmail. * nndoc.el (nndoc-dissect-mime-parts-sub): Recognize first part. Sun Oct 25 06:23:13 1998 Lars Magne Ingebrigtsen * gnus.el: Pterodactyl Gnus v0.39 is released. 1998-10-25 00:34:39 Lars Magne Ingebrigtsen * gnus-art.el (gnus-ignored-mime-types): New variable. (gnus-mime-display-single): Use it. (gnus-treatment-function-alist): New variable. * gnus.el (gnus-mime): New group. * gnus-art.el (gnus-mime-display-alternative): Don't destroy things for other parts. (gnus-mime-display-alternative): Place point. * gnus.el: autoload gnus-uu-post-news. * mailcap.el (mailcap-mailcap-entry-passes-test): Also check needsterm/DISPLAY. * mm-decode.el (mm-display-part): Default to inline text/.* parts. * mm-bodies.el (mm-decode-content-transfer-encoding): Default to 8bit. * gnus-art.el (gnus-mime-copy-part): Use normal-mode. (gnus-mime-display-single): Inline all text parts. (gnus-article-narrow-to-signature): Removed mime:: stubs. 1998-10-24 21:38:37 Lars Magne Ingebrigtsen * nnml.el (nnml-possibly-create-directory): Rewrite. (nnml-request-create-group): Change to right server. * gnus-xmas.el (gnus-xmas-define): Use byte-code-function-p. * gnus-sum.el (gnus-set-mode-line): Use truncate-string-to-width. * gnus.el: rmail-output-to-rmail-file autoload. * gnus-util.el (gnus-output-to-rmail): Didn't work if not in Gnus. * nnheader.el (nnheader-parse-head): Checked wrong variable. * gnus-sum.el (gnus-summary-update-mark): Ignore nil'd marks. Tue Oct 20 23:37:43 1998 Shenghuo ZHU * gnus-art.el (gnus-mime-display-mixed): Multipart in mixed part. Tue Oct 20 23:36:43 1998 Shenghuo ZHU * gnus-sum.el (gnus-summary-exit): Use mm-destroy-parts. * gnus-sum.el (gnus-summary-exit-no-update): Ditto. Tue Oct 20 16:22:51 1998 Shenghuo ZHU * mm-uu.el (mm-uu-dissect): Create pseudo multipart head. 1998-10-24 20:51:53 Lars Magne Ingebrigtsen * gnus-sum.el (gnus-valid-move-group-p): Make sure group has a value. * gnus-art.el (gnus-article-hidden-text-p): Return nil when not hidden. * gnus-spec.el (gnus-update-format-specifications): Use the article mode line spec. * gnus-art.el (gnus-insert-mime-button): Put right type. (gnus-insert-prev-page-button): Ditto. (gnus-insert-next-page-button): Dutti. * pop3.el: New version installed. Sat Oct 24 16:48:51 1998 Shenghuo ZHU * mm-uu.el (mm-uu-dissect): Delete the begining spurious newline and display last part. Sat Oct 24 20:31:55 1998 Lars Magne Ingebrigtsen * gnus.el: Pterodactyl Gnus v0.38 is released. 1998-10-24 07:54:58 Lars Magne Ingebrigtsen * gnus-art.el (article-mime-decode-quoted-printable-buffer): Removed. (article-de-quoted-unreadable): Narrow to default. * qp.el (quoted-printable-encode-region): Encode before QP-ing. * gnus-art.el (article-decode-charset): Decode even when broken MIME. * gnus-sum.el (gnus-summary-from-or-to-or-newsgroups): Return name. * gnus-msg.el (gnus-copy-article-buffer): Delete headers. * gnus-cache.el (gnus-cache-possibly-enter-article): Use nnheader. * nnmail.el (nnmail-extra-headers): New variable. * nnheader.el (nnheader-insert-nov): Insert extra. * gnus.el (gnus-summary-line-format): Doc fix. * gnus-sum.el (gnus-get-newsgroup-headers): Parse extra. (gnus-nov-parse-line): Ditto. (gnus-nov-parse-extra): New macro. (gnus-header): New function. (gnus-update-summary-mark-positions): Change. (gnus-ignored-from-addresses): New variable. (gnus-summary-insert-from-or-to): New function. * gnus.el (gnus-extra-headers): New variable. * nnheader.el (make-mail-header): Expand. (mail-header-extra): New macro. (mail-header-set-extra): Ditto. (make-full-mail-header): Expand. Sat Oct 24 07:41:42 1998 Lars Magne Ingebrigtsen * gnus.el: Pterodactyl Gnus v0.37 is released. 1998-10-24 07:29:11 Lars Magne Ingebrigtsen * mm-bodies.el (mm-decode-body): Check for multibyticity. * mm-util.el (mm-enable-multibyte): Don't always switch multibyte on. 1998-10-22 Didier Verna * gnus-spec.el (gnus-balloon-face-function): new function (gnus-parse-format): understand the %< %> specifiers (gnus-parse-complex-format): ditto. 1998-10-24 06:31:33 Lars Magne Ingebrigtsen * gnus.el: Changed following-char to char-after throughout. 1998-10-22 04:05:55 Lars Magne Ingebrigtsen * mm-decode.el (mm-display-external): Protect more and message. Wed Oct 21 03:26:30 1998 Shenghuo ZHU * gnus-xmas.el (gnus-xmas-article-push-button): Go to the position. Tue Oct 20 23:37:43 1998 Shenghuo ZHU * gnus-art.el (gnus-mime-display-mixed): Multipart in mixed part. Tue Oct 20 23:36:43 1998 Shenghuo ZHU * gnus-sum.el (gnus-summary-exit): Use mm-destroy-parts. * gnus-sum.el (gnus-summary-exit-no-update): Ditto. Tue Oct 20 16:22:51 1998 Shenghuo ZHU * mm-uu.el (mm-uu-dissect): Create pseudo multipart head. 1998-10-21 Hrvoje Niksic * mailcap.el (mailcap-save-binary-file): Use unwind-protect. * mm-decode.el (mm-display-external): Set undisplayer to mm buffer, not the current buffer; use unwind-protect. 1998-10-21 00:07:59 Lars Magne Ingebrigtsen * gnus-sum.el (gnus-summary-exit): Destroy parts. (gnus-summary-exit-no-update): Ditto. 1998-10-20 22:02:05 Lars Magne Ingebrigtsen * mm-decode.el (mm-inline-media-tests): Look for w3. * mailcap.el (mailcap-mime-data): Inline html. Tue Oct 20 20:25:03 1998 Lars Magne Ingebrigtsen * gnus.el: Pterodactyl Gnus v0.36 is released. 1998-10-20 18:13:08 Lars Magne Ingebrigtsen * gnus-art.el (article-translate-strings): (gnus-article-dumbquotes-map): Don't dot. * pop3.el (pop3-open-server): Set point right. * mm-decode.el (mm-dissect-multipart): Dissect hierarchically. (mm-dissect-buffer): Ditto. (mm-destroy-part): Ignore non-handles. (mm-remove-part): Ditto. (mm-destroy-parts): New function. (mm-remove-parts): Ditto. * gnus-art.el (gnus-mm-display-part): Don't move point. Tue Oct 20 02:16:36 1998 Shenghuo ZHU * mm-uu.el : New file. * gnus-art.el (gnus-display-mime): Dissect uu stuffs. * mm-bodies.el (mm-decode-content-transfer-encoding): Encoding as a function. 1998-10-20 00:35:05 Lars Magne Ingebrigtsen * mm-decode.el (mm-display-external): Check before selecting. Sat Sep 26 02:03:00 1998 Shenghuo ZHU * gnus-sum.el (gnus-multi-decode-encoded-word-string): Rewrite. * gnus-sum.el (gnus-decode-encoded-word-methods): New variable. * gnus-sum.el (gnus-decode-encoded-word-methods-cache): New variable. * gnus-sum.el (gnus-encoded-word-method-alist): Deleted. * gnus-art.el (gnus-decode-header-methods): New variable. * gnus-art.el (gnus-decode-header-methods-cache): New variable. * gnus-art.el (gnus-multi-decode-header): New function. Tue Oct 20 00:24:16 1998 Lars Magne Ingebrigtsen * gnus.el: Pterodactyl Gnus v0.35 is released. 1998-10-20 00:00:36 Lars Magne Ingebrigtsen * uudecode.el (uudecode-decode-region-external): Insert literally. * gnus-xmas.el (gnus-xmas-mime-button-menu): Moved here. * mm-bodies.el (mm-decode-body): Optional encoding. 1998-10-19 23:57:57 Lars Magne Ingebrigtsen * gnus-ems.el (gnus-mouse-3): New variable. * binhex.el (binhex-decode-region-external): Don't use -internally. 1998-10-16 14:54:02 Simon Josefsson * mailcap.el (mailcap-parse-mailcaps): Only open regular files. 1998-09-26 22:28:01 Simon Josefsson * gnus-group.el (gnus-add-marked-articles): Request backend update of flags. 1998-09-26 19:39:31 Simon Josefsson * gnus-sum.el (gnus-update-read-articles): (gnus-update-marks): Request backend update of mark. 1998-09-26 19:33:58 Simon Josefsson * gnus.texi (Optional Backend Functions): New item, nnchoke-request-set-mark. 1998-09-26 16:27:27 Simon Josefsson * gnus-range.el (gnus-remove-from-range): Don't add stuff in list to range. 1998-10-19 23:45:13 Simon Josefsson * gnus-sum.el (gnus-summary-exit-no-update): Don't expire. 1998-10-14 SL Baur * gnus-sum.el: Move gnus-save-hidden-threads above where it is first used. 1998-10-10 SL Baur * mm-view.el: Require mm-decode for macros. * mm-decode.el (mm-handle-type): Move macro declarations above the place where they are used. Sun Oct 18 13:59:07 1998 Kurt Swanson * gnus-msg.el (gnus-summary-mail-forward): Erase old forward buffer. 1998-10-19 23:38:11 Katsumi Yamaoka * nnagent.el (nnagent-open-server): Error message. 1998-10-19 23:35:08 Joerg Lenneis * nnheader.el (nnheader-article-p): Recognize lower-case headers. 1998-10-19 Hrvoje Niksic * score-mode.el (gnus-score-mode-map): Ditto. * message.el (message-mode-map): Ditto. * gnus-uu.el (gnus-uu-post-news): Ditto. * gnus-kill.el (gnus-kill-file-mode-map): Ditto. * gnus-eform.el (gnus-edit-form-mode-map): Ditto. * gnus-art.el (gnus-article-edit-mode-map): Use `set-keymap-parent' rather than `copy-keymap'. 1998-10-18 Hrvoje Niksic * gnus-art.el (gnus-mime-button-commands): New variable. (gnus-mime-button-map): Initialize it from `gnus-mime-button-commands'. (gnus-mime-button-menu): New function. (gnus-insert-mime-button): Use `gnus-mime-button-map'. 1998-10-11 Hrvoje Niksic * message.el (message-insert-to): Make `nobody' and `poster' synonymous to `never' and `always' in Mail-Copies-To. (message-reply): Ditto. (message-followup): Ditto. 1998-10-19 23:17:41 Lars Magne Ingebrigtsen * mailcap.el (mailcap-mime-data): Save sound. 1998-09-24 Hrvoje Niksic * message.el (message-ignored-supersedes-headers): Include `NNTP-Posting-Date'. 1998-10-19 01:25:27 Jonas Steverud * gnus-art.el (gnus-article-dumbquotes-table): New variable. 1998-10-19 00:50:22 Lars Magne Ingebrigtsen * mm-bodies.el (mm-decode-content-transfer-encoding): Use uudecode. 1998-10-18 18:20:34 Lars Magne Ingebrigtsen * mm-decode.el (mm-display-external): Don't switch on save. 1998-10-18 18:14:06 Andy Piper * nnmail.el (nnmail-movemail-args): New variable. 1998-10-18 00:17:02 Lars Magne Ingebrigtsen * gnus-art.el (article-translate-strings): 1998-10-17 22:51:31 Lars Magne Ingebrigtsen * gnus-art.el (gnus-article-view-part): Use it. (gnus-mm-display-part): New function. (article-de-quoted-unreadable): Yse mm-default-coding-system. * mm-decode.el (mm-handle-displayed-p): New function. * gnus-art.el (gnus-mime-copy-part): Create better names. (gnus-mime-button-line-format): Include dots spec. 1998-10-15 Matt Pharr * gnus-msg.el (gnus-summary-mail-forward): Erase contents of old forward buffer first. 1998-10-17 21:16:46 Lars Magne Ingebrigtsen * gnus-util.el (gnus-set-window-start): New function. * message.el (message-send): Don't check changed. 1998-10-12 15:26:41 Lars Magne Ingebrigtsen * gnus-art.el (gnus-article-setup-buffer): Set params. * mm-decode.el (mm-user-display-methods): Inline "message/delivery-status". 1998-10-11 07:06:38 Lars Magne Ingebrigtsen * message.el (message-auto-save-directory): Rename. (message-mode): Dof fix. * gnus-art.el (gnus-summary-save-in-pipe): Default to "cat". (gnus-summary-save-in-pipe): No, check gnus-last-shell-command. * nndoc.el (nndoc-mime-parts-type-p): Be a bit more forgiving. * message.el (message-make-date): Avoid locale. * gnus-art.el (gnus-article-edit-done): Allow update before doing cache. * mm-decode.el (mm-display-inline): Goto point-min. * gnus-art.el (gnus-article-prepare-display): Not read-only. * mm-decode.el (mm-display-external): Reverse before sorting. * gnus-draft.el (gnus-draft-send): Allow mail. 1998-10-10 SL Baur * message.el (message-check): Move message-check macro above where it is first used. * gnus-art.el (article-hide-pgp): Hide the PGP 5/GNUPG Hash: line. 1998-10-11 06:45:37 Lloyd Zusman * gnus-sum.el (gnus-summary-make-menu-bar): Fix. Sun Oct 11 02:28:40 1998 Lars Magne Ingebrigtsen * gnus.el: Pterodactyl Gnus v0.34 is released. 1998-10-11 02:15:41 Lars Magne Ingebrigtsen * mm-decode.el (mm-inline-media-tests): delivery-status. * mm-view.el (mm-inline-text): Provide default. 1998-10-11 01:01:37 Lloyd Zusman * mailcap.el (mailcap-possible-viewers): Fix nils. 1998-10-11 00:03:37 Lars Magne Ingebrigtsen * gnus-art.el (gnus-article-edit-exit): Don't do updates. (article-update-date-lapsed): Record the buffer. (article-update-date-lapsed): Do all windows that display article buffers. * nnml.el (nnml-generate-nov-databases-1): Ditto. * gnus-score.el (gnus-score-score-files-1): Ignore dotted files. * gnus-art.el (gnus-insert-mime-button): Mark buttons as annoations. * gnus-msg.el (gnus-summary-mail-forward): Decode properly. 1998-10-10 22:07:03 Lars Magne Ingebrigtsen * gnus-agent.el (gnus-category-add): Change default category to 'false. * nnvirtual.el (nnvirtual-update-read-and-marked): Don't nix out scores. * gnus-draft.el (gnus-draft-send): Check server more. * gnus-art.el (gnus-article-view-part): New command and keystroke. (gnus-article-goto-part): New function. * mm-view.el (mm-inline-text): Insert richtext properly. * gnus-art.el (gnus-insert-mime-button): Store handle in alist. 1998-10-03 15:04:27 Lars Magne Ingebrigtsen * parse-time.el (parse-time-rules): Accept dates far into the past and the future, and parse single-digit numbers as years. 1998-10-02 04:46:46 Lars Magne Ingebrigtsen * mm-decode.el (mm-display-external): Chop off directories. 1998-10-01 07:33:35 Lars Magne Ingebrigtsen * uudecode.el (uu-decode-region-external): Use insert-file-contents-literally. * gnus-cache.el (gnus-cache-generate-active): Translate _ to :. 1998-10-01 07:02:11 Shenghuo ZHU * uudecode.el: New file. * mm-bodies.el (mm-decode-content-transfer-encoding): Do x-uuencode. 1998-10-01 05:19:35 Lars Magne Ingebrigtsen * gnus-art.el (gnus-mime-display-alternative): Set faces. * message.el (message-fetch-field): Unfold properly. * mm-bodies.el (mm-decode-content-transfer-encoding): Replace CRLF in text/plain. 1998-09-30 05:47:49 Lars Magne Ingebrigtsen * gnus-sum.el (gnus-summary-first-unread-subject): New command. (gnus-auto-select-first): Removed. (gnus-auto-select-first): Extended. (gnus-summary-read-group-1): Use new value. 1998-09-29 13:21:06 Lars Magne Ingebrigtsen * message.el (message-fix-before-sending): Space. * nnmail.el (nnmail-find-file): Don't erase. Wed Sep 30 23:49:03 1998 Shenghuo ZHU * gnus-agent.el (gnus-agent-fetch-headers): Do not decode headers. Wed Sep 30 23:46:29 1998 Shenghuo ZHU * gnus-soup.el (gnus-soup-add-article): Do not decode headers. Wed Sep 30 23:44:08 1998 Shenghuo ZHU * gnus-soup.el (gnus-soup-pack-packet): Pack only if necesary. Sat Sep 26 03:04:18 1998 Shenghuo ZHU * mm-util.el (mm-with-unibyte-buffer): Make it work in XEmacs 20.4. 1998-09-29 11:35:09 Lars Magne Ingebrigtsen * gnus-art.el (gnus-mime-view-all-parts): New command and keystroke. * mm-decode.el (mm-display-external): Translate slashes. * nnmail.el (nnmail-find-file): Restrict auto-mode-alist. * nndraft.el (nndraft-retrieve-headers): Don't copy so much. * mm-decode.el (mm-quote-arg): Quote spaces. (mm-display-external): Quote args. 1998-09-24 22:27:55 Lars Magne Ingebrigtsen * mm-decode.el (mm-inlinable-part-p): New function. 1998-09-25 22:28:01 Simon Josefsson * mm-util.el (mm-disable-multibyte): New function. Thu Sep 24 20:28:31 1998 Lars Magne Ingebrigtsen * gnus.el: Pterodactyl Gnus v0.33 is released. 1998-09-24 18:47:31 Lars Magne Ingebrigtsen * gnus-art.el (gnus-insert-mime-button): Get buffer size. * mm-decode.el (mm-display-external): Don't switch for externals. (mm-dissect-multipart): Don't include end-sep. * mm-util.el (mm-get-coding-system-list): New function. (mm-coding-system-list): New variable. Thu Sep 24 02:08:10 1998 ZHU Shenghuo * gnus-cus.el (gnus-group-parameters): Add charset as a parameter Thu Sep 24 02:05:48 1998 ZHU Shenghuo * gnus-cus.el (gnus-group-customize): Use variable as cons not as group Thu Sep 24 01:41:03 1998 ZHU Shenghuo * base64.el (base64-run-command-on-region): External base64 decoder do not use coding system Thu Sep 24 01:39:44 1998 ZHU Shenghuo * mm-decode.el (mm-interactively-view-part): Typo. Thu Sep 24 01:37:30 1998 ZHU Shenghuo * mm-decode.el (mm-dissect-multipart): Display last part when the article has no close-delimiter Thu Sep 24 01:28:54 1998 ZHU Shenghuo * mm-decode.el (mm-dissect-buffer): Display parts which have no content-type. Thu Sep 24 01:23:57 1998 ZHU Shenghuo * gnus-art.el (gnus-display-mime): Typo. Thu Sep 24 02:29:57 1998 Lars Magne Ingebrigtsen * gnus.el: Pterodactyl Gnus v0.32 is released. 1998-09-24 00:27:11 Lars Magne Ingebrigtsen * gnus-kill.el (gnus-batch-score): Protect against errors. * gnus-art.el: Protect against broken headers. * mm-decode.el (mm-display-external): Respect needsterm. (mm-display-external): Create buffer for external commands. 1998-09-23 22:04:05 Lars Magne Ingebrigtsen * mailcap.el (mailcap-mime-info): Return the proper viewer. * mm-decode.el (mm-display-external): Use file name. 1998-09-22 Markus Rost * gnus-util.el (gnus-output-to-rmail): adjust to `rmail-output-to-rmail-file' 1998-09-23 20:07:00 Lars Magne Ingebrigtsen * gnus-util.el (gnus-output-to-rmail): Reinstated function. * gnus-sum.el (gnus-select-newsgroup): Set global variables before headers. * gnus-art.el (article-decode-charset): Fold case. 1998-09-17 15:49:10 Simon Josefsson * mailcap.el (mailcap-save-binary-file): Goto point-min. 1998-09-23 19:48:52 Aaron M. Ucko * nnmail.el (nnmail-check-duplication): Enter into duplicate list after being stored. Tue Sep 15 16:15:16 1998 Kurt Swanson * gnus-salt.el (gnus-pick-setup-message): Return from whence ye come. 1998-09-23 19:42:03 Lars Magne Ingebrigtsen * gnus-xmas.el (wid-edit): Required. * gnus-ems.el (gnus-widget-button-keymap): New variable. Sun Sep 20 00:27:55 1998 ZHU Shenghuo * gnus-art.el (gnus-mime-inline-part): remove part if necessary 1998-09-23 19:30:52 Matt Armstrong * gnus-art.el (article-decode-charset): Narrow to the correct region. * mm-bodies.el: Fix autoload. 1998-09-22 18:35:12 Lee Willis * gnus-art.el (gnus-mime-button-line-format): Doc fix. 1998-09-22 14:53:35 Lars Magne Ingebrigtsen * rfc2047.el (rfc2047-decode): Use rfc2047-default-charset. 1998-09-19 13:58:35 Lars Magne Ingebrigtsen * gnus-art.el (gnus-insert-mime-button): Specify keymap. (gnus-article-add-button): Ditto. * gnus-sum.el (gnus-summary-insert-pseudos): Use mm. * gnus-art.el (gnus-article-prepare-display): Make article mode. (gnus-article-prepare-display): Bind url-standalone-mode. * mm-decode.el (mm-remove-part): Also delete directory. (mm-display-external): Create a private sub-dir. * mailcap.el (mailcap-binary-suffixes): New variable. (mailcap-command-p): Use it. 1998-09-16 10:38:21 Lars Magne Ingebrigtsen * nnmbox.el (nnmbox-request-group): Change server. (nnmbox-possibly-change-newsgroup): Enable multibyte. * message.el (message-encode-message-body): Don't stomp MIME headers. * gnus-sum.el (gnus-summary-edit-article-done): Don't encode unless useful. (gnus-summary-exit): Check for a live article buffer. (gnus-summary-exit-no-update): Ditto. * gnus-int.el (gnus-request-replace-article): Accept no-encode param. * gnus-sum.el (gnus-article-decoded-p): New variable. * mm-decode.el (mm-display-external): Use no-conv. * rfc2047.el (rfc2047-q-encode-region): Bound properly. (rfc2047-charset-encoding-alist): Use B encoding for koi8-r. * gnus-art.el (gnus-article-mode-map): Bind button2 to mouse-click. 1998-09-15 14:38:02 Lars Magne Ingebrigtsen * gnus-agent.el (gnus-agent-expire): Protect against nil infos. Mon Sep 14 18:55:38 1998 Lars Magne Ingebrigtsen * gnus.el: Pterodactyl Gnus v0.31 is released. 1998-09-14 15:12:59 Lars Magne Ingebrigtsen * gnus-sum.el (gnus-summary-exit): Destroy MIME. * mm-decode.el (mm-display-part): Accept no-default. * gnus-art.el (gnus-insert-mime-button): buffer-size doesn't take a parameter. * gnus-sum.el (gnus-summary-insert-line): Don't exclude faces. (gnus-summary-prepare-threads): Ditto. * gnus.el (gnus-article-mode-map): Make sparse keymap. * gnus-art.el (gnus-mime-button-line-format-alist): Allow a %d spec. (gnus-mime-button-line-format): Doc fix. (gnus-insert-mime-button): Use it. (gnus-article-add-button): Use widget-convert-button. * gnus.el ((featurep 'gnus-xmas)): Defalias gnus-decode-rfc1522 to ignore. * mm-decode.el (mm-alternative-precedence): Ditto. 1998-09-14 15:12:49 Conrad Sauerwald * mm-decode.el (mm-user-automatic-display): Use enriched. 1998-09-14 15:09:12 Paul Fisher * mm-decode.el (mm-dissect-multipart): Have the part start on the right place. 1998-09-14 14:33:34 Lars Magne Ingebrigtsen * gnus-msg.el (gnus-inews-add-send-actions): Mark silently. * gnus-art.el (article-update-date-lapsed): Only update header if buffer is dispalyed in frame. (gnus-article-prepare-display): New function. (gnus-article-prepare): Use it. 1998-09-14 08:16:43 Lars Magne Ingebrigtsen * gnus-art.el (gnus-mime-inline-part): New command and keystroke. * mm-view.el (mm-insert-inline): New function. * mm-decode.el (mm-pipe-part): Bugged. * gnus-agent.el (gnus-agent-send-mail): Don't encode. * mm-bodies.el (mm-encode-body): Move over the body. * nnmbox.el (nnmbox-read-mbox): Enable multibyte. * rfc2047.el (rfc2047-q-encode-region): Would bug out. 1998-09-13 Francois Pinard * nndoc.el: Make nndoc-dissection-alist simpler for MIME, adjust all related functions. Handle message/rfc822 parts. Display subject on multipart summary lines. Display name on sub-parts when available. 1998-09-14 07:36:38 Hallvard B. Furuseth * mailcap.el (mailcap-command-p): New version. 1998-09-13 Mike McEwan * gnus-agent.el (gnus-agent-expire): Stop expiry barfing on killed groups. 1998-09-13 18:34:06 Lars Magne Ingebrigtsen * message.el (message-make-date): Remove weekday name. * mm-decode.el (mm-dissect-buffer): Protect against broken headers. * mailcap.el (mailcap-command-in-path-p): New function. (mailcap-command-p): Renamed. 1998-09-13 17:58:47 Hallvard B. Furuseth * rfc2047.el (eval): Autoload. 1998-09-13 12:22:40 Lars Magne Ingebrigtsen * gnus-sum.el (gnus-decode-encoded-word-functions): New variable. (gnus-multi-decode-encoded-word-string): New function. (gnus-encoded-word-method-alist): New variable. (gnus-decode-encoded-word-functions): Removed. 1998-09-13 Shenghuo ZHU * gnus-int.el (gnus-request-replace-article): Replace message-narrow-to-headers with message-narrow-to-head 1998-09-13 12:05:41 Lars Magne Ingebrigtsen * drums.el (drums-quote-string): Reversed match. * message.el (message-make-date): Use weekday name. Sun Sep 11 10:27:15 1998 Lars Magne Ingebrigtsen * gnus.el: Pterodactyl Gnus v0.30 is released. 1998-09-13 08:00:41 Lars Magne Ingebrigtsen * gnus-art.el (article-decode-encoded-words): Use it. (gnus-decode-header-function): New variable. * gnus-sum.el (gnus-nov-parse-line): Use it. (gnus-decode-encoded-word-function): New variable. * gnus-msg.el (gnus-copy-article-buffer): Decode the right buffer. * gnus-art.el (gnus-insert-mime-button): Use widget. (gnus-widget-press-button): New function. (gnus-article-prev-button): Removed. (gnus-article-next-button): Ditto. (gnus-article-add-button): Ditto. * gnus.el (gnus-article-mode-map): Inherit from widget. (gnus-article-mode-map): No, don't. * mm-decode.el (mm-dissect-buffer): Store Content-ID things. (mm-content-id-alist): New variable. (mm-get-content-id): New function. * gnus-art.el (gnus-request-article-this-buffer): Only decode articles if we are fetching to the article buffer. 1998-09-13 07:58:59 Shenghuo ZHU * gnus-sum.el (gnus-summary-move-article): Don't decode accepting articles. 1998-09-13 07:23:28 Lars Magne Ingebrigtsen * mm-util.el (mm-mime-charset): Try to use safe-charsets. (mm-default-mime-charset): New variable. * rfc2047.el (rfc2047-dissect-region): Dissect using tspecials. * drums.el (drums-quote-string): Reversed test. 1998-09-12 14:29:21 Lars Magne Ingebrigtsen * mm-util.el (mm-insert-rfc822-headers): Possibly not quote string. * drums.el (drums-quote-string): New function. * rfc2047.el (rfc2047-encode-message-header): Goto point-min. (rfc2047-b-encode-region): Chop lines. (rfc2047-q-encode-region): Ditto. Sat Sep 12 13:27:15 1998 Lars Magne Ingebrigtsen * gnus.el: Pterodactyl Gnus v0.29 is released. 1998-09-12 12:46:30 Istvan Marko * mm-decode.el (mm-save-part): Message right. 1998-09-12 11:30:01 Lars Magne Ingebrigtsen * drums.el (drums-parse-address): Returned a list instead of a string. (drums-remove-whitespace): Skip comments. (drums-parse-addresses): Didn't work. Sat Sep 12 09:17:30 1998 Lars Magne Ingebrigtsen * gnus.el: Pterodactyl Gnus v0.28 is released. 1998-09-12 04:57:25 Lars Magne Ingebrigtsen * gnus-art.el (gnus-mime-button-map): Use the article keymap as a starting point. (article-decode-encoded-words): Rename. * message.el (message-narrow-to-headers-or-head): New function. * gnus-int.el (gnus-request-accept-article): Narrow to the right region. * message.el (message-send-news): Encode body after checking syntax. * gnus-art.el (gnus-mime-button-line-format): Allow descriptions. * mm-decode.el (mm-save-part): Use Content-Disposition filename. * gnus-art.el (gnus-display-mime): Respect disposition. * mm-decode.el (mm-preferred-alternative): Respect disposition. * gnus-art.el (article-strip-multiple-blank-lines): Don't delete text with annotations. * message.el (message-make-date): Fix sign for negative time zones. * mm-view.el (mm-inline-image): Insert a space at the end of the image. * mail-parse.el: New file. * rfc2231.el: New file. * drums.el (drums-content-type-get): Removed. (drums-parse-content-type): Ditto. * mailcap.el (mailcap-mime-data): Use symbols instead of strings. Fri Sep 11 18:23:34 1998 Lars Magne Ingebrigtsen * gnus.el: Pterodactyl Gnus v0.27 is released. 1998-09-11 12:42:07 Lars Magne Ingebrigtsen * mm-decode.el (mm-alternative-precedence): New variable. (mm-preferred-alternative): New function. * gnus-art.el (gnus-mime-copy-part): New command. * mm-decode.el (mm-get-part): New function. * mm-view.el: New file. * mm-decode.el (mm-dissect-buffer): Downcase cte. (mm-display-part): Default to mailcap-save-binary-file. Fri Sep 11 12:32:50 1998 Lars Magne Ingebrigtsen * gnus.el: Pterodactyl Gnus v0.26 is released. 1998-09-11 08:25:33 Lars Magne Ingebrigtsen * mm-decode.el (mm-interactively-view-part): New function. * gnus-art.el (gnus-mime-view-part): New command. * mm-decode.el (mm-last-shell-command): New variable. * mailcap.el (mailcap-mime-info): Allow returning all matches. * mm-decode.el (mm-save-part): New function. * gnus-art.el (article-decode-charset): Protect against buggy content-types. (gnus-mime-pipe-part): New command. (gnus-mime-save-part): New command. (gnus-mime-button-map): New keymap. (gnus-mime-button-line-format): New variable. (gnus-insert-mime-button): New function. (gnus-display-mime): Use it. * gnus-util.el (gnus-dd-mmm): Removed length spec. * mm-decode.el (mm-inline-text): Decode charsets. * gnus-art.el (gnus-article-save): Comment fix. * gnus-int.el (gnus-start-news-server): When in batch, don't prompt. * gnus-cache.el (gnus-cache-possibly-enter-article): Don't decode. * mm-decode.el (mm-inline-media-tests): Add audio. (mm-inline-audio): New function. 1998-09-11 08:19:22 Katsumi Yamaoka * gnus-art.el (article-make-date-line): Didn't work. * parse-time.el (parse-time-string): One too many nils. Fri Sep 11 08:09:40 1998 Lars Magne Ingebrigtsen * gnus.el: Pterodactyl Gnus v0.25 is released. 1998-09-11 07:38:14 Lars Magne Ingebrigtsen * gnus-art.el (article-remove-trailing-blank-lines): Don't remove annotations. * gnus.el ((featurep 'gnus-xmas)): New 'gnus-annotation-in-region-p alias. 1998-09-10 06:20:52 Lars Magne Ingebrigtsen * mm-util.el (mm-with-unibyte-buffer): New function. * gnus-uu.el (gnus-quote-arg-for-sh-or-csh): Renamed. * mm-decode.el (mm-inline-media-tests): New variable. * gnus-sum.el (gnus-summary-exit): Destroy handles. * gnus-art.el (gnus-article-mime-handles): New variable. * drums.el (drums-narrow-to-header): New function. * gnus-art.el (article-decode-charset): Use it. * drums.el (drums-content-type-get): New function. * mm-util.el (mm-content-type-charset): Removed. * drums.el (drums-syntax-table): @ is word. (drums-parse-content-type): New function. * parse-time.el (parse-time-rules): Parse "Wed, 29 Apr 98 0:26:01 EDT" times. * gnus-util.el (gnus-date-get-time): Use safe date. * gnus-sum.el (gnus-show-mime): Removed. (gnus-summary-toggle-mime): Removed. * gnus-art.el (gnus-strict-mime): Removed. (gnus-article-prepare): Don't do MIME. (gnus-decode-encoded-word-method): Removed. (gnus-show-mime-method): Removed. Thu Sep 10 04:03:29 1998 Lars Magne Ingebrigtsen * gnus.el: Pterodactyl Gnus v0.24 is released. 1998-09-10 01:58:24 Lars Magne Ingebrigtsen * gnus-sum.el (gnus-summary-show-article): Don't decode chars if PREFIX. * parse-time.el (parse-time-rules): Accept times that look like "h:mm". * message.el (message-make-date): Use zone properly. * gnus.el: Autoload gnus-batch. * gnus-art.el (article-de-quoted-unreadable): Do not do gnus-article-decode-rfc1522. * gnus-msg.el (gnus-inews-do-gcc): Use it. * gnus-int.el (gnus-request-accept-article): Accept a no-encode param. * message.el (message-encode-message-body): Check for us-ascii. * gnus-msg.el (gnus-extended-version): Move Gnus version comments to the left. 1998-09-09 13:18:13 Lars Magne Ingebrigtsen * gnus-art.el (article-decode-charset): Rename. Wed Sep 9 12:25:48 1998 Lars Magne Ingebrigtsen * gnus.el: Pterodactyl Gnus v0.23 is released. 1998-09-09 12:14:47 Lars Magne Ingebrigtsen * gnus-util.el (gnus-parent-id): Ditto. (gnus-put-text-property-excluding-newlines): Ditto. * gnus-sum.el (gnus-dependencies-add-header): Make into subst. 1998-09-08 Karl Kleinpaste * message.el (message-generate-headers): Generate User-Agent instead of X-Mailer & X-Newsreader. * gnus-msg.el (gnus-extended-version): Reformat for USEFOR User-Agent header format. Tue Sep 8 22:38:27 1998 Lars Magne Ingebrigtsen * gnus.el: Pterodactyl Gnus v0.22 is released. 1998-09-08 22:36:54 Lars Magne Ingebrigtsen * mm-util.el (mm-multibyte-p): Typo. Tue Sep 8 22:25:53 1998 Lars Magne Ingebrigtsen * gnus.el: Pterodactyl Gnus v0.21 is released. 1998-09-08 Hrvoje Niksic * gnus-art.el (article-treat-dumbquotes): Handle \224 correctly. 1998-09-08 22:18:03 Lars Magne Ingebrigtsen * mm-util.el (mm-multibyte-p): New function. Tue Sep 8 21:43:03 1998 Lars Magne Ingebrigtsen * gnus.el: Pterodactyl Gnus v0.20 is released. 1998-09-08 11:40:45 Lars Magne Ingebrigtsen * rfc2047.el (rfc2047-decode-region): Only decode when in multibyte. * nnheader.el (nnheader-pathname-coding-system): Changed to binary. * gnus-int.el (gnus-request-replace-article): Encode. (gnus-request-accept-article): Encode. * gnus-art.el (gnus-request-article-this-buffer): Decode charsets here. * gnus.el (gnus-article-display-hook): Take the charset functions out. * time-date.el (safe-date-to-time): New function. * gnus-util.el (gnus-dd-mmm): Protect against bogus dates. Tue Sep 8 07:09:28 1998 Lars Magne Ingebrigtsen * gnus.el: Pterodactyl Gnus v0.19 is released. 1998-09-08 04:51:39 Lars Magne Ingebrigtsen * base64.el (base64-encode-region): Accept no-line-break. * mm-util.el (mm-mime-charset): New function. * gnus-draft.el (gnus-draft-edit-message): Delete article. Tue Sep 8 04:29:23 1998 Lars Magne Ingebrigtsen * gnus.el: Pterodactyl Gnus v0.18 is released. 1998-09-08 02:21:36 Lars Magne Ingebrigtsen * message.el (message-send-and-exit): Return t on success. (message-make-date): Make a proper time zone. * gnus-draft.el (gnus-draft-send): Only remove article if the sending is successful. * drums.el (drums-get-comment): Return the last comment. (drums-parse-address): Parse old-style From headers. 1998-09-07 SL Baur * gnus-sum.el (gnus-data-compute-positions): Move below `gnus-save-hidden-threads' so the former is correctly detected as a macro. 1998-09-06 Dave Love * nnweb.el (require): Wrap requirement of w3 and url in ignore-errors too, eval'd when compile. Require w3 stuff at load time for nicer failure if it's not available. 1998-09-08 00:38:39 Lars Magne Ingebrigtsen * time-date.el (time-to-seconds): Renamed. * parse-time.el (parse-time-string): Downcase before handling. (parse-time-rules): Times without seconds have 0 seconds. * rfc2047.el (rfc2047-encode-region): New version. (rfc2047-dissect-region): New function. 1998-09-07 01:08:35 Lars Magne Ingebrigtsen * message.el (message-make-date): Use symbolic zone. 1998-09-06 23:23:06 Lars Magne Ingebrigtsen * time-date.el (parse-time): Always use parse-time. * parse-time.el (parse-time-syntax): Use vectors. Sun Sep 6 21:19:26 1998 Lars Magne Ingebrigtsen * gnus.el: Pterodactyl Gnus v0.17 is released. 1998-09-06 05:45:17 Lars Magne Ingebrigtsen * time-date.el: Renamed from "date". * gnus.el: Removed all timezone dependencies. * score-mode.el: Removed. (gnus-score-edit-insert-date): Use date. * date.el (float-to-time): New function. * nnspool.el (nnspool-seconds-since-epoch): Removed. * date.el (time-to-float): New function. * message.el (message-make-date): Use format-time-string. (message-make-expires): Use make-date. * gnus-xmas.el (gnus-xmas-seconds-since-epoch): Removed. * gnus-util.el (gnus-dd-mmm): Use date. (gnus-sortable-date): Ditto. * message.el (message-make-date): Take an optional time. * gnus: Applied patches from 5.6.43. * date.el (if): Use parse-time. * gnus-score.el (gnus-summary-score-entry): Make into a command again. * gnus-group.el (gnus-group-get-new-news-this-group): Only call if gnus-agent. * gnus.el (gnus-agent-meta-information-header): Moved here. 1998-09-05 Mike McEwan * gnus-agent.el (gnus-agent-scoreable-headers): New variable. (gnus-agent-fetch-group-1): Score article headers using normal group score files if the download score rule of a category/group is `file'. (gnus-agent-fetch-group-1): Don't parse the entire .overview when deciding what articles to download. (gnus-agent-fetch-group-1): Don't push headers through scoring and predicate processing if predicate is `true' or `false'. 1998-09-06 01:56:02 Lars Magne Ingebrigtsen * gnus-score.el (gnus-score-load-score-alist): Bind coding system. * gnus-art.el (gnus-article-setup-buffer): Enable multibyte. * score-mode.el (score-mode-coding-system): New variable. (gnus-score-edit-exit): Use it. 1998-09-04 Jason R Mastaler * drums.el: Corrected typo. 1998-09-05 23:24:43 Hallvard B. Furuseth * mm-bodies.el (mm-body-encoding): Faster version. 1998-09-05 22:23:03 Lars Magne Ingebrigtsen * gnus-art.el (gnus-article-decode-charset): Only decode text things. * message.el (message-output): Use rmail. * rfc2047.el (rfc2047-encoded-word-regexp): Allow spaces in the word part. * mm-util.el (mm-charset-to-coding-system): Use rfc2047-default-charset. (mm-known-charsets): New variable. * message.el (message-caesar-region): Bugged out. 1998-09-06 Mike McEwan * gnus-agent.el (gnus-agent-fetch-group-1): Allow lists when specifying `agent-predicate' in a group's parameters. Sat Sep 5 21:55:01 1998 Lars Magne Ingebrigtsen * gnus.el: Pterodactyl Gnus v0.16 is released. 1998-09-05 17:30:11 Lars Magne Ingebrigtsen * nnmail.el (nnmail-expired-article-p): Use predicate. * date.el (time-less-p): Renamed. * gnus-art.el (gnus-article-decode-charset): Really fetch headers from the headers. * rfc2047.el (rfc2047-decode-region): Use the mm decoding functions. * gnus-group.el (gnus-group-sort-selected-flat): Didn't work at all. (gnus-group-sort-selected-groups-by-alphabet): Changed interface to all functions. Sat Sep 5 01:45:52 1998 Lars Magne Ingebrigtsen * gnus.el: Pterodactyl Gnus v0.15 is released. 1998-09-05 00:21:22 Lars Magne Ingebrigtsen * date.el: New file. * gnus-util.el (gnus-encode-date): Removed. (gnus-time-less): Ditto. * nnmail.el (nnmail-date-to-time): Removed. (nnmail-time-less): Ditto. (nnmail-days-to-time): Ditto. (nnmail-time-since): Ditto. * drums.el: New file. 1998-09-04 00:25:52 Lars Magne Ingebrigtsen * message.el (message-encode-message-body): Encode headers with body encoding. * rfc2047.el (rfc2047-default-charset): Renamed. (rfc2047-encodable-p): Use it. * base64.el (mm-util): Required. 1998-09-03 16:28:30 Lars Magne Ingebrigtsen * gnus-msg.el (gnus-post-method): Peel off real info from opened servers. * gnus-util.el (gnus-output-to-rmail): Removed. * gnus-art.el (gnus-summary-save-in-rmail): Use gnus-output-to-rmailrmail-output-to-rmail-file. * rfc2047.el (rfc2047-decode-region): Fold case. (rfc2047-decode): Use decode-string. * mm-util.el: Provide mm-char-int. Thu Sep 3 15:23:22 1998 Lars Magne Ingebrigtsen * gnus.el: Pterodactyl Gnus v0.14 is released. 1998-09-03 15:08:30 Lars Magne Ingebrigtsen * mm-bodies.el (mm-body-encoding): Go through the buffer to make sure we have 7bit. 1998-09-02 14:38:18 Lars Magne Ingebrigtsen * gnus-msg.el (gnus-post-method): Use opened servers, and remove ducplicates. (gnus-inews-insert-mime-headers): Removed. * message.el (message-caesar-region): Protect against MULE chars. 1998-09-02 00:36:23 Hallvard B. Furuseth * mm-util.el (if): fset the right function. 1998-09-02 00:31:53 Lars Magne Ingebrigtsen * gnus-art.el (gnus-article-decode-charset): Use real read-coding-system. 1998-09-01 17:58:40 Lars Magne Ingebrigtsen * mm-bodies.el (mm-decode-body): Protect against malformed base64. (mm-decode-body): Check that buffer-file-coding-system is non-nil. Tue Sep 1 10:29:33 1998 Lars Magne Ingebrigtsen * gnus.el: Pterodactyl Gnus v0.13 is released. 1998-09-01 09:14:33 Lars Magne Ingebrigtsen * gnus-util.el (gnus-strip-whitespace): Already defined. Removed. * gnus-art.el (gnus-article-decode-charset): Strip whitespace. * gnus-util.el (gnus-strip-whitespace): New function. * mm-util.el (mm-content-type-charset): Downcase. 1998-08-31 23:04:29 Lars Magne Ingebrigtsen * gnus-art.el (gnus-article-decode-charset): Accept a prefix. (gnus-article-decode-charset): Don't fetch all headers. * mm-util.el (mm-read-coding-system): New function. * mm-bodies.el (mm-decode-body): Check the right charset. * gnus-sum.el (gnus-summary-mode-line-format): Ditto. * gnus-art.el (gnus-article-mode-line-format): Use short group format. Mon Aug 31 23:03:13 1998 Lars Magne Ingebrigtsen * gnus.el: Pterodactyl Gnus v0.12 is released. 1998-08-31 22:39:36 Lars Magne Ingebrigtsen * mm-bodies.el (mm-decode-body): Don't do charset unless MULE. * gnus-art.el (gnus-article-decode-charset): Supply cte. (gnus-article-decode-charset): Always run. * mm-bodies.el (mm-decode-body): Decode cte. Mon Aug 31 22:14:50 1998 Lars Magne Ingebrigtsen * gnus.el: Pterodactyl Gnus v0.11 is released. 1998-08-31 14:27:25 Lars Magne Ingebrigtsen * message.el (message-encode-message-body): Ditto. * gnus-art.el (gnus-article-decode-mime-words): New command and keystroke. (gnus-article-decode-charset): Ditto. (gnus-article-decode-charset): Only work under MULE. * mm-util.el (mm-content-type-charset): New function. * nnmail.el (nnmail-delete-incoming): Changed to nil. * message.el (message-send-mail): Insert MIME headers. (message-check-news-body-syntax): Don't warn for escape sequences. (message-check-news-body-syntax): Insert MIME headers. * mm-bodies.el (mm-body-encoding): New function. * message.el (message-encode-message-body): New function. * mm-bodies.el: New file. * mm-util.el (mm-narrow-to-head): New function. * rfc2047.el (rfc2047-encode): Use it. * mm-util.el: Provide mm-encode-coding-region. * gnus-sum.el (gnus-summary-mode): Enable multibyte. * gnus-util.el (gnus-set-work-buffer): Enable multibyte. * mm-util.el (mm-enable-multibyte): New function. * message.el (message-set-work-buffer): Set multibyte. * gnus.el (gnus-continuum-version): Be valid forever and ever. * gnus-util.el (gnus-point-at-eol): Removed. (gnus-point-at-bol): Ditto. * base64.el (base64-decode-region): Commented out messaging. 1998-08-31 Didier Verna * gnus-msg.el (gnus-group-mail): make it behave like gnus-group-post-news with regards to the prefix (this enables the use of posting styles). 1998-08-31 12:53:32 Lars Magne Ingebrigtsen * gnus.el (gnus-article-display-hook): Added gnus-article-decode-rfc1522 to hook. Mon Aug 31 12:43:46 1998 Lars Magne Ingebrigtsen * gnus.el: Pterodactyl Gnus v0.10 is released. 1998-08-31 11:45:13 Lars Magne Ingebrigtsen * nnfolder.el (nnfolder-delete-mail): Narrow to mail and allow hook to be run. 1998-08-30 17:59:07 Lars Magne Ingebrigtsen * rfc2047.el (rfc2047-encodable-p): Use find-charset-region. * mm-util.el (mm-charsets-in-region): Removed. * rfc2047.el: Renamed file. * gnus-msg.el (gnus-copy-article-buffer): Multibyte. * message.el (message-mode): Set multibyte. * mm-util.el (mm-charsets-in-region): Copied here. * gnus-util.el: Removed gnus-truncate-string. * gnus-art.el (gnus-article-decode-mime-words): Use 1522. * rfc1522.el (rfc1522-unencoded-charsets): New variable. (rfc1522-encodable-p): New function. (rfc1522-encode-message-header): Use it. Sun Aug 30 17:46:01 1998 Lars Magne Ingebrigtsen * gnus.el: Pterodactyl Gnus v0.9 is released. 1998-08-30 16:13:08 Lars Magne Ingebrigtsen * mm-util.el: Shadow encode-coding-string. * base64.el (base64-encode-region): Don't add newline. * rfc1522.el (rfc1522-narrow-to-field): Copied here. * mm-util.el: New file. * mm-decode.el: Somewhat depleted. * mm-encode.el: Ditto. * rfc1522.el: New file. * mm-util.el (mm-replace-chars-in-string): Copied here. * mm-encode.el (mm-q-encode-region): New function. * qp.el (quoted-printable-encode-region): Take an optional CLASS param. * mm-encode.el (mm-encode-word-region): Downcase. Sun Aug 30 15:28:01 1998 Lars Magne Ingebrigtsen * gnus.el: Pterodactyl Gnus v0.8 is released. 1998-08-30 12:23:03 Lars Magne Ingebrigtsen * message.el (message-send-mail): Encode headers. * qp.el (quoted-printable-encode-region): Encode 8-bit words. (quoted-printable-encode-region): Upcase. * message.el (message-default-charset): New variable. * qp.el (quoted-printable-encode-region): Optional param FOLD. * message.el (message-narrow-to-field): Changed name. * mm-encode.el: New file. * message.el (message-narrow-to-header): New function. * gnus-art.el (gnus-article-decode-mime-words): Place point in the right buffer. Sun Aug 30 12:15:54 1998 Lars Magne Ingebrigtsen * gnus.el: Pterodactyl Gnus v0.7 is released. 1998-08-30 01:26:12 Lars Magne Ingebrigtsen * gnus.el: Remove autoload for gnus-article-mime-decode-quoted-printable. * mm-decode.el (mm-charset-to-coding-system): Allow iso-8859-1 to be decoded in non-MULE Emacsen. * gnus-xmas.el (gnus-xmas-logo-color-alist): More brown. 1998-08-29 SL Baur * gnus-xmas.el (gnus-xmas-logo-color-alist): Try shades of brown. 1998-08-30 01:04:57 Lars Magne Ingebrigtsen * mm-decode.el: Check for coding-system-list. Sun Aug 30 00:59:15 1998 Lars Magne Ingebrigtsen * gnus.el: Pterodactyl Gnus v0.6 is released. 1998-08-30 00:36:28 Lars Magne Ingebrigtsen * nnheader.el (fboundp): Protect code-coding-string. * gnus-art.el (gnus-article-mode): Check that set-buffer-multibyte is available. Sat Aug 29 23:24:31 1998 Lars Magne Ingebrigtsen * gnus.el: Pterodactyl Gnus v0.5 is released. 1998-08-29 22:38:35 Lars Magne Ingebrigtsen * gnus-art.el (gnus-article-mode): Make article buffer multibyte. (gnus-hack-decode-rfc1522): Removed. * mm-decode.el (mm-charset-coding-system-alist): Check better. Sat Aug 29 22:20:39 1998 Lars Magne Ingebrigtsen * gnus.el: Gnus v0.4 is released. 1998-08-29 20:53:29 Lars Magne Ingebrigtsen * gnus-art.el (gnus-article-decode-mime-words): New command and keystroke. * qp.el (quoted-printable-decode-region): Don't use hexl. * gnus-xmas.el (gnus-xmas-logo-color-style): Changed to dino. * gnus-sum.el (gnus-parse-headers-hook): Default to nil. (gnus-structured-field-decoder): Removed. (gnus-unstructured-field-decoder): Ditto. * mm-decode.el: New file. * qp.el: New file. * gnus-art.el (article-mime-decode-quoted-printable): Removed. * gnus-ems.el (fboundp): Removed gnus-split-string. * gnus.el (gnus-splash-face): Doc fix. * gnus-ems.el (fboundp): Don't bind mail-file-babyl-p. * gnus-art.el (article-mime-decode-quoted-printable): Don't use hexl. * nnheader.el (nnheader-temp-write): Removed. Sat Aug 29 20:34:17 1998 Lars Magne Ingebrigtsen * gnus.el: Gnus v0.3 is released. Sat Aug 29 19:32:06 1998 Lars Magne Ingebrigtsen * gnus.el: Gnus v0.2 is released. Copyright (C) 1998, 1999, 2000 Free Software Foundation, Inc. Copying and distribution of this file, with or without modification, are permitted provided the copyright notice and this notice are preserved. ;; Local Variables: ;; coding: iso-2022-7bit ;; End: ;;; arch-tag: bc9bf70e-b352-4a38-9dec-edce4b023b22 gnus-5.11+v0.10.dfsg/lisp/gnus-setup.el0000644000175000017500000001552411004005110017664 0ustar tvainikatvainika;;; gnus-setup.el --- Initialization & Setup for Gnus 5 ;; Copyright (C) 1995, 1996, 2000, 2001, 2002, 2003, 2004, ;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc. ;; Author: Steven L. Baur ;; Keywords: news ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 3, or (at your option) ;; any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Commentary: ;; My head is starting to spin with all the different mail/news packages. ;; Stop The Madness! ;; Given that Emacs Lisp byte codes may be diverging, it is probably best ;; not to byte compile this, and just arrange to have the .el loaded out ;; of .emacs. ;;; Code: (eval-when-compile (require 'cl)) (defvar gnus-use-installed-gnus t "*If non-nil use installed version of Gnus.") (defvar gnus-use-installed-mailcrypt (featurep 'xemacs) "*If non-nil use installed version of mailcrypt.") (defvar gnus-emacs-lisp-directory (if (featurep 'xemacs) "/usr/local/lib/xemacs/" "/usr/local/share/emacs/") "Directory where Emacs site lisp is located.") (defvar gnus-gnus-lisp-directory (concat gnus-emacs-lisp-directory "gnus/lisp/") "Directory where Gnus Emacs lisp is found.") (defvar gnus-mailcrypt-lisp-directory (concat gnus-emacs-lisp-directory "site-lisp/mailcrypt/") "Directory where Mailcrypt Emacs Lisp is found.") (defvar gnus-bbdb-lisp-directory (concat gnus-emacs-lisp-directory "site-lisp/bbdb/") "Directory where Big Brother Database is found.") (defvar gnus-use-mhe nil "Set this if you want to use MH-E for mail reading.") (defvar gnus-use-rmail nil "Set this if you want to use RMAIL for mail reading.") (defvar gnus-use-sendmail t "Set this if you want to use SENDMAIL for mail reading.") (defvar gnus-use-vm nil "Set this if you want to use the VM package for mail reading.") (defvar gnus-use-sc nil "Set this if you want to use Supercite.") (defvar gnus-use-mailcrypt t "Set this if you want to use Mailcrypt for dealing with PGP messages.") (defvar gnus-use-bbdb nil "Set this if you want to use the Big Brother DataBase.") (when (and (not gnus-use-installed-gnus) (null (member gnus-gnus-lisp-directory load-path))) (push gnus-gnus-lisp-directory load-path)) ;;; We can't do this until we know where Gnus is. (require 'message) ;;; Mailcrypt by ;;; Jin Choi ;;; Patrick LoPresti (when gnus-use-mailcrypt (when (and (not gnus-use-installed-mailcrypt) (null (member gnus-mailcrypt-lisp-directory load-path))) (setq load-path (cons gnus-mailcrypt-lisp-directory load-path))) (autoload 'mc-install-write-mode "mailcrypt" nil t) (autoload 'mc-install-read-mode "mailcrypt" nil t) ;;; (add-hook 'message-mode-hook 'mc-install-write-mode) ;;; (add-hook 'gnus-summary-mode-hook 'mc-install-read-mode) (when gnus-use-mhe (add-hook 'mh-folder-mode-hook 'mc-install-read-mode) (add-hook 'mh-letter-mode-hook 'mc-install-write-mode))) ;;; BBDB by ;;; Jamie Zawinski (when gnus-use-bbdb ;; bbdb will never be installed with emacs. (when (null (member gnus-bbdb-lisp-directory load-path)) (setq load-path (cons gnus-bbdb-lisp-directory load-path))) (autoload 'bbdb "bbdb-com" "Insidious Big Brother Database" t) (autoload 'bbdb-name "bbdb-com" "Insidious Big Brother Database" t) (autoload 'bbdb-company "bbdb-com" "Insidious Big Brother Database" t) (autoload 'bbdb-net "bbdb-com" "Insidious Big Brother Database" t) (autoload 'bbdb-notes "bbdb-com" "Insidious Big Brother Database" t) (when gnus-use-vm (autoload 'bbdb-insinuate-vm "bbdb-vm" "Hook BBDB into VM" t)) (when gnus-use-rmail (autoload 'bbdb-insinuate-rmail "bbdb-rmail" "Hook BBDB into RMAIL" t) (add-hook 'rmail-mode-hook 'bbdb-insinuate-rmail)) (when gnus-use-mhe (autoload 'bbdb-insinuate-mh "bbdb-mh" "Hook BBDB into MH-E" t) (add-hook 'mh-folder-mode-hook 'bbdb-insinuate-mh)) (autoload 'bbdb-insinuate-gnus "bbdb-gnus" "Hook BBDB into Gnus" t) (add-hook 'gnus-startup-hook 'bbdb-insinuate-gnus) (when gnus-use-sendmail (autoload 'bbdb-insinuate-sendmail "bbdb" "Insidious Big Brother Database" t) (add-hook 'mail-setup-hook 'bbdb-insinuate-sendmail) (add-hook 'message-setup-hook 'bbdb-insinuate-sendmail))) (when gnus-use-sc (add-hook 'mail-citation-hook 'sc-cite-original) (setq message-cite-function 'sc-cite-original)) ;;;### (autoloads (gnus gnus-slave gnus-no-server) "gnus" "lisp/gnus.el" (12473 2137)) ;;; Generated autoloads from lisp/gnus.el ;; Don't redo this if autoloads already exist (unless (fboundp 'gnus) (autoload 'gnus-slave-no-server "gnus" "\ Read network news as a slave without connecting to local server." t nil) (autoload 'gnus-no-server "gnus" "\ Read network news. If ARG is a positive number, Gnus will use that as the startup level. If ARG is nil, Gnus will be started at level 2. If ARG is non-nil and not a positive number, Gnus will prompt the user for the name of an NNTP server to use. As opposed to `gnus', this command will not connect to the local server." t nil) (autoload 'gnus-slave "gnus" "\ Read news as a slave." t nil) (autoload 'gnus "gnus" "\ Read network news. If ARG is non-nil and a positive number, Gnus will use that as the startup level. If ARG is non-nil and not a positive number, Gnus will prompt the user for the name of an NNTP server to use." t nil) ;;;*** ;;; These have moved out of gnus.el into other files. ;;; FIX FIX FIX: should other things be in gnus-setup? or these not in it? (autoload 'gnus-update-format "gnus-spec" "\ Update the format specification near point." t nil) (autoload 'gnus-fetch-group "gnus-group" "\ Start Gnus if necessary and enter GROUP. Returns whether the fetching was successful or not." t nil) (defalias 'gnus-batch-kill 'gnus-batch-score) (autoload 'gnus-batch-score "gnus-kill" "\ Run batched scoring. Usage: emacs -batch -l gnus -f gnus-batch-score ... Newsgroups is a list of strings in Bnews format. If you want to score the comp hierarchy, you'd say \"comp.all\". If you would not like to score the alt hierarchy, you'd say \"!alt.all\"." t nil)) (provide 'gnus-setup) (run-hooks 'gnus-setup-load-hook) ;; arch-tag: 08e4af93-8565-46bf-905c-36229400609d ;;; gnus-setup.el ends here gnus-5.11+v0.10.dfsg/lisp/flow-fill.el0000644000175000017500000001704411004005110017444 0ustar tvainikatvainika;;; flow-fill.el --- interpret RFC2646 "flowed" text ;; Copyright (C) 2000, 2001, 2002, 2003, 2004, ;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc. ;; Author: Simon Josefsson ;; Keywords: mail ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 3, or (at your option) ;; any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Commentary: ;; This implement decoding of RFC2646 formatted text, including the ;; quoted-depth wins rules. ;; Theory of operation: search for lines ending with SPC, save quote ;; length of line, remove SPC and concatenate line with the following ;; line if quote length of following line matches current line. ;; When no further concatenations are possible, we've found a ;; paragraph and we let `fill-region' fill the long line into several ;; lines with the quote prefix as `fill-prefix'. ;; Todo: implement basic `fill-region' (Emacs and XEmacs ;; implementations differ..) ;;; History: ;; 2000-02-17 posted on ding mailing list ;; 2000-02-19 use `point-at-{b,e}ol' in XEmacs ;; 2000-03-11 no compile warnings for point-at-bol stuff ;; 2000-03-26 committed to gnus cvs ;; 2000-10-23 don't flow "-- " lines, make "quote-depth wins" rule ;; work when first line is at level 0. ;; 2002-01-12 probably incomplete encoding support ;; 2003-12-08 started working on test harness. ;;; Code: (eval-when-compile (require 'cl)) (defcustom fill-flowed-display-column 'fill-column "Column beyond which format=flowed lines are wrapped, when displayed. This can be a Lisp expression or an integer." :version "22.1" :group 'mime-display :type '(choice (const :tag "Standard `fill-column'" fill-column) (const :tag "Fit Window" (- (window-width) 5)) (sexp) (integer))) (defcustom fill-flowed-encode-column 66 "Column beyond which format=flowed lines are wrapped, in outgoing messages. This can be a Lisp expression or an integer. RFC 2646 suggests 66 characters for readability." :version "22.1" :group 'mime-display :type '(choice (const :tag "Standard fill-column" fill-column) (const :tag "RFC 2646 default (66)" 66) (sexp) (integer))) ;;;###autoload (defun fill-flowed-encode (&optional buffer) (with-current-buffer (or buffer (current-buffer)) ;; No point in doing this unless hard newlines is used. (when use-hard-newlines (let ((start (point-min)) end) ;; Go through each paragraph, filling it and adding SPC ;; as the last character on each line. (while (setq end (text-property-any start (point-max) 'hard 't)) (let ((fill-column (eval fill-flowed-encode-column))) (fill-region start end t 'nosqueeze 'to-eop)) (goto-char start) ;; `fill-region' probably distorted end. (setq end (text-property-any start (point-max) 'hard 't)) (while (and (< (point) end) (re-search-forward "$" (1- end) t)) (insert " ") (setq end (1+ end)) (forward-char)) (goto-char (setq start (1+ end))))) t))) ;;;###autoload (defun fill-flowed (&optional buffer delete-space) (save-excursion (set-buffer (or (current-buffer) buffer)) (goto-char (point-min)) ;; Remove space stuffing. (while (re-search-forward "^\\( \\|>+ $\\)" nil t) (delete-char -1) (forward-line 1)) (goto-char (point-min)) (while (re-search-forward " $" nil t) (when delete-space (delete-char -1)) (when (save-excursion (beginning-of-line) (looking-at "^\\(>*\\)\\( ?\\)")) (let ((quote (match-string 1)) sig) (if (string= quote "") (setq quote nil)) (when (and quote (string= (match-string 2) "")) (save-excursion ;; insert SP after quote for pleasant reading of quoted lines (beginning-of-line) (when (> (skip-chars-forward ">") 0) (insert " ")))) ;; XXX slightly buggy handling of "-- " (while (and (save-excursion (ignore-errors (backward-char 3)) (setq sig (looking-at "-- ")) (looking-at "[^-][^-] ")) (save-excursion (unless (eobp) (forward-char 1) (looking-at (format "^\\(%s\\)\\([^>\n\r]\\)" (or quote " ?")))))) (save-excursion (replace-match (if (string= (match-string 2) " ") "" "\\2"))) (backward-delete-char -1) (end-of-line)) (unless sig (condition-case nil (let ((fill-prefix (when quote (concat quote " "))) (fill-column (eval fill-flowed-display-column)) filladapt-mode adaptive-fill-mode) (fill-region (point-at-bol) (min (1+ (point-at-eol)) (point-max)) 'left 'nosqueeze)) (error (forward-line 1) nil)))))))) ;; Test vectors. (defvar show-trailing-whitespace) (defvar fill-flowed-encode-tests `( ;; The syntax of each list element is: ;; (INPUT . EXPECTED-OUTPUT) (,(concat "> Thou villainous ill-breeding spongy dizzy-eyed \n" "> reeky elf-skinned pigeon-egg! \n" ">> Thou artless swag-bellied milk-livered \n" ">> dismal-dreaming idle-headed scut!\n" ">>> Thou errant folly-fallen spleeny reeling-ripe \n" ">>> unmuzzled ratsbane!\n" ">>>> Henceforth, the coding style is to be strictly \n" ">>>> enforced, including the use of only upper case.\n" ">>>>> I've noticed a lack of adherence to the coding \n" ">>>>> styles, of late.\n" ">>>>>> Any complaints?") . ,(concat "> Thou villainous ill-breeding spongy dizzy-eyed reeky elf-skinned\n" "> pigeon-egg! \n" ">> Thou artless swag-bellied milk-livered dismal-dreaming idle-headed\n" ">> scut!\n" ">>> Thou errant folly-fallen spleeny reeling-ripe unmuzzled ratsbane!\n" ">>>> Henceforth, the coding style is to be strictly enforced,\n" ">>>> including the use of only upper case.\n" ">>>>> I've noticed a lack of adherence to the coding styles, of late.\n" ">>>>>> Any complaints?\n" )) ;; (,(concat ;; "\n" ;; "> foo\n" ;; "> \n" ;; "> \n" ;; "> bar\n") ;; . ;; ,(concat ;; "\n" ;; "> foo bar\n")) )) (defun fill-flowed-test () (interactive "") (switch-to-buffer (get-buffer-create "*Format=Flowed test output*")) (erase-buffer) (setq show-trailing-whitespace t) (dolist (test fill-flowed-encode-tests) (let (start output) (insert "***** BEGIN TEST INPUT *****\n") (insert (car test)) (insert "***** END TEST INPUT *****\n\n") (insert "***** BEGIN TEST OUTPUT *****\n") (setq start (point)) (insert (car test)) (save-restriction (narrow-to-region start (point)) (fill-flowed)) (setq output (buffer-substring start (point-max))) (insert "***** END TEST OUTPUT *****\n") (unless (string= output (cdr test)) (insert "\n***** BEGIN TEST EXPECTED OUTPUT *****\n") (insert (cdr test)) (insert "***** END TEST EXPECTED OUTPUT *****\n")) (insert "\n\n"))) (goto-char (point-max))) (provide 'flow-fill) ;; arch-tag: addc0040-bc53-4f17-b4bc-1eb44eed6f0b ;;; flow-fill.el ends here gnus-5.11+v0.10.dfsg/lisp/nnspool.el0000644000175000017500000003613611004005110017244 0ustar tvainikatvainika;;; nnspool.el --- spool access for GNU Emacs ;; Copyright (C) 1988, 1989, 1990, 1993, 1994, 1995, 1996, 1997, 1998, ;; 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc. ;; Author: Masanobu UMEDA ;; Lars Magne Ingebrigtsen ;; Keywords: news ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 3, or (at your option) ;; any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Commentary: ;;; Code: (require 'nnheader) (require 'nntp) (require 'nnoo) (eval-when-compile (require 'cl)) (nnoo-declare nnspool) (defvoo nnspool-inews-program news-inews-program "Program to post news. This is most commonly `inews' or `injnews'.") (defvoo nnspool-inews-switches '("-h" "-S") "Switches for nnspool-request-post to pass to `inews' for posting news. If you are using Cnews, you probably should set this variable to nil.") (defvoo nnspool-spool-directory (file-name-as-directory (if (boundp 'news-directory) (symbol-value 'news-directory) news-path)) "Local news spool directory.") (defvoo nnspool-nov-directory (concat nnspool-spool-directory "over.view/") "Local news nov directory.") (defvoo nnspool-lib-dir (if (file-exists-p "/usr/lib/news/active") "/usr/lib/news/" "/var/lib/news/") "Where the local news library files are stored.") (defvoo nnspool-active-file (concat nnspool-lib-dir "active") "Local news active file.") (defvoo nnspool-newsgroups-file (concat nnspool-lib-dir "newsgroups") "Local news newsgroups file.") (defvoo nnspool-distributions-file (concat nnspool-lib-dir "distribs.pat") "Local news distributions file.") (defvoo nnspool-history-file (concat nnspool-lib-dir "history") "Local news history file.") (defvoo nnspool-active-times-file (concat nnspool-lib-dir "active.times") "Local news active date file.") (defvoo nnspool-large-newsgroup 50 "The number of articles which indicates a large newsgroup. If the number of articles is greater than the value, verbose messages will be shown to indicate the current status.") (defvoo nnspool-nov-is-evil nil "Non-nil means that nnspool will never return NOV lines instead of headers.") (defconst nnspool-sift-nov-with-sed nil "If non-nil, use sed to get the relevant portion from the overview file. If nil, nnspool will load the entire file into a buffer and process it there.") (defvoo nnspool-rejected-article-hook nil "*A hook that will be run when an article has been rejected by the server.") (defvoo nnspool-file-coding-system nnheader-file-coding-system "Coding system for nnspool.") (defconst nnspool-version "nnspool 2.0" "Version numbers of this version of NNSPOOL.") (defvoo nnspool-current-directory nil "Current news group directory.") (defvoo nnspool-current-group nil) (defvoo nnspool-status-string "") ;;; Interface functions. (nnoo-define-basics nnspool) (deffoo nnspool-retrieve-headers (articles &optional group server fetch-old) "Retrieve the headers of ARTICLES." (save-excursion (set-buffer nntp-server-buffer) (erase-buffer) (when (nnspool-possibly-change-directory group) (let* ((number (length articles)) (count 0) (default-directory nnspool-current-directory) (do-message (and (numberp nnspool-large-newsgroup) (> number nnspool-large-newsgroup))) (nnheader-file-coding-system nnspool-file-coding-system) file beg article ag) (if (and (numberp (car articles)) (nnspool-retrieve-headers-with-nov articles fetch-old)) ;; We successfully retrieved the NOV headers. 'nov ;; No NOV headers here, so we do it the hard way. (while (setq article (pop articles)) (if (stringp article) ;; This is a Message-ID. (setq ag (nnspool-find-id article) file (and ag (nnspool-article-pathname (car ag) (cdr ag))) article (cdr ag)) ;; This is an article in the current group. (setq file (int-to-string article))) ;; Insert the head of the article. (when (and file (file-exists-p file)) (insert "221 ") (princ article (current-buffer)) (insert " Article retrieved.\n") (setq beg (point)) (inline (nnheader-insert-head file)) (goto-char beg) (if (search-forward "\n\n" nil t) (progn (forward-char -1) (insert ".\n")) (goto-char (point-max)) (if (bolp) (insert ".\n") (insert "\n.\n"))) (delete-region (point) (point-max))) (and do-message (zerop (% (incf count) 20)) (nnheader-message 5 "nnspool: Receiving headers... %d%%" (/ (* count 100) number)))) (when do-message (nnheader-message 5 "nnspool: Receiving headers...done")) ;; Fold continuation lines. (nnheader-fold-continuation-lines) 'headers))))) (deffoo nnspool-open-server (server &optional defs) (nnoo-change-server 'nnspool server defs) (cond ((not (file-exists-p nnspool-spool-directory)) (nnspool-close-server) (nnheader-report 'nnspool "Spool directory doesn't exist: %s" nnspool-spool-directory)) ((not (file-directory-p (directory-file-name (file-truename nnspool-spool-directory)))) (nnspool-close-server) (nnheader-report 'nnspool "Not a directory: %s" nnspool-spool-directory)) ((not (file-exists-p nnspool-active-file)) (nnheader-report 'nnspool "The active file doesn't exist: %s" nnspool-active-file)) (t (nnheader-report 'nnspool "Opened server %s using directory %s" server nnspool-spool-directory) t))) (deffoo nnspool-request-article (id &optional group server buffer) "Select article by message ID (or number)." (nnspool-possibly-change-directory group) (let ((nntp-server-buffer (or buffer nntp-server-buffer)) file ag) (if (stringp id) ;; This is a Message-ID. (when (setq ag (nnspool-find-id id)) (setq file (nnspool-article-pathname (car ag) (cdr ag)))) (setq file (nnspool-article-pathname nnspool-current-group id))) (and file (file-exists-p file) (not (file-directory-p file)) (save-excursion (nnspool-find-file file)) ;; We return the article number and group name. (if (numberp id) (cons nnspool-current-group id) ag)))) (deffoo nnspool-request-body (id &optional group server) "Select article body by message ID (or number)." (nnspool-possibly-change-directory group) (let ((res (nnspool-request-article id))) (when res (save-excursion (set-buffer nntp-server-buffer) (goto-char (point-min)) (when (search-forward "\n\n" nil t) (delete-region (point-min) (point))) res)))) (deffoo nnspool-request-head (id &optional group server) "Select article head by message ID (or number)." (nnspool-possibly-change-directory group) (let ((res (nnspool-request-article id))) (when res (save-excursion (set-buffer nntp-server-buffer) (goto-char (point-min)) (when (search-forward "\n\n" nil t) (delete-region (1- (point)) (point-max))) (nnheader-fold-continuation-lines))) res)) (deffoo nnspool-request-group (group &optional server dont-check) "Select news GROUP." (let ((pathname (nnspool-article-pathname group)) dir) (if (not (file-directory-p pathname)) (nnheader-report 'nnspool "Invalid group name (no such directory): %s" group) (setq nnspool-current-directory pathname) (nnheader-report 'nnspool "Selected group %s" group) (if dont-check (progn (nnheader-report 'nnspool "Selected group %s" group) t) ;; Yes, completely empty spool directories *are* possible. ;; Fix by Sudish Joseph (when (setq dir (directory-files pathname nil "^[0-9]+$" t)) (setq dir (sort (mapcar 'string-to-number dir) '<))) (if dir (nnheader-insert "211 %d %d %d %s\n" (length dir) (car dir) (car (last dir)) group) (nnheader-report 'nnspool "Empty group %s" group) (nnheader-insert "211 0 0 0 %s\n" group)))))) (deffoo nnspool-request-type (group &optional article) 'news) (deffoo nnspool-close-group (group &optional server) t) (deffoo nnspool-request-list (&optional server) "List active newsgroups." (save-excursion (or (nnspool-find-file nnspool-active-file) (nnheader-report 'nnspool (nnheader-file-error nnspool-active-file))))) (deffoo nnspool-request-list-newsgroups (&optional server) "List newsgroups (defined in NNTP2)." (save-excursion (or (nnspool-find-file nnspool-newsgroups-file) (nnheader-report 'nnspool (nnheader-file-error nnspool-newsgroups-file))))) (deffoo nnspool-request-list-distributions (&optional server) "List distributions (defined in NNTP2)." (save-excursion (or (nnspool-find-file nnspool-distributions-file) (nnheader-report 'nnspool (nnheader-file-error nnspool-distributions-file))))) ;; Suggested by Hallvard B Furuseth . (deffoo nnspool-request-newgroups (date &optional server) "List groups created after DATE." (if (nnspool-find-file nnspool-active-times-file) (save-excursion ;; Find the last valid line. (goto-char (point-max)) (while (and (not (looking-at "\\([^ ]+\\) +\\([0-9]+\\)[0-9][0-9][0-9] ")) (zerop (forward-line -1)))) (let ((seconds (time-to-seconds (date-to-time date))) groups) ;; Go through lines and add the latest groups to a list. (while (and (looking-at "\\([^ ]+\\) +[0-9]+ ") (progn ;; We insert a .0 to make the list reader ;; interpret the number as a float. It is far ;; too big to be stored in a lisp integer. (goto-char (1- (match-end 0))) (insert ".0") (> (progn (goto-char (match-end 1)) (read (current-buffer))) seconds)) (push (buffer-substring (match-beginning 1) (match-end 1)) groups) (zerop (forward-line -1)))) (erase-buffer) (dolist (group groups) (insert group " 0 0 y\n"))) t) nil)) (deffoo nnspool-request-post (&optional server) "Post a new news in current buffer." (save-excursion (let* ((process-connection-type nil) ; t bugs out on Solaris (inews-buffer (generate-new-buffer " *nnspool post*")) (proc (condition-case err (apply 'start-process "*nnspool inews*" inews-buffer nnspool-inews-program nnspool-inews-switches) (error (nnheader-report 'nnspool "inews error: %S" err))))) (if (not proc) ;; The inews program failed. () (nnheader-report 'nnspool "") (set-process-sentinel proc 'nnspool-inews-sentinel) (mm-with-unibyte-current-buffer (process-send-region proc (point-min) (point-max))) ;; We slap a condition-case around this, because the process may ;; have exited already... (ignore-errors (process-send-eof proc)) t)))) ;;; Internal functions. (defun nnspool-inews-sentinel (proc status) (save-excursion (set-buffer (process-buffer proc)) (goto-char (point-min)) (if (or (zerop (buffer-size)) (search-forward "spooled" nil t)) (kill-buffer (current-buffer)) ;; Make status message by folding lines. (while (re-search-forward "[ \t\n]+" nil t) (replace-match " " t t)) (nnheader-report 'nnspool "%s" (buffer-string)) (nnheader-message 5 "nnspool: %s" nnspool-status-string) (ding) (run-hooks 'nnspool-rejected-article-hook)))) (defun nnspool-retrieve-headers-with-nov (articles &optional fetch-old) (if (or gnus-nov-is-evil nnspool-nov-is-evil) nil (let ((nov (nnheader-group-pathname nnspool-current-group nnspool-nov-directory ".overview")) (arts articles) (nnheader-file-coding-system nnspool-file-coding-system) last) (if (not (file-exists-p nov)) () (save-excursion (set-buffer nntp-server-buffer) (erase-buffer) (if nnspool-sift-nov-with-sed (nnspool-sift-nov-with-sed articles nov) (nnheader-insert-file-contents nov) (if (and fetch-old (not (numberp fetch-old))) t ; We want all the headers. (ignore-errors ;; Delete unwanted NOV lines. (nnheader-nov-delete-outside-range (if fetch-old (max 1 (- (car articles) fetch-old)) (car articles)) (car (last articles))) ;; If the buffer is empty, this wasn't very successful. (unless (zerop (buffer-size)) ;; We check what the last article number was. ;; The NOV file may be out of sync with the articles ;; in the group. (forward-line -1) (setq last (read (current-buffer))) (if (= last (car articles)) ;; Yup, it's all there. t ;; Perhaps not. We try to find the missing articles. (while (and arts (<= last (car arts))) (pop arts)) ;; The articles in `arts' are missing from the buffer. (mapc 'nnspool-insert-nov-head arts) t)))))))))) (defun nnspool-insert-nov-head (article) "Read the head of ARTICLE, convert to NOV headers, and insert." (save-excursion (let ((cur (current-buffer)) buf) (setq buf (nnheader-set-temp-buffer " *nnspool head*")) (when (nnheader-insert-head (nnspool-article-pathname nnspool-current-group article)) (nnheader-insert-article-line article) (let ((headers (nnheader-parse-head))) (set-buffer cur) (goto-char (point-max)) (nnheader-insert-nov headers))) (kill-buffer buf)))) (defun nnspool-sift-nov-with-sed (articles file) (let ((first (car articles)) (last (car (last articles)))) (call-process "awk" nil t nil (format "BEGIN {firstmsg=%d; lastmsg=%d;}\n $1 >= firstmsg && $1 <= lastmsg {print;}" (1- first) (1+ last)) file))) ;; Fixed by fdc@cliwe.ping.de (Frank D. Cringle). ;; Find out what group an article identified by a Message-ID is in. (defun nnspool-find-id (id) (with-temp-buffer (ignore-errors (call-process "grep" nil t nil (regexp-quote id) nnspool-history-file)) (goto-char (point-min)) (when (looking-at "<[^>]+>[ \t]+[-0-9~]+[ \t]+\\([^ /\t\n]+\\)/\\([0-9]+\\)[ \t\n]") (cons (match-string 1) (string-to-number (match-string 2)))))) (defun nnspool-find-file (file) "Insert FILE in server buffer safely." (set-buffer nntp-server-buffer) (erase-buffer) (condition-case () (let ((coding-system-for-read nnspool-file-coding-system)) (mm-insert-file-contents file) t) (file-error nil))) (defun nnspool-possibly-change-directory (group) (if (not group) t (let ((pathname (nnspool-article-pathname group))) (if (file-directory-p pathname) (setq nnspool-current-directory pathname nnspool-current-group group) (nnheader-report 'nnspool "No such newsgroup: %s" group))))) (defun nnspool-article-pathname (group &optional article) "Find the file name for GROUP." (nnheader-group-pathname group nnspool-spool-directory article)) (provide 'nnspool) ;; arch-tag: bdac8d27-2934-4eee-bad0-49e6b90c0d05 ;;; nnspool.el ends here gnus-5.11+v0.10.dfsg/lisp/mm-view.el0000644000175000017500000005477611004005110017147 0ustar tvainikatvainika;;; mm-view.el --- functions for viewing MIME objects ;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, ;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 3, or (at your option) ;; any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Commentary: ;;; Code: (eval-and-compile (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) (eval-when-compile (require 'cl)) (require 'mail-parse) (require 'mailcap) (require 'mm-bodies) (require 'mm-decode) (require 'smime) (eval-and-compile (autoload 'gnus-article-prepare-display "gnus-art") (autoload 'vcard-parse-string "vcard") (autoload 'vcard-format-string "vcard") (autoload 'fill-flowed "flow-fill") (autoload 'html2text "html2text" nil t)) (defvar gnus-article-mime-handles) (defvar gnus-newsgroup-charset) (defvar smime-keys) (defvar w3m-cid-retrieve-function-alist) (defvar w3m-current-buffer) (defvar w3m-display-inline-images) (defvar w3m-minor-mode-map) (defvar mm-text-html-renderer-alist '((w3 . mm-inline-text-html-render-with-w3) (w3m . mm-inline-text-html-render-with-w3m) (w3m-standalone . mm-inline-text-html-render-with-w3m-standalone) (links mm-inline-render-with-file mm-links-remove-leading-blank "links" "-dump" file) (lynx mm-inline-render-with-stdin nil "lynx" "-dump" "-force_html" "-stdin" "-nolist") (html2text mm-inline-render-with-function html2text)) "The attributes of renderer types for text/html.") (defvar mm-text-html-washer-alist '((w3 . gnus-article-wash-html-with-w3) (w3m . gnus-article-wash-html-with-w3m) (w3m-standalone . gnus-article-wash-html-with-w3m-standalone) (links mm-inline-wash-with-file mm-links-remove-leading-blank "links" "-dump" file) (lynx mm-inline-wash-with-stdin nil "lynx" "-dump" "-force_html" "-stdin" "-nolist") (html2text html2text)) "The attributes of washer types for text/html.") (defcustom mm-fill-flowed t "If non-nil a format=flowed article will be displayed flowed." :type 'boolean :version "22.1" :group 'mime-display) ;;; Internal variables. ;;; ;;; Functions for displaying various formats inline ;;; (defun mm-inline-image-emacs (handle) (let ((b (point-marker)) (inhibit-read-only t)) (put-image (mm-get-image handle) b) (insert "\n\n") (mm-handle-set-undisplayer handle `(lambda () (let ((b ,b) (inhibit-read-only t)) (remove-images b b) (delete-region b (+ b 2))))))) (defun mm-inline-image-xemacs (handle) (when (featurep 'xemacs) (insert "\n\n") (forward-char -2) (let ((annot (make-annotation (mm-get-image handle) nil 'text)) (inhibit-read-only t)) (mm-handle-set-undisplayer handle `(lambda () (let ((b ,(point-marker)) (inhibit-read-only t)) (delete-annotation ,annot) (delete-region (- b 2) b)))) (set-extent-property annot 'mm t) (set-extent-property annot 'duplicable t)))) (eval-and-compile (if (featurep 'xemacs) (defalias 'mm-inline-image 'mm-inline-image-xemacs) (defalias 'mm-inline-image 'mm-inline-image-emacs))) ;; External. (declare-function w3-do-setup "ext:w3" ()) (declare-function w3-region "ext:w3-display" (st nd)) (declare-function w3-prepare-buffer "ext:w3-display" (&rest args)) (defvar mm-w3-setup nil) (defun mm-setup-w3 () (unless mm-w3-setup (require 'w3) (w3-do-setup) (require 'url) (require 'w3-vars) (require 'url-vars) (setq mm-w3-setup t))) (defun mm-inline-text-html-render-with-w3 (handle) (mm-setup-w3) (let ((text (mm-get-part handle)) (b (point)) (url-standalone-mode t) (url-gateway-unplugged t) (w3-honor-stylesheets nil) (url-current-object (url-generic-parse-url (format "cid:%s" (mm-handle-id handle)))) (width (window-width)) (charset (mail-content-type-get (mm-handle-type handle) 'charset))) (save-excursion (insert (if charset (mm-decode-string text charset) text)) (save-restriction (narrow-to-region b (point)) (unless charset (goto-char (point-min)) (when (or (and (boundp 'w3-meta-content-type-charset-regexp) (re-search-forward w3-meta-content-type-charset-regexp nil t)) (and (boundp 'w3-meta-charset-content-type-regexp) (re-search-forward w3-meta-charset-content-type-regexp nil t))) (setq charset (let ((bsubstr (buffer-substring-no-properties (match-beginning 2) (match-end 2)))) (if (fboundp 'w3-coding-system-for-mime-charset) (w3-coding-system-for-mime-charset bsubstr) (mm-charset-to-coding-system bsubstr)))) (delete-region (point-min) (point-max)) (insert (mm-decode-string text charset)))) (save-window-excursion (save-restriction (let ((w3-strict-width width) ;; Don't let w3 set the global version of ;; this variable. (fill-column fill-column)) (if (or debug-on-error debug-on-quit) (w3-region (point-min) (point-max)) (condition-case () (w3-region (point-min) (point-max)) (error (delete-region (point-min) (point-max)) (let ((b (point)) (charset (mail-content-type-get (mm-handle-type handle) 'charset))) (if (or (eq charset 'gnus-decoded) (eq mail-parse-charset 'gnus-decoded)) (save-restriction (narrow-to-region (point) (point)) (mm-insert-part handle) (goto-char (point-max))) (insert (mm-decode-string (mm-get-part handle) charset)))) (message "Error while rendering html; showing as text/plain"))))))) (mm-handle-set-undisplayer handle `(lambda () (let ((inhibit-read-only t)) ,@(if (functionp 'remove-specifier) '((dolist (prop '(background background-pixmap foreground)) (remove-specifier (face-property 'default prop) (current-buffer))))) (delete-region ,(point-min-marker) ,(point-max-marker))))))))) (defvar mm-w3m-setup nil "Whether gnus-article-mode has been setup to use emacs-w3m.") ;; External. (declare-function w3m-detect-meta-charset "ext:w3m" ()) (declare-function w3m-region "ext:w3m" (start end &optional url charset)) (defun mm-setup-w3m () "Setup gnus-article-mode to use emacs-w3m." (unless mm-w3m-setup (require 'w3m) (unless (assq 'gnus-article-mode w3m-cid-retrieve-function-alist) (push (cons 'gnus-article-mode 'mm-w3m-cid-retrieve) w3m-cid-retrieve-function-alist)) (setq mm-w3m-setup t)) (setq w3m-display-inline-images mm-inline-text-html-with-images)) (defun mm-w3m-cid-retrieve-1 (url handle) (dolist (elem handle) (when (consp elem) (when (equal url (mm-handle-id elem)) (mm-insert-part elem) (throw 'found-handle (mm-handle-media-type elem))) (when (and (stringp (car elem)) (equal "multipart" (mm-handle-media-supertype elem))) (mm-w3m-cid-retrieve-1 url elem))))) (defun mm-w3m-cid-retrieve (url &rest args) "Insert a content pointed by URL if it has the cid: scheme." (when (string-match "\\`cid:" url) (or (catch 'found-handle (mm-w3m-cid-retrieve-1 (setq url (concat "<" (substring url (match-end 0)) ">")) (with-current-buffer w3m-current-buffer gnus-article-mime-handles))) (prog1 nil (message "Failed to find \"Content-ID: %s\"" url))))) (defun mm-inline-text-html-render-with-w3m (handle) "Render a text/html part using emacs-w3m." (mm-setup-w3m) (let ((text (mm-get-part handle)) (b (point)) (charset (or (mail-content-type-get (mm-handle-type handle) 'charset) mail-parse-charset))) (save-excursion (insert (if charset (mm-decode-string text charset) text)) (save-restriction (narrow-to-region b (point)) (unless charset (goto-char (point-min)) (when (setq charset (w3m-detect-meta-charset)) (delete-region (point-min) (point-max)) (insert (mm-decode-string text charset)))) (let ((w3m-safe-url-regexp mm-w3m-safe-url-regexp) w3m-force-redisplay) (w3m-region (point-min) (point-max) nil charset)) (when (and mm-inline-text-html-with-w3m-keymap (boundp 'w3m-minor-mode-map) w3m-minor-mode-map) (add-text-properties (point-min) (point-max) (list 'keymap w3m-minor-mode-map ;; Put the mark meaning this part was rendered by emacs-w3m. 'mm-inline-text-html-with-w3m t))) (mm-handle-set-undisplayer handle `(lambda () (let ((inhibit-read-only t)) (delete-region ,(point-min-marker) ,(point-max-marker))))))))) (defvar mm-w3m-standalone-supports-m17n-p (if (featurep 'mule) 'undecided) "*T means the w3m command supports the m17n feature.") (defun mm-w3m-standalone-supports-m17n-p () "Say whether the w3m command supports the m17n feature." (cond ((eq mm-w3m-standalone-supports-m17n-p t) t) ((eq mm-w3m-standalone-supports-m17n-p nil) nil) ((not (featurep 'mule)) (setq mm-w3m-standalone-supports-m17n-p nil)) ((condition-case nil (let ((coding-system-for-write 'iso-2022-jp) (coding-system-for-read 'iso-2022-jp) (str (mm-decode-coding-string "\ \e$B#D#o#e#s!!#w#3#m!!#s#u#p#p#o#r#t!!#m#1#7#n!)\e(B" 'iso-2022-jp))) (mm-with-multibyte-buffer (insert str) (call-process-region (point-min) (point-max) "w3m" t t nil "-dump" "-T" "text/html" "-I" "iso-2022-jp" "-O" "iso-2022-jp") (goto-char (point-min)) (search-forward str nil t))) (error nil)) (setq mm-w3m-standalone-supports-m17n-p t)) (t ;;(message "You had better upgrade your w3m command") (setq mm-w3m-standalone-supports-m17n-p nil)))) (defun mm-inline-text-html-render-with-w3m-standalone (handle) "Render a text/html part using w3m." (if (mm-w3m-standalone-supports-m17n-p) (let ((source (mm-get-part handle)) (charset (or (mail-content-type-get (mm-handle-type handle) 'charset) (symbol-name mail-parse-charset))) cs) (unless (and charset (setq cs (mm-charset-to-coding-system charset)) (not (eq cs 'ascii))) ;; The default. (setq charset "iso-8859-1" cs 'iso-8859-1)) (mm-insert-inline handle (mm-with-unibyte-buffer (insert source) (mm-enable-multibyte) (let ((coding-system-for-write 'binary) (coding-system-for-read cs)) (call-process-region (point-min) (point-max) "w3m" t t nil "-dump" "-T" "text/html" "-I" charset "-O" charset)) (buffer-string)))) (mm-inline-render-with-stdin handle nil "w3m" "-dump" "-T" "text/html"))) (defun mm-links-remove-leading-blank () ;; Delete the annoying three spaces preceding each line of links ;; output. (goto-char (point-min)) (while (re-search-forward "^ " nil t) (delete-region (match-beginning 0) (match-end 0)))) (defun mm-inline-wash-with-file (post-func cmd &rest args) (let ((file (mm-make-temp-file (expand-file-name "mm" mm-tmp-directory)))) (let ((coding-system-for-write 'binary)) (write-region (point-min) (point-max) file nil 'silent)) (delete-region (point-min) (point-max)) (unwind-protect (apply 'call-process cmd nil t nil (mapcar 'eval args)) (delete-file file)) (and post-func (funcall post-func)))) (defun mm-inline-wash-with-stdin (post-func cmd &rest args) (let ((coding-system-for-write 'binary)) (apply 'call-process-region (point-min) (point-max) cmd t t nil args)) (and post-func (funcall post-func))) (defun mm-inline-render-with-file (handle post-func cmd &rest args) (let ((source (mm-get-part handle))) (mm-insert-inline handle (mm-with-unibyte-buffer (insert source) (apply 'mm-inline-wash-with-file post-func cmd args) (buffer-string))))) (defun mm-inline-render-with-stdin (handle post-func cmd &rest args) (let ((source (mm-get-part handle))) (mm-insert-inline handle (mm-with-unibyte-buffer (insert source) (apply 'mm-inline-wash-with-stdin post-func cmd args) (buffer-string))))) (defun mm-inline-render-with-function (handle func &rest args) (let ((source (mm-get-part handle)) (charset (or (mail-content-type-get (mm-handle-type handle) 'charset) mail-parse-charset))) (mm-insert-inline handle (mm-with-multibyte-buffer (insert (if charset (mm-decode-string source charset) source)) (apply func args) (buffer-string))))) (defun mm-inline-text-html (handle) (let* ((func (or mm-inline-text-html-renderer mm-text-html-renderer)) (entry (assq func mm-text-html-renderer-alist)) (inhibit-read-only t)) (if entry (setq func (cdr entry))) (cond ((functionp func) (funcall func handle)) (t (apply (car func) handle (cdr func)))))) (defun mm-inline-text-vcard (handle) (let ((inhibit-read-only t)) (mm-insert-inline handle (concat "\n-- \n" (ignore-errors (if (fboundp 'vcard-pretty-print) (vcard-pretty-print (mm-get-part handle)) (vcard-format-string (vcard-parse-string (mm-get-part handle) 'vcard-standard-filter)))))))) (defun mm-inline-text (handle) (let ((b (point)) (type (mm-handle-media-subtype handle)) (charset (mail-content-type-get (mm-handle-type handle) 'charset)) (inhibit-read-only t)) (if (or (eq charset 'gnus-decoded) ;; This is probably not entirely correct, but ;; makes rfc822 parts with embedded multiparts work. (eq mail-parse-charset 'gnus-decoded)) (save-restriction (narrow-to-region (point) (point)) (mm-insert-part handle) (goto-char (point-max))) (insert (mm-decode-string (mm-get-part handle) charset))) (when (and mm-fill-flowed (equal type "plain") (equal (cdr (assoc 'format (mm-handle-type handle))) "flowed")) (save-restriction (narrow-to-region b (point)) (goto-char b) (fill-flowed nil (equal (cdr (assoc 'delsp (mm-handle-type handle))) "yes")) (goto-char (point-max)))) (save-restriction (narrow-to-region b (point)) (when (member type '("enriched" "richtext")) (set-text-properties (point-min) (point-max) nil) (ignore-errors (enriched-decode (point-min) (point-max)))) (mm-handle-set-undisplayer handle `(lambda () (let ((inhibit-read-only t)) (delete-region ,(point-min-marker) ,(point-max-marker)))))))) (defun mm-insert-inline (handle text) "Insert TEXT inline from HANDLE." (let ((b (point))) (insert text) (unless (bolp) (insert "\n")) (mm-handle-set-undisplayer handle `(lambda () (let ((inhibit-read-only t)) (delete-region ,(copy-marker b) ,(copy-marker (point)))))))) (defun mm-inline-audio (handle) (message "Not implemented")) (defun mm-view-sound-file () (message "Not implemented")) (defun mm-w3-prepare-buffer () (require 'w3) (let ((url-standalone-mode t) (url-gateway-unplugged t) (w3-honor-stylesheets nil)) (w3-prepare-buffer))) (defun mm-view-message () (mm-enable-multibyte) (let (handles) (let (gnus-article-mime-handles) ;; Double decode problem may happen. See mm-inline-message. (run-hooks 'gnus-article-decode-hook) (gnus-article-prepare-display) (setq handles gnus-article-mime-handles)) (when handles (setq gnus-article-mime-handles (mm-merge-handles gnus-article-mime-handles handles)))) (fundamental-mode) (goto-char (point-min))) (defun mm-inline-message (handle) (let ((b (point)) (bolp (bolp)) (charset (mail-content-type-get (mm-handle-type handle) 'charset)) gnus-displaying-mime handles) (when (and charset (stringp charset)) (setq charset (intern (downcase charset))) (when (eq charset 'us-ascii) (setq charset nil))) (save-excursion (save-restriction (narrow-to-region b b) (mm-insert-part handle) (let (gnus-article-mime-handles ;; disable prepare hook gnus-article-prepare-hook (gnus-newsgroup-charset (unless (eq charset 'gnus-decoded) ;; mm-uu might set it. (or charset gnus-newsgroup-charset)))) (let ((gnus-original-article-buffer (mm-handle-buffer handle))) (run-hooks 'gnus-article-decode-hook)) (gnus-article-prepare-display) (setq handles gnus-article-mime-handles)) (goto-char (point-min)) (unless bolp (insert "\n")) (goto-char (point-max)) (unless (bolp) (insert "\n")) (insert "----------\n\n") (when handles (setq gnus-article-mime-handles (mm-merge-handles gnus-article-mime-handles handles))) (mm-handle-set-undisplayer handle `(lambda () (let ((inhibit-read-only t)) (if (fboundp 'remove-specifier) ;; This is only valid on XEmacs. (dolist (prop '(background background-pixmap foreground)) (remove-specifier (face-property 'default prop) (current-buffer)))) (delete-region ,(point-min-marker) ,(point-max-marker))))))))) (defun mm-display-inline-fontify (handle mode) (let ((charset (mail-content-type-get (mm-handle-type handle) 'charset)) text coding-system) (unless (eq charset 'gnus-decoded) (mm-with-unibyte-buffer (mm-insert-part handle) (mm-decompress-buffer (or (mail-content-type-get (mm-handle-disposition handle) 'name) (mail-content-type-get (mm-handle-disposition handle) 'filename)) t t) (unless charset (setq coding-system (mm-find-buffer-file-coding-system))) (setq text (buffer-string)))) ;; XEmacs @#$@ version of font-lock refuses to fully turn itself ;; on for buffers whose name begins with " ". That's why we use ;; `with-current-buffer'/`generate-new-buffer' rather than ;; `with-temp-buffer'. (with-current-buffer (generate-new-buffer "*fontification*") (buffer-disable-undo) (mm-enable-multibyte) (insert (cond ((eq charset 'gnus-decoded) (with-current-buffer (mm-handle-buffer handle) (buffer-string))) (coding-system (mm-decode-coding-string text coding-system)) (charset (mm-decode-string text charset)) (t text))) (require 'font-lock) (let ((font-lock-maximum-size nil) ;; Disable support modes, e.g., jit-lock, lazy-lock, etc. (font-lock-mode-hook nil) (font-lock-support-mode nil) ;; I find font-lock a bit too verbose. (font-lock-verbose nil)) (funcall mode) ;; The mode function might have already turned on font-lock. (unless (symbol-value 'font-lock-mode) (font-lock-fontify-buffer))) ;; By default, XEmacs font-lock uses non-duplicable text ;; properties. This code forces all the text properties ;; to be copied along with the text. (when (featurep 'xemacs) (map-extents (lambda (ext ignored) (set-extent-property ext 'duplicable t) nil) nil nil nil nil nil 'text-prop)) (setq text (buffer-string)) (kill-buffer (current-buffer))) (mm-insert-inline handle text))) ;; Shouldn't these functions check whether the user even wants to use ;; font-lock? At least under XEmacs, this fontification is pretty ;; much unconditional. Also, it would be nice to change for the size ;; of the fontified region. (defun mm-display-patch-inline (handle) (mm-display-inline-fontify handle 'diff-mode)) (defun mm-display-elisp-inline (handle) (mm-display-inline-fontify handle 'emacs-lisp-mode)) (defun mm-display-dns-inline (handle) (mm-display-inline-fontify handle 'dns-mode)) ;; id-signedData OBJECT IDENTIFIER ::= { iso(1) member-body(2) ;; us(840) rsadsi(113549) pkcs(1) pkcs7(7) 2 } (defvar mm-pkcs7-signed-magic (funcall (if (fboundp 'unibyte-string) 'unibyte-string 'string) ?\x30 ?\x5c ?\x28 ?\x80 ?\x5c ?\x7c ?\x81 ?\x2e ?\x5c ?\x7c ?\x82 ?\x2e ?\x2e ?\x5c ?\x7c ?\x83 ?\x2e ?\x2e ?\x2e ?\x5c ?\x29 ?\x06 ?\x09 ?\x5c ?\x2a ?\x86 ?\x48 ?\x86 ?\xf7 ?\x0d ?\x01 ?\x07 ?\x02)) ;; id-envelopedData OBJECT IDENTIFIER ::= { iso(1) member-body(2) ;; us(840) rsadsi(113549) pkcs(1) pkcs7(7) 3 } (defvar mm-pkcs7-enveloped-magic (funcall (if (fboundp 'unibyte-string) 'unibyte-string 'string) ?\x30 ?\x5c ?\x28 ?\x80 ?\x5c ?\x7c ?\x81 ?\x2e ?\x5c ?\x7c ?\x82 ?\x2e ?\x2e ?\x5c ?\x7c ?\x83 ?\x2e ?\x2e ?\x2e ?\x5c ?\x29 ?\x06 ?\x09 ?\x5c ?\x2a ?\x86 ?\x48 ?\x86 ?\xf7 ?\x0d ?\x01 ?\x07 ?\x03)) (defun mm-view-pkcs7-get-type (handle) (mm-with-unibyte-buffer (mm-insert-part handle) (cond ((looking-at mm-pkcs7-enveloped-magic) 'enveloped) ((looking-at mm-pkcs7-signed-magic) 'signed) (t (error "Could not identify PKCS#7 type"))))) (defun mm-view-pkcs7 (handle) (case (mm-view-pkcs7-get-type handle) (enveloped (mm-view-pkcs7-decrypt handle)) (signed (mm-view-pkcs7-verify handle)) (otherwise (error "Unknown or unimplemented PKCS#7 type")))) (defun mm-view-pkcs7-verify (handle) (let ((verified nil)) (with-temp-buffer (insert "MIME-Version: 1.0\n") (mm-insert-headers "application/pkcs7-mime" "base64" "smime.p7m") (insert-buffer-substring (mm-handle-buffer handle)) (setq verified (smime-verify-region (point-min) (point-max)))) (goto-char (point-min)) (mm-insert-part handle) (if (search-forward "Content-Type: " nil t) (delete-region (point-min) (match-beginning 0))) (goto-char (point-max)) (if (re-search-backward "--\r?\n?" nil t) (delete-region (match-end 0) (point-max))) (unless verified (insert-buffer-substring smime-details-buffer))) (goto-char (point-min)) (while (search-forward "\r\n" nil t) (replace-match "\n")) t) (defun mm-view-pkcs7-decrypt (handle) (insert-buffer-substring (mm-handle-buffer handle)) (goto-char (point-min)) (insert "MIME-Version: 1.0\n") (mm-insert-headers "application/pkcs7-mime" "base64" "smime.p7m") (smime-decrypt-region (point-min) (point-max) (if (= (length smime-keys) 1) (cadar smime-keys) (smime-get-key-by-email (completing-read (concat "Decipher using key" (if smime-keys (concat "(default " (caar smime-keys) "): ") ": ")) smime-keys nil nil nil nil (car-safe (car-safe smime-keys)))))) (goto-char (point-min)) (while (search-forward "\r\n" nil t) (replace-match "\n")) (goto-char (point-min))) (provide 'mm-view) ;; arch-tag: b60e749a-d05c-47f2-bccd-bdaa59327cb2 ;;; mm-view.el ends here gnus-5.11+v0.10.dfsg/lisp/gnus-salt.el0000644000175000017500000010577010744555355017531 0ustar tvainikatvainika;;; gnus-salt.el --- alternate summary mode interfaces for Gnus ;; Copyright (C) 1996, 1997, 1998, 1999, 2001, 2002, 2003, 2004, ;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; Keywords: news ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 3, or (at your option) ;; any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Commentary: ;;; Code: (eval-when-compile (require 'cl)) (require 'gnus) (require 'gnus-sum) (require 'gnus-win) ;;; ;;; gnus-pick-mode ;;; (defvar gnus-pick-mode nil "Minor mode for providing a pick-and-read interface in Gnus summary buffers.") (defcustom gnus-pick-display-summary nil "*Display summary while reading." :type 'boolean :group 'gnus-summary-pick) (defcustom gnus-pick-mode-hook nil "Hook run in summary pick mode buffers." :type 'hook :group 'gnus-summary-pick) (when (featurep 'xemacs) (add-hook 'gnus-pick-mode-hook 'gnus-xmas-pick-menu-add)) (defcustom gnus-mark-unpicked-articles-as-read nil "*If non-nil, mark all unpicked articles as read." :type 'boolean :group 'gnus-summary-pick) (defcustom gnus-pick-elegant-flow t "If non-nil, `gnus-pick-start-reading' runs `gnus-summary-next-group' when no articles have been picked." :type 'boolean :group 'gnus-summary-pick) (defcustom gnus-summary-pick-line-format "%-5P %U\%R\%z\%I\%(%[%4L: %-23,23n%]%) %s\n" "*The format specification of the lines in pick buffers. It accepts the same format specs that `gnus-summary-line-format' does." :type 'string :group 'gnus-summary-pick) ;;; Internal variables. (defvar gnus-pick-mode-map nil) (unless gnus-pick-mode-map (setq gnus-pick-mode-map (make-sparse-keymap)) (gnus-define-keys gnus-pick-mode-map " " gnus-pick-next-page "u" gnus-pick-unmark-article-or-thread "." gnus-pick-article-or-thread gnus-down-mouse-2 gnus-pick-mouse-pick-region "\r" gnus-pick-start-reading)) (defun gnus-pick-make-menu-bar () (unless (boundp 'gnus-pick-menu) (easy-menu-define gnus-pick-menu gnus-pick-mode-map "" '("Pick" ("Pick" ["Article" gnus-summary-mark-as-processable t] ["Thread" gnus-uu-mark-thread t] ["Region" gnus-uu-mark-region t] ["Regexp" gnus-uu-mark-by-regexp t] ["Buffer" gnus-uu-mark-buffer t]) ("Unpick" ["Article" gnus-summary-unmark-as-processable t] ["Thread" gnus-uu-unmark-thread t] ["Region" gnus-uu-unmark-region t] ["Regexp" gnus-uu-unmark-by-regexp t] ["Buffer" gnus-summary-unmark-all-processable t]) ["Start reading" gnus-pick-start-reading t] ["Switch pick mode off" gnus-pick-mode gnus-pick-mode])))) (defun gnus-pick-mode (&optional arg) "Minor mode for providing a pick-and-read interface in Gnus summary buffers. \\{gnus-pick-mode-map}" (interactive "P") (when (eq major-mode 'gnus-summary-mode) (if (not (set (make-local-variable 'gnus-pick-mode) (if (null arg) (not gnus-pick-mode) (> (prefix-numeric-value arg) 0)))) (remove-hook 'gnus-message-setup-hook 'gnus-pick-setup-message) ;; Make sure that we don't select any articles upon group entry. (set (make-local-variable 'gnus-auto-select-first) nil) ;; Change line format. (setq gnus-summary-line-format gnus-summary-pick-line-format) (setq gnus-summary-line-format-spec nil) (gnus-update-format-specifications nil 'summary) (gnus-update-summary-mark-positions) (add-hook 'gnus-message-setup-hook 'gnus-pick-setup-message) (set (make-local-variable 'gnus-summary-goto-unread) 'never) ;; Set up the menu. (when (gnus-visual-p 'pick-menu 'menu) (gnus-pick-make-menu-bar)) (add-minor-mode 'gnus-pick-mode " Pick" gnus-pick-mode-map) (gnus-run-hooks 'gnus-pick-mode-hook)))) (defun gnus-pick-setup-message () "Make Message do the right thing on exit." (when (and (gnus-buffer-live-p gnus-summary-buffer) (with-current-buffer gnus-summary-buffer gnus-pick-mode)) (message-add-action `(gnus-configure-windows ,gnus-current-window-configuration t) 'send 'exit 'postpone 'kill))) (defvar gnus-pick-line-number 1) (defun gnus-pick-line-number () "Return the current line number." (if (bobp) (setq gnus-pick-line-number 1) (incf gnus-pick-line-number))) (defun gnus-pick-start-reading (&optional catch-up) "Start reading the picked articles. If given a prefix, mark all unpicked articles as read." (interactive "P") (if gnus-newsgroup-processable (progn (gnus-summary-limit-to-articles nil) (when (or catch-up gnus-mark-unpicked-articles-as-read) (gnus-summary-limit-mark-excluded-as-read)) (gnus-summary-first-article) (gnus-configure-windows (if gnus-pick-display-summary 'article 'pick) t)) (if gnus-pick-elegant-flow (progn (when (or catch-up gnus-mark-unpicked-articles-as-read) (gnus-summary-catchup nil t)) (if (gnus-group-quit-config gnus-newsgroup-name) (gnus-summary-exit) (gnus-summary-next-group))) (error "No articles have been picked")))) (defun gnus-pick-goto-article (arg) "Go to the article number indicated by ARG. If ARG is an invalid article number, then stay on current line." (let (pos) (save-excursion (goto-char (point-min)) (when (zerop (forward-line (1- (prefix-numeric-value arg)))) (setq pos (point)))) (if (not pos) (gnus-error 2 "No such line: %s" arg) (goto-char pos)))) (defun gnus-pick-article (&optional arg) "Pick the article on the current line. If ARG, pick the article on that line instead." (interactive "P") (when arg (gnus-pick-goto-article arg)) (gnus-summary-mark-as-processable 1)) (defun gnus-pick-article-or-thread (&optional arg) "If `gnus-thread-hide-subtree' is t, then pick the thread on the current line. Otherwise pick the article on the current line. If ARG, pick the article/thread on that line instead." (interactive "P") (when arg (gnus-pick-goto-article arg)) (if gnus-thread-hide-subtree (progn (save-excursion (gnus-uu-mark-thread)) (forward-line 1)) (gnus-summary-mark-as-processable 1))) (defun gnus-pick-unmark-article-or-thread (&optional arg) "If `gnus-thread-hide-subtree' is t, then unmark the thread on current line. Otherwise unmark the article on current line. If ARG, unmark thread/article on that line instead." (interactive "P") (when arg (gnus-pick-goto-article arg)) (if gnus-thread-hide-subtree (save-excursion (gnus-uu-unmark-thread)) (gnus-summary-unmark-as-processable 1))) (defun gnus-pick-mouse-pick (e) (interactive "e") (mouse-set-point e) (save-excursion (gnus-summary-mark-as-processable 1))) (defun gnus-pick-mouse-pick-region (start-event) "Pick articles that the mouse is dragged over. This must be bound to a button-down mouse event." (interactive "e") (mouse-minibuffer-check start-event) (let* ((echo-keystrokes 0) (start-posn (event-start start-event)) (start-point (posn-point start-posn)) (start-line (1+ (count-lines (point-min) start-point))) (start-window (posn-window start-posn)) (bounds (gnus-window-edges start-window)) (top (nth 1 bounds)) (bottom (if (window-minibuffer-p start-window) (nth 3 bounds) ;; Don't count the mode line. (1- (nth 3 bounds)))) (click-count (1- (event-click-count start-event)))) (setq mouse-selection-click-count click-count) (setq mouse-selection-click-count-buffer (current-buffer)) (mouse-set-point start-event) ;; In case the down click is in the middle of some intangible text, ;; use the end of that text, and put it in START-POINT. (when (< (point) start-point) (goto-char start-point)) (gnus-pick-article) (setq start-point (point)) ;; end-of-range is used only in the single-click case. ;; It is the place where the drag has reached so far ;; (but not outside the window where the drag started). (let (event end end-point (end-of-range (point))) (track-mouse (while (progn (setq event (cdr (gnus-read-event-char))) (or (mouse-movement-p event) (eq (car-safe event) 'switch-frame))) (if (eq (car-safe event) 'switch-frame) nil (setq end (event-end event) end-point (posn-point end)) (cond ;; Are we moving within the original window? ((and (eq (posn-window end) start-window) (integer-or-marker-p end-point)) ;; Go to START-POINT first, so that when we move to END-POINT, ;; if it's in the middle of intangible text, ;; point jumps in the direction away from START-POINT. (goto-char start-point) (goto-char end-point) (gnus-pick-article) ;; In case the user moved his mouse really fast, pick ;; articles on the line between this one and the last one. (let* ((this-line (1+ (count-lines (point-min) end-point))) (min-line (min this-line start-line)) (max-line (max this-line start-line))) ;; Why not use `forward-line'? --Stef (while (< min-line max-line) (goto-line min-line) (gnus-pick-article) (setq min-line (1+ min-line))) (setq start-line this-line)) (when (zerop (% click-count 3)) (setq end-of-range (point)))) (t (let ((mouse-row (cdr (cdr (mouse-position))))) (cond ((null mouse-row)) ((< mouse-row top) (mouse-scroll-subr start-window (- mouse-row top))) ((>= mouse-row bottom) (mouse-scroll-subr start-window (1+ (- mouse-row bottom))))))))))) (when (consp event) (let ((fun (key-binding (vector (car event))))) ;; Run the binding of the terminating up-event, if possible. ;; In the case of a multiple click, it gives the wrong results, ;; because it would fail to set up a region. (when nil ;; (and (= (mod mouse-selection-click-count 3) 0) (fboundp fun)) ;; In this case, we can just let the up-event execute normally. (let ((end (event-end event))) ;; Set the position in the event before we replay it, ;; because otherwise it may have a position in the wrong ;; buffer. (setcar (cdr end) end-of-range) ;; Delete the overlay before calling the function, ;; because delete-overlay increases buffer-modified-tick. (push event unread-command-events)))))))) (defun gnus-pick-next-page () "Go to the next page. If at the end of the buffer, start reading articles." (interactive) (let ((scroll-in-place nil)) (condition-case nil (scroll-up) (end-of-buffer (gnus-pick-start-reading))))) ;;; ;;; gnus-binary-mode ;;; (defvar gnus-binary-mode nil "Minor mode for providing a binary group interface in Gnus summary buffers.") (defvar gnus-binary-mode-hook nil "Hook run in summary binary mode buffers.") (defvar gnus-binary-mode-map nil) (unless gnus-binary-mode-map (setq gnus-binary-mode-map (make-sparse-keymap)) (gnus-define-keys gnus-binary-mode-map "g" gnus-binary-show-article)) (defun gnus-binary-make-menu-bar () (unless (boundp 'gnus-binary-menu) (easy-menu-define gnus-binary-menu gnus-binary-mode-map "" '("Pick" ["Switch binary mode off" gnus-binary-mode t])))) (defun gnus-binary-mode (&optional arg) "Minor mode for providing a binary group interface in Gnus summary buffers." (interactive "P") (when (eq major-mode 'gnus-summary-mode) (make-local-variable 'gnus-binary-mode) (setq gnus-binary-mode (if (null arg) (not gnus-binary-mode) (> (prefix-numeric-value arg) 0))) (when gnus-binary-mode ;; Make sure that we don't select any articles upon group entry. (make-local-variable 'gnus-auto-select-first) (setq gnus-auto-select-first nil) (make-local-variable 'gnus-summary-display-article-function) (setq gnus-summary-display-article-function 'gnus-binary-display-article) ;; Set up the menu. (when (gnus-visual-p 'binary-menu 'menu) (gnus-binary-make-menu-bar)) (add-minor-mode 'gnus-binary-mode " Binary" gnus-binary-mode-map) (gnus-run-hooks 'gnus-binary-mode-hook)))) (defun gnus-binary-display-article (article &optional all-header) "Run ARTICLE through the binary decode functions." (when (gnus-summary-goto-subject article) (let ((gnus-view-pseudos (or gnus-view-pseudos 'automatic))) (gnus-uu-decode-uu)))) (defun gnus-binary-show-article (&optional arg) "Bypass the binary functions and show the article." (interactive "P") (let (gnus-summary-display-article-function) (gnus-summary-show-article arg))) ;;; ;;; gnus-tree-mode ;;; (defcustom gnus-tree-line-format "%(%[%3,3n%]%)" "Format of tree elements." :type 'string :group 'gnus-summary-tree) (defcustom gnus-tree-minimize-window t "If non-nil, minimize the tree buffer window. If a number, never let the tree buffer grow taller than that number of lines." :type '(choice boolean integer) :group 'gnus-summary-tree) (defcustom gnus-selected-tree-face 'modeline "*Face used for highlighting selected articles in the thread tree." :type 'face :group 'gnus-summary-tree) (defvar gnus-tree-brackets '((?\[ . ?\]) (?\( . ?\)) (?\{ . ?\}) (?< . ?>)) "Brackets used in tree nodes.") (defvar gnus-tree-parent-child-edges '(?- ?\\ ?|) "Characters used to connect parents with children.") (defcustom gnus-tree-mode-line-format "Gnus: %%b %S %Z" "*The format specification for the tree mode line." :type 'string :group 'gnus-summary-tree) (defcustom gnus-generate-tree-function 'gnus-generate-vertical-tree "*Function for generating a thread tree. Two predefined functions are available: `gnus-generate-horizontal-tree' and `gnus-generate-vertical-tree'." :type '(radio (function-item gnus-generate-vertical-tree) (function-item gnus-generate-horizontal-tree) (function :tag "Other" nil)) :group 'gnus-summary-tree) (defcustom gnus-tree-mode-hook nil "*Hook run in tree mode buffers." :type 'hook :group 'gnus-summary-tree) (when (featurep 'xemacs) (add-hook 'gnus-tree-mode-hook 'gnus-xmas-tree-menu-add) (add-hook 'gnus-tree-mode-hook 'gnus-xmas-switch-horizontal-scrollbar-off)) ;;; Internal variables. (defvar gnus-tree-line-format-alist `((?n gnus-tmp-name ?s) (?f gnus-tmp-from ?s) (?N gnus-tmp-number ?d) (?\[ gnus-tmp-open-bracket ?c) (?\] gnus-tmp-close-bracket ?c) (?s gnus-tmp-subject ?s))) (defvar gnus-tree-mode-line-format-alist gnus-summary-mode-line-format-alist) (defvar gnus-tree-mode-line-format-spec nil) (defvar gnus-tree-line-format-spec nil) (defvar gnus-tree-node-length nil) (defvar gnus-selected-tree-overlay nil) (defvar gnus-tree-displayed-thread nil) (defvar gnus-tree-inhibit nil) (defvar gnus-tree-mode-map nil) (put 'gnus-tree-mode 'mode-class 'special) (unless gnus-tree-mode-map (setq gnus-tree-mode-map (make-keymap)) (suppress-keymap gnus-tree-mode-map) (gnus-define-keys gnus-tree-mode-map "\r" gnus-tree-select-article gnus-mouse-2 gnus-tree-pick-article "\C-?" gnus-tree-read-summary-keys "h" gnus-tree-show-summary "\C-c\C-i" gnus-info-find-node) (substitute-key-definition 'undefined 'gnus-tree-read-summary-keys gnus-tree-mode-map)) (defun gnus-tree-make-menu-bar () (unless (boundp 'gnus-tree-menu) (easy-menu-define gnus-tree-menu gnus-tree-mode-map "" '("Tree" ["Select article" gnus-tree-select-article t])))) (defun gnus-tree-mode () "Major mode for displaying thread trees." (interactive) (gnus-set-format 'tree-mode) (gnus-set-format 'tree t) (when (gnus-visual-p 'tree-menu 'menu) (gnus-tree-make-menu-bar)) (kill-all-local-variables) (gnus-simplify-mode-line) (setq mode-name "Tree") (setq major-mode 'gnus-tree-mode) (use-local-map gnus-tree-mode-map) (buffer-disable-undo) (setq buffer-read-only t) (setq truncate-lines t) (save-excursion (gnus-set-work-buffer) (gnus-tree-node-insert (make-mail-header "") nil) (setq gnus-tree-node-length (1- (point)))) (gnus-run-mode-hooks 'gnus-tree-mode-hook)) (defun gnus-tree-read-summary-keys (&optional arg) "Read a summary buffer key sequence and execute it." (interactive "P") (unless gnus-tree-inhibit (let ((buf (current-buffer)) (gnus-tree-inhibit t) win) (set-buffer gnus-article-buffer) (gnus-article-read-summary-keys arg nil t) (when (setq win (get-buffer-window buf)) (select-window win) (when gnus-selected-tree-overlay (goto-char (or (gnus-overlay-end gnus-selected-tree-overlay) 1))) (gnus-tree-minimize))))) (defun gnus-tree-show-summary () "Reconfigure windows to show summary buffer." (interactive) (if (not (gnus-buffer-live-p gnus-summary-buffer)) (error "There is no summary buffer for this tree buffer") (gnus-configure-windows 'article) (gnus-summary-goto-subject gnus-current-article))) (defun gnus-tree-select-article (article) "Select the article under point, if any." (interactive (list (gnus-tree-article-number))) (let ((buf (current-buffer))) (when article (with-current-buffer gnus-summary-buffer (gnus-summary-goto-article article)) (select-window (get-buffer-window buf))))) (defun gnus-tree-pick-article (e) "Select the article under the mouse pointer." (interactive "e") (mouse-set-point e) (gnus-tree-select-article (gnus-tree-article-number))) (defun gnus-tree-article-number () (get-text-property (point) 'gnus-number)) (defun gnus-tree-article-region (article) "Return a cons with BEG and END of the article region." (let ((pos (text-property-any (point-min) (point-max) 'gnus-number article))) (when pos (cons pos (next-single-property-change pos 'gnus-number))))) (defun gnus-tree-goto-article (article) (let ((pos (text-property-any (point-min) (point-max) 'gnus-number article))) (when pos (goto-char pos)))) (defun gnus-tree-recenter () "Center point in the tree window." (let ((selected (selected-window)) (tree-window (gnus-get-buffer-window gnus-tree-buffer t))) (when tree-window (select-window tree-window) (when gnus-selected-tree-overlay (goto-char (or (gnus-overlay-end gnus-selected-tree-overlay) 1))) (let* ((top (cond ((< (window-height) 4) 0) ((< (window-height) 7) 1) (t 2))) (height (1- (window-height))) (bottom (save-excursion (goto-char (point-max)) (forward-line (- height)) (point)))) ;; Set the window start to either `bottom', which is the biggest ;; possible valid number, or the second line from the top, ;; whichever is the least. (set-window-start tree-window (min bottom (save-excursion (forward-line (- top)) (point))))) (select-window selected)))) (defun gnus-get-tree-buffer () "Return the tree buffer properly initialized." (with-current-buffer (gnus-get-buffer-create gnus-tree-buffer) (unless (eq major-mode 'gnus-tree-mode) (gnus-tree-mode)) (current-buffer))) (defun gnus-tree-minimize () (when (and gnus-tree-minimize-window (not (one-window-p))) (let ((windows 0) tot-win-height) (walk-windows (lambda (window) (incf windows))) (setq tot-win-height (- (frame-height) (* window-min-height (1- windows)) 2)) (let* ((window-min-height 2) (height (count-lines (point-min) (point-max))) (min (max (1- window-min-height) height)) (tot (if (numberp gnus-tree-minimize-window) (min gnus-tree-minimize-window min) min)) (win (get-buffer-window (current-buffer))) (wh (and win (1- (window-height win))))) (setq tot (min tot tot-win-height)) (when (and win (not (eq tot wh))) (let ((selected (selected-window))) (when (ignore-errors (select-window win)) (enlarge-window (- tot wh)) (select-window selected)))))))) ;;; Generating the tree. (defun gnus-tree-node-insert (header sparse &optional adopted) (let* ((dummy (stringp header)) (header (if (vectorp header) header (progn (setq header (make-mail-header "*****")) (mail-header-set-number header 0) (mail-header-set-lines header 0) (mail-header-set-chars header 0) header))) (gnus-tmp-from (mail-header-from header)) (gnus-tmp-subject (mail-header-subject header)) (gnus-tmp-number (mail-header-number header)) (gnus-tmp-name (cond ((string-match "(.+)" gnus-tmp-from) (substring gnus-tmp-from (1+ (match-beginning 0)) (1- (match-end 0)))) ((string-match "<[^>]+> *$" gnus-tmp-from) (let ((beg (match-beginning 0))) (or (and (string-match "^\"[^\"]*\"" gnus-tmp-from) (substring gnus-tmp-from (1+ (match-beginning 0)) (1- (match-end 0)))) (substring gnus-tmp-from 0 beg)))) ((memq gnus-tmp-number sparse) "***") (t gnus-tmp-from))) (gnus-tmp-open-bracket (cond ((memq gnus-tmp-number sparse) (caadr gnus-tree-brackets)) (dummy (caaddr gnus-tree-brackets)) (adopted (car (nth 3 gnus-tree-brackets))) (t (caar gnus-tree-brackets)))) (gnus-tmp-close-bracket (cond ((memq gnus-tmp-number sparse) (cdadr gnus-tree-brackets)) (adopted (cdr (nth 3 gnus-tree-brackets))) (dummy (cdaddr gnus-tree-brackets)) (t (cdar gnus-tree-brackets)))) (buffer-read-only nil) beg end) (gnus-add-text-properties (setq beg (point)) (setq end (progn (eval gnus-tree-line-format-spec) (point))) (list 'gnus-number gnus-tmp-number)) (when (or t (gnus-visual-p 'tree-highlight 'highlight)) (gnus-tree-highlight-node gnus-tmp-number beg end)))) (defun gnus-tree-highlight-node (article beg end) "Highlight current line according to `gnus-summary-highlight'." (let ((list gnus-summary-highlight) face) (with-current-buffer gnus-summary-buffer (let* ((score (or (cdr (assq article gnus-newsgroup-scored)) gnus-summary-default-score 0)) (default gnus-summary-default-score) (default-high gnus-summary-default-high-score) (default-low gnus-summary-default-low-score) (uncached (memq article gnus-newsgroup-undownloaded)) (downloaded (not uncached)) (mark (or (gnus-summary-article-mark article) gnus-unread-mark))) ;; Eval the cars of the lists until we find a match. (while (and list (not (eval (caar list)))) (setq list (cdr list))))) (unless (eq (setq face (cdar list)) (get-text-property beg 'face)) (gnus-put-text-property-excluding-characters-with-faces beg end 'face (if (boundp face) (symbol-value face) face))))) (defun gnus-tree-indent (level) (insert (make-string (1- (* (1+ gnus-tree-node-length) level)) ? ))) (defvar gnus-tmp-limit) (defvar gnus-tmp-sparse) (defvar gnus-tmp-indent) (defun gnus-generate-tree (thread) "Generate a thread tree for THREAD." (with-current-buffer (gnus-get-tree-buffer) (let ((buffer-read-only nil) (gnus-tmp-indent 0)) (erase-buffer) (funcall gnus-generate-tree-function thread 0) (gnus-set-mode-line 'tree) (goto-char (point-min)) (gnus-tree-minimize) (gnus-tree-recenter) (let ((selected (selected-window))) (when (gnus-get-buffer-window (set-buffer gnus-tree-buffer) t) (select-window (gnus-get-buffer-window (set-buffer gnus-tree-buffer) t)) (gnus-horizontal-recenter) (select-window selected)))))) (defun gnus-generate-horizontal-tree (thread level &optional dummyp adopted) "Generate a horizontal tree." (let* ((dummy (stringp (car thread))) (do (or dummy (and (car thread) (memq (mail-header-number (car thread)) gnus-tmp-limit)))) col beg) (if (not do) ;; We don't want this article. (setq thread (cdr thread)) (if (not (bolp)) ;; Not the first article on the line, so we insert a "-". (insert (car gnus-tree-parent-child-edges)) ;; If the level isn't zero, then we insert some indentation. (unless (zerop level) (gnus-tree-indent level) (insert (cadr gnus-tree-parent-child-edges)) (setq col (- (setq beg (point)) (point-at-bol) 1)) ;; Draw "|" lines upwards. (while (progn (forward-line -1) (forward-char col) (eq (char-after) ? )) (delete-char 1) (insert (caddr gnus-tree-parent-child-edges))) (goto-char beg))) (setq dummyp nil) ;; Insert the article node. (gnus-tree-node-insert (pop thread) gnus-tmp-sparse adopted)) (if (null thread) ;; End of the thread, so we go to the next line. (unless (bolp) (insert "\n")) ;; Recurse downwards in all children of this article. (while thread (gnus-generate-horizontal-tree (pop thread) (if do (1+ level) level) (or dummyp dummy) dummy))))) (defsubst gnus-tree-indent-vertical () (let ((len (- (* (1+ gnus-tree-node-length) gnus-tmp-indent) (- (point) (point-at-bol))))) (when (> len 0) (insert (make-string len ? ))))) (defsubst gnus-tree-forward-line (n) (while (>= (decf n) 0) (unless (zerop (forward-line 1)) (end-of-line) (insert "\n"))) (end-of-line)) (defun gnus-generate-vertical-tree (thread level &optional dummyp adopted) "Generate a vertical tree." (let* ((dummy (stringp (car thread))) (do (or dummy (and (car thread) (memq (mail-header-number (car thread)) gnus-tmp-limit)))) beg) (if (not do) ;; We don't want this article. (setq thread (cdr thread)) (if (not (save-excursion (beginning-of-line) (bobp))) ;; Not the first article on the line, so we insert a "-". (progn (gnus-tree-indent-vertical) (insert (make-string (/ gnus-tree-node-length 2) ? )) (insert (caddr gnus-tree-parent-child-edges)) (gnus-tree-forward-line 1)) ;; If the level isn't zero, then we insert some indentation. (unless (zerop gnus-tmp-indent) (gnus-tree-forward-line (1- (* 2 level))) (gnus-tree-indent-vertical) (delete-char -1) (insert (cadr gnus-tree-parent-child-edges)) (setq beg (point)) (forward-char -1) ;; Draw "-" lines leftwards. (while (and (not (bobp)) (eq (char-after (1- (point))) ? )) (delete-char -1) (insert (car gnus-tree-parent-child-edges)) (forward-char -1)) (goto-char beg) (gnus-tree-forward-line 1))) (setq dummyp nil) ;; Insert the article node. (gnus-tree-indent-vertical) (gnus-tree-node-insert (pop thread) gnus-tmp-sparse adopted) (gnus-tree-forward-line 1)) (if (null thread) ;; End of the thread, so we go to the next line. (progn (goto-char (point-min)) (end-of-line) (incf gnus-tmp-indent)) ;; Recurse downwards in all children of this article. (while thread (gnus-generate-vertical-tree (pop thread) (if do (1+ level) level) (or dummyp dummy) dummy))))) ;;; Interface functions. (defun gnus-possibly-generate-tree (article &optional force) "Generate the thread tree for ARTICLE if it isn't displayed already." (when (with-current-buffer gnus-summary-buffer (and gnus-use-trees gnus-show-threads (vectorp (gnus-summary-article-header article)))) (save-excursion (let ((top (with-current-buffer gnus-summary-buffer (gnus-cut-thread (gnus-remove-thread (mail-header-id (gnus-summary-article-header article)) t)))) (gnus-tmp-limit gnus-newsgroup-limit) (gnus-tmp-sparse gnus-newsgroup-sparse)) (when (or force (not (eq top gnus-tree-displayed-thread))) (gnus-generate-tree top) (setq gnus-tree-displayed-thread top)))))) (defun gnus-tree-open (group) (gnus-get-tree-buffer)) (defun gnus-tree-close (group) (gnus-kill-buffer gnus-tree-buffer)) (defun gnus-tree-perhaps-minimize () (when (and gnus-tree-minimize-window (get-buffer gnus-tree-buffer)) (with-current-buffer gnus-tree-buffer (gnus-tree-minimize)))) (defun gnus-highlight-selected-tree (article) "Highlight the selected article in the tree." (let ((buf (current-buffer)) region) (set-buffer gnus-tree-buffer) (when (setq region (gnus-tree-article-region article)) (when (or (not gnus-selected-tree-overlay) (gnus-extent-detached-p gnus-selected-tree-overlay)) ;; Create a new overlay. (gnus-overlay-put (setq gnus-selected-tree-overlay (gnus-make-overlay (point-min) (1+ (point-min)))) 'face gnus-selected-tree-face)) ;; Move the overlay to the article. (gnus-move-overlay gnus-selected-tree-overlay (goto-char (car region)) (cdr region)) (gnus-tree-minimize) (gnus-tree-recenter) (let ((selected (selected-window))) (when (gnus-get-buffer-window (set-buffer gnus-tree-buffer) t) (select-window (gnus-get-buffer-window (set-buffer gnus-tree-buffer) t)) (gnus-horizontal-recenter) (select-window selected)))) ;; If we remove this save-excursion, it updates the wrong mode lines?!? (with-current-buffer gnus-tree-buffer (gnus-set-mode-line 'tree)) (set-buffer buf))) (defun gnus-tree-highlight-article (article face) (with-current-buffer (gnus-get-tree-buffer) (let (region) (when (setq region (gnus-tree-article-region article)) (gnus-put-text-property (car region) (cdr region) 'face face) (set-window-point (gnus-get-buffer-window (current-buffer) t) (cdr region)))))) ;;; ;;; gnus-carpal ;;; (defvar gnus-carpal-group-buffer-buttons '(("next" . gnus-group-next-unread-group) ("prev" . gnus-group-prev-unread-group) ("read" . gnus-group-read-group) ("select" . gnus-group-select-group) ("catch-up" . gnus-group-catchup-current) ("new-news" . gnus-group-get-new-news-this-group) ("toggle-sub" . gnus-group-unsubscribe-current-group) ("subscribe" . gnus-group-unsubscribe-group) ("kill" . gnus-group-kill-group) ("yank" . gnus-group-yank-group) ("describe" . gnus-group-describe-group) "list" ("subscribed" . gnus-group-list-groups) ("all" . gnus-group-list-all-groups) ("killed" . gnus-group-list-killed) ("zombies" . gnus-group-list-zombies) ("matching" . gnus-group-list-matching) ("post" . gnus-group-post-news) ("mail" . gnus-group-mail) ("local" . (lambda () (interactive) (gnus-group-news 0))) ("rescan" . gnus-group-get-new-news) ("browse-foreign" . gnus-group-browse-foreign) ("exit" . gnus-group-exit))) (defvar gnus-carpal-summary-buffer-buttons '("mark" ("read" . gnus-summary-mark-as-read-forward) ("tick" . gnus-summary-tick-article-forward) ("clear" . gnus-summary-clear-mark-forward) ("expirable" . gnus-summary-mark-as-expirable) "move" ("scroll" . gnus-summary-next-page) ("next-unread" . gnus-summary-next-unread-article) ("prev-unread" . gnus-summary-prev-unread-article) ("first" . gnus-summary-first-unread-article) ("best" . gnus-summary-best-unread-article) "article" ("headers" . gnus-summary-toggle-header) ("uudecode" . gnus-uu-decode-uu) ("enter-digest" . gnus-summary-enter-digest-group) ("fetch-parent" . gnus-summary-refer-parent-article) "mail" ("move" . gnus-summary-move-article) ("copy" . gnus-summary-copy-article) ("respool" . gnus-summary-respool-article) "threads" ("lower" . gnus-summary-lower-thread) ("kill" . gnus-summary-kill-thread) "post" ("post" . gnus-summary-post-news) ("local" . gnus-summary-news-other-window) ("mail" . gnus-summary-mail-other-window) ("followup" . gnus-summary-followup-with-original) ("reply" . gnus-summary-reply-with-original) ("cancel" . gnus-summary-cancel-article) "misc" ("exit" . gnus-summary-exit) ("fed-up" . gnus-summary-catchup-and-goto-next-group))) (defvar gnus-carpal-server-buffer-buttons '(("add" . gnus-server-add-server) ("browse" . gnus-server-browse-server) ("list" . gnus-server-list-servers) ("kill" . gnus-server-kill-server) ("yank" . gnus-server-yank-server) ("copy" . gnus-server-copy-server) ("exit" . gnus-server-exit))) (defvar gnus-carpal-browse-buffer-buttons '(("subscribe" . gnus-browse-unsubscribe-current-group) ("exit" . gnus-browse-exit))) (defvar gnus-carpal-group-buffer "*Carpal Group*") (defvar gnus-carpal-summary-buffer "*Carpal Summary*") (defvar gnus-carpal-server-buffer "*Carpal Server*") (defvar gnus-carpal-browse-buffer "*Carpal Browse*") (defvar gnus-carpal-attached-buffer nil) (defvar gnus-carpal-mode-hook nil "*Hook run in carpal mode buffers.") (defvar gnus-carpal-button-face 'bold "*Face used on carpal buttons.") (defvar gnus-carpal-header-face 'bold-italic "*Face used on carpal buffer headers.") (defvar gnus-carpal-mode-map nil) (put 'gnus-carpal-mode 'mode-class 'special) (if gnus-carpal-mode-map nil (setq gnus-carpal-mode-map (make-keymap)) (suppress-keymap gnus-carpal-mode-map) (define-key gnus-carpal-mode-map " " 'gnus-carpal-select) (define-key gnus-carpal-mode-map "\r" 'gnus-carpal-select) (define-key gnus-carpal-mode-map gnus-mouse-2 'gnus-carpal-mouse-select)) (defun gnus-carpal-mode () "Major mode for clicking buttons. All normal editing commands are switched off. \\ The following commands are available: \\{gnus-carpal-mode-map}" (interactive) (kill-all-local-variables) (setq mode-line-modified (cdr gnus-mode-line-modified)) (setq major-mode 'gnus-carpal-mode) (setq mode-name "Gnus Carpal") (setq mode-line-process nil) (use-local-map gnus-carpal-mode-map) (buffer-disable-undo) (setq buffer-read-only t) (make-local-variable 'gnus-carpal-attached-buffer) (gnus-run-mode-hooks 'gnus-carpal-mode-hook)) (defun gnus-carpal-setup-buffer (type) (let ((buffer (symbol-value (intern (format "gnus-carpal-%s-buffer" type))))) (if (get-buffer buffer) () (with-current-buffer (gnus-get-buffer-create buffer) (gnus-carpal-mode) (setq gnus-carpal-attached-buffer (intern (format "gnus-%s-buffer" type))) (let ((buttons (symbol-value (intern (format "gnus-carpal-%s-buffer-buttons" type)))) (buffer-read-only nil) button) (while buttons (setq button (car buttons) buttons (cdr buttons)) (if (stringp button) (set-text-properties (point) (prog2 (insert button) (point) (insert " ")) (list 'face gnus-carpal-header-face)) (set-text-properties (point) (prog2 (insert (car button)) (point) (insert " ")) (list 'gnus-callback (cdr button) 'face gnus-carpal-button-face gnus-mouse-face-prop 'highlight)))) (let ((fill-column (- (window-width) 2))) (fill-region (point-min) (point-max))) (set-window-point (get-buffer-window (current-buffer)) (point-min))))))) (defun gnus-carpal-select () "Select the button under point." (interactive) (let ((func (get-text-property (point) 'gnus-callback))) (if (null func) () (pop-to-buffer (symbol-value gnus-carpal-attached-buffer)) (call-interactively func)))) (defun gnus-carpal-mouse-select (event) "Select the button under the mouse pointer." (interactive "e") (mouse-set-point event) (gnus-carpal-select)) ;;; Allow redefinition of functions. (gnus-ems-redefine) (provide 'gnus-salt) ;; arch-tag: 35449164-77b3-4398-bcbd-a2e3e998f810 ;;; gnus-salt.el ends here gnus-5.11+v0.10.dfsg/lisp/pgg-def.el0000644000175000017500000000546511004005111017067 0ustar tvainikatvainika;;; pgg-def.el --- functions/macros for defining PGG functions ;; Copyright (C) 1999, 2002, 2003, 2004, 2005, ;; 2006, 2007, 2008 Free Software Foundation, Inc. ;; Author: Daiki Ueno ;; Created: 1999/11/02 ;; Keywords: PGP, OpenPGP, GnuPG ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 3, or (at your option) ;; any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Code: (defgroup pgg () "Glue for the various PGP implementations." :group 'mime :version "22.1") (defcustom pgg-default-scheme 'gpg "Default PGP scheme." :group 'pgg :type '(choice (const :tag "GnuPG" gpg) (const :tag "PGP 5" pgp5) (const :tag "PGP" pgp))) (defcustom pgg-default-user-id (user-login-name) "User ID of your default identity." :group 'pgg :type 'string) (defcustom pgg-default-keyserver-address "subkeys.pgp.net" "Host name of keyserver." :group 'pgg :type 'string) (defcustom pgg-query-keyserver nil "Whether PGG queries keyservers for missing keys when verifying messages." :version "22.1" :group 'pgg :type 'boolean) (defcustom pgg-encrypt-for-me t "If t, encrypt all outgoing messages with user's public key." :group 'pgg :type 'boolean) (defcustom pgg-cache-passphrase t "If t, cache passphrase." :group 'pgg :type 'boolean) (defcustom pgg-passphrase-cache-expiry 16 "How many seconds the passphrase is cached. Whether the passphrase is cached at all is controlled by `pgg-cache-passphrase'." :group 'pgg :type 'integer) (defcustom pgg-passphrase-coding-system nil "Coding system to encode passphrase." :group 'pgg :type 'coding-system) (defvar pgg-messages-coding-system nil "Coding system used when reading from a PGP external process.") (defvar pgg-status-buffer " *PGG status*") (defvar pgg-errors-buffer " *PGG errors*") (defvar pgg-output-buffer " *PGG output*") (defvar pgg-echo-buffer "*PGG-echo*") (defvar pgg-scheme nil "Current scheme of PGP implementation.") (defvar pgg-text-mode nil "If t, inform the recipient that the input is text.") (defmacro pgg-truncate-key-identifier (key) `(if (> (length ,key) 8) (substring ,key -8) ,key)) (provide 'pgg-def) ;; arch-tag: c425f3ab-ed75-4055-bb46-431a418c94b7 ;;; pgg-def.el ends here gnus-5.11+v0.10.dfsg/lisp/mml-sec.el0000644000175000017500000003172111004005111017105 0ustar tvainikatvainika;;; mml-sec.el --- A package with security functions for MML documents ;; Copyright (C) 2000, 2001, 2002, 2003, 2004, ;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc. ;; Author: Simon Josefsson ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 3, or (at your option) ;; any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Commentary: ;;; Code: (eval-when-compile (require 'cl)) (if (locate-library "password-cache") (require 'password-cache) (require 'password)) (autoload 'mml2015-sign "mml2015") (autoload 'mml2015-encrypt "mml2015") (autoload 'mml1991-sign "mml1991") (autoload 'mml1991-encrypt "mml1991") (autoload 'message-goto-body "message") (autoload 'mml-insert-tag "mml") (autoload 'mml-smime-sign "mml-smime") (autoload 'mml-smime-encrypt "mml-smime") (autoload 'mml-smime-sign-query "mml-smime") (autoload 'mml-smime-encrypt-query "mml-smime") (autoload 'mml-smime-verify "mml-smime") (autoload 'mml-smime-verify-test "mml-smime") (defvar mml-sign-alist '(("smime" mml-smime-sign-buffer mml-smime-sign-query) ("pgp" mml-pgp-sign-buffer list) ("pgpauto" mml-pgpauto-sign-buffer list) ("pgpmime" mml-pgpmime-sign-buffer list)) "Alist of MIME signer functions.") (defcustom mml-default-sign-method "pgpmime" "Default sign method. The string must have an entry in `mml-sign-alist'." :version "22.1" :type '(choice (const "smime") (const "pgp") (const "pgpauto") (const "pgpmime") string) :group 'message) (defvar mml-encrypt-alist '(("smime" mml-smime-encrypt-buffer mml-smime-encrypt-query) ("pgp" mml-pgp-encrypt-buffer list) ("pgpauto" mml-pgpauto-sign-buffer list) ("pgpmime" mml-pgpmime-encrypt-buffer list)) "Alist of MIME encryption functions.") (defcustom mml-default-encrypt-method "pgpmime" "Default encryption method. The string must have an entry in `mml-encrypt-alist'." :version "22.1" :type '(choice (const "smime") (const "pgp") (const "pgpauto") (const "pgpmime") string) :group 'message) (defcustom mml-signencrypt-style-alist '(("smime" separate) ("pgp" combined) ("pgpauto" combined) ("pgpmime" combined)) "Alist specifying if `signencrypt' results in two separate operations or not. The first entry indicates the MML security type, valid entries include the strings \"smime\", \"pgp\", and \"pgpmime\". The second entry is a symbol `separate' or `combined' where `separate' means that MML signs and encrypt messages in a two step process, and `combined' means that MML signs and encrypt the message in one step. Note that the output generated by using a `combined' mode is NOT understood by all PGP implementations, in particular PGP version 2 does not support it! See Info node `(message)Security' for details." :version "22.1" :group 'message :type '(repeat (list (choice (const :tag "S/MIME" "smime") (const :tag "PGP" "pgp") (const :tag "PGP/MIME" "pgpmime") (string :tag "User defined")) (choice (const :tag "Separate" separate) (const :tag "Combined" combined))))) (defcustom mml-secure-verbose nil "If non-nil, ask the user about the current operation more verbosely." :group 'message :type 'boolean) (defcustom mml-secure-cache-passphrase password-cache "If t, cache passphrase." :group 'message :type 'boolean) (defcustom mml-secure-passphrase-cache-expiry password-cache-expiry "How many seconds the passphrase is cached. Whether the passphrase is cached at all is controlled by `mml-secure-cache-passphrase'." :group 'message :type 'integer) ;;; Configuration/helper functions (defun mml-signencrypt-style (method &optional style) "Function for setting/getting the signencrypt-style used. Takes two arguments, the method (e.g. \"pgp\") and optionally the mode \(e.g. combined). If the mode is omitted, the current value is returned. For example, if you prefer to use combined sign & encrypt with smime, putting the following in your Gnus startup file will enable that behavior: \(mml-set-signencrypt-style \"smime\" combined) You can also customize or set `mml-signencrypt-style-alist' instead." (let ((style-item (assoc method mml-signencrypt-style-alist))) (if style-item (if (or (eq style 'separate) (eq style 'combined)) ;; valid style setting? (setf (second style-item) style) ;; otherwise, just return the current value (second style-item)) (message "Warning, attempt to set invalid signencrypt style")))) ;;; Security functions (defun mml-smime-sign-buffer (cont) (or (mml-smime-sign cont) (error "Signing failed... inspect message logs for errors"))) (defun mml-smime-encrypt-buffer (cont &optional sign) (when sign (message "Combined sign and encrypt S/MIME not support yet") (sit-for 1)) (or (mml-smime-encrypt cont) (error "Encryption failed... inspect message logs for errors"))) (defun mml-pgp-sign-buffer (cont) (or (mml1991-sign cont) (error "Signing failed... inspect message logs for errors"))) (defun mml-pgp-encrypt-buffer (cont &optional sign) (or (mml1991-encrypt cont sign) (error "Encryption failed... inspect message logs for errors"))) (defun mml-pgpmime-sign-buffer (cont) (or (mml2015-sign cont) (error "Signing failed... inspect message logs for errors"))) (defun mml-pgpmime-encrypt-buffer (cont &optional sign) (or (mml2015-encrypt cont sign) (error "Encryption failed... inspect message logs for errors"))) (defun mml-pgpauto-sign-buffer (cont) (message-goto-body) (or (if (re-search-backward "Content-Type: *multipart/.*" nil t) ; there must be a better way... (mml2015-sign cont) (mml1991-sign cont)) (error "Encryption failed... inspect message logs for errors"))) (defun mml-pgpauto-encrypt-buffer (cont &optional sign) (message-goto-body) (or (if (re-search-backward "Content-Type: *multipart/.*" nil t) ; there must be a better way... (mml2015-encrypt cont sign) (mml1991-encrypt cont sign)) (error "Encryption failed... inspect message logs for errors"))) (defun mml-secure-part (method &optional sign) (save-excursion (let ((tags (funcall (nth 2 (assoc method (if sign mml-sign-alist mml-encrypt-alist)))))) (cond ((re-search-backward "<#\\(multipart\\|part\\|external\\|mml\\)" nil t) (goto-char (match-end 0)) (insert (if sign " sign=" " encrypt=") method) (while tags (let ((key (pop tags)) (value (pop tags))) (when value ;; Quote VALUE if it contains suspicious characters. (when (string-match "[\"'\\~/*;() \t\n]" value) (setq value (prin1-to-string value))) (insert (format " %s=%s" key value)))))) ((or (re-search-backward (concat "^" (regexp-quote mail-header-separator) "\n") nil t) (re-search-forward (concat "^" (regexp-quote mail-header-separator) "\n") nil t)) (goto-char (match-end 0)) (apply 'mml-insert-tag 'part (cons (if sign 'sign 'encrypt) (cons method tags)))) (t (error "The message is corrupted. No mail header separator")))))) (defvar mml-secure-method (if (equal mml-default-encrypt-method mml-default-sign-method) mml-default-sign-method "pgpmime") "Current security method. Internal variable.") (defun mml-secure-sign (&optional method) "Add MML tags to sign this MML part. Use METHOD if given. Else use `mml-secure-method' or `mml-default-sign-method'." (interactive) (mml-secure-part (or method mml-secure-method mml-default-sign-method) 'sign)) (defun mml-secure-encrypt (&optional method) "Add MML tags to encrypt this MML part. Use METHOD if given. Else use `mml-secure-method' or `mml-default-sign-method'." (interactive) (mml-secure-part (or method mml-secure-method mml-default-sign-method))) (defun mml-secure-sign-pgp () "Add MML tags to PGP sign this MML part." (interactive) (mml-secure-part "pgp" 'sign)) (defun mml-secure-sign-pgpauto () "Add MML tags to PGP-auto sign this MML part." (interactive) (mml-secure-part "pgpauto" 'sign)) (defun mml-secure-sign-pgpmime () "Add MML tags to PGP/MIME sign this MML part." (interactive) (mml-secure-part "pgpmime" 'sign)) (defun mml-secure-sign-smime () "Add MML tags to S/MIME sign this MML part." (interactive) (mml-secure-part "smime" 'sign)) (defun mml-secure-encrypt-pgp () "Add MML tags to PGP encrypt this MML part." (interactive) (mml-secure-part "pgp")) (defun mml-secure-encrypt-pgpmime () "Add MML tags to PGP/MIME encrypt this MML part." (interactive) (mml-secure-part "pgpmime")) (defun mml-secure-encrypt-smime () "Add MML tags to S/MIME encrypt this MML part." (interactive) (mml-secure-part "smime")) ;; defuns that add the proper <#secure ...> tag to the top of the message body (defun mml-secure-message (method &optional modesym) (let ((mode (prin1-to-string modesym)) (tags (append (if (or (eq modesym 'sign) (eq modesym 'signencrypt)) (funcall (nth 2 (assoc method mml-sign-alist)))) (if (or (eq modesym 'encrypt) (eq modesym 'signencrypt)) (funcall (nth 2 (assoc method mml-encrypt-alist)))))) insert-loc) (mml-unsecure-message) (save-excursion (goto-char (point-min)) (cond ((re-search-forward (concat "^" (regexp-quote mail-header-separator) "\n") nil t) (goto-char (setq insert-loc (match-end 0))) (unless (looking-at "<#secure") (apply 'mml-insert-tag 'secure 'method method 'mode mode tags))) (t (error "The message is corrupted. No mail header separator")))) (when (eql insert-loc (point)) (forward-line 1)))) (defun mml-unsecure-message () "Remove security related MML tags from message." (interactive) (save-excursion (goto-char (point-max)) (when (re-search-backward "^<#secure.*>\n" nil t) (delete-region (match-beginning 0) (match-end 0))))) (defun mml-secure-message-sign (&optional method) "Add MML tags to sign this MML part. Use METHOD if given. Else use `mml-secure-method' or `mml-default-sign-method'." (interactive) (mml-secure-part (or method mml-secure-method mml-default-sign-method) 'sign)) (defun mml-secure-message-sign-encrypt (&optional method) "Add MML tag to sign and encrypt the entire message. Use METHOD if given. Else use `mml-secure-method' or `mml-default-sign-method'." (interactive) (mml-secure-message (or method mml-secure-method mml-default-sign-method) 'signencrypt)) (defun mml-secure-message-encrypt (&optional method) "Add MML tag to encrypt the entire message. Use METHOD if given. Else use `mml-secure-method' or `mml-default-sign-method'." (interactive) (mml-secure-message (or method mml-secure-method mml-default-sign-method) 'encrypt)) (defun mml-secure-message-sign-smime () "Add MML tag to encrypt/sign the entire message." (interactive) (mml-secure-message "smime" 'sign)) (defun mml-secure-message-sign-pgp () "Add MML tag to encrypt/sign the entire message." (interactive) (mml-secure-message "pgp" 'sign)) (defun mml-secure-message-sign-pgpmime () "Add MML tag to encrypt/sign the entire message." (interactive) (mml-secure-message "pgpmime" 'sign)) (defun mml-secure-message-sign-pgpauto () "Add MML tag to encrypt/sign the entire message." (interactive) (mml-secure-message "pgpauto" 'sign)) (defun mml-secure-message-encrypt-smime (&optional dontsign) "Add MML tag to encrypt and sign the entire message. If called with a prefix argument, only encrypt (do NOT sign)." (interactive "P") (mml-secure-message "smime" (if dontsign 'encrypt 'signencrypt))) (defun mml-secure-message-encrypt-pgp (&optional dontsign) "Add MML tag to encrypt and sign the entire message. If called with a prefix argument, only encrypt (do NOT sign)." (interactive "P") (mml-secure-message "pgp" (if dontsign 'encrypt 'signencrypt))) (defun mml-secure-message-encrypt-pgpmime (&optional dontsign) "Add MML tag to encrypt and sign the entire message. If called with a prefix argument, only encrypt (do NOT sign)." (interactive "P") (mml-secure-message "pgpmime" (if dontsign 'encrypt 'signencrypt))) (defun mml-secure-message-encrypt-pgpauto (&optional dontsign) "Add MML tag to encrypt and sign the entire message. If called with a prefix argument, only encrypt (do NOT sign)." (interactive "P") (mml-secure-message "pgpauto" (if dontsign 'encrypt 'signencrypt))) (provide 'mml-sec) ;; arch-tag: 111c56e7-df5e-4287-87d7-93ed2911ec6c ;;; mml-sec.el ends here gnus-5.11+v0.10.dfsg/lisp/dns.el0000644000175000017500000003436011004005111016336 0ustar tvainikatvainika;;; dns.el --- Domain Name Service lookups ;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008 ;; Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; Keywords: network ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 3, or (at your option) ;; any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Commentary: ;;; Code: (defvar dns-timeout 5 "How many seconds to wait when doing DNS queries.") (defvar dns-servers nil "Which DNS servers to query. If nil, /etc/resolv.conf will be consulted.") ;;; Internal code: (defvar dns-query-types '((A 1) (NS 2) (MD 3) (MF 4) (CNAME 5) (SOA 6) (MB 7) (MG 8) (MR 9) (NULL 10) (WKS 11) (PTR 12) (HINFO 13) (MINFO 14) (MX 15) (TXT 16) (AAAA 28) ; RFC3596 (SRV 33) ; RFC2782 (AXFR 252) (MAILB 253) (MAILA 254) (* 255)) "Names of query types and their values.") (defvar dns-classes '((IN 1) (CS 2) (CH 3) (HS 4)) "Classes of queries.") (defun dns-write-bytes (value &optional length) (let (bytes) (dotimes (i (or length 1)) (push (% value 256) bytes) (setq value (/ value 256))) (dolist (byte bytes) (insert byte)))) (defun dns-read-bytes (length) (let ((value 0)) (dotimes (i length) (setq value (logior (* value 256) (following-char))) (forward-char 1)) value)) (defun dns-get (type spec) (cadr (assq type spec))) (defun dns-inverse-get (value spec) (let ((found nil)) (while (and (not found) spec) (if (eq value (cadr (car spec))) (setq found (caar spec)) (pop spec))) found)) (defun dns-write-name (name) (dolist (part (split-string name "\\.")) (dns-write-bytes (length part)) (insert part)) (dns-write-bytes 0)) (defun dns-read-string-name (string buffer) (with-temp-buffer (set-buffer-multibyte nil) (insert string) (goto-char (point-min)) (dns-read-name buffer))) (defun dns-read-name (&optional buffer) (let ((ended nil) (name nil) length) (while (not ended) (setq length (dns-read-bytes 1)) (if (= 192 (logand length (lsh 3 6))) (let ((offset (+ (* (logand 63 length) 256) (dns-read-bytes 1)))) (save-excursion (when buffer (set-buffer buffer)) (goto-char (1+ offset)) (setq ended (dns-read-name buffer)))) (if (zerop length) (setq ended t) (push (buffer-substring (point) (progn (forward-char length) (point))) name)))) (if (stringp ended) (if (null name) ended (concat (mapconcat 'identity (nreverse name) ".") "." ended)) (mapconcat 'identity (nreverse name) ".")))) (defun dns-write (spec &optional tcp-p) "Write a DNS packet according to SPEC. If TCP-P, the first two bytes of the package with be the length field." (with-temp-buffer (set-buffer-multibyte nil) (dns-write-bytes (dns-get 'id spec) 2) (dns-write-bytes (logior (lsh (if (dns-get 'response-p spec) 1 0) -7) (lsh (cond ((eq (dns-get 'opcode spec) 'query) 0) ((eq (dns-get 'opcode spec) 'inverse-query) 1) ((eq (dns-get 'opcode spec) 'status) 2) (t (error "No such opcode: %s" (dns-get 'opcode spec)))) -3) (lsh (if (dns-get 'authoritative-p spec) 1 0) -2) (lsh (if (dns-get 'truncated-p spec) 1 0) -1) (lsh (if (dns-get 'recursion-desired-p spec) 1 0) 0))) (dns-write-bytes (cond ((eq (dns-get 'response-code spec) 'no-error) 0) ((eq (dns-get 'response-code spec) 'format-error) 1) ((eq (dns-get 'response-code spec) 'server-failure) 2) ((eq (dns-get 'response-code spec) 'name-error) 3) ((eq (dns-get 'response-code spec) 'not-implemented) 4) ((eq (dns-get 'response-code spec) 'refused) 5) (t 0))) (dns-write-bytes (length (dns-get 'queries spec)) 2) (dns-write-bytes (length (dns-get 'answers spec)) 2) (dns-write-bytes (length (dns-get 'authorities spec)) 2) (dns-write-bytes (length (dns-get 'additionals spec)) 2) (dolist (query (dns-get 'queries spec)) (dns-write-name (car query)) (dns-write-bytes (cadr (assq (or (dns-get 'type query) 'A) dns-query-types)) 2) (dns-write-bytes (cadr (assq (or (dns-get 'class query) 'IN) dns-classes)) 2)) (dolist (slot '(answers authorities additionals)) (dolist (resource (dns-get slot spec)) (dns-write-name (car resource)) (dns-write-bytes (cadr (assq (dns-get 'type resource) dns-query-types)) 2) (dns-write-bytes (cadr (assq (dns-get 'class resource) dns-classes)) 2) (dns-write-bytes (dns-get 'ttl resource) 4) (dns-write-bytes (length (dns-get 'data resource)) 2) (insert (dns-get 'data resource)))) (when tcp-p (goto-char (point-min)) (dns-write-bytes (buffer-size) 2)) (buffer-string))) (defun dns-read (packet) (with-temp-buffer (set-buffer-multibyte nil) (let ((spec nil) queries answers authorities additionals) (insert packet) (goto-char (point-min)) (push (list 'id (dns-read-bytes 2)) spec) (let ((byte (dns-read-bytes 1))) (push (list 'response-p (if (zerop (logand byte (lsh 1 7))) nil t)) spec) (let ((opcode (logand byte (lsh 7 3)))) (push (list 'opcode (cond ((eq opcode 0) 'query) ((eq opcode 1) 'inverse-query) ((eq opcode 2) 'status))) spec)) (push (list 'authoritative-p (if (zerop (logand byte (lsh 1 2))) nil t)) spec) (push (list 'truncated-p (if (zerop (logand byte (lsh 1 2))) nil t)) spec) (push (list 'recursion-desired-p (if (zerop (logand byte (lsh 1 0))) nil t)) spec)) (let ((rc (logand (dns-read-bytes 1) 15))) (push (list 'response-code (cond ((eq rc 0) 'no-error) ((eq rc 1) 'format-error) ((eq rc 2) 'server-failure) ((eq rc 3) 'name-error) ((eq rc 4) 'not-implemented) ((eq rc 5) 'refused))) spec)) (setq queries (dns-read-bytes 2)) (setq answers (dns-read-bytes 2)) (setq authorities (dns-read-bytes 2)) (setq additionals (dns-read-bytes 2)) (let ((qs nil)) (dotimes (i queries) (push (list (dns-read-name) (list 'type (dns-inverse-get (dns-read-bytes 2) dns-query-types)) (list 'class (dns-inverse-get (dns-read-bytes 2) dns-classes))) qs)) (push (list 'queries qs) spec)) (dolist (slot '(answers authorities additionals)) (let ((qs nil) type) (dotimes (i (symbol-value slot)) (push (list (dns-read-name) (list 'type (setq type (dns-inverse-get (dns-read-bytes 2) dns-query-types))) (list 'class (dns-inverse-get (dns-read-bytes 2) dns-classes)) (list 'ttl (dns-read-bytes 4)) (let ((length (dns-read-bytes 2))) (list 'data (dns-read-type (buffer-substring (point) (progn (forward-char length) (point))) type)))) qs)) (push (list slot qs) spec))) (nreverse spec)))) (defun dns-read-int32 () ;; Full 32 bit Integers can't be handled by Emacs. If we use ;; floats, it works. (format "%.0f" (+ (* (dns-read-bytes 1) 16777216.0) (dns-read-bytes 3)))) (defun dns-read-type (string type) (let ((buffer (current-buffer)) (point (point))) (prog1 (with-temp-buffer (set-buffer-multibyte nil) (insert string) (goto-char (point-min)) (cond ((eq type 'A) (let ((bytes nil)) (dotimes (i 4) (push (dns-read-bytes 1) bytes)) (mapconcat 'number-to-string (nreverse bytes) "."))) ((eq type 'AAAA) (let (hextets) (dotimes (i 8) (push (dns-read-bytes 2) hextets)) (mapconcat (lambda (n) (format "%x" n)) (nreverse hextets) ":"))) ((eq type 'SOA) (list (list 'mname (dns-read-name buffer)) (list 'rname (dns-read-name buffer)) (list 'serial (dns-read-int32)) (list 'refresh (dns-read-int32)) (list 'retry (dns-read-int32)) (list 'expire (dns-read-int32)) (list 'minimum (dns-read-int32)))) ((eq type 'SRV) (list (list 'priority (dns-read-bytes 2)) (list 'weight (dns-read-bytes 2)) (list 'port (dns-read-bytes 2)) (list 'target (dns-read-name buffer)))) ((eq type 'MX) (cons (dns-read-bytes 2) (dns-read-name buffer))) ((or (eq type 'CNAME) (eq type 'NS) (eq type 'PTR)) (dns-read-string-name string buffer)) (t string))) (goto-char point)))) (defun dns-parse-resolv-conf () (when (file-exists-p "/etc/resolv.conf") (with-temp-buffer (insert-file-contents "/etc/resolv.conf") (goto-char (point-min)) (while (re-search-forward "^nameserver[\t ]+\\([^ \t\n]+\\)" nil t) (push (match-string 1) dns-servers)) (setq dns-servers (nreverse dns-servers))))) (defun dns-read-txt (string) (if (> (length string) 1) (substring string 1) string)) (defun dns-get-txt-answer (answers) (let ((result "") (do-next nil)) (dolist (answer answers) (dolist (elem answer) (when (consp elem) (cond ((eq (car elem) 'type) (setq do-next (eq (cadr elem) 'TXT))) ((eq (car elem) 'data) (when do-next (setq result (concat result (dns-read-txt (cadr elem)))))))))) result)) ;;; Interface functions. (defmacro dns-make-network-process (server) (if (featurep 'xemacs) `(let ((coding-system-for-read 'binary) (coding-system-for-write 'binary)) (open-network-stream "dns" (current-buffer) ,server "domain" 'udp)) `(let ((server ,server) (coding-system-for-read 'binary) (coding-system-for-write 'binary)) (if (fboundp 'make-network-process) (make-network-process :name "dns" :coding 'binary :buffer (current-buffer) :host server :service "domain" :type 'datagram) ;; Older versions of Emacs doesn't have ;; `make-network-process', so we fall back on opening a TCP ;; connection to the DNS server. (open-network-stream "dns" (current-buffer) server "domain"))))) (defvar dns-cache (make-vector 4096 0)) (defun query-dns-cached (name &optional type fullp reversep) (let* ((key (format "%s:%s:%s:%s" name type fullp reversep)) (sym (intern-soft key dns-cache))) (if (and sym (boundp sym)) (symbol-value sym) (let ((result (query-dns name type fullp reversep))) (set (intern key dns-cache) result) result)))) (defun query-dns (name &optional type fullp reversep) "Query a DNS server for NAME of TYPE. If FULLP, return the entire record returned. If REVERSEP, look up an IP address." (setq type (or type 'A)) (unless dns-servers (dns-parse-resolv-conf)) (when reversep (setq name (concat (mapconcat 'identity (nreverse (split-string name "\\.")) ".") ".in-addr.arpa") type 'PTR)) (if (not dns-servers) (message "No DNS server configuration found") (with-temp-buffer (set-buffer-multibyte nil) (let ((process (condition-case () (dns-make-network-process (car dns-servers)) (error (message "dns: Got an error while trying to talk to %s" (car dns-servers)) nil))) (tcp-p (and (not (fboundp 'make-network-process)) (not (featurep 'xemacs)))) (step 100) (times (* dns-timeout 1000)) (id (random 65000))) (when process (process-send-string process (dns-write `((id ,id) (opcode query) (queries ((,name (type ,type)))) (recursion-desired-p t)) tcp-p)) (while (and (zerop (buffer-size)) (> times 0)) (sit-for (/ step 1000.0)) (accept-process-output process 0 step) (setq times (- times step))) (condition-case nil (delete-process process) (error nil)) (when (and tcp-p (>= (buffer-size) 2)) (goto-char (point-min)) (delete-region (point) (+ (point) 2))) (when (and (>= (buffer-size) 2) ;; We had a time-out. (> times 0)) (let ((result (dns-read (buffer-string)))) (if fullp result (let ((answer (car (dns-get 'answers result)))) (when (eq type (dns-get 'type answer)) (if (eq type 'TXT) (dns-get-txt-answer (dns-get 'answers result)) (dns-get 'data answer)))))))))))) (provide 'dns) ;; arch-tag: d0edd0c4-4cce-4538-ae92-06c3356ee80a ;;; dns.el ends here gnus-5.11+v0.10.dfsg/lisp/earcon.el0000644000175000017500000001655311004005110017024 0ustar tvainikatvainika;;; earcon.el --- Sound effects for messages ;; Copyright (C) 1996, 2000, 2001, 2002, 2003, 2004, ;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc. ;; Author: Steven L. Baur ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 3, or (at your option) ;; any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Commentary: ;; This file provides access to sound effects in Gnus. ;;; Code: (eval-when-compile (require 'cl)) (require 'gnus) (require 'gnus-audio) (require 'gnus-art) (defgroup earcon nil "Turn ** sounds ** into noise." :group 'gnus-visual) (defcustom earcon-prefix "**" "*String denoting the start of an earcon." :type 'string :group 'earcon) (defcustom earcon-suffix "**" "String denoting the end of an earcon." :type 'string :group 'earcon) (defcustom earcon-regexp-alist '(("boring" 1 "Boring.au") ("evil[ \t]+laugh" 1 "Evil_Laugh.au") ("gag\\|puke" 1 "Puke.au") ("snicker" 1 "Snicker.au") ("meow" 1 "catmeow.wav") ("sob\\|boohoo" 1 "cry.wav") ("drum[ \t]*roll" 1 "drumroll.au") ("blast" 1 "explosion.au") ("flush\\|plonk!*" 1 "flush.au") ("kiss" 1 "kiss.wav") ("tee[ \t]*hee" 1 "laugh.au") ("shoot" 1 "shotgun.wav") ("yawn" 1 "snore.wav") ("cackle" 1 "witch.au") ("yell\\|roar" 1 "yell2.au") ("whoop-de-doo" 1 "whistle.au")) "*A list of regexps to map earcons to real sounds." :type '(repeat (list regexp (integer :tag "Match") (string :tag "Sound"))) :group 'earcon) (defvar earcon-button-marker-list nil) (make-variable-buffer-local 'earcon-button-marker-list) ;;; FIXME!! clone of code from gnus-vis.el FIXME!! (defun earcon-article-push-button (event) "Check text under the mouse pointer for a callback function. If the text under the mouse pointer has a `earcon-callback' property, call it with the value of the `earcon-data' text property." (interactive "e") (set-buffer (window-buffer (posn-window (event-start event)))) (let* ((pos (posn-point (event-start event))) (data (get-text-property pos 'earcon-data)) (fun (get-text-property pos 'earcon-callback))) (if fun (funcall fun data)))) (defun earcon-article-press-button () "Check text at point for a callback function. If the text at point has a `earcon-callback' property, call it with the value of the `earcon-data' text property." (interactive) (let* ((data (get-text-property (point) 'earcon-data)) (fun (get-text-property (point) 'earcon-callback))) (if fun (funcall fun data)))) (defun earcon-article-prev-button (n) "Move point to N buttons backward. If N is negative, move forward instead." (interactive "p") (earcon-article-next-button (- n))) (defun earcon-article-next-button (n) "Move point to N buttons forward. If N is negative, move backward instead." (interactive "p") (let ((function (if (< n 0) 'previous-single-property-change 'next-single-property-change)) (inhibit-point-motion-hooks t) (backward (< n 0)) (limit (if (< n 0) (point-min) (point-max)))) (setq n (abs n)) (while (and (not (= limit (point))) (> n 0)) ;; Skip past the current button. (when (get-text-property (point) 'earcon-callback) (goto-char (funcall function (point) 'earcon-callback nil limit))) ;; Go to the next (or previous) button. (gnus-goto-char (funcall function (point) 'earcon-callback nil limit)) ;; Put point at the start of the button. (when (and backward (not (get-text-property (point) 'earcon-callback))) (goto-char (funcall function (point) 'earcon-callback nil limit))) ;; Skip past intangible buttons. (when (get-text-property (point) 'intangible) (incf n)) (decf n)) (unless (zerop n) (gnus-message 5 "No more buttons")) n)) (defun earcon-article-add-button (from to fun &optional data) "Create a button between FROM and TO with callback FUN and data DATA." (and (boundp gnus-article-button-face) gnus-article-button-face (gnus-overlay-put (gnus-make-overlay from to) 'face gnus-article-button-face)) (gnus-add-text-properties from to (nconc (and gnus-article-mouse-face (list gnus-mouse-face-prop gnus-article-mouse-face)) (list 'gnus-callback fun) (and data (list 'gnus-data data))))) (defun earcon-button-entry () ;; Return the first entry in `gnus-button-alist' matching this place. (let ((alist earcon-regexp-alist) (case-fold-search t) (entry nil)) (while alist (setq entry (pop alist)) (if (looking-at (car entry)) (setq alist nil) (setq entry nil))) entry)) (defun earcon-button-push (marker) ;; Push button starting at MARKER. (save-excursion (set-buffer gnus-article-buffer) (goto-char marker) (let* ((entry (earcon-button-entry)) (inhibit-point-motion-hooks t) (fun 'gnus-audio-play) (args (list (nth 2 entry)))) (cond ((fboundp fun) (apply fun args)) ((and (boundp fun) (fboundp (symbol-value fun))) (apply (symbol-value fun) args)) (t (gnus-message 1 "You must define `%S' to use this button" (cons fun args))))))) ;;; FIXME!! clone of code from gnus-vis.el FIXME!! ;;;###interactive (defun earcon-region (beg end) "Play Sounds in the region between point and mark." (interactive "r") (earcon-buffer (current-buffer) beg end)) ;;;###interactive (defun earcon-buffer (&optional buffer st nd) (interactive) (save-excursion ;; clear old markers. (if (boundp 'earcon-button-marker-list) (while earcon-button-marker-list (set-marker (pop earcon-button-marker-list) nil)) (setq earcon-button-marker-list nil)) (and buffer (set-buffer buffer)) (let ((buffer-read-only nil) (inhibit-point-motion-hooks t) (case-fold-search t) (alist earcon-regexp-alist) beg entry regexp) (goto-char (point-min)) (setq beg (point)) (while (setq entry (pop alist)) (setq regexp (concat (regexp-quote earcon-prefix) ".*\\(" (car entry) "\\).*" (regexp-quote earcon-suffix))) (goto-char beg) (while (re-search-forward regexp nil t) (let* ((start (and entry (match-beginning 1))) (end (and entry (match-end 1))) (from (match-beginning 1))) (earcon-article-add-button start end 'earcon-button-push (car (push (set-marker (make-marker) from) earcon-button-marker-list))) (gnus-audio-play (caddr entry)))))))) ;;;###autoload (defun gnus-earcon-display () "Play sounds in message buffers." (interactive) (save-excursion (set-buffer gnus-article-buffer) (goto-char (point-min)) ;; Skip headers (unless (search-forward "\n\n" nil t) (goto-char (point-max))) (sit-for 0) (earcon-buffer (current-buffer) (point)))) ;;;*** (provide 'earcon) (run-hooks 'earcon-load-hook) ;; arch-tag: 844dfeea-980c-4ed0-907f-a30bf139691c ;;; earcon.el ends here gnus-5.11+v0.10.dfsg/lisp/mail-parse.el0000644000175000017500000000676711004005110017615 0ustar tvainikatvainika;;; mail-parse.el --- Interface functions for parsing mail ;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, ;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 3, or (at your option) ;; any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Commentary: ;; This file contains wrapper functions for a wide range of mail ;; parsing functions. The idea is that there are low-level libraries ;; that impement according to various specs (RFC2231, DRUMS, USEFOR), ;; but that programmers that want to parse some header (say, ;; Content-Type) will want to use the latest spec. ;; ;; So while each low-level library (rfc2231.el, for instance) decodes ;; faithfully according to that (proposed) standard, this library is ;; the interface library. If some later RFC supersedes RFC2231, one ;; would just have to write a new low-level library, adjust the ;; aliases in this library, and the users and programmers won't notice ;; any changes. ;;; Code: (require 'mail-prsvr) (require 'ietf-drums) (require 'rfc2231) (require 'rfc2047) (require 'rfc2045) (defalias 'mail-header-parse-content-type 'rfc2231-parse-qp-string) (defalias 'mail-header-parse-content-disposition 'rfc2231-parse-qp-string) (defalias 'mail-content-type-get 'rfc2231-get-value) ;(defalias 'mail-header-encode-parameter 'rfc2045-encode-string) (defalias 'mail-header-encode-parameter 'rfc2231-encode-string) (defalias 'mail-header-remove-comments 'ietf-drums-remove-comments) (defalias 'mail-header-remove-whitespace 'ietf-drums-remove-whitespace) (defalias 'mail-header-strip 'ietf-drums-strip) (defalias 'mail-header-get-comment 'ietf-drums-get-comment) (defalias 'mail-header-parse-address 'ietf-drums-parse-address) (defalias 'mail-header-parse-addresses 'ietf-drums-parse-addresses) (defalias 'mail-header-parse-date 'ietf-drums-parse-date) (defalias 'mail-narrow-to-head 'ietf-drums-narrow-to-header) (defalias 'mail-quote-string 'ietf-drums-quote-string) (defalias 'mail-header-make-address 'ietf-drums-make-address) (defalias 'mail-header-fold-field 'rfc2047-fold-field) (defalias 'mail-header-unfold-field 'rfc2047-unfold-field) (defalias 'mail-header-narrow-to-field 'rfc2047-narrow-to-field) (defalias 'mail-header-field-value 'rfc2047-field-value) (defalias 'mail-encode-encoded-word-region 'rfc2047-encode-region) (defalias 'mail-encode-encoded-word-buffer 'rfc2047-encode-message-header) (defalias 'mail-encode-encoded-word-string 'rfc2047-encode-string) (defalias 'mail-decode-encoded-word-region 'rfc2047-decode-region) (defalias 'mail-decode-encoded-word-string 'rfc2047-decode-string) (defalias 'mail-decode-encoded-address-region 'rfc2047-decode-address-region) (defalias 'mail-decode-encoded-address-string 'rfc2047-decode-address-string) (provide 'mail-parse) ;; arch-tag: 3e63d75c-c962-4784-ab01-7ba07ca9d2d4 ;;; mail-parse.el ends here gnus-5.11+v0.10.dfsg/lisp/pgg-pgp5.el0000644000175000017500000002134711004005110017200 0ustar tvainikatvainika;;; pgg-pgp5.el --- PGP 5.* support for PGG. ;; Copyright (C) 1999, 2000, 2002, 2003, 2004, ;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc. ;; Author: Daiki Ueno ;; Created: 1999/11/02 ;; Keywords: PGP, OpenPGP ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 3, or (at your option) ;; any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Code: (eval-when-compile (require 'cl) ; for pgg macros (require 'pgg)) (defgroup pgg-pgp5 () "PGP 5.* interface." :group 'pgg) (defcustom pgg-pgp5-pgpe-program "pgpe" "PGP 5.* 'pgpe' executable." :group 'pgg-pgp5 :type 'string) (defcustom pgg-pgp5-pgps-program "pgps" "PGP 5.* 'pgps' executable." :group 'pgg-pgp5 :type 'string) (defcustom pgg-pgp5-pgpk-program "pgpk" "PGP 5.* 'pgpk' executable." :group 'pgg-pgp5 :type 'string) (defcustom pgg-pgp5-pgpv-program "pgpv" "PGP 5.* 'pgpv' executable." :group 'pgg-pgp5 :type 'string) (defcustom pgg-pgp5-shell-file-name "/bin/sh" "File name to load inferior shells from. Bourne shell or its equivalent \(not tcsh) is needed for \"2>\"." :group 'pgg-pgp5 :type 'string) (defcustom pgg-pgp5-shell-command-switch "-c" "Switch used to have the shell execute its command line argument." :group 'pgg-pgp5 :type 'string) (defcustom pgg-pgp5-extra-args nil "Extra arguments for every PGP 5.* invocation." :group 'pgg-pgp5 :type '(choice (const :tag "None" nil) (string :tag "Arguments"))) (defvar pgg-pgp5-user-id nil "PGP 5.* ID of your default identity.") (defun pgg-pgp5-process-region (start end passphrase program args) (let* ((errors-file-name (pgg-make-temp-file "pgg-errors")) (args (append args pgg-pgp5-extra-args (list (concat "2>" errors-file-name)))) (shell-file-name pgg-pgp5-shell-file-name) (shell-command-switch pgg-pgp5-shell-command-switch) (process-environment process-environment) (output-buffer pgg-output-buffer) (errors-buffer pgg-errors-buffer) (process-connection-type nil) process status exit-status) (with-current-buffer (get-buffer-create output-buffer) (buffer-disable-undo) (erase-buffer)) (when passphrase (setenv "PGPPASSFD" "0")) (unwind-protect (progn (let ((coding-system-for-read 'binary) (coding-system-for-write 'binary)) (setq process (apply #'funcall #'start-process-shell-command "*PGP*" output-buffer program args))) (set-process-sentinel process #'ignore) (when passphrase (process-send-string process (concat passphrase "\n"))) (process-send-region process start end) (process-send-eof process) (while (eq 'run (process-status process)) (accept-process-output process 5)) (setq status (process-status process) exit-status (process-exit-status process)) (delete-process process) (with-current-buffer output-buffer (pgg-convert-lbt-region (point-min)(point-max) 'LF) (if (memq status '(stop signal)) (error "%s exited abnormally: '%s'" program exit-status)) (if (= 127 exit-status) (error "%s could not be found" program)) (set-buffer (get-buffer-create errors-buffer)) (buffer-disable-undo) (erase-buffer) (insert-file-contents errors-file-name))) (if (and process (eq 'run (process-status process))) (interrupt-process process)) (condition-case nil (delete-file errors-file-name) (file-error nil))))) (defun pgg-pgp5-lookup-key (string &optional type) "Search keys associated with STRING." (let ((args (list "+language=en" "-l" string))) (with-current-buffer (get-buffer-create pgg-output-buffer) (buffer-disable-undo) (erase-buffer) (apply #'call-process pgg-pgp5-pgpk-program nil t nil args) (goto-char (point-min)) (when (re-search-forward "^sec" nil t) (substring (nth 2 (split-string (buffer-substring (match-end 0)(progn (end-of-line)(point))))) 2))))) (defun pgg-pgp5-encrypt-region (start end recipients &optional sign passphrase) "Encrypt the current region between START and END." (let* ((pgg-pgp5-user-id (or pgg-pgp5-user-id pgg-default-user-id)) (passphrase (or passphrase (when sign (pgg-read-passphrase (format "PGP passphrase for %s: " pgg-pgp5-user-id) pgg-pgp5-user-id)))) (args (append `("+NoBatchInvalidKeys=off" "-fat" "+batchmode=1" ,@(if (or recipients pgg-encrypt-for-me) (apply #'append (mapcar (lambda (rcpt) (list "-r" (concat "\"" rcpt "\""))) (append recipients (if pgg-encrypt-for-me (list pgg-pgp5-user-id))))))) (if sign '("-s" "-u" pgg-pgp5-user-id))))) (pgg-pgp5-process-region start end nil pgg-pgp5-pgpe-program args) (pgg-process-when-success nil))) (defun pgg-pgp5-decrypt-region (start end &optional passphrase) "Decrypt the current region between START and END." (let* ((pgg-pgp5-user-id (or pgg-pgp5-user-id pgg-default-user-id)) (passphrase (or passphrase (pgg-read-passphrase (format "PGP passphrase for %s: " pgg-pgp5-user-id) (pgg-pgp5-lookup-key pgg-pgp5-user-id 'encrypt)))) (args '("+verbose=1" "+batchmode=1" "+language=us" "-f"))) (pgg-pgp5-process-region start end passphrase pgg-pgp5-pgpv-program args) (pgg-process-when-success nil))) (defun pgg-pgp5-sign-region (start end &optional clearsign passphrase) "Make detached signature from text between START and END." (let* ((pgg-pgp5-user-id (or pgg-pgp5-user-id pgg-default-user-id)) (passphrase (or passphrase (pgg-read-passphrase (format "PGP passphrase for %s: " pgg-pgp5-user-id) (pgg-pgp5-lookup-key pgg-pgp5-user-id 'sign)))) (args (list (if clearsign "-fat" "-fbat") "+verbose=1" "+language=us" "+batchmode=1" "-u" pgg-pgp5-user-id))) (pgg-pgp5-process-region start end passphrase pgg-pgp5-pgps-program args) (pgg-process-when-success (when (re-search-forward "^-+BEGIN PGP SIGNATURE" nil t);XXX (let ((packet (cdr (assq 2 (pgg-parse-armor-region (progn (beginning-of-line 2) (point)) (point-max)))))) (if pgg-cache-passphrase (pgg-add-passphrase-to-cache (cdr (assq 'key-identifier packet)) passphrase))))))) (defun pgg-pgp5-verify-region (start end &optional signature) "Verify region between START and END as the detached signature SIGNATURE." (let ((orig-file (pgg-make-temp-file "pgg")) (args '("+verbose=1" "+batchmode=1" "+language=us")) (orig-mode (default-file-modes))) (unwind-protect (progn (set-default-file-modes 448) (let ((coding-system-for-write 'binary) jka-compr-compression-info-list jam-zcat-filename-list) (write-region start end orig-file))) (set-default-file-modes orig-mode)) (when (stringp signature) (copy-file signature (setq signature (concat orig-file ".asc"))) (setq args (append args (list signature)))) (pgg-pgp5-process-region (point)(point) nil pgg-pgp5-pgpv-program args) (delete-file orig-file) (if signature (delete-file signature)) (with-current-buffer pgg-errors-buffer (goto-char (point-min)) (if (re-search-forward "^Good signature" nil t) (progn (set-buffer pgg-output-buffer) (insert-buffer-substring pgg-errors-buffer) t) nil)))) (defun pgg-pgp5-insert-key () "Insert public key at point." (let* ((pgg-pgp5-user-id (or pgg-pgp5-user-id pgg-default-user-id)) (args (list "+verbose=1" "+batchmode=1" "+language=us" "-x" (concat "\"" pgg-pgp5-user-id "\"")))) (pgg-pgp5-process-region (point)(point) nil pgg-pgp5-pgpk-program args) (insert-buffer-substring pgg-output-buffer))) (defun pgg-pgp5-snarf-keys-region (start end) "Add all public keys in region between START and END to the keyring." (let* ((pgg-pgp5-user-id (or pgg-pgp5-user-id pgg-default-user-id)) (key-file (pgg-make-temp-file "pgg")) (args (list "+verbose=1" "+batchmode=1" "+language=us" "-a" key-file))) (let ((coding-system-for-write 'raw-text-dos)) (write-region start end key-file)) (pgg-pgp5-process-region start end nil pgg-pgp5-pgpk-program args) (delete-file key-file) (pgg-process-when-success nil))) (provide 'pgg-pgp5) ;; arch-tag: 3dbd1073-6b3a-466c-9f55-5c587ffa6d7b ;;; pgg-pgp5.el ends here gnus-5.11+v0.10.dfsg/lisp/sieve-mode.el0000644000175000017500000001730511004005110017606 0ustar tvainikatvainika;;; sieve-mode.el --- Sieve code editing commands for Emacs ;; Copyright (C) 2001, 2002, 2003, 2004, 2005, ;; 2006, 2007, 2008 Free Software Foundation, Inc. ;; Author: Simon Josefsson ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 3, or (at your option) ;; any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Commentary: ;; This file contain editing mode functions and font-lock support for ;; editing Sieve scripts. It sets up C-mode with support for ;; sieve-style #-comments and a lightly hacked syntax table. It was ;; strongly influenced by awk-mode.el. ;; ;; Put something similar to the following in your .emacs to use this file: ;; ;; (load "~/lisp/sieve") ;; (setq auto-mode-alist (cons '("\\.siv\\'" . sieve-mode) auto-mode-alist)) ;; ;; References: ;; ;; RFC 3028, ;; "Sieve: A Mail Filtering Language", ;; by Tim Showalter. ;; ;; Release history: ;; ;; 2001-03-02 version 1.0 posted to gnu.emacs.sources ;; version 1.1 change file extension into ".siv" (official one) ;; added keymap and menubar to hook into sieve-manage ;; 2001-10-31 version 1.2 committed to Oort Gnus ;;; Code: (autoload 'sieve-manage "sieve") (autoload 'sieve-upload "sieve") (require 'easymenu) (eval-when-compile (require 'font-lock)) (defgroup sieve nil "Sieve." :group 'languages) (defcustom sieve-mode-hook nil "Hook run in sieve mode buffers." :group 'sieve :type 'hook) ;; Font-lock (defvar sieve-control-commands-face 'sieve-control-commands "Face name used for Sieve Control Commands.") (defface sieve-control-commands '((((type tty) (class color)) (:foreground "blue" :weight light)) (((class grayscale) (background light)) (:foreground "LightGray" :bold t)) (((class grayscale) (background dark)) (:foreground "DimGray" :bold t)) (((class color) (background light)) (:foreground "Orchid")) (((class color) (background dark)) (:foreground "LightSteelBlue")) (t (:bold t))) "Face used for Sieve Control Commands." :group 'sieve) ;; backward-compatibility alias (put 'sieve-control-commands-face 'face-alias 'sieve-control-commands) (defvar sieve-action-commands-face 'sieve-action-commands "Face name used for Sieve Action Commands.") (defface sieve-action-commands '((((type tty) (class color)) (:foreground "blue" :weight bold)) (((class color) (background light)) (:foreground "Blue")) (((class color) (background dark)) (:foreground "LightSkyBlue")) (t (:inverse-video t :bold t))) "Face used for Sieve Action Commands." :group 'sieve) ;; backward-compatibility alias (put 'sieve-action-commands-face 'face-alias 'sieve-action-commands) (defvar sieve-test-commands-face 'sieve-test-commands "Face name used for Sieve Test Commands.") (defface sieve-test-commands '((((type tty) (class color)) (:foreground "magenta")) (((class grayscale) (background light)) (:foreground "LightGray" :bold t :underline t)) (((class grayscale) (background dark)) (:foreground "Gray50" :bold t :underline t)) (((class color) (background light)) (:foreground "CadetBlue")) (((class color) (background dark)) (:foreground "Aquamarine")) (t (:bold t :underline t))) "Face used for Sieve Test Commands." :group 'sieve) ;; backward-compatibility alias (put 'sieve-test-commands-face 'face-alias 'sieve-test-commands) (defvar sieve-tagged-arguments-face 'sieve-tagged-arguments "Face name used for Sieve Tagged Arguments.") (defface sieve-tagged-arguments '((((type tty) (class color)) (:foreground "cyan" :weight bold)) (((class grayscale) (background light)) (:foreground "LightGray" :bold t)) (((class grayscale) (background dark)) (:foreground "DimGray" :bold t)) (((class color) (background light)) (:foreground "Purple")) (((class color) (background dark)) (:foreground "Cyan")) (t (:bold t))) "Face used for Sieve Tagged Arguments." :group 'sieve) ;; backward-compatibility alias (put 'sieve-tagged-arguments-face 'face-alias 'sieve-tagged-arguments) (defconst sieve-font-lock-keywords (eval-when-compile (list ;; control commands (cons (regexp-opt '("require" "if" "else" "elsif" "stop")) 'sieve-control-commands-face) ;; action commands (cons (regexp-opt '("fileinto" "redirect" "reject" "keep" "discard")) 'sieve-action-commands-face) ;; test commands (cons (regexp-opt '("address" "allof" "anyof" "exists" "false" "true" "header" "not" "size" "envelope")) 'sieve-test-commands-face) (cons "\\Sw+:\\sw+" 'sieve-tagged-arguments-face)))) ;; Syntax table (defvar sieve-mode-syntax-table nil "Syntax table in use in sieve-mode buffers.") (if sieve-mode-syntax-table () (setq sieve-mode-syntax-table (make-syntax-table)) (modify-syntax-entry ?\\ "\\" sieve-mode-syntax-table) (modify-syntax-entry ?\n "> " sieve-mode-syntax-table) (modify-syntax-entry ?\f "> " sieve-mode-syntax-table) (modify-syntax-entry ?\# "< " sieve-mode-syntax-table) (modify-syntax-entry ?/ "." sieve-mode-syntax-table) (modify-syntax-entry ?* "." sieve-mode-syntax-table) (modify-syntax-entry ?+ "." sieve-mode-syntax-table) (modify-syntax-entry ?- "." sieve-mode-syntax-table) (modify-syntax-entry ?= "." sieve-mode-syntax-table) (modify-syntax-entry ?% "." sieve-mode-syntax-table) (modify-syntax-entry ?< "." sieve-mode-syntax-table) (modify-syntax-entry ?> "." sieve-mode-syntax-table) (modify-syntax-entry ?& "." sieve-mode-syntax-table) (modify-syntax-entry ?| "." sieve-mode-syntax-table) (modify-syntax-entry ?_ "_" sieve-mode-syntax-table) (modify-syntax-entry ?\' "\"" sieve-mode-syntax-table)) ;; Key map definition (defvar sieve-mode-map (let ((map (make-sparse-keymap))) (define-key map "\C-c\C-l" 'sieve-upload) (define-key map "\C-c\C-c" 'sieve-upload-and-bury) (define-key map "\C-c\C-m" 'sieve-manage) map) "Key map used in sieve mode.") ;; Menu definition (defvar sieve-mode-menu nil "Menubar used in sieve mode.") ;; Code for Sieve editing mode. ;;;###autoload (define-derived-mode sieve-mode c-mode "Sieve" "Major mode for editing Sieve code. This is much like C mode except for the syntax of comments. Its keymap inherits from C mode's and it has the same variables for customizing indentation. It has its own abbrev table and its own syntax table. Turning on Sieve mode runs `sieve-mode-hook'." (set (make-local-variable 'paragraph-start) (concat "$\\|" page-delimiter)) (set (make-local-variable 'paragraph-separate) paragraph-start) (set (make-local-variable 'comment-start) "#") (set (make-local-variable 'comment-end) "") ;;(set (make-local-variable 'comment-start-skip) "\\(^\\|\\s-\\);?#+ *") (set (make-local-variable 'comment-start-skip) "#+ *") (unless (featurep 'xemacs) (set (make-local-variable 'font-lock-defaults) '(sieve-font-lock-keywords nil nil ((?_ . "w"))))) (easy-menu-add-item nil nil sieve-mode-menu)) ;; Menu (easy-menu-define sieve-mode-menu sieve-mode-map "Sieve Menu." '("Sieve" ["Upload script" sieve-upload t] ["Manage scripts on server" sieve-manage t])) (provide 'sieve-mode) ;; arch-tag: 3b8ab76d-065d-4c52-b1e8-ab2ec21f2ace ;; sieve-mode.el ends here gnus-5.11+v0.10.dfsg/lisp/gnus-mlspl.el0000644000175000017500000002112611004005110017646 0ustar tvainikatvainika;;; gnus-mlspl.el --- a group params-based mail splitting mechanism ;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, ;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc. ;; Author: Alexandre Oliva ;; Keywords: news, mail ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published ;; by the Free Software Foundation; either version 3, or (at your ;; option) any later version. ;; GNU Emacs is distributed in the hope that it will be useful, but ;; WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with this program; see the file COPYING. If not, write to ;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Commentary: ;;; Code: (eval-when-compile (require 'cl)) (require 'gnus) (require 'gnus-sum) (require 'gnus-group) (require 'nnmail) (defvar gnus-group-split-updated-hook nil "Hook called just after `nnmail-split-fancy' is updated by `gnus-group-split-update'.") (defvar gnus-group-split-default-catch-all-group "mail.misc" "Group name (or arbitrary fancy split) with default splitting rules. Used by `gnus-group-split' and `gnus-group-split-update' as a fallback split, in case none of the group-based splits matches.") ;;;###autoload (defun gnus-group-split-setup (&optional auto-update catch-all) "Set up the split for `nnmail-split-fancy'. Sets things up so that nnmail-split-fancy is used for mail splitting, and defines the variable nnmail-split-fancy according with group parameters. If AUTO-UPDATE is non-nil (prefix argument accepted, if called interactively), it makes sure nnmail-split-fancy is re-computed before getting new mail, by adding `gnus-group-split-update' to `nnmail-pre-get-new-mail-hook'. A non-nil CATCH-ALL replaces the current value of `gnus-group-split-default-catch-all-group'. This variable is only used by gnus-group-split-update, and only when its CATCH-ALL argument is nil. This argument may contain any fancy split, that will be added as the last split in a `|' split produced by `gnus-group-split-fancy', unless overridden by any group marked as a catch-all group. Typical uses are as simple as the name of a default mail group, but more elaborate fancy splits may also be useful to split mail that doesn't match any of the group-specified splitting rules. See `gnus-group-split-fancy' for details." (interactive "P") (setq nnmail-split-methods 'nnmail-split-fancy) (when catch-all (setq gnus-group-split-default-catch-all-group catch-all)) (gnus-group-split-update) (when auto-update (add-hook 'nnmail-pre-get-new-mail-hook 'gnus-group-split-update))) ;;;###autoload (defun gnus-group-split-update (&optional catch-all) "Computes nnmail-split-fancy from group params and CATCH-ALL. It does this by calling by calling (gnus-group-split-fancy nil nil CATCH-ALL). If CATCH-ALL is nil, `gnus-group-split-default-catch-all-group' is used instead. This variable is set by `gnus-group-split-setup'." (interactive) (setq nnmail-split-fancy (gnus-group-split-fancy nil (null nnmail-crosspost) (or catch-all gnus-group-split-default-catch-all-group))) (run-hooks 'gnus-group-split-updated-hook)) ;;;###autoload (defun gnus-group-split () "Use information from group parameters in order to split mail. See `gnus-group-split-fancy' for more information. `gnus-group-split' is a valid value for `nnmail-split-methods'." (let (nnmail-split-fancy) (gnus-group-split-update) (nnmail-split-fancy))) ;;;###autoload (defun gnus-group-split-fancy (&optional groups no-crosspost catch-all) "Uses information from group parameters in order to split mail. It can be embedded into `nnmail-split-fancy' lists with the SPLIT \(: gnus-group-split-fancy GROUPS NO-CROSSPOST CATCH-ALL\) GROUPS may be a regular expression or a list of group names, that will be used to select candidate groups. If it is omitted or nil, all existing groups are considered. if NO-CROSSPOST is omitted or nil, a & split will be returned, otherwise, a | split, that does not allow crossposting, will be returned. For each selected group, a SPLIT is composed like this: if SPLIT-SPEC is specified, this split is returned as-is (unless it is nil: in this case, the group is ignored). Otherwise, if TO-ADDRESS, TO-LIST and/or EXTRA-ALIASES are specified, a regexp that matches any of them is constructed (extra-aliases may be a list). Additionally, if SPLIT-REGEXP is specified, the regexp will be extended so that it matches this regexp too, and if SPLIT-EXCLUDE is specified, RESTRICT clauses will be generated. If CATCH-ALL is nil, no catch-all handling is performed, regardless of catch-all marks in group parameters. Otherwise, if there is no selected group whose SPLIT-REGEXP matches the empty string, nor is there a selected group whose SPLIT-SPEC is 'catch-all, this fancy split (say, a group name) will be appended to the returned SPLIT list, as the last element of a '| SPLIT. For example, given the following group parameters: nnml:mail.bar: \((to-address . \"bar@femail.com\") (split-regexp . \".*@femail\\\\.com\")) nnml:mail.foo: \((to-list . \"foo@nowhere.gov\") (extra-aliases \"foo@localhost\" \"foo-redist@home\") (split-exclude \"bugs-foo\" \"rambling-foo\") (admin-address . \"foo-request@nowhere.gov\")) nnml:mail.others: \((split-spec . catch-all)) Calling (gnus-group-split-fancy nil nil \"mail.others\") returns: \(| (& (any \"\\\\(bar@femail\\\\.com\\\\|.*@femail\\\\.com\\\\)\" \"mail.bar\") (any \"\\\\(foo@nowhere\\\\.gov\\\\|foo@localhost\\\\|foo-redist@home\\\\)\" - \"bugs-foo\" - \"rambling-foo\" \"mail.foo\")) \"mail.others\")" (let* ((newsrc (cdr gnus-newsrc-alist)) split) (dolist (info newsrc) (let ((group (gnus-info-group info)) (params (gnus-info-params info))) ;; For all GROUPs that match the specified GROUPS (when (or (not groups) (and (listp groups) (memq group groups)) (and (stringp groups) (string-match groups group))) (let ((split-spec (assoc 'split-spec params)) group-clean) ;; Remove backend from group name (setq group-clean (string-match ":" group)) (setq group-clean (if group-clean (substring group (1+ group-clean)) group)) (if split-spec (when (setq split-spec (cdr split-spec)) (if (eq split-spec 'catch-all) ;; Emit catch-all only when requested (when catch-all (setq catch-all group-clean)) ;; Append split-spec to the main split (push split-spec split))) ;; Let's deduce split-spec from other params (let ((to-address (cdr (assoc 'to-address params))) (to-list (cdr (assoc 'to-list params))) (extra-aliases (cdr (assoc 'extra-aliases params))) (split-regexp (cdr (assoc 'split-regexp params))) (split-exclude (cdr (assoc 'split-exclude params)))) (when (or to-address to-list extra-aliases split-regexp) ;; regexp-quote to-address, to-list and extra-aliases ;; and add them all to split-regexp (setq split-regexp (concat "\\(" (mapconcat 'identity (append (and to-address (list (regexp-quote to-address))) (and to-list (list (regexp-quote to-list))) (and extra-aliases (if (listp extra-aliases) (mapcar 'regexp-quote extra-aliases) (list extra-aliases))) (and split-regexp (list split-regexp))) "\\|") "\\)")) ;; Now create the new SPLIT (push (append (list 'any split-regexp) ;; Generate RESTRICTs for SPLIT-EXCLUDEs. (if (listp split-exclude) (apply #'append (mapcar (lambda (arg) (list '- arg)) split-exclude)) (list '- split-exclude)) (list group-clean)) split) ;; If it matches the empty string, it is a catch-all (when (string-match split-regexp "") (setq catch-all nil))))))))) ;; Add catch-all if not crossposting (if (and catch-all no-crosspost) (push catch-all split)) ;; Move it to the tail, while arranging that SPLITs appear in the ;; same order as groups. (setq split (reverse split)) ;; Decide whether to accept cross-postings or not. (push (if no-crosspost '| '&) split) ;; Even if we can cross-post, catch-all should not get ;; cross-posts. (if (and catch-all (not no-crosspost)) (setq split (list '| split catch-all))) split)) (provide 'gnus-mlspl) ;; arch-tag: 62b3381f-1e45-4b61-be1a-29fb27703322 ;;; gnus-mlspl.el ends here gnus-5.11+v0.10.dfsg/lisp/sieve.el0000644000175000017500000003203211004005111016657 0ustar tvainikatvainika;;; sieve.el --- Utilities to manage sieve scripts ;; Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc. ;; Author: Simon Josefsson ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 3, or (at your option) ;; any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Commentary: ;; This file contain utilities to facilate upload, download and ;; general management of sieve scripts. Currently only the ;; Managesieve protocol is supported (using sieve-manage.el), but when ;; (useful) alternatives become available, they might be supported as ;; well. ;; ;; The cursor navigation was inspired by biff-mode by Franklin Lee. ;; ;; Release history: ;; ;; 2001-10-31 Committed to Oort Gnus. ;; 2002-07-27 Fix down-mouse-2 and down-mouse-3 in manage-mode. Fix menubar ;; in manage-mode. Change some messages. Added sieve-deactivate*, ;; sieve-remove. Fixed help text in manage-mode. Suggested by ;; Ned Ludd. ;; ;; Todo: ;; ;; * Namespace? This file contains `sieve-manage' and ;; `sieve-manage-mode', but there is a sieve-manage.el file as well. ;; Can't think of a good solution though, this file need a *-mode, ;; and naming it `sieve-mode' would collide with sieve-mode.el. One ;; solution would be to come up with some better name that this file ;; can use that doesn't have the managesieve specific "manage" in ;; it. sieve-dired? i dunno. we could copy all off sieve.el into ;; sieve-manage.el too, but I'd like to separate the interface from ;; the protocol implementation since the backends are likely to ;; change (well). ;; ;; * Define servers? We could have a customize buffer to create a server, ;; with authentication/stream/etc parameters, much like Gnus, and then ;; only use names of defined servers when interacting with M-x sieve-*. ;; Right now you can't use STARTTLS, which sieve-manage.el provides ;;; Code: (require 'sieve-manage) (require 'sieve-mode) ;; User customizable variables: (defgroup sieve nil "Manage sieve scripts." :version "22.1" :group 'tools) (defcustom sieve-new-script "" "Name of name script indicator." :type 'string :group 'sieve) (defcustom sieve-buffer "*sieve*" "Name of sieve management buffer." :type 'string :group 'sieve) (defcustom sieve-template "\ require \"fileinto\"; # Example script (remove comment character '#' to make it effective!): # # if header :contains \"from\" \"coyote\" { # discard; # } elsif header :contains [\"subject\"] [\"$$$\"] { # discard; # } else { # fileinto \"INBOX\"; # } " "Template sieve script." :type 'string :group 'sieve) ;; Internal variables: (defvar sieve-manage-buffer nil) (defvar sieve-buffer-header-end nil) ;; Sieve-manage mode: (defvar sieve-manage-mode-map nil "Keymap for `sieve-manage-mode'.") (if sieve-manage-mode-map () (setq sieve-manage-mode-map (make-sparse-keymap)) (suppress-keymap sieve-manage-mode-map) ;; various (define-key sieve-manage-mode-map "?" 'sieve-help) (define-key sieve-manage-mode-map "h" 'sieve-help) (define-key sieve-manage-mode-map "q" 'sieve-bury-buffer) ;; activating (define-key sieve-manage-mode-map "m" 'sieve-activate) (define-key sieve-manage-mode-map "u" 'sieve-deactivate) (define-key sieve-manage-mode-map "\M-\C-?" 'sieve-deactivate-all) ;; navigation keys (define-key sieve-manage-mode-map "\C-p" 'sieve-prev-line) (define-key sieve-manage-mode-map [up] 'sieve-prev-line) (define-key sieve-manage-mode-map "\C-n" 'sieve-next-line) (define-key sieve-manage-mode-map [down] 'sieve-next-line) (define-key sieve-manage-mode-map " " 'sieve-next-line) (define-key sieve-manage-mode-map "n" 'sieve-next-line) (define-key sieve-manage-mode-map "p" 'sieve-prev-line) (define-key sieve-manage-mode-map "\C-m" 'sieve-edit-script) (define-key sieve-manage-mode-map "f" 'sieve-edit-script) (define-key sieve-manage-mode-map "o" 'sieve-edit-script-other-window) (define-key sieve-manage-mode-map "r" 'sieve-remove) (define-key sieve-manage-mode-map [(down-mouse-2)] 'sieve-edit-script) (define-key sieve-manage-mode-map [(down-mouse-3)] 'sieve-manage-mode-menu)) (easy-menu-define sieve-manage-mode-menu sieve-manage-mode-map "Sieve Menu." '("Manage Sieve" ["Edit script" sieve-edit-script t] ["Activate script" sieve-activate t] ["Deactivate script" sieve-deactivate t])) (define-derived-mode sieve-manage-mode fundamental-mode "SIEVE" "Mode used for sieve script management." (setq mode-name "SIEVE") (buffer-disable-undo (current-buffer)) (setq truncate-lines t) (easy-menu-add sieve-manage-mode-menu sieve-manage-mode-map)) (put 'sieve-manage-mode 'mode-class 'special) ;; This is necessary to allow correct handling of \\[cvs-mode-diff-map] ;; in substitute-command-keys. ;(fset 'sieve-manage-mode-map sieve-manage-mode-map) ;; Commands used in sieve-manage mode: (defun sieve-activate (&optional pos) (interactive "d") (let ((name (sieve-script-at-point)) err) (when (or (null name) (string-equal name sieve-new-script)) (error "No sieve script at point")) (message "Activating script %s..." name) (setq err (sieve-manage-setactive name sieve-manage-buffer)) (sieve-refresh-scriptlist) (if (sieve-manage-ok-p err) (message "Activating script %s...done" name) (message "Activating script %s...failed: %s" name (nth 2 err))))) (defun sieve-deactivate-all (&optional pos) (interactive "d") (let ((name (sieve-script-at-point)) err) (message "Deactivating scripts...") (setq err (sieve-manage-setactive "" sieve-manage-buffer)) (sieve-refresh-scriptlist) (if (sieve-manage-ok-p err) (message "Deactivating scripts...done") (message "Deactivating scripts...failed: %s" (nth 2 err))))) (defalias 'sieve-deactivate 'sieve-deactivate-all) (defun sieve-remove (&optional pos) (interactive "d") (let ((name (sieve-script-at-point)) err) (when (or (null name) (string-equal name sieve-new-script)) (error "No sieve script at point")) (message "Removing sieve script %s..." name) (setq err (sieve-manage-deletescript name sieve-manage-buffer)) (unless (sieve-manage-ok-p err) (error "Removing sieve script %s...failed: " err)) (sieve-refresh-scriptlist) (message "Removing sieve script %s...done" name))) (defun sieve-edit-script (&optional pos) (interactive "d") (let ((name (sieve-script-at-point))) (unless name (error "No sieve script at point")) (if (not (string-equal name sieve-new-script)) (let ((newbuf (generate-new-buffer name)) err) (setq err (sieve-manage-getscript name newbuf sieve-manage-buffer)) (switch-to-buffer newbuf) (unless (sieve-manage-ok-p err) (error "Sieve download failed: %s" err))) (switch-to-buffer (get-buffer-create "template.siv")) (insert sieve-template)) (sieve-mode) (message "Press C-c C-l to upload script to server."))) (defmacro sieve-change-region (&rest body) "Turns off sieve-region before executing BODY, then re-enables it after. Used to bracket operations which move point in the sieve-buffer." `(progn (sieve-highlight nil) ,@body (sieve-highlight t))) (put 'sieve-change-region 'lisp-indent-function 0) (defun sieve-next-line (&optional arg) (interactive) (unless arg (setq arg 1)) (if (save-excursion (forward-line arg) (sieve-script-at-point)) (sieve-change-region (forward-line arg)) (message "End of list"))) (defun sieve-prev-line (&optional arg) (interactive) (unless arg (setq arg -1)) (if (save-excursion (forward-line arg) (sieve-script-at-point)) (sieve-change-region (forward-line arg)) (message "Beginning of list"))) (defun sieve-help () "Display help for various sieve commands." (interactive) (if (eq last-command 'sieve-help) ;; would need minor-mode for log-edit-mode (describe-function 'sieve-mode) (message "%s" (substitute-command-keys "`\\[sieve-edit-script]':edit `\\[sieve-activate]':activate `\\[sieve-deactivate]':deactivate `\\[sieve-remove]':remove")))) (defun sieve-bury-buffer (buf &optional mainbuf) "Hide the buffer BUF that was temporarily popped up. BUF is assumed to be a temporary buffer used from the buffer MAINBUF." (interactive (list (current-buffer))) (save-current-buffer (let ((win (if (eq buf (window-buffer (selected-window))) (selected-window) (get-buffer-window buf t)))) (when win (if (window-dedicated-p win) (condition-case () (delete-window win) (error (iconify-frame (window-frame win)))) (if (and mainbuf (get-buffer-window mainbuf)) (delete-window win))))) (with-current-buffer buf (bury-buffer (unless (and (eq buf (window-buffer (selected-window))) (not (window-dedicated-p (selected-window)))) buf))) (when mainbuf (let ((mainwin (or (get-buffer-window mainbuf) (get-buffer-window mainbuf 'visible)))) (when mainwin (select-window mainwin)))))) ;; Create buffer: (defun sieve-setup-buffer (server port) (setq buffer-read-only nil) (erase-buffer) (buffer-disable-undo) (insert "\ Server : " server ":" (or port "2000") " ") (set (make-local-variable 'sieve-buffer-header-end) (point-max))) (defun sieve-script-at-point (&optional pos) "Return name of sieve script at point POS, or nil." (interactive "d") (get-char-property (or pos (point)) 'script-name)) (eval-and-compile (defalias 'sieve-make-overlay (if (featurep 'xemacs) 'make-extent 'make-overlay)) (defalias 'sieve-overlay-put (if (featurep 'xemacs) 'set-extent-property 'overlay-put)) (defalias 'sieve-overlays-at (if (featurep 'xemacs) 'extents-at 'overlays-at))) (defun sieve-highlight (on) "Turn ON or off highlighting on the current language overlay." (sieve-overlay-put (car (sieve-overlays-at (point))) 'face (if on 'highlight 'default))) (defun sieve-insert-scripts (scripts) "Format and insert LANGUAGE-LIST strings into current buffer at point." (while scripts (let ((p (point)) (ext nil) (script (pop scripts))) (if (consp script) (insert (format " ACTIVE %s" (cdr script))) (insert (format " %s" script))) (setq ext (sieve-make-overlay p (point))) (sieve-overlay-put ext 'mouse-face 'highlight) (sieve-overlay-put ext 'script-name (if (consp script) (cdr script) script)) (insert "\n")))) (defun sieve-open-server (server &optional port) ;; open server (set (make-local-variable 'sieve-manage-buffer) (sieve-manage-open server)) ;; authenticate (sieve-manage-authenticate nil nil sieve-manage-buffer)) (defun sieve-refresh-scriptlist () (interactive) (with-current-buffer sieve-buffer (setq buffer-read-only nil) (delete-region (or sieve-buffer-header-end (point-max)) (point-max)) (goto-char (point-max)) ;; get list of script names and print them (let ((scripts (sieve-manage-listscripts sieve-manage-buffer))) (if (null scripts) (insert (format (concat "No scripts on server, press RET on %s to " "create a new script.\n") sieve-new-script)) (insert (format (concat "%d script%s on server, press RET on a script " "name edits it, or\npress RET on %s to create " "a new script.\n") (length scripts) (if (eq (length scripts) 1) "" "s") sieve-new-script))) (save-excursion (sieve-insert-scripts (list sieve-new-script)) (sieve-insert-scripts scripts))) (sieve-highlight t) (setq buffer-read-only t))) ;;;###autoload (defun sieve-manage (server &optional port) (interactive "sServer: ") (switch-to-buffer (get-buffer-create sieve-buffer)) (sieve-manage-mode) (sieve-setup-buffer server port) (if (sieve-open-server server port) (sieve-refresh-scriptlist) (message "Could not open server %s" server))) ;;;###autoload (defun sieve-upload (&optional name) (interactive) (unless name (setq name (buffer-name))) (when (or (get-buffer sieve-buffer) (call-interactively 'sieve-manage)) (let ((script (buffer-string)) err) (with-current-buffer (get-buffer sieve-buffer) (setq err (sieve-manage-putscript name script sieve-manage-buffer)) (if (sieve-manage-ok-p err) (message (concat "Sieve upload done. Use `C-c RET' to manage scripts.")) (message "Sieve upload failed: %s" (nth 2 err))))))) ;;;###autoload (defun sieve-upload-and-bury (&optional name) (interactive) (sieve-upload name) (bury-buffer)) (provide 'sieve) ;; arch-tag: 7f6a6d94-94e1-4654-ab9a-aee21b9b8a94 ;; sieve.el ends here gnus-5.11+v0.10.dfsg/lisp/pgg-parse.el0000644000175000017500000004017511004005111017440 0ustar tvainikatvainika;;; pgg-parse.el --- OpenPGP packet parsing ;; Copyright (C) 1999, 2002, 2003, 2004, 2005, ;; 2006, 2007, 2008 Free Software Foundation, Inc. ;; Author: Daiki Ueno ;; Created: 1999/10/28 ;; Keywords: PGP, OpenPGP, GnuPG ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 3, or (at your option) ;; any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Commentary: ;; This module is based on ;; [OpenPGP] RFC 2440: "OpenPGP Message Format" ;; by John W. Noerenberg, II , ;; Jon Callas , Lutz Donnerhacke , ;; Hal Finney and Rodney Thayer ;; (1998/11) ;;; Code: (eval-when-compile (unless (fboundp 'declare-function) (defmacro declare-function (&rest r))) (require 'cl)) (defgroup pgg-parse () "OpenPGP packet parsing." :group 'pgg) (defcustom pgg-parse-public-key-algorithm-alist '((1 . RSA) (2 . RSA-E) (3 . RSA-S) (16 . ELG-E) (17 . DSA) (20 . ELG)) "Alist of the assigned number to the public key algorithm." :group 'pgg-parse :type '(repeat (cons (sexp :tag "Number") (sexp :tag "Type")))) (defcustom pgg-parse-symmetric-key-algorithm-alist '((1 . IDEA) (2 . 3DES) (4 . CAST5) (5 . SAFER-SK128)) "Alist of the assigned number to the simmetric key algorithm." :group 'pgg-parse :type '(repeat (cons (sexp :tag "Number") (sexp :tag "Type")))) (defcustom pgg-parse-hash-algorithm-alist '((1 . MD5) (2 . SHA1) (3 . RIPEMD160) (5 . MD2) (8 . SHA256) (9 . SHA384) (10 . SHA512)) "Alist of the assigned number to the cryptographic hash algorithm." :group 'pgg-parse :type '(repeat (cons (sexp :tag "Number") (sexp :tag "Type")))) (defcustom pgg-parse-compression-algorithm-alist '((0 . nil); Uncompressed (1 . ZIP) (2 . ZLIB)) "Alist of the assigned number to the compression algorithm." :group 'pgg-parse :type '(repeat (cons (sexp :tag "Number") (sexp :tag "Type")))) (defcustom pgg-parse-signature-type-alist '((0 . "Signature of a binary document") (1 . "Signature of a canonical text document") (2 . "Standalone signature") (16 . "Generic certification of a User ID and Public Key packet") (17 . "Persona certification of a User ID and Public Key packet") (18 . "Casual certification of a User ID and Public Key packet") (19 . "Positive certification of a User ID and Public Key packet") (24 . "Subkey Binding Signature") (31 . "Signature directly on a key") (32 . "Key revocation signature") (40 . "Subkey revocation signature") (48 . "Certification revocation signature") (64 . "Timestamp signature.")) "Alist of the assigned number to the signature type." :group 'pgg-parse :type '(repeat (cons (sexp :tag "Number") (sexp :tag "Type")))) (defcustom pgg-ignore-packet-checksum t; XXX "If non-nil checksum of each ascii armored packet will be ignored." :group 'pgg-parse :type 'boolean) (defvar pgg-armor-header-lines '("^-----BEGIN PGP MESSAGE\\(, PART [0-9]+\\(/[0-9]+\\)?\\)?-----\r?$" "^-----BEGIN PGP PUBLIC KEY BLOCK-----\r?$" "^-----BEGIN PGP PRIVATE KEY BLOCK-----\r?$" "^-----BEGIN PGP SIGNATURE-----\r?$") "Armor headers.") (eval-and-compile (defalias 'pgg-char-int (if (fboundp 'char-int) 'char-int 'identity))) (defmacro pgg-format-key-identifier (string) `(mapconcat (lambda (c) (format "%02X" (pgg-char-int c))) ,string "") ;; `(upcase (apply #'format "%02x%02x%02x%02x%02x%02x%02x%02x" ;; (string-to-number-list ,string))) ) (defmacro pgg-parse-time-field (bytes) `(list (logior (lsh (car ,bytes) 8) (nth 1 ,bytes)) (logior (lsh (nth 2 ,bytes) 8) (nth 3 ,bytes)) 0)) (defmacro pgg-byte-after (&optional pos) `(pgg-char-int (char-after ,(or pos `(point))))) (defmacro pgg-read-byte () `(pgg-char-int (char-after (prog1 (point) (forward-char))))) (defmacro pgg-read-bytes-string (nbytes) `(buffer-substring (point) (prog1 (+ ,nbytes (point)) (forward-char ,nbytes)))) (defmacro pgg-read-bytes (nbytes) `(mapcar #'pgg-char-int (pgg-read-bytes-string ,nbytes)) ;; `(string-to-number-list (pgg-read-bytes-string ,nbytes)) ) (defmacro pgg-read-body-string (ptag) `(if (nth 1 ,ptag) (pgg-read-bytes-string (nth 1 ,ptag)) (pgg-read-bytes-string (- (point-max) (point))))) (defmacro pgg-read-body (ptag) `(mapcar #'pgg-char-int (pgg-read-body-string ,ptag)) ;; `(string-to-number-list (pgg-read-body-string ,ptag)) ) (defalias 'pgg-skip-bytes 'forward-char) (defmacro pgg-skip-header (ptag) `(pgg-skip-bytes (nth 2 ,ptag))) (defmacro pgg-skip-body (ptag) `(pgg-skip-bytes (nth 1 ,ptag))) (defmacro pgg-set-alist (alist key value) `(setq ,alist (nconc ,alist (list (cons ,key ,value))))) (when (fboundp 'define-ccl-program) (define-ccl-program pgg-parse-crc24 '(1 ((loop (read r0) (r1 ^= r0) (r2 ^= 0) (r5 = 0) (loop (r1 <<= 1) (r1 += ((r2 >> 15) & 1)) (r2 <<= 1) (if (r1 & 256) ((r1 ^= 390) (r2 ^= 19707))) (if (r5 < 7) ((r5 += 1) (repeat)))) (repeat))))) (defvar pgg-parse-crc24) (defun pgg-parse-crc24-string (string) (let ((h (vector nil 183 1230 nil nil nil nil nil nil))) (ccl-execute-on-string pgg-parse-crc24 h string) (format "%c%c%c" (logand (aref h 1) 255) (logand (lsh (aref h 2) -8) 255) (logand (aref h 2) 255))))) (defmacro pgg-parse-length-type (c) `(cond ((< ,c 192) (cons ,c 1)) ((< ,c 224) (cons (+ (lsh (- ,c 192) 8) (pgg-byte-after (+ 2 (point))) 192) 2)) ((= ,c 255) (cons (cons (logior (lsh (pgg-byte-after (+ 2 (point))) 8) (pgg-byte-after (+ 3 (point)))) (logior (lsh (pgg-byte-after (+ 4 (point))) 8) (pgg-byte-after (+ 5 (point))))) 5)) (t;partial body length '(0 . 0)))) (defun pgg-parse-packet-header () (let ((ptag (pgg-byte-after)) length-type content-tag packet-bytes header-bytes) (if (zerop (logand 64 ptag));Old format (progn (setq length-type (logand ptag 3) length-type (if (= 3 length-type) 0 (lsh 1 length-type)) content-tag (logand 15 (lsh ptag -2)) packet-bytes 0 header-bytes (1+ length-type)) (dotimes (i length-type) (setq packet-bytes (logior (lsh packet-bytes 8) (pgg-byte-after (+ 1 i (point))))))) (setq content-tag (logand 63 ptag) length-type (pgg-parse-length-type (pgg-byte-after (1+ (point)))) packet-bytes (car length-type) header-bytes (1+ (cdr length-type)))) (list content-tag packet-bytes header-bytes))) (defun pgg-parse-packet (ptag) (case (car ptag) (1 ;Public-Key Encrypted Session Key Packet (pgg-parse-public-key-encrypted-session-key-packet ptag)) (2 ;Signature Packet (pgg-parse-signature-packet ptag)) (3 ;Symmetric-Key Encrypted Session Key Packet (pgg-parse-symmetric-key-encrypted-session-key-packet ptag)) ;; 4 -- One-Pass Signature Packet ;; 5 -- Secret Key Packet (6 ;Public Key Packet (pgg-parse-public-key-packet ptag)) ;; 7 -- Secret Subkey Packet ;; 8 -- Compressed Data Packet (9 ;Symmetrically Encrypted Data Packet (pgg-read-body-string ptag)) (10 ;Marker Packet (pgg-read-body-string ptag)) (11 ;Literal Data Packet (pgg-read-body-string ptag)) ;; 12 -- Trust Packet (13 ;User ID Packet (pgg-read-body-string ptag)) ;; 14 -- Public Subkey Packet ;; 60 .. 63 -- Private or Experimental Values )) (defun pgg-parse-packets (&optional header-parser body-parser) (let ((header-parser (or header-parser (function pgg-parse-packet-header))) (body-parser (or body-parser (function pgg-parse-packet))) result ptag) (while (> (point-max) (1+ (point))) (setq ptag (funcall header-parser)) (pgg-skip-header ptag) (push (cons (car ptag) (save-excursion (funcall body-parser ptag))) result) (if (zerop (nth 1 ptag)) (goto-char (point-max)) (forward-char (nth 1 ptag)))) result)) (defun pgg-parse-signature-subpacket-header () (let ((length-type (pgg-parse-length-type (pgg-byte-after)))) (list (pgg-byte-after (+ (cdr length-type) (point))) (1- (car length-type)) (1+ (cdr length-type))))) (defun pgg-parse-signature-subpacket (ptag) (case (car ptag) (2 ;signature creation time (cons 'creation-time (let ((bytes (pgg-read-bytes 4))) (pgg-parse-time-field bytes)))) (3 ;signature expiration time (cons 'signature-expiry (let ((bytes (pgg-read-bytes 4))) (pgg-parse-time-field bytes)))) (4 ;exportable certification (cons 'exportability (pgg-read-byte))) (5 ;trust signature (cons 'trust-level (pgg-read-byte))) (6 ;regular expression (cons 'regular-expression (pgg-read-body-string ptag))) (7 ;revocable (cons 'revocability (pgg-read-byte))) (9 ;key expiration time (cons 'key-expiry (let ((bytes (pgg-read-bytes 4))) (pgg-parse-time-field bytes)))) ;; 10 = placeholder for backward compatibility (11 ;preferred symmetric algorithms (cons 'preferred-symmetric-key-algorithm (cdr (assq (pgg-read-byte) pgg-parse-symmetric-key-algorithm-alist)))) (12 ;revocation key ) (16 ;issuer key ID (cons 'key-identifier (pgg-format-key-identifier (pgg-read-body-string ptag)))) (20 ;notation data (pgg-skip-bytes 4) (cons 'notation (let ((name-bytes (pgg-read-bytes 2)) (value-bytes (pgg-read-bytes 2))) (cons (pgg-read-bytes-string (logior (lsh (car name-bytes) 8) (nth 1 name-bytes))) (pgg-read-bytes-string (logior (lsh (car value-bytes) 8) (nth 1 value-bytes))))))) (21 ;preferred hash algorithms (cons 'preferred-hash-algorithm (cdr (assq (pgg-read-byte) pgg-parse-hash-algorithm-alist)))) (22 ;preferred compression algorithms (cons 'preferred-compression-algorithm (cdr (assq (pgg-read-byte) pgg-parse-compression-algorithm-alist)))) (23 ;key server preferences (cons 'key-server-preferences (pgg-read-body ptag))) (24 ;preferred key server (cons 'preferred-key-server (pgg-read-body-string ptag))) ;; 25 = primary user id (26 ;policy URL (cons 'policy-url (pgg-read-body-string ptag))) ;; 27 = key flags ;; 28 = signer's user id ;; 29 = reason for revocation ;; 100 to 110 = internal or user-defined )) (defun pgg-parse-signature-packet (ptag) (let* ((signature-version (pgg-byte-after)) (result (list (cons 'version signature-version))) hashed-material field n) (cond ((= signature-version 3) (pgg-skip-bytes 2) (setq hashed-material (pgg-read-bytes 5)) (pgg-set-alist result 'signature-type (cdr (assq (pop hashed-material) pgg-parse-signature-type-alist))) (pgg-set-alist result 'creation-time (pgg-parse-time-field hashed-material)) (pgg-set-alist result 'key-identifier (pgg-format-key-identifier (pgg-read-bytes-string 8))) (pgg-set-alist result 'public-key-algorithm (pgg-read-byte)) (pgg-set-alist result 'hash-algorithm (pgg-read-byte))) ((= signature-version 4) (pgg-skip-bytes 1) (pgg-set-alist result 'signature-type (cdr (assq (pgg-read-byte) pgg-parse-signature-type-alist))) (pgg-set-alist result 'public-key-algorithm (pgg-read-byte)) (pgg-set-alist result 'hash-algorithm (pgg-read-byte)) (when (>= 10000 (setq n (pgg-read-bytes 2) n (logior (lsh (car n) 8) (nth 1 n)))) (save-restriction (narrow-to-region (point)(+ n (point))) (nconc result (mapcar (function cdr) ;remove packet types (pgg-parse-packets #'pgg-parse-signature-subpacket-header #'pgg-parse-signature-subpacket))) (goto-char (point-max)))) (when (>= 10000 (setq n (pgg-read-bytes 2) n (logior (lsh (car n) 8) (nth 1 n)))) (save-restriction (narrow-to-region (point)(+ n (point))) (nconc result (mapcar (function cdr) ;remove packet types (pgg-parse-packets #'pgg-parse-signature-subpacket-header #'pgg-parse-signature-subpacket))))))) (setcdr (setq field (assq 'public-key-algorithm result)) (cdr (assq (cdr field) pgg-parse-public-key-algorithm-alist))) (setcdr (setq field (assq 'hash-algorithm result)) (cdr (assq (cdr field) pgg-parse-hash-algorithm-alist))) result)) (defun pgg-parse-public-key-encrypted-session-key-packet (ptag) (let (result) (pgg-set-alist result 'version (pgg-read-byte)) (pgg-set-alist result 'key-identifier (pgg-format-key-identifier (pgg-read-bytes-string 8))) (pgg-set-alist result 'public-key-algorithm (cdr (assq (pgg-read-byte) pgg-parse-public-key-algorithm-alist))) result)) (defun pgg-parse-symmetric-key-encrypted-session-key-packet (ptag) (let (result) (pgg-set-alist result 'version (pgg-read-byte)) (pgg-set-alist result 'symmetric-key-algorithm (cdr (assq (pgg-read-byte) pgg-parse-symmetric-key-algorithm-alist))) result)) (defun pgg-parse-public-key-packet (ptag) (let* ((key-version (pgg-read-byte)) (result (list (cons 'version key-version))) field) (cond ((= 3 key-version) (pgg-set-alist result 'creation-time (let ((bytes (pgg-read-bytes 4))) (pgg-parse-time-field bytes))) (pgg-set-alist result 'key-expiry (pgg-read-bytes 2)) (pgg-set-alist result 'public-key-algorithm (pgg-read-byte))) ((= 4 key-version) (pgg-set-alist result 'creation-time (let ((bytes (pgg-read-bytes 4))) (pgg-parse-time-field bytes))) (pgg-set-alist result 'public-key-algorithm (pgg-read-byte)))) (setcdr (setq field (assq 'public-key-algorithm result)) (cdr (assq (cdr field) pgg-parse-public-key-algorithm-alist))) result)) ;; p-d-p only calls this if it is defined, but the compiler does not ;; recognize that. (declare-function pgg-parse-crc24-string "pgg-parse" (string)) (defun pgg-decode-packets () (if (re-search-forward "^=\\([A-Za-z0-9+/]\\{4\\}\\)$" nil t) (let ((p (match-beginning 0)) (checksum (match-string 1))) (delete-region p (point-max)) (if (ignore-errors (base64-decode-region (point-min) p)) (or (not (fboundp 'pgg-parse-crc24-string)) pgg-ignore-packet-checksum (string-equal (base64-encode-string (pgg-parse-crc24-string (buffer-string))) checksum) (progn (message "PGP packet checksum does not match") nil)) (message "PGP packet contain invalid base64") nil)) (message "PGP packet checksum not found") nil)) (defun pgg-decode-armor-region (start end) (save-restriction (narrow-to-region start end) (goto-char (point-min)) (re-search-forward "^-+BEGIN PGP" nil t) (delete-region (point-min) (and (search-forward "\n\n") (match-end 0))) (when (pgg-decode-packets) (goto-char (point-min)) (pgg-parse-packets)))) (defun pgg-parse-armor (string) (with-temp-buffer (buffer-disable-undo) (if (fboundp 'set-buffer-multibyte) (set-buffer-multibyte nil)) (insert string) (pgg-decode-armor-region (point-min)(point)))) (eval-and-compile (defalias 'pgg-string-as-unibyte (if (fboundp 'string-as-unibyte) 'string-as-unibyte 'identity))) (defun pgg-parse-armor-region (start end) (pgg-parse-armor (pgg-string-as-unibyte (buffer-substring start end)))) (provide 'pgg-parse) ;; arch-tag: 16c2eb82-1313-4a7c-a70f-420709b5b43e ;;; pgg-parse.el ends here gnus-5.11+v0.10.dfsg/lisp/rfc2045.el0000644000175000017500000000320311004005111016627 0ustar tvainikatvainika;;; rfc2045.el --- Functions for decoding rfc2045 headers ;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, ;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 3, or (at your option) ;; any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;; RFC 2045 is: "Multipurpose Internet Mail Extensions (MIME) Part ;; One: Format of Internet Message Bodies". ;;; Commentary: ;;; Code: (require 'ietf-drums) (defun rfc2045-encode-string (param value) "Return and PARAM=VALUE string encoded according to RFC2045." (if (or (string-match (concat "[" ietf-drums-no-ws-ctl-token "]") value) (string-match (concat "[" ietf-drums-tspecials "]") value) (string-match "[ \n\t]" value) (not (string-match (concat "[" ietf-drums-text-token "]") value))) (concat param "=" (format "%S" value)) (concat param "=" value))) (provide 'rfc2045) ;; arch-tag: 9ca54127-97bc-432c-b6e2-8c59cadba306 ;;; rfc2045.el ends here gnus-5.11+v0.10.dfsg/lisp/lpath.el0000644000175000017500000001034010767343124016702 0ustar tvainikatvainika;; Shut up. (defun maybe-fbind (args) (while args (or (fboundp (car args)) (defalias (car args) 'ignore)) (setq args (cdr args)))) (defun maybe-bind (args) (mapcar (lambda (var) (unless (boundp var) (set var nil))) args)) (unless (featurep 'xemacs) (maybe-fbind '(pgg-display-output-buffer url-generic-parse-url)) (maybe-bind '(help-xref-stack-item url-version w3-meta-charset-content-type-regexp w3-meta-content-type-charset-regexp)) (when (<= emacs-major-version 22) (defun nnkiboze-score-file (a)) (maybe-fbind '(Info-index Info-index-next Info-menu bbdb-complete-name display-time-event-handler epg-check-configuration find-coding-system frame-device w3-do-setup w3-prepare-buffer w3-region w32-focus-frame w3m-detect-meta-charset w3m-region))) (when (= emacs-major-version 21) (defun split-line (&optional arg)) (maybe-fbind '(clear-string custom-autoload delete-annotation delete-extent device-connection dfw-device events-to-keys find-face font-lock-set-defaults get-char-table glyph-height glyph-width help-buffer ldap-search-entries mail-aliases-setup make-annotation make-event make-glyph make-network-process map-extents message-xmas-redefine put-char-table run-mode-hooks set-extent-property set-itimer-function set-keymap-default-binding temp-directory unicode-precedence-list url-generic-parse-url url-http-file-exists-p valid-image-instantiator-format-p vcard-pretty-print w3-coding-system-for-mime-charset window-pixel-height window-pixel-width)) (maybe-bind '(eudc-protocol filladapt-mode help-echo-owns-message itimer-list ps-print-color-p w3-meta-charset-content-type-regexp w3-meta-content-type-charset-regexp)))) (when (featurep 'xemacs) (defun nnkiboze-score-file (a)) (defun split-line (&optional arg)) (maybe-fbind '(clear-string codepage-setup create-image detect-coding-string display-time-event-handler epg-check-configuration event-click-count event-end event-start find-coding-systems-for-charsets find-coding-systems-region find-coding-systems-string find-image help-buffer image-size image-type-available-p insert-image mail-abbrevs-setup make-mode-line-mouse-map make-network-process mouse-minibuffer-check mouse-movement-p mouse-scroll-subr pgg-display-output-buffer posn-point posn-window put-image read-event select-safe-coding-system sort-coding-systems track-mouse url-generic-parse-url url-http-file-exists-p vcard-pretty-print w3m-detect-meta-charset window-edges)) (maybe-bind '(adaptive-fill-first-line-regexp buffer-display-table cursor-in-non-selected-windows default-enable-multibyte-characters eudc-protocol filladapt-mode gnus-agent-expire-current-dirs help-xref-stack-item line-spacing mark-active mouse-selection-click-count mouse-selection-click-count-buffer rmail-insert-mime-forwarded-message-function show-trailing-whitespace tool-bar-mode transient-mark-mode url-version w3-meta-charset-content-type-regexp w3-meta-content-type-charset-regexp)) (when (or (and (= emacs-major-version 21) (= emacs-minor-version 4)) (featurep 'sxemacs)) (maybe-fbind '(custom-autoload display-graphic-p display-images-p display-visual-class select-frame-set-input-focus unicode-precedence-list w32-focus-frame x-focus-frame)) (maybe-bind '(default-file-name-coding-system))) (unless (featurep 'mule) (maybe-fbind '(ccl-execute-on-string charsetp coding-system-get get-charset-property pgg-display-output-buffer pgg-parse-crc24-string unicode-precedence-list)) (maybe-bind '(current-language-environment default-file-name-coding-system language-info-alist pgg-parse-crc24))) (unless (featurep 'file-coding) (maybe-fbind '(coding-system-base coding-system-change-eol-conversion coding-system-list coding-system-p find-coding-system)) (maybe-bind '(buffer-file-coding-system coding-system-for-read coding-system-for-write enable-multibyte-characters file-name-coding-system)))) (provide 'lpath) ;;; arch-tag: d1ad864f-dca6-4d21-aa3f-be3248e66dba gnus-5.11+v0.10.dfsg/lisp/gnus-ml.el0000644000175000017500000001407411004005110017133 0ustar tvainikatvainika;;; gnus-ml.el --- Mailing list minor mode for Gnus ;; Copyright (C) 2000, 2001, 2002, 2003, 2004, ;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc. ;; Author: Julien Gilles ;; Keywords: news, mail ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 3, or (at your option) ;; any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Commentary: ;; implement (small subset of) RFC 2369 ;;; Code: (require 'gnus) (require 'gnus-msg) (eval-when-compile (require 'cl)) ;;; Mailing list minor mode (defvar gnus-mailing-list-mode nil "Minor mode for providing mailing-list commands.") (defvar gnus-mailing-list-mode-map nil) (defvar gnus-mailing-list-menu) (unless gnus-mailing-list-mode-map (setq gnus-mailing-list-mode-map (make-sparse-keymap)) (gnus-define-keys gnus-mailing-list-mode-map "\C-c\C-nh" gnus-mailing-list-help "\C-c\C-ns" gnus-mailing-list-subscribe "\C-c\C-nu" gnus-mailing-list-unsubscribe "\C-c\C-np" gnus-mailing-list-post "\C-c\C-no" gnus-mailing-list-owner "\C-c\C-na" gnus-mailing-list-archive)) (defun gnus-mailing-list-make-menu-bar () (unless (boundp 'gnus-mailing-list-menu) (easy-menu-define gnus-mailing-list-menu gnus-mailing-list-mode-map "" '("Mailing-Lists" ["Get help" gnus-mailing-list-help t] ["Subscribe" gnus-mailing-list-subscribe t] ["Unsubscribe" gnus-mailing-list-unsubscribe t] ["Post a message" gnus-mailing-list-post t] ["Mail to owner" gnus-mailing-list-owner t] ["Browse archive" gnus-mailing-list-archive t])))) ;;;###autoload (defun turn-on-gnus-mailing-list-mode () (when (gnus-group-find-parameter gnus-newsgroup-name 'to-list) (gnus-mailing-list-mode 1))) ;;;###autoload (defun gnus-mailing-list-insinuate (&optional force) "Setup group parameters from List-Post header. If FORCE is non-nil, replace the old ones." (interactive "P") (let ((list-post (with-current-buffer gnus-original-article-buffer (gnus-fetch-field "list-post")))) (if list-post (if (and (not force) (gnus-group-get-parameter gnus-newsgroup-name 'to-list)) (gnus-message 1 "to-list is non-nil.") (if (string-match "]*\\)>" list-post) (setq list-post (match-string 1 list-post))) (gnus-group-add-parameter gnus-newsgroup-name (cons 'to-list list-post)) (gnus-mailing-list-mode 1)) (gnus-message 1 "no list-post in this message.")))) ;;;###autoload (defun gnus-mailing-list-mode (&optional arg) "Minor mode for providing mailing-list commands. \\{gnus-mailing-list-mode-map}" (interactive "P") (when (eq major-mode 'gnus-summary-mode) (when (set (make-local-variable 'gnus-mailing-list-mode) (if (null arg) (not gnus-mailing-list-mode) (> (prefix-numeric-value arg) 0))) ;; Set up the menu. (when (gnus-visual-p 'mailing-list-menu 'menu) (gnus-mailing-list-make-menu-bar)) (add-minor-mode 'gnus-mailing-list-mode " Mailing-List" gnus-mailing-list-mode-map) (gnus-run-hooks 'gnus-mailing-list-mode-hook)))) ;;; Commands (defun gnus-mailing-list-help () "Get help from mailing list server." (interactive) (let ((list-help (with-current-buffer gnus-original-article-buffer (gnus-fetch-field "list-help")))) (cond (list-help (gnus-mailing-list-message list-help)) (t (gnus-message 1 "no list-help in this group"))))) (defun gnus-mailing-list-subscribe () "Subscribe to mailing list." (interactive) (let ((list-subscribe (with-current-buffer gnus-original-article-buffer (gnus-fetch-field "list-subscribe")))) (cond (list-subscribe (gnus-mailing-list-message list-subscribe)) (t (gnus-message 1 "no list-subscribe in this group"))))) (defun gnus-mailing-list-unsubscribe () "Unsubscribe from mailing list." (interactive) (let ((list-unsubscribe (with-current-buffer gnus-original-article-buffer (gnus-fetch-field "list-unsubscribe")))) (cond (list-unsubscribe (gnus-mailing-list-message list-unsubscribe)) (t (gnus-message 1 "no list-unsubscribe in this group"))))) (defun gnus-mailing-list-post () "Post message (really useful ?)" (interactive) (let ((list-post (with-current-buffer gnus-original-article-buffer (gnus-fetch-field "list-post")))) (cond (list-post (gnus-mailing-list-message list-post)) (t (gnus-message 1 "no list-post in this group"))))) (defun gnus-mailing-list-owner () "Mail to the mailing list owner." (interactive) (let ((list-owner (with-current-buffer gnus-original-article-buffer (gnus-fetch-field "list-owner")))) (cond (list-owner (gnus-mailing-list-message list-owner)) (t (gnus-message 1 "no list-owner in this group"))))) (defun gnus-mailing-list-archive () "Browse archive." (interactive) (require 'browse-url) (let ((list-archive (with-current-buffer gnus-original-article-buffer (gnus-fetch-field "list-archive")))) (cond (list-archive (if (string-match "<\\(http:[^>]*\\)>" list-archive) (browse-url (match-string 1 list-archive)) (browse-url list-archive))) (t (gnus-message 1 "no list-archive in this group"))))) ;;; Utility functions (defun gnus-mailing-list-message (address) "Send message to ADDRESS. ADDRESS is specified by a \"mailto:\" URL." (cond ((string-match "<\\(mailto:[^>]*\\)>" address) (require 'gnus-art) (gnus-url-mailto (match-string 1 address))) ;; other case to be done. (t nil))) (provide 'gnus-ml) ;; arch-tag: 936c0fe6-acce-4c16-87d0-eded88078896 ;;; gnus-ml.el ends here gnus-5.11+v0.10.dfsg/lisp/mm-bodies.el0000644000175000017500000002421111004005110017417 0ustar tvainikatvainika;;; mm-bodies.el --- Functions for decoding MIME things ;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, ;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; MORIOKA Tomohiko ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 3, or (at your option) ;; any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Commentary: ;;; Code: ;; For Emacs < 22.2. (eval-and-compile (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) (require 'mm-util) (require 'rfc2047) (require 'mm-encode) (defvar mm-uu-yenc-decode-function) (defvar mm-uu-decode-function) (defvar mm-uu-binhex-decode-function) ;; 8bit treatment gets any char except: 0x32 - 0x7f, LF, TAB, BEL, ;; BS, vertical TAB, form feed, and ^_ ;; ;; Note that CR is *not* included, as that would allow a non-paired CR ;; in the body contrary to RFC 2822: ;; ;; - CR and LF MUST only occur together as CRLF; they MUST NOT ;; appear independently in the body. (defvar mm-7bit-chars "\x20-\x7f\n\t\x7\x8\xb\xc\x1f") (defcustom mm-body-charset-encoding-alist '((iso-2022-jp . 7bit) (iso-2022-jp-2 . 7bit) ;; We MUST encode UTF-16 because it can contain \0's which is ;; known to break servers. ;; Note: UTF-16 variants are invalid for text parts [RFC 2781], ;; so this can't happen :-/. ;; PPS: Yes, it can happen if the user specifies UTF-16 in the MML ;; markup. - jh. (utf-16 . base64) (utf-16be . base64) (utf-16le . base64)) "Alist of MIME charsets to encodings. Valid encodings are `7bit', `8bit', `quoted-printable' and `base64'." :type '(repeat (cons (symbol :tag "charset") (choice :tag "encoding" (const 7bit) (const 8bit) (const quoted-printable) (const base64)))) :group 'mime) (autoload 'message-options-get "message") (declare-function message-options-set "message" (symbol value)) (defun mm-encode-body (&optional charset) "Encode a body. Should be called narrowed to the body that is to be encoded. If there is more than one non-ASCII MULE charset in the body, then the list of MULE charsets found is returned. If CHARSET is non-nil, it is used as the MIME charset to encode the body. If successful, the MIME charset is returned. If no encoding was done, nil is returned." (if (not (mm-multibyte-p)) ;; In the non-Mule case, we search for non-ASCII chars and ;; return the value of `mail-parse-charset' if any are found. (or charset (save-excursion (goto-char (point-min)) (if (re-search-forward "[^\x0-\x7f]" nil t) (or mail-parse-charset (message-options-get 'mm-encody-body-charset) (message-options-set 'mm-encody-body-charset (mm-read-coding-system "Charset used in the article: "))) ;; The logic in `mml-generate-mime-1' confirms that it's OK ;; to return nil here. nil))) (save-excursion (if charset (progn (mm-encode-coding-region (point-min) (point-max) (mm-charset-to-coding-system charset)) charset) (goto-char (point-min)) (let ((charsets (mm-find-mime-charset-region (point-min) (point-max) mm-hack-charsets))) (cond ;; No encoding. ((null charsets) nil) ;; Too many charsets. ((> (length charsets) 1) charsets) ;; We encode. (t (prog1 (setq charset (car charsets)) (mm-encode-coding-region (point-min) (point-max) (mm-charset-to-coding-system charset)))) )))))) (defun mm-long-lines-p (length) "Say whether any of the lines in the buffer is longer than LENGTH." (save-excursion (goto-char (point-min)) (end-of-line) (while (and (not (eobp)) (not (> (current-column) length))) (forward-line 1) (end-of-line)) (and (> (current-column) length) (current-column)))) (defvar message-posting-charset) (defun mm-body-encoding (charset &optional encoding) "Do Content-Transfer-Encoding and return the encoding of the current buffer." (when (stringp encoding) (setq encoding (intern (downcase encoding)))) (let ((bits (mm-body-7-or-8)) (longp (mm-long-lines-p 1000))) (require 'message) (cond ((and (not longp) (not (and mm-use-ultra-safe-encoding (or (save-excursion (re-search-forward " $" nil t)) (save-excursion (re-search-forward "^From " nil t))))) (eq bits '7bit)) bits) ((and (not mm-use-ultra-safe-encoding) (not longp) (not (cdr (assq charset mm-body-charset-encoding-alist))) (or (eq t (cdr message-posting-charset)) (memq charset (cdr message-posting-charset)) (eq charset mail-parse-charset))) bits) (t (let ((encoding (or encoding (cdr (assq charset mm-body-charset-encoding-alist)) (mm-qp-or-base64)))) (when mm-use-ultra-safe-encoding (setq encoding (mm-safer-encoding encoding))) (mm-encode-content-transfer-encoding encoding "text/plain") encoding))))) (defun mm-body-7-or-8 () "Say whether the body is 7bit or 8bit." (if (save-excursion (goto-char (point-min)) (skip-chars-forward mm-7bit-chars) (eobp)) '7bit '8bit)) ;;; ;;; Functions for decoding ;;; (defun mm-decode-content-transfer-encoding (encoding &optional type) "Decodes buffer encoded with ENCODING, returning success status. If TYPE is `text/plain' CRLF->LF translation may occur." (prog1 (condition-case error (cond ((eq encoding 'quoted-printable) (quoted-printable-decode-region (point-min) (point-max)) t) ((eq encoding 'base64) (base64-decode-region (point-min) ;; Some mailers insert whitespace ;; junk at the end which ;; base64-decode-region dislikes. ;; Also remove possible junk which could ;; have been added by mailing list software. (save-excursion (goto-char (point-min)) (while (re-search-forward "^[\t ]*\r?\n" nil t) (delete-region (match-beginning 0) (match-end 0))) (goto-char (point-max)) (when (re-search-backward "^[A-Za-z0-9+/]+=*[\t ]*$" nil t) (forward-line)) (point)))) ((memq encoding '(nil 7bit 8bit binary)) ;; Do nothing. t) ((memq encoding '(x-uuencode x-uue)) (require 'mm-uu) (funcall mm-uu-decode-function (point-min) (point-max)) t) ((eq encoding 'x-binhex) (require 'mm-uu) (funcall mm-uu-binhex-decode-function (point-min) (point-max)) t) ((eq encoding 'x-yenc) (require 'mm-uu) (funcall mm-uu-yenc-decode-function (point-min) (point-max)) ) ((functionp encoding) (funcall encoding (point-min) (point-max)) t) (t (message "Unknown encoding %s; defaulting to 8bit" encoding))) (error (message "Error while decoding: %s" error) nil)) (when (and type (memq encoding '(base64 x-uuencode x-uue x-binhex x-yenc)) (string-match "\\`text/" type)) (goto-char (point-min)) (while (search-forward "\r\n" nil t) (replace-match "\n" t t))))) (defun mm-decode-body (charset &optional encoding type) "Decode the current article that has been encoded with ENCODING to CHARSET. ENCODING is a MIME content transfer encoding. CHARSET is the MIME charset with which to decode the data after transfer decoding. If it is nil, default to `mail-parse-charset'." (when (stringp charset) (setq charset (intern (downcase charset)))) (when (or (not charset) (eq 'gnus-all mail-parse-ignored-charsets) (memq 'gnus-all mail-parse-ignored-charsets) (memq charset mail-parse-ignored-charsets)) (setq charset mail-parse-charset)) (save-excursion (when encoding (mm-decode-content-transfer-encoding encoding type)) (when (and (featurep 'mule) ;; Fixme: Wrong test for unibyte session. (not (eq charset 'gnus-decoded))) (let ((coding-system (mm-charset-to-coding-system ;; Allow overwrite using ;; `mm-charset-override-alist'. charset nil t))) (if (and (not coding-system) (listp mail-parse-ignored-charsets) (memq 'gnus-unknown mail-parse-ignored-charsets)) (setq coding-system (mm-charset-to-coding-system mail-parse-charset))) (when (and charset coding-system ;; buffer-file-coding-system ;;Article buffer is nil coding system ;;in XEmacs (mm-multibyte-p) (or (not (eq coding-system 'ascii)) (setq coding-system mail-parse-charset))) (mm-decode-coding-region (point-min) (point-max) coding-system)) (setq buffer-file-coding-system (if (boundp 'last-coding-system-used) (symbol-value 'last-coding-system-used) coding-system)))))) (defun mm-decode-string (string charset) "Decode STRING with CHARSET." (when (stringp charset) (setq charset (intern (downcase charset)))) (when (or (not charset) (eq 'gnus-all mail-parse-ignored-charsets) (memq 'gnus-all mail-parse-ignored-charsets) (memq charset mail-parse-ignored-charsets)) (setq charset mail-parse-charset)) (or (when (featurep 'mule) (let ((coding-system (mm-charset-to-coding-system charset ;; Allow overwrite using ;; `mm-charset-override-alist'. nil t))) (if (and (not coding-system) (listp mail-parse-ignored-charsets) (memq 'gnus-unknown mail-parse-ignored-charsets)) (setq coding-system (mm-charset-to-coding-system mail-parse-charset))) (when (and charset coding-system (mm-multibyte-p) (or (not (eq coding-system 'ascii)) (setq coding-system mail-parse-charset))) (mm-decode-coding-string string coding-system)))) string)) (provide 'mm-bodies) ;; arch-tag: 41104bb6-4443-4ca9-8d5c-ff87ecf27d8d ;;; mm-bodies.el ends here gnus-5.11+v0.10.dfsg/lisp/ntlm.el0000644000175000017500000004613111004005110016522 0ustar tvainikatvainika;;; ntlm.el --- NTLM (NT LanManager) authentication support ;; Copyright (C) 2001, 2007, 2008 Free Software Foundation, Inc. ;; Author: Taro Kawagishi ;; Keywords: NTLM, SASL ;; Version: 1.00 ;; Created: February 2001 ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 3, or (at your option) ;; any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Commentary: ;; This library is a direct translation of the Samba release 2.2.0 ;; implementation of Windows NT and LanManager compatible password ;; encryption. ;; ;; Interface functions: ;; ;; ntlm-build-auth-request ;; This will return a binary string, which should be used in the ;; base64 encoded form and it is the caller's responsibility to encode ;; the returned string with base64. ;; ;; ntlm-build-auth-response ;; It is the caller's responsibility to pass a base64 decoded string ;; (which will be a binary string) as the first argument and to ;; encode the returned string with base64. The second argument user ;; should be given in user@domain format. ;; ;; ntlm-get-password-hashes ;; ;; ;; NTLM authentication procedure example: ;; ;; 1. Open a network connection to the Exchange server at the IMAP port (143) ;; 2. Receive an opening message such as: ;; "* OK Microsoft Exchange IMAP4rev1 server version 5.5.2653.7 (XXXX) ready" ;; 3. Ask for IMAP server capability by sending "NNN capability" ;; 4. Receive a capability message such as: ;; "* CAPABILITY IMAP4 IMAP4rev1 IDLE LITERAL+ LOGIN-REFERRALS MAILBOX-REFERRALS NAMESPACE AUTH=NTLM" ;; 5. Ask for NTLM authentication by sending a string ;; "NNN authenticate ntlm" ;; 6. Receive continuation acknowledgment "+" ;; 7. Send NTLM authentication request generated by 'ntlm-build-auth-request ;; 8. Receive NTLM challenge string following acknowledgment "+" ;; 9. Generate response to challenge by 'ntlm-build-auth-response ;; (here two hash function values of the user password are encrypted) ;; 10. Receive authentication completion message such as ;; "NNN OK AUTHENTICATE NTLM completed." ;;; Code: (require 'md4) ;;; ;;; NTLM authentication interface functions (defun ntlm-build-auth-request (user &optional domain) "Return the NTLM authentication request string for USER and DOMAIN. USER is a string representing a user name to be authenticated and DOMAIN is a NT domain. USER can include a NT domain part as in user@domain where the string after @ is used as the domain if DOMAIN is not given." (interactive) (let ((request-ident (concat "NTLMSSP" (make-string 1 0))) (request-msgType (concat (make-string 1 1) (make-string 3 0))) ;0x01 0x00 0x00 0x00 (request-flags (concat (make-string 1 7) (make-string 1 178) (make-string 2 0))) ;0x07 0xb2 0x00 0x00 lu ld off-d off-u) (when (string-match "@" user) (unless domain (setq domain (substring user (1+ (match-beginning 0))))) (setq user (substring user 0 (match-beginning 0)))) ;; set fields offsets within the request struct (setq lu (length user)) (setq ld (length domain)) (setq off-u 32) ;offset to the string 'user (setq off-d (+ 32 lu)) ;offset to the string 'domain ;; pack the request struct in a string (concat request-ident ;8 bytes request-msgType ;4 bytes request-flags ;4 bytes (md4-pack-int16 lu) ;user field, count field (md4-pack-int16 lu) ;user field, max count field (md4-pack-int32 (cons 0 off-u)) ;user field, offset field (md4-pack-int16 ld) ;domain field, count field (md4-pack-int16 ld) ;domain field, max count field (md4-pack-int32 (cons 0 off-d)) ;domain field, offset field user ;bufer field domain ;bufer field ))) (eval-when-compile (defmacro ntlm-string-as-unibyte (string) (if (fboundp 'string-as-unibyte) `(string-as-unibyte ,string) string))) (defun ntlm-build-auth-response (challenge user password-hashes) "Return the response string to a challenge string CHALLENGE given by the NTLM based server for the user USER and the password hash list PASSWORD-HASHES. NTLM uses two hash values which are represented by PASSWORD-HASHES. PASSWORD-HASHES should be a return value of (list (ntlm-smb-passwd-hash password) (ntlm-md4hash password))" (let* ((rchallenge (ntlm-string-as-unibyte challenge)) ;; get fields within challenge struct ;;(ident (substring rchallenge 0 8)) ;ident, 8 bytes ;;(msgType (substring rchallenge 8 12)) ;msgType, 4 bytes (uDomain (substring rchallenge 12 20)) ;uDomain, 8 bytes (flags (substring rchallenge 20 24)) ;flags, 4 bytes (challengeData (substring rchallenge 24 32)) ;challengeData, 8 bytes uDomain-len uDomain-offs ;; response struct and its fields lmRespData ;lmRespData, 24 bytes ntRespData ;ntRespData, 24 bytes domain ;ascii domain string lu ld off-lm off-nt off-d off-u off-w off-s) ;; extract domain string from challenge string (setq uDomain-len (md4-unpack-int16 (substring uDomain 0 2))) (setq uDomain-offs (md4-unpack-int32 (substring uDomain 4 8))) (setq domain (ntlm-unicode2ascii (substring challenge (cdr uDomain-offs) (+ (cdr uDomain-offs) uDomain-len)) (/ uDomain-len 2))) ;; overwrite domain in case user is given in @ format (when (string-match "@" user) (setq domain (substring user (1+ (match-beginning 0)))) (setq user (substring user 0 (match-beginning 0)))) ;; generate response data (setq lmRespData (ntlm-smb-owf-encrypt (car password-hashes) challengeData)) (setq ntRespData (ntlm-smb-owf-encrypt (cadr password-hashes) challengeData)) ;; get offsets to fields to pack the response struct in a string (setq lu (length user)) (setq ld (length domain)) (setq off-lm 64) ;offset to string 'lmResponse (setq off-nt (+ 64 24)) ;offset to string 'ntResponse (setq off-d (+ 64 48)) ;offset to string 'uDomain (setq off-u (+ 64 48 (* 2 ld))) ;offset to string 'uUser (setq off-w (+ 64 48 (* 2 (+ ld lu)))) ;offset to string 'uWks (setq off-s (+ 64 48 (* 2 (+ ld lu lu)))) ;offset to string 'sessionKey ;; pack the response struct in a string (concat "NTLMSSP\0" ;response ident field, 8 bytes (md4-pack-int32 '(0 . 3)) ;response msgType field, 4 bytes ;; lmResponse field, 8 bytes ;;AddBytes(response,lmResponse,lmRespData,24); (md4-pack-int16 24) ;len field (md4-pack-int16 24) ;maxlen field (md4-pack-int32 (cons 0 off-lm)) ;field offset ;; ntResponse field, 8 bytes ;;AddBytes(response,ntResponse,ntRespData,24); (md4-pack-int16 24) ;len field (md4-pack-int16 24) ;maxlen field (md4-pack-int32 (cons 0 off-nt)) ;field offset ;; uDomain field, 8 bytes ;;AddUnicodeString(response,uDomain,domain); ;;AddBytes(response, uDomain, udomain, 2*ld); (md4-pack-int16 (* 2 ld)) ;len field (md4-pack-int16 (* 2 ld)) ;maxlen field (md4-pack-int32 (cons 0 off-d)) ;field offset ;; uUser field, 8 bytes ;;AddUnicodeString(response,uUser,u); ;;AddBytes(response, uUser, uuser, 2*lu); (md4-pack-int16 (* 2 lu)) ;len field (md4-pack-int16 (* 2 lu)) ;maxlen field (md4-pack-int32 (cons 0 off-u)) ;field offset ;; uWks field, 8 bytes ;;AddUnicodeString(response,uWks,u); (md4-pack-int16 (* 2 lu)) ;len field (md4-pack-int16 (* 2 lu)) ;maxlen field (md4-pack-int32 (cons 0 off-w)) ;field offset ;; sessionKey field, 8 bytes ;;AddString(response,sessionKey,NULL); (md4-pack-int16 0) ;len field (md4-pack-int16 0) ;maxlen field (md4-pack-int32 (cons 0 (- off-s off-lm))) ;field offset ;; flags field, 4 bytes flags ; ;; buffer field lmRespData ;lmResponse, 24 bytes ntRespData ;ntResponse, 24 bytes (ntlm-ascii2unicode domain ;unicode domain string, 2*ld bytes (length domain)) ; (ntlm-ascii2unicode user ;unicode user string, 2*lu bytes (length user)) ; (ntlm-ascii2unicode user ;unicode user string, 2*lu bytes (length user)) ; ))) (defun ntlm-get-password-hashes (password) "Return a pair of SMB hash and NT MD4 hash of the given password PASSWORD" (list (ntlm-smb-passwd-hash password) (ntlm-md4hash password))) (defun ntlm-ascii2unicode (str len) "Convert an ASCII string into a NT Unicode string, which is little-endian utf16." (let ((utf (make-string (* 2 len) 0)) (i 0) val) (while (and (< i len) (not (zerop (setq val (aref str i))))) (aset utf (* 2 i) val) (aset utf (1+ (* 2 i)) 0) (setq i (1+ i))) utf)) (defun ntlm-unicode2ascii (str len) "Extract 7 bits ASCII part of a little endian utf16 string STR of length LEN." (let ((buf (make-string len 0)) (i 0) (j 0)) (while (< i len) (aset buf i (logand (aref str j) 127)) ;(string-to-number "7f" 16) (setq i (1+ i) j (+ 2 j))) buf)) (defun ntlm-smb-passwd-hash (passwd) "Return the SMB password hash string of 16 bytes long for the given password string PASSWD. PASSWD is truncated to 14 bytes if longer." (let ((len (min (length passwd) 14))) (ntlm-smb-des-e-p16 (concat (substring (upcase passwd) 0 len) ;fill top 14 bytes with passwd (make-string (- 15 len) 0))))) (defun ntlm-smb-owf-encrypt (passwd c8) "Return the response string of 24 bytes long for the given password string PASSWD based on the DES encryption. PASSWD is of at most 14 bytes long and the challenge string C8 of 8 bytes long." (let ((len (min (length passwd) 16)) p22) (setq p22 (concat (substring passwd 0 len) ;fill top 16 bytes with passwd (make-string (- 22 len) 0))) (ntlm-smb-des-e-p24 p22 c8))) (defun ntlm-smb-des-e-p24 (p22 c8) "Return a 24 bytes hashed string for a 21 bytes string P22 and a 8 bytes string C8." (concat (ntlm-smb-hash c8 p22 t) ;hash first 8 bytes of p22 (ntlm-smb-hash c8 (substring p22 7) t) (ntlm-smb-hash c8 (substring p22 14) t))) (defconst ntlm-smb-sp8 [75 71 83 33 64 35 36 37]) (defun ntlm-smb-des-e-p16 (p15) "Return a 16 bytes hashed string for a 15 bytes string P15." (concat (ntlm-smb-hash ntlm-smb-sp8 p15 t) ;hash of first 8 bytes of p15 (ntlm-smb-hash ntlm-smb-sp8 ;hash of last 8 bytes of p15 (substring p15 7) t))) (defun ntlm-smb-hash (in key forw) "Return the hash string of length 8 for a string IN of length 8 and a string KEY of length 8. FORW is t or nil." (let ((out (make-string 8 0)) outb ;string of length 64 (inb (make-string 64 0)) (keyb (make-string 64 0)) (key2 (ntlm-smb-str-to-key key)) (i 0) aa) (while (< i 64) (unless (zerop (logand (aref in (/ i 8)) (lsh 1 (- 7 (% i 8))))) (aset inb i 1)) (unless (zerop (logand (aref key2 (/ i 8)) (lsh 1 (- 7 (% i 8))))) (aset keyb i 1)) (setq i (1+ i))) (setq outb (ntlm-smb-dohash inb keyb forw)) (setq i 0) (while (< i 64) (unless (zerop (aref outb i)) (setq aa (aref out (/ i 8))) (aset out (/ i 8) (logior aa (lsh 1 (- 7 (% i 8)))))) (setq i (1+ i))) out)) (defun ntlm-smb-str-to-key (str) "Return a string of length 8 for the given string STR of length 7." (let ((key (make-string 8 0)) (i 7)) (aset key 0 (lsh (aref str 0) -1)) (aset key 1 (logior (lsh (logand (aref str 0) 1) 6) (lsh (aref str 1) -2))) (aset key 2 (logior (lsh (logand (aref str 1) 3) 5) (lsh (aref str 2) -3))) (aset key 3 (logior (lsh (logand (aref str 2) 7) 4) (lsh (aref str 3) -4))) (aset key 4 (logior (lsh (logand (aref str 3) 15) 3) (lsh (aref str 4) -5))) (aset key 5 (logior (lsh (logand (aref str 4) 31) 2) (lsh (aref str 5) -6))) (aset key 6 (logior (lsh (logand (aref str 5) 63) 1) (lsh (aref str 6) -7))) (aset key 7 (logand (aref str 6) 127)) (while (>= i 0) (aset key i (lsh (aref key i) 1)) (setq i (1- i))) key)) (defconst ntlm-smb-perm1 [57 49 41 33 25 17 9 1 58 50 42 34 26 18 10 2 59 51 43 35 27 19 11 3 60 52 44 36 63 55 47 39 31 23 15 7 62 54 46 38 30 22 14 6 61 53 45 37 29 21 13 5 28 20 12 4]) (defconst ntlm-smb-perm2 [14 17 11 24 1 5 3 28 15 6 21 10 23 19 12 4 26 8 16 7 27 20 13 2 41 52 31 37 47 55 30 40 51 45 33 48 44 49 39 56 34 53 46 42 50 36 29 32]) (defconst ntlm-smb-perm3 [58 50 42 34 26 18 10 2 60 52 44 36 28 20 12 4 62 54 46 38 30 22 14 6 64 56 48 40 32 24 16 8 57 49 41 33 25 17 9 1 59 51 43 35 27 19 11 3 61 53 45 37 29 21 13 5 63 55 47 39 31 23 15 7]) (defconst ntlm-smb-perm4 [32 1 2 3 4 5 4 5 6 7 8 9 8 9 10 11 12 13 12 13 14 15 16 17 16 17 18 19 20 21 20 21 22 23 24 25 24 25 26 27 28 29 28 29 30 31 32 1]) (defconst ntlm-smb-perm5 [16 7 20 21 29 12 28 17 1 15 23 26 5 18 31 10 2 8 24 14 32 27 3 9 19 13 30 6 22 11 4 25]) (defconst ntlm-smb-perm6 [40 8 48 16 56 24 64 32 39 7 47 15 55 23 63 31 38 6 46 14 54 22 62 30 37 5 45 13 53 21 61 29 36 4 44 12 52 20 60 28 35 3 43 11 51 19 59 27 34 2 42 10 50 18 58 26 33 1 41 9 49 17 57 25]) (defconst ntlm-smb-sc [1 1 2 2 2 2 2 2 1 2 2 2 2 2 2 1]) (defconst ntlm-smb-sbox [[[14 4 13 1 2 15 11 8 3 10 6 12 5 9 0 7] [ 0 15 7 4 14 2 13 1 10 6 12 11 9 5 3 8] [ 4 1 14 8 13 6 2 11 15 12 9 7 3 10 5 0] [15 12 8 2 4 9 1 7 5 11 3 14 10 0 6 13]] [[15 1 8 14 6 11 3 4 9 7 2 13 12 0 5 10] [ 3 13 4 7 15 2 8 14 12 0 1 10 6 9 11 5] [ 0 14 7 11 10 4 13 1 5 8 12 6 9 3 2 15] [13 8 10 1 3 15 4 2 11 6 7 12 0 5 14 9]] [[10 0 9 14 6 3 15 5 1 13 12 7 11 4 2 8] [13 7 0 9 3 4 6 10 2 8 5 14 12 11 15 1] [13 6 4 9 8 15 3 0 11 1 2 12 5 10 14 7] [ 1 10 13 0 6 9 8 7 4 15 14 3 11 5 2 12]] [[ 7 13 14 3 0 6 9 10 1 2 8 5 11 12 4 15] [13 8 11 5 6 15 0 3 4 7 2 12 1 10 14 9] [10 6 9 0 12 11 7 13 15 1 3 14 5 2 8 4] [ 3 15 0 6 10 1 13 8 9 4 5 11 12 7 2 14]] [[ 2 12 4 1 7 10 11 6 8 5 3 15 13 0 14 9] [14 11 2 12 4 7 13 1 5 0 15 10 3 9 8 6] [ 4 2 1 11 10 13 7 8 15 9 12 5 6 3 0 14] [11 8 12 7 1 14 2 13 6 15 0 9 10 4 5 3]] [[12 1 10 15 9 2 6 8 0 13 3 4 14 7 5 11] [10 15 4 2 7 12 9 5 6 1 13 14 0 11 3 8] [ 9 14 15 5 2 8 12 3 7 0 4 10 1 13 11 6] [ 4 3 2 12 9 5 15 10 11 14 1 7 6 0 8 13]] [[ 4 11 2 14 15 0 8 13 3 12 9 7 5 10 6 1] [13 0 11 7 4 9 1 10 14 3 5 12 2 15 8 6] [ 1 4 11 13 12 3 7 14 10 15 6 8 0 5 9 2] [ 6 11 13 8 1 4 10 7 9 5 0 15 14 2 3 12]] [[13 2 8 4 6 15 11 1 10 9 3 14 5 0 12 7] [ 1 15 13 8 10 3 7 4 12 5 6 11 0 14 9 2] [ 7 11 4 1 9 12 14 2 0 6 10 13 15 3 5 8] [ 2 1 14 7 4 10 8 13 15 12 9 0 3 5 6 11]]]) (defsubst ntlm-string-permute (in perm n) "Return a string of length N for a string IN and a permutation vector PERM of size N. The length of IN should be height of PERM." (let ((i 0) (out (make-string n 0))) (while (< i n) (aset out i (aref in (- (aref perm i) 1))) (setq i (1+ i))) out)) (defsubst ntlm-string-lshift (str count len) "Return a string by circularly shifting a string STR by COUNT to the left. length of STR is LEN." (let ((c (% count len))) (concat (substring str c len) (substring str 0 c)))) (defsubst ntlm-string-xor (in1 in2 n) "Return exclusive-or of sequences in1 and in2" (let ((w (make-string n 0)) (i 0)) (while (< i n) (aset w i (logxor (aref in1 i) (aref in2 i))) (setq i (1+ i))) w)) (defun ntlm-smb-dohash (in key forw) "Return the hash value for a string IN and a string KEY. Length of IN and KEY are 64. FORW non nill means forward, nil means backward." (let (pk1 ;string of length 56 c ;string of length 28 d ;string of length 28 cd ;string of length 56 (ki (make-vector 16 0)) ;vector of string of length 48 pd1 ;string of length 64 l ;string of length 32 r ;string of length 32 rl ;string of length 64 (i 0) (j 0) (k 0)) (setq pk1 (ntlm-string-permute key ntlm-smb-perm1 56)) (setq c (substring pk1 0 28)) (setq d (substring pk1 28 56)) (setq i 0) (while (< i 16) (setq c (ntlm-string-lshift c (aref ntlm-smb-sc i) 28)) (setq d (ntlm-string-lshift d (aref ntlm-smb-sc i) 28)) (setq cd (concat (substring c 0 28) (substring d 0 28))) (aset ki i (ntlm-string-permute cd ntlm-smb-perm2 48)) (setq i (1+ i))) (setq pd1 (ntlm-string-permute in ntlm-smb-perm3 64)) (setq l (substring pd1 0 32)) (setq r (substring pd1 32 64)) (setq i 0) (let (er ;string of length 48 erk ;string of length 48 (b (make-vector 8 0)) ;vector of strings of length 6 cb ;string of length 32 pcb ;string of length 32 r2 ;string of length 32 jj m n bj sbox-jmn) (while (< i 16) (setq er (ntlm-string-permute r ntlm-smb-perm4 48)) (setq erk (ntlm-string-xor er (aref ki (if forw i (- 15 i))) 48)) (setq j 0) (while (< j 8) (setq jj (* 6 j)) (aset b j (substring erk jj (+ jj 6))) (setq j (1+ j))) (setq j 0) (while (< j 8) (setq bj (aref b j)) (setq m (logior (lsh (aref bj 0) 1) (aref bj 5))) (setq n (logior (lsh (aref bj 1) 3) (lsh (aref bj 2) 2) (lsh (aref bj 3) 1) (aref bj 4))) (setq k 0) (setq sbox-jmn (aref (aref (aref ntlm-smb-sbox j) m) n)) (while (< k 4) (aset bj k (if (zerop (logand sbox-jmn (lsh 1 (- 3 k)))) 0 1)) (setq k (1+ k))) (setq j (1+ j))) (setq j 0) (setq cb nil) (while (< j 8) (setq cb (concat cb (substring (aref b j) 0 4))) (setq j (1+ j))) (setq pcb (ntlm-string-permute cb ntlm-smb-perm5 32)) (setq r2 (ntlm-string-xor l pcb 32)) (setq l r) (setq r r2) (setq i (1+ i)))) (setq rl (concat r l)) (ntlm-string-permute rl ntlm-smb-perm6 64))) (defun ntlm-md4hash (passwd) "Return the 16 bytes MD4 hash of a string PASSWD after converting it into a Unicode string. PASSWD is truncated to 128 bytes if longer." (let (len wpwd) ;; Password cannot be longer than 128 characters (setq len (length passwd)) (if (> len 128) (setq len 128)) ;; Password must be converted to NT unicode (setq wpwd (ntlm-ascii2unicode passwd len)) ;; Calculate length in bytes (setq len (* len 2)) (md4 wpwd len))) (provide 'ntlm) ;; arch-tag: 348ace18-f8e2-4176-8fe9-d9ab4e96f296 ;;; ntlm.el ends here gnus-5.11+v0.10.dfsg/lisp/sieve-manage.el0000644000175000017500000006002711004005110020111 0ustar tvainikatvainika;;; sieve-manage.el --- Implementation of the managesive protocol in elisp ;; Copyright (C) 2001, 2002, 2003, 2004, 2005, ;; 2006, 2007, 2008 Free Software Foundation, Inc. ;; Author: Simon Josefsson ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 3, or (at your option) ;; any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Commentary: ;; This library provides an elisp API for the managesieve network ;; protocol. ;; ;; It uses the SASL library for authentication, which means it ;; supports DIGEST-MD5, CRAM-MD5, SCRAM-MD5, NTLM, PLAIN and LOGIN ;; methods. STARTTLS is not well tested, but should be easy to get to ;; work if someone wants. ;; ;; The API should be fairly obvious for anyone familiar with the ;; managesieve protocol, interface functions include: ;; ;; `sieve-manage-open' ;; open connection to managesieve server, returning a buffer to be ;; used by all other API functions. ;; ;; `sieve-manage-opened' ;; check if a server is open or not ;; ;; `sieve-manage-close' ;; close a server connection. ;; ;; `sieve-manage-authenticate' ;; `sieve-manage-listscripts' ;; `sieve-manage-deletescript' ;; `sieve-manage-getscript' ;; performs managesieve protocol actions ;; ;; and that's it. Example of a managesieve session in *scratch*: ;; ;; (setq my-buf (sieve-manage-open "my.server.com")) ;; " *sieve* my.server.com:2000*" ;; ;; (sieve-manage-authenticate "myusername" "mypassword" my-buf) ;; 'auth ;; ;; (sieve-manage-listscripts my-buf) ;; ("vacation" "testscript" ("splitmail") "badscript") ;; ;; References: ;; ;; draft-martin-managesieve-02.txt, ;; "A Protocol for Remotely Managing Sieve Scripts", ;; by Tim Martin. ;; ;; Release history: ;; ;; 2001-10-31 Committed to Oort Gnus. ;; 2002-07-27 Added DELETESCRIPT. Suggested by Ned Ludd. ;; 2002-08-03 Use SASL library. ;;; Code: ;; For Emacs < 22.2. (eval-and-compile (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) (if (locate-library "password-cache") (require 'password-cache) (require 'password)) (eval-when-compile (require 'sasl) (require 'starttls)) (eval-and-compile (autoload 'sasl-find-mechanism "sasl") (autoload 'starttls-open-stream "starttls")) ;; User customizable variables: (defgroup sieve-manage nil "Low-level Managesieve protocol issues." :group 'mail :prefix "sieve-") (defcustom sieve-manage-log "*sieve-manage-log*" "Name of buffer for managesieve session trace." :type 'string :group 'sieve-manage) (defcustom sieve-manage-default-user (user-login-name) "Default username to use." :type 'string :group 'sieve-manage) (defcustom sieve-manage-server-eol "\r\n" "The EOL string sent from the server." :type 'string :group 'sieve-manage) (defcustom sieve-manage-client-eol "\r\n" "The EOL string we send to the server." :type 'string :group 'sieve-manage) (defcustom sieve-manage-streams '(network starttls shell) "Priority of streams to consider when opening connection to server." :group 'sieve-manage) (defcustom sieve-manage-stream-alist '((network sieve-manage-network-p sieve-manage-network-open) (shell sieve-manage-shell-p sieve-manage-shell-open) (starttls sieve-manage-starttls-p sieve-manage-starttls-open)) "Definition of network streams. \(NAME CHECK OPEN) NAME names the stream, CHECK is a function returning non-nil if the server support the stream and OPEN is a function for opening the stream." :group 'sieve-manage) (defcustom sieve-manage-authenticators '(digest-md5 cram-md5 scram-md5 ntlm plain login) "Priority of authenticators to consider when authenticating to server." :group 'sieve-manage) (defcustom sieve-manage-authenticator-alist '((cram-md5 sieve-manage-cram-md5-p sieve-manage-cram-md5-auth) (digest-md5 sieve-manage-digest-md5-p sieve-manage-digest-md5-auth) (scram-md5 sieve-manage-scram-md5-p sieve-manage-scram-md5-auth) (ntlm sieve-manage-ntlm-p sieve-manage-ntlm-auth) (plain sieve-manage-plain-p sieve-manage-plain-auth) (login sieve-manage-login-p sieve-manage-login-auth)) "Definition of authenticators. \(NAME CHECK AUTHENTICATE) NAME names the authenticator. CHECK is a function returning non-nil if the server support the authenticator and AUTHENTICATE is a function for doing the actual authentication." :group 'sieve-manage) (defcustom sieve-manage-default-port 2000 "Default port number for managesieve protocol." :type 'integer :group 'sieve-manage) ;; Internal variables: (defconst sieve-manage-local-variables '(sieve-manage-server sieve-manage-port sieve-manage-auth sieve-manage-stream sieve-manage-username sieve-manage-password sieve-manage-process sieve-manage-client-eol sieve-manage-server-eol sieve-manage-capability)) (defconst sieve-manage-default-stream 'network) (defconst sieve-manage-coding-system-for-read 'binary) (defconst sieve-manage-coding-system-for-write 'binary) (defvar sieve-manage-stream nil) (defvar sieve-manage-auth nil) (defvar sieve-manage-server nil) (defvar sieve-manage-port nil) (defvar sieve-manage-username nil) (defvar sieve-manage-password nil) (defvar sieve-manage-state 'closed "Managesieve state. Valid states are `closed', `initial', `nonauth', and `auth'.") (defvar sieve-manage-process nil) (defvar sieve-manage-capability nil) ;; Internal utility functions (defsubst sieve-manage-disable-multibyte () "Enable multibyte in the current buffer." (when (fboundp 'set-buffer-multibyte) (set-buffer-multibyte nil))) (declare-function password-read "password-cache" (prompt &optional key)) (declare-function password-cache-add "password-cache" (key password)) (declare-function password-cache-remove "password-cache" (key)) ;; Uses the dynamically bound `reason' variable. (defvar reason) (defun sieve-manage-interactive-login (buffer loginfunc) "Login to server in BUFFER. LOGINFUNC is passed a username and a password, it should return t if it was successful authenticating itself to the server, nil otherwise. Returns t if login was successful, nil otherwise." (with-current-buffer buffer (make-local-variable 'sieve-manage-username) (make-local-variable 'sieve-manage-password) (let (user passwd ret reason passwd-key) (condition-case () (while (or (not user) (not passwd)) (setq user (or sieve-manage-username (read-from-minibuffer (concat "Managesieve username for " sieve-manage-server ": ") (or user sieve-manage-default-user))) passwd-key (concat "managesieve:" user "@" sieve-manage-server ":" sieve-manage-port) passwd (or sieve-manage-password (password-read (concat "Managesieve password for " user "@" sieve-manage-server ": ") passwd-key))) (when (y-or-n-p "Store password for this session? ") (password-cache-add passwd-key (copy-sequence passwd))) (when (and user passwd) (if (funcall loginfunc user passwd) (setq ret t sieve-manage-username user) (if reason (message "Login failed (reason given: %s)..." reason) (message "Login failed...")) (password-cache-remove passwd-key) (setq sieve-manage-password nil) (setq passwd nil) (setq reason nil) (sit-for 1)))) (quit (with-current-buffer buffer (password-cache-remove passwd-key) (setq user nil passwd nil sieve-manage-password nil))) (error (with-current-buffer buffer (password-cache-remove passwd-key) (setq user nil passwd nil sieve-manage-password nil)))) ret))) (defun sieve-manage-erase (&optional p buffer) (let ((buffer (or buffer (current-buffer)))) (and sieve-manage-log (with-current-buffer (get-buffer-create sieve-manage-log) (sieve-manage-disable-multibyte) (buffer-disable-undo) (goto-char (point-max)) (insert-buffer-substring buffer (with-current-buffer buffer (point-min)) (or p (with-current-buffer buffer (point-max))))))) (delete-region (point-min) (or p (point-max)))) (defun sieve-manage-open-1 (buffer) (with-current-buffer buffer (sieve-manage-erase) (setq sieve-manage-state 'initial sieve-manage-process (condition-case () (funcall (nth 2 (assq sieve-manage-stream sieve-manage-stream-alist)) "sieve" buffer sieve-manage-server sieve-manage-port) ((error quit) nil))) (when sieve-manage-process (while (and (eq sieve-manage-state 'initial) (memq (process-status sieve-manage-process) '(open run))) (message "Waiting for response from %s..." sieve-manage-server) (accept-process-output sieve-manage-process 1)) (message "Waiting for response from %s...done" sieve-manage-server) (and (memq (process-status sieve-manage-process) '(open run)) sieve-manage-process)))) ;; Streams (defun sieve-manage-network-p (buffer) t) (defun sieve-manage-network-open (name buffer server port) (let* ((port (or port sieve-manage-default-port)) (coding-system-for-read sieve-manage-coding-system-for-read) (coding-system-for-write sieve-manage-coding-system-for-write) (process (open-network-stream name buffer server port))) (when process (while (and (memq (process-status process) '(open run)) (set-buffer buffer) ;; XXX "blue moon" nntp.el bug (goto-char (point-min)) (not (sieve-manage-parse-greeting-1))) (accept-process-output process 1) (sit-for 1)) (sieve-manage-erase nil buffer) (when (memq (process-status process) '(open run)) process)))) (defun imap-starttls-p (buffer) ;; (and (imap-capability 'STARTTLS buffer) (condition-case () (progn (require 'starttls) (call-process "starttls")) (error nil))) (defun imap-starttls-open (name buffer server port) (let* ((port (or port sieve-manage-default-port)) (coding-system-for-read sieve-manage-coding-system-for-read) (coding-system-for-write sieve-manage-coding-system-for-write) (process (starttls-open-stream name buffer server port)) done) (when process (while (and (memq (process-status process) '(open run)) (set-buffer buffer) ;; XXX "blue moon" nntp.el bug (goto-char (point-min)) (not (sieve-manage-parse-greeting-1))) (accept-process-output process 1) (sit-for 1)) (sieve-manage-erase nil buffer) (sieve-manage-send "STARTTLS") (starttls-negotiate process)) (when (memq (process-status process) '(open run)) process))) ;; Authenticators (defun sieve-sasl-auth (buffer mech) "Login to server using the SASL MECH method." (message "sieve: Authenticating using %s..." mech) (if (sieve-manage-interactive-login buffer (lambda (user passwd) (let (client step tag data rsp) (setq client (sasl-make-client (sasl-find-mechanism (list mech)) user "sieve" sieve-manage-server)) (setq sasl-read-passphrase (function (lambda (prompt) passwd))) (setq step (sasl-next-step client nil)) (setq tag (sieve-manage-send (concat "AUTHENTICATE \"" mech "\"" (and (sasl-step-data step) (concat " \"" (base64-encode-string (sasl-step-data step) 'no-line-break) "\""))))) (catch 'done (while t (setq rsp nil) (goto-char (point-min)) (while (null (or (progn (setq rsp (sieve-manage-is-string)) (if (not (and rsp (looking-at sieve-manage-server-eol))) (setq rsp nil) (goto-char (match-end 0)) rsp)) (setq rsp (sieve-manage-is-okno)))) (accept-process-output sieve-manage-process 1) (goto-char (point-min))) (sieve-manage-erase) (when (sieve-manage-ok-p rsp) (when (string-match "^SASL \"\\([^\"]+\\)\"" (cadr rsp)) (sasl-step-set-data step (base64-decode-string (match-string 1 (cadr rsp))))) (if (and (setq step (sasl-next-step client step)) (setq data (sasl-step-data step))) ;; We got data for server but it's finished (error "Server not ready for SASL data: %s" data) ;; The authentication process is finished. (throw 'done t))) (unless (stringp rsp) (apply 'error "Server aborted SASL authentication: %s %s %s" rsp)) (sasl-step-set-data step (base64-decode-string rsp)) (setq step (sasl-next-step client step)) (sieve-manage-send (if (sasl-step-data step) (concat "\"" (base64-encode-string (sasl-step-data step) 'no-line-break) "\"") ""))))))) (message "sieve: Authenticating using %s...done" mech) (message "sieve: Authenticating using %s...failed" mech))) (defun sieve-manage-cram-md5-p (buffer) (sieve-manage-capability "SASL" "CRAM-MD5" buffer)) (defun sieve-manage-cram-md5-auth (buffer) "Login to managesieve server using the CRAM-MD5 SASL method." (sieve-sasl-auth buffer "CRAM-MD5")) (defun sieve-manage-digest-md5-p (buffer) (sieve-manage-capability "SASL" "DIGEST-MD5" buffer)) (defun sieve-manage-digest-md5-auth (buffer) "Login to managesieve server using the DIGEST-MD5 SASL method." (sieve-sasl-auth buffer "DIGEST-MD5")) (defun sieve-manage-scram-md5-p (buffer) (sieve-manage-capability "SASL" "SCRAM-MD5" buffer)) (defun sieve-manage-scram-md5-auth (buffer) "Login to managesieve server using the SCRAM-MD5 SASL method." (sieve-sasl-auth buffer "SCRAM-MD5")) (defun sieve-manage-ntlm-p (buffer) (sieve-manage-capability "SASL" "NTLM" buffer)) (defun sieve-manage-ntlm-auth (buffer) "Login to managesieve server using the NTLM SASL method." (sieve-sasl-auth buffer "NTLM")) (defun sieve-manage-plain-p (buffer) (sieve-manage-capability "SASL" "PLAIN" buffer)) (defun sieve-manage-plain-auth (buffer) "Login to managesieve server using the PLAIN SASL method." (sieve-sasl-auth buffer "PLAIN")) (defun sieve-manage-login-p (buffer) (sieve-manage-capability "SASL" "LOGIN" buffer)) (defun sieve-manage-login-auth (buffer) "Login to managesieve server using the LOGIN SASL method." (sieve-sasl-auth buffer "LOGIN")) ;; Managesieve API (defun sieve-manage-open (server &optional port stream auth buffer) "Open a network connection to a managesieve SERVER (string). Optional variable PORT is port number (integer) on remote server. Optional variable STREAM is any of `sieve-manage-streams' (a symbol). Optional variable AUTH indicates authenticator to use, see `sieve-manage-authenticators' for available authenticators. If nil, chooses the best stream the server is capable of. Optional variable BUFFER is buffer (buffer, or string naming buffer) to work in." (setq buffer (or buffer (format " *sieve* %s:%d" server (or port 2000)))) (with-current-buffer (get-buffer-create buffer) (mapc 'make-local-variable sieve-manage-local-variables) (sieve-manage-disable-multibyte) (buffer-disable-undo) (setq sieve-manage-server (or server sieve-manage-server)) (setq sieve-manage-port (or port sieve-manage-port)) (setq sieve-manage-stream (or stream sieve-manage-stream)) (message "sieve: Connecting to %s..." sieve-manage-server) (if (let ((sieve-manage-stream (or sieve-manage-stream sieve-manage-default-stream))) (sieve-manage-open-1 buffer)) ;; Choose stream. (let (stream-changed) (message "sieve: Connecting to %s...done" sieve-manage-server) (when (null sieve-manage-stream) (let ((streams sieve-manage-streams)) (while (setq stream (pop streams)) (if (funcall (nth 1 (assq stream sieve-manage-stream-alist)) buffer) (setq stream-changed (not (eq (or sieve-manage-stream sieve-manage-default-stream) stream)) sieve-manage-stream stream streams nil))) (unless sieve-manage-stream (error "Couldn't figure out a stream for server")))) (when stream-changed (message "sieve: Reconnecting with stream `%s'..." sieve-manage-stream) (sieve-manage-close buffer) (if (sieve-manage-open-1 buffer) (message "sieve: Reconnecting with stream `%s'...done" sieve-manage-stream) (message "sieve: Reconnecting with stream `%s'...failed" sieve-manage-stream)) (setq sieve-manage-capability nil)) (if (sieve-manage-opened buffer) ;; Choose authenticator (when (and (null sieve-manage-auth) (not (eq sieve-manage-state 'auth))) (let ((auths sieve-manage-authenticators)) (while (setq auth (pop auths)) (if (funcall (nth 1 (assq auth sieve-manage-authenticator-alist)) buffer) (setq sieve-manage-auth auth auths nil))) (unless sieve-manage-auth (error "Couldn't figure out authenticator for server")))))) (message "sieve: Connecting to %s...failed" sieve-manage-server)) (when (sieve-manage-opened buffer) (sieve-manage-erase) buffer))) (defun sieve-manage-opened (&optional buffer) "Return non-nil if connection to managesieve server in BUFFER is open. If BUFFER is nil then the current buffer is used." (and (setq buffer (get-buffer (or buffer (current-buffer)))) (buffer-live-p buffer) (with-current-buffer buffer (and sieve-manage-process (memq (process-status sieve-manage-process) '(open run)))))) (defun sieve-manage-close (&optional buffer) "Close connection to managesieve server in BUFFER. If BUFFER is nil, the current buffer is used." (with-current-buffer (or buffer (current-buffer)) (when (sieve-manage-opened) (sieve-manage-send "LOGOUT") (sit-for 1)) (when (and sieve-manage-process (memq (process-status sieve-manage-process) '(open run))) (delete-process sieve-manage-process)) (setq sieve-manage-process nil) (sieve-manage-erase) t)) (defun sieve-manage-authenticate (&optional user passwd buffer) "Authenticate to server in BUFFER, using current buffer if nil. It uses the authenticator specified when opening the server. If the authenticator requires username/passwords, they are queried from the user and optionally stored in the buffer. If USER and/or PASSWD is specified, the user will not be questioned and the username and/or password is remembered in the buffer." (with-current-buffer (or buffer (current-buffer)) (if (not (eq sieve-manage-state 'nonauth)) (eq sieve-manage-state 'auth) (make-local-variable 'sieve-manage-username) (make-local-variable 'sieve-manage-password) (if user (setq sieve-manage-username user)) (if passwd (setq sieve-manage-password passwd)) (if (funcall (nth 2 (assq sieve-manage-auth sieve-manage-authenticator-alist)) buffer) (setq sieve-manage-state 'auth))))) (defun sieve-manage-capability (&optional name value buffer) (with-current-buffer (or buffer (current-buffer)) (if (null name) sieve-manage-capability (if (null value) (nth 1 (assoc name sieve-manage-capability)) (when (string-match value (nth 1 (assoc name sieve-manage-capability))) (nth 1 (assoc name sieve-manage-capability))))))) (defun sieve-manage-listscripts (&optional buffer) (with-current-buffer (or buffer (current-buffer)) (sieve-manage-send "LISTSCRIPTS") (sieve-manage-parse-listscripts))) (defun sieve-manage-havespace (name size &optional buffer) (with-current-buffer (or buffer (current-buffer)) (sieve-manage-send (format "HAVESPACE \"%s\" %s" name size)) (sieve-manage-parse-okno))) (eval-and-compile (if (fboundp 'string-bytes) (defalias 'sieve-string-bytes 'string-bytes) (defalias 'sieve-string-bytes 'length))) (defun sieve-manage-putscript (name content &optional buffer) (with-current-buffer (or buffer (current-buffer)) (sieve-manage-send (format "PUTSCRIPT \"%s\" {%d+}%s%s" name (sieve-string-bytes content) sieve-manage-client-eol content)) (sieve-manage-parse-okno))) (defun sieve-manage-deletescript (name &optional buffer) (with-current-buffer (or buffer (current-buffer)) (sieve-manage-send (format "DELETESCRIPT \"%s\"" name)) (sieve-manage-parse-okno))) (defun sieve-manage-getscript (name output-buffer &optional buffer) (with-current-buffer (or buffer (current-buffer)) (sieve-manage-send (format "GETSCRIPT \"%s\"" name)) (let ((script (sieve-manage-parse-string))) (sieve-manage-parse-crlf) (with-current-buffer output-buffer (insert script)) (sieve-manage-parse-okno)))) (defun sieve-manage-setactive (name &optional buffer) (with-current-buffer (or buffer (current-buffer)) (sieve-manage-send (format "SETACTIVE \"%s\"" name)) (sieve-manage-parse-okno))) ;; Protocol parsing routines (defun sieve-manage-ok-p (rsp) (string= (downcase (or (car-safe rsp) "")) "ok")) (defsubst sieve-manage-forward () (or (eobp) (forward-char))) (defun sieve-manage-is-okno () (when (looking-at (concat "^\\(OK\\|NO\\)\\( (\\([^)]+\\))\\)?\\( \\(.*\\)\\)?" sieve-manage-server-eol)) (let ((status (match-string 1)) (resp-code (match-string 3)) (response (match-string 5))) (when response (goto-char (match-beginning 5)) (setq response (sieve-manage-is-string))) (list status resp-code response)))) (defun sieve-manage-parse-okno () (let (rsp) (while (null rsp) (accept-process-output (get-buffer-process (current-buffer)) 1) (goto-char (point-min)) (setq rsp (sieve-manage-is-okno))) (sieve-manage-erase) rsp)) (defun sieve-manage-parse-capability-1 () "Accept a managesieve greeting." (let (str) (while (setq str (sieve-manage-is-string)) (if (eq (char-after) ? ) (progn (sieve-manage-forward) (push (list str (sieve-manage-is-string)) sieve-manage-capability)) (push (list str) sieve-manage-capability)) (forward-line))) (when (re-search-forward (concat "^OK" sieve-manage-server-eol) nil t) (setq sieve-manage-state 'nonauth))) (defalias 'sieve-manage-parse-greeting-1 'sieve-manage-parse-capability-1) (defun sieve-manage-is-string () (cond ((looking-at "\"\\([^\"]+\\)\"") (prog1 (match-string 1) (goto-char (match-end 0)))) ((looking-at (concat "{\\([0-9]+\\)}" sieve-manage-server-eol)) (let ((pos (match-end 0)) (len (string-to-number (match-string 1)))) (if (< (point-max) (+ pos len)) nil (goto-char (+ pos len)) (buffer-substring pos (+ pos len))))))) (defun sieve-manage-parse-string () (let (rsp) (while (null rsp) (accept-process-output (get-buffer-process (current-buffer)) 1) (goto-char (point-min)) (setq rsp (sieve-manage-is-string))) (sieve-manage-erase (point)) rsp)) (defun sieve-manage-parse-crlf () (when (looking-at sieve-manage-server-eol) (sieve-manage-erase (match-end 0)))) (defun sieve-manage-parse-listscripts () (let (tmp rsp data) (while (null rsp) (while (null (or (setq rsp (sieve-manage-is-okno)) (setq tmp (sieve-manage-is-string)))) (accept-process-output (get-buffer-process (current-buffer)) 1) (goto-char (point-min))) (when tmp (while (not (looking-at (concat "\\( ACTIVE\\)?" sieve-manage-server-eol))) (accept-process-output (get-buffer-process (current-buffer)) 1) (goto-char (point-min))) (if (match-string 1) (push (cons 'active tmp) data) (push tmp data)) (goto-char (match-end 0)) (setq tmp nil))) (sieve-manage-erase) (if (sieve-manage-ok-p rsp) data rsp))) (defun sieve-manage-send (cmdstr) (setq cmdstr (concat cmdstr sieve-manage-client-eol)) (and sieve-manage-log (with-current-buffer (get-buffer-create sieve-manage-log) (sieve-manage-disable-multibyte) (buffer-disable-undo) (goto-char (point-max)) (insert cmdstr))) (process-send-string sieve-manage-process cmdstr)) (provide 'sieve-manage) ;; arch-tag: 321c4640-1371-4495-9baf-8ccb71dd5bd1 ;; sieve-manage.el ends here gnus-5.11+v0.10.dfsg/lisp/smiley.el0000644000175000017500000001652711004005111017061 0ustar tvainikatvainika;;; smiley.el --- displaying smiley faces ;; Copyright (C) 2000, 2001, 2002, 2003, 2004, ;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc. ;; Author: Dave Love ;; Keywords: news mail multimedia ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 3, or (at your option) ;; any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Commentary: ;; A re-written, simplified version of Wes Hardaker's XEmacs smiley.el ;; which might be merged back to smiley.el if we get an assignment for ;; that. We don't have assignments for the images smiley.el uses, but ;; I'm not sure we need that degree of rococoness and defaults like a ;; yellow background. Also, using PBM means we can display the images ;; more generally. -- fx ;; `smiley.el' was replaced by `smiley-ems.el' on 2002-01-26 (after fx' ;; comment). ;; Test smileys: ;; smile ^:-) ^:) ;; blink ;-) ;) ;; forced :-] ;; braindamaged 8-) ;; indifferent :-| ;; wry :-/ :-\ ;; sad :-( ;; frown :-{ ;; evil >:-) ;; cry ;-( ;; dead X-) ;; grin :-D ;;; Code: (eval-when-compile (require 'cl)) (require 'nnheader) (require 'gnus-art) (defgroup smiley nil "Turn :-)'s into real images." :group 'gnus-visual) (defvar smiley-data-directory) (defcustom smiley-style (if (or (and (fboundp 'face-attribute) (>= (face-attribute 'default :height) 160)) (and (fboundp 'face-height) (>= (face-height 'default) 14))) 'medium 'low-color) "Smiley style." :type '(choice (const :tag "small, 3 colors" low-color) ;; 13x14 (const :tag "medium, ~10 colors" medium) ;; 16x16 (const :tag "dull, grayscale" grayscale));; 14x14 :set (lambda (symbol value) (set-default symbol value) (setq smiley-data-directory (smiley-directory)) (smiley-update-cache)) :initialize 'custom-initialize-default :version "23.1" ;; No Gnus :group 'smiley) ;; For compatibility, honor the variable `smiley-data-directory' if the user ;; has set it. (defun smiley-directory (&optional style) "Return a the location of the smiley faces files. STYLE specifies which style to use, see `smiley-style'. If STYLE is nil, use `smiley-style'." (unless style (setq style smiley-style)) (nnheader-find-etc-directory (concat "images/smilies" (cond ((eq smiley-style 'low-color) "") ((eq smiley-style 'medium) "/medium") ((eq smiley-style 'grayscale) "/grayscale"))))) (defcustom smiley-data-directory (smiley-directory) "*Location of the smiley faces files." :set (lambda (symbol value) (set-default symbol value) (smiley-update-cache)) :initialize 'custom-initialize-default :type 'directory :group 'smiley) ;; The XEmacs version has a baroque, if not rococo, set of these. (defcustom smiley-regexp-alist '(("\\(;-?)\\)\\W" 1 "blink") ("\\(:-]\\)\\W" 1 "forced") ("\\(8-)\\)\\W" 1 "braindamaged") ("\\(:-|\\)\\W" 1 "indifferent") ("\\(:-[/\\]\\)\\W" 1 "wry") ("\\(:-(\\)\\W" 1 "sad") ("\\(X-)\\)\\W" 1 "dead") ("\\(:-{\\)\\W" 1 "frown") ("\\(>:-)\\)\\W" 1 "evil") ("\\(;-(\\)\\W" 1 "cry") ("\\(:-D\\)\\W" 1 "grin") ;; "smile" must be come after "evil" ("\\(\\^?:-?)\\)\\W" 1 "smile")) "*A list of regexps to map smilies to images. The elements are (REGEXP MATCH IMAGE), where MATCH is the submatch in regexp to replace with IMAGE. IMAGE is the name of an image file in `smiley-data-directory'." :type '(repeat (list regexp (integer :tag "Regexp match number") (string :tag "Image name"))) :set (lambda (symbol value) (set-default symbol value) (smiley-update-cache)) :initialize 'custom-initialize-default :group 'smiley) (defcustom gnus-smiley-file-types (let ((types (list "pbm"))) (when (gnus-image-type-available-p 'xpm) (push "xpm" types)) types) "*List of suffixes on smiley file names to try." :version "22.1" :type '(repeat string) :group 'smiley) (defvar smiley-cached-regexp-alist nil) (defun smiley-update-cache () (setq smiley-cached-regexp-alist nil) (dolist (elt (if (symbolp smiley-regexp-alist) (symbol-value smiley-regexp-alist) smiley-regexp-alist)) (let ((types gnus-smiley-file-types) file type) (while (and (not file) (setq type (pop types))) (unless (file-exists-p (setq file (expand-file-name (concat (nth 2 elt) "." type) smiley-data-directory))) (setq file nil))) (when type (let ((image (gnus-create-image file (intern type) nil :ascent 'center))) (when image (push (list (car elt) (cadr elt) image) smiley-cached-regexp-alist))))))) ;; Not implemented: ;; (defvar smiley-mouse-map ;; (let ((map (make-sparse-keymap))) ;; (define-key map [down-mouse-2] 'ignore) ; override widget ;; (define-key map [mouse-2] ;; 'smiley-mouse-toggle-buffer) ;; map)) ;;;###autoload (defun smiley-region (start end) "Replace in the region `smiley-regexp-alist' matches with corresponding images. A list of images is returned." (interactive "r") (when (gnus-graphic-display-p) (unless smiley-cached-regexp-alist (smiley-update-cache)) (save-excursion (let ((beg (or start (point-min))) group image images string) (dolist (entry smiley-cached-regexp-alist) (setq group (nth 1 entry) image (nth 2 entry)) (goto-char beg) (while (re-search-forward (car entry) end t) (setq string (match-string group)) (goto-char (match-end group)) (delete-region (match-beginning group) (match-end group)) (when image (push image images) (gnus-add-wash-type 'smiley) (gnus-add-image 'smiley image) (gnus-put-image image string 'smiley)))) images)))) ;;;###autoload (defun smiley-buffer (&optional buffer) "Run `smiley-region' at the buffer, specified in the argument or interactively. If there's no argument, do it at the current buffer" (interactive "bBuffer to run smiley-region: ") (save-excursion (if buffer (set-buffer (get-buffer buffer))) (smiley-region (point-min) (point-max)))) (defun smiley-toggle-buffer (&optional arg) "Toggle displaying smiley faces in article buffer. With arg, turn displaying on if and only if arg is positive." (interactive "P") (gnus-with-article-buffer (if (if (numberp arg) (> arg 0) (not (memq 'smiley gnus-article-wash-types))) (smiley-region (point-min) (point-max)) (gnus-delete-images 'smiley)))) (defun smiley-mouse-toggle-buffer (event) "Toggle displaying smiley faces. With arg, turn displaying on if and only if arg is positive." (interactive "e") (save-excursion (save-window-excursion (mouse-set-point event) (smiley-toggle-buffer)))) (provide 'smiley) ;; arch-tag: 5beb161b-4321-40af-8ac9-876afb8ee818 ;;; smiley.el ends here gnus-5.11+v0.10.dfsg/lisp/mm-url.el0000644000175000017500000003235011004005111016760 0ustar tvainikatvainika;;; mm-url.el --- a wrapper of url functions/commands for Gnus ;; Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc. ;; Author: Shenghuo Zhu ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published ;; by the Free Software Foundation; either version 3, or (at your ;; option) any later version. ;; GNU Emacs is distributed in the hope that it will be useful, but ;; WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Commentary: ;; Some codes are stolen from w3 and url packages. Some are moved from ;; nnweb. ;; TODO: Support POST, cookie. ;;; Code: (eval-when-compile (require 'cl)) (require 'mm-util) (require 'gnus) (defvar url-current-object) (defvar url-package-name) (defvar url-package-version) (defgroup mm-url nil "A wrapper of url package and external url command for Gnus." :group 'gnus) (defcustom mm-url-use-external (not (condition-case nil (require 'url) (error nil))) "*If non-nil, use external grab program `mm-url-program'." :version "22.1" :type 'boolean :group 'mm-url) (defvar mm-url-predefined-programs '((wget "wget" "--user-agent=mm-url" "-q" "-O" "-") (w3m "w3m" "-dump_source") (lynx "lynx" "-source") (curl "curl" "--silent" "--user-agent" "mm-url" "--location"))) (defcustom mm-url-program (cond ((executable-find "wget") 'wget) ((executable-find "w3m") 'w3m) ((executable-find "lynx") 'lynx) ((executable-find "curl") 'curl) (t "GET")) "The url grab program. Likely values are `wget', `w3m', `lynx' and `curl'." :version "22.1" :type '(choice (symbol :tag "wget" wget) (symbol :tag "w3m" w3m) (symbol :tag "lynx" lynx) (symbol :tag "curl" curl) (string :tag "other")) :group 'mm-url) (defcustom mm-url-arguments nil "The arguments for `mm-url-program'." :version "22.1" :type '(repeat string) :group 'mm-url) ;;; Internal variables (defvar mm-url-package-name (gnus-replace-in-string (gnus-replace-in-string gnus-version " v.*$" "") " " "-")) (defvar mm-url-package-version gnus-version-number) ;; Stolen from w3. (defvar mm-url-html-entities '( ;;(excl . 33) (quot . 34) ;;(num . 35) ;;(dollar . 36) ;;(percent . 37) (amp . 38) (rsquo . 39) ; should be U+8217 ;;(apos . 39) ;;(lpar . 40) ;;(rpar . 41) ;;(ast . 42) ;;(plus . 43) ;;(comma . 44) ;;(period . 46) ;;(colon . 58) ;;(semi . 59) (lt . 60) ;;(equals . 61) (gt . 62) ;;(quest . 63) ;;(commat . 64) ;;(lsqb . 91) ;;(rsqb . 93) (uarr . 94) ; should be U+8593 ;;(lowbar . 95) (lsquo . 96) ; should be U+8216 (lcub . 123) ;;(verbar . 124) (rcub . 125) (tilde . 126) (nbsp . 160) (iexcl . 161) (cent . 162) (pound . 163) (curren . 164) (yen . 165) (brvbar . 166) (sect . 167) (uml . 168) (copy . 169) (ordf . 170) (laquo . 171) (not . 172) (shy . 173) (reg . 174) (macr . 175) (deg . 176) (plusmn . 177) (sup2 . 178) (sup3 . 179) (acute . 180) (micro . 181) (para . 182) (middot . 183) (cedil . 184) (sup1 . 185) (ordm . 186) (raquo . 187) (frac14 . 188) (frac12 . 189) (frac34 . 190) (iquest . 191) (Agrave . 192) (Aacute . 193) (Acirc . 194) (Atilde . 195) (Auml . 196) (Aring . 197) (AElig . 198) (Ccedil . 199) (Egrave . 200) (Eacute . 201) (Ecirc . 202) (Euml . 203) (Igrave . 204) (Iacute . 205) (Icirc . 206) (Iuml . 207) (ETH . 208) (Ntilde . 209) (Ograve . 210) (Oacute . 211) (Ocirc . 212) (Otilde . 213) (Ouml . 214) (times . 215) (Oslash . 216) (Ugrave . 217) (Uacute . 218) (Ucirc . 219) (Uuml . 220) (Yacute . 221) (THORN . 222) (szlig . 223) (agrave . 224) (aacute . 225) (acirc . 226) (atilde . 227) (auml . 228) (aring . 229) (aelig . 230) (ccedil . 231) (egrave . 232) (eacute . 233) (ecirc . 234) (euml . 235) (igrave . 236) (iacute . 237) (icirc . 238) (iuml . 239) (eth . 240) (ntilde . 241) (ograve . 242) (oacute . 243) (ocirc . 244) (otilde . 245) (ouml . 246) (divide . 247) (oslash . 248) (ugrave . 249) (uacute . 250) (ucirc . 251) (uuml . 252) (yacute . 253) (thorn . 254) (yuml . 255) ;; Special handling of these (frac56 . "5/6") (frac16 . "1/6") (frac45 . "4/5") (frac35 . "3/5") (frac25 . "2/5") (frac15 . "1/5") (frac23 . "2/3") (frac13 . "1/3") (frac78 . "7/8") (frac58 . "5/8") (frac38 . "3/8") (frac18 . "1/8") ;; The following 5 entities are not mentioned in the HTML 2.0 ;; standard, nor in any other HTML proposed standard of which I ;; am aware. I am not even sure they are ISO entity names. *** ;; Hence, some arrangement should be made to give a bad HTML ;; message when they are seen. (ndash . 45) (mdash . 45) (emsp . 32) (ensp . 32) (sim . 126) (le . "<=") (agr . "alpha") (rdquo . "''") (ldquo . "``") (trade . "(TM)") ;; To be done ;; (shy . ????) ; soft hyphen ) "*An assoc list of entity names and how to actually display them.") (defconst mm-url-unreserved-chars '( ?a ?b ?c ?d ?e ?f ?g ?h ?i ?j ?k ?l ?m ?n ?o ?p ?q ?r ?s ?t ?u ?v ?w ?x ?y ?z ?A ?B ?C ?D ?E ?F ?G ?H ?I ?J ?K ?L ?M ?N ?O ?P ?Q ?R ?S ?T ?U ?V ?W ?X ?Y ?Z ?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9 ?- ?_ ?. ?! ?~ ?* ?' ?\( ?\)) "A list of characters that are _NOT_ reserved in the URL spec. This is taken from RFC 2396.") (defun mm-url-load-url () "Load `url-insert-file-contents'." (unless (condition-case () (progn (require 'url-handlers) (require 'url-parse) (require 'url-vars)) (error nil)) ;; w3-4.0pre0.46 or earlier version. (require 'w3-vars) (require 'url))) ;;;###autoload (defun mm-url-insert-file-contents (url) "Insert file contents of URL. If `mm-url-use-external' is non-nil, use `mm-url-program'." (if mm-url-use-external (progn (if (string-match "^file:/+" url) (insert-file-contents (substring url (1- (match-end 0)))) (mm-url-insert-file-contents-external url)) (goto-char (point-min)) (if (fboundp 'url-generic-parse-url) (setq url-current-object (url-generic-parse-url url))) (list url (buffer-size))) (mm-url-load-url) (let ((name buffer-file-name) (url-request-extra-headers ;; ISTM setting a Connection header was a workaround for ;; older versions of url included with w3, but it does more ;; harm than good with the one shipped with Emacs. --ansel (if (not (and (boundp 'url-version) (equal url-version "Emacs"))) (list (cons "Connection" "Close")))) (url-package-name (or mm-url-package-name url-package-name)) (url-package-version (or mm-url-package-version url-package-version)) result) (setq result (url-insert-file-contents url)) (save-excursion (goto-char (point-min)) (while (re-search-forward "\r 1000\r ?" nil t) (replace-match ""))) (setq buffer-file-name name) (if (and (fboundp 'url-generic-parse-url) (listp result)) (setq url-current-object (url-generic-parse-url (car result)))) result))) ;;;###autoload (defun mm-url-insert-file-contents-external (url) "Insert file contents of URL using `mm-url-program'." (let (program args) (if (symbolp mm-url-program) (let ((item (cdr (assq mm-url-program mm-url-predefined-programs)))) (setq program (car item) args (append (cdr item) (list url)))) (setq program mm-url-program args (append mm-url-arguments (list url)))) (unless (eq 0 (apply 'call-process program nil t nil args)) (error "Couldn't fetch %s" url)))) (defvar mm-url-timeout 30 "The number of seconds before timing out an URL fetch.") (defvar mm-url-retries 10 "The number of retries after timing out when fetching an URL.") (defun mm-url-insert (url &optional follow-refresh) "Insert the contents from an URL in the current buffer. If FOLLOW-REFRESH is non-nil, redirect refresh url in META." (let ((times mm-url-retries) (done nil) (first t) result) (while (and (not (zerop (decf times))) (not done)) (with-timeout (mm-url-timeout) (unless first (message "Trying again (%s)..." (- mm-url-retries times))) (setq first nil) (if follow-refresh (save-restriction (narrow-to-region (point) (point)) (mm-url-insert-file-contents url) (goto-char (point-min)) (when (re-search-forward "]*URL=\\([^\"]+\\)\"" nil t) (let ((url (match-string 1))) (delete-region (point-min) (point-max)) (setq result (mm-url-insert url t))))) (setq result (mm-url-insert-file-contents url))) (setq done t))) result)) (defun mm-url-decode-entities () "Decode all HTML entities." (goto-char (point-min)) (while (re-search-forward "&\\(#[0-9]+\\|[a-z]+[0-9]*\\);" nil t) (let ((elem (if (eq (aref (match-string 1) 0) ?\#) (let ((c (string-to-number (substring (match-string 1) 1)))) (if (mm-char-or-char-int-p c) c 32)) (or (cdr (assq (intern (match-string 1)) mm-url-html-entities)) ?#)))) (unless (stringp elem) (setq elem (char-to-string elem))) (replace-match elem t t)))) (defun mm-url-decode-entities-nbsp () "Decode all HTML entities and   to a space." (let ((mm-url-html-entities (cons '(nbsp . 32) mm-url-html-entities))) (mm-url-decode-entities))) (defun mm-url-decode-entities-string (string) (with-temp-buffer (insert string) (mm-url-decode-entities) (buffer-string))) (defun mm-url-form-encode-xwfu (chunk) "Escape characters in a string for application/x-www-form-urlencoded. Blasphemous crap because someone didn't think %20 was good enough for encoding spaces. Die Die Die." ;; This will get rid of the 'attributes' specified by the file type, ;; which are useless for an application/x-www-form-urlencoded form. (if (consp chunk) (setq chunk (cdr chunk))) (mapconcat (lambda (char) (cond ((= char ? ) "+") ((memq char mm-url-unreserved-chars) (char-to-string char)) (t (upcase (format "%%%02x" char))))) ;; Fixme: Should this actually be accepting multibyte? Is there a ;; better way in XEmacs? (if (featurep 'mule) (encode-coding-string chunk (if (fboundp 'find-coding-systems-string) (car (find-coding-systems-string chunk)) buffer-file-coding-system)) chunk) "")) (defun mm-url-encode-www-form-urlencoded (pairs) "Return PAIRS encoded for forms." (mapconcat (lambda (data) (concat (mm-url-form-encode-xwfu (car data)) "=" (mm-url-form-encode-xwfu (cdr data)))) pairs "&")) (defun mm-url-fetch-form (url pairs) "Fetch a form from URL with PAIRS as the data using the POST method." (mm-url-load-url) (let ((url-request-data (mm-url-encode-www-form-urlencoded pairs)) (url-request-method "POST") (url-request-extra-headers '(("Content-type" . "application/x-www-form-urlencoded")))) (url-insert-file-contents url) (setq buffer-file-name nil)) t) (defun mm-url-fetch-simple (url content) (mm-url-load-url) (let ((url-request-data content) (url-request-method "POST") (url-request-extra-headers '(("Content-type" . "application/x-www-form-urlencoded")))) (url-insert-file-contents url) (setq buffer-file-name nil)) t) (defun mm-url-remove-markup () "Remove all HTML markup, leaving just plain text." (goto-char (point-min)) (while (search-forward "" nil t) (point-max)))) (goto-char (point-min)) (while (re-search-forward "<[^>]+>" nil t) (replace-match "" t t))) (provide 'mm-url) ;; arch-tag: 0594f9b3-417c-48b0-adc2-5082e1e7917f ;;; mm-url.el ends here gnus-5.11+v0.10.dfsg/lisp/gnus-mh.el0000644000175000017500000000765411004005110017135 0ustar tvainikatvainika;;; gnus-mh.el --- mh-e interface for Gnus ;; Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, ;; 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc. ;; Author: Masanobu UMEDA ;; Lars Magne Ingebrigtsen ;; Keywords: news ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 3, or (at your option) ;; any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Commentary: ;;; Send mail using mh-e. ;; The following mh-e interface is all cooperative works of ;; tanaka@flab.fujitsu.CO.JP (TANAKA Hiroshi), kawabe@sra.CO.JP ;; (Yoshikatsu Kawabe), and shingu@casund.cpr.canon.co.jp (Toshiaki ;; SHINGU). ;;; Code: (require 'gnus) (require 'mh-e) (require 'mh-comp) (require 'gnus-msg) (require 'gnus-sum) (defvar mh-lib-progs) (defun gnus-summary-save-article-folder (&optional arg) "Append the current article to an mh folder. If N is a positive number, save the N next articles. If N is a negative number, save the N previous articles. If N is nil and any articles have been marked with the process mark, save those articles instead." (interactive "P") (require 'gnus-art) (let ((gnus-default-article-saver 'gnus-summary-save-in-folder)) (gnus-summary-save-article arg))) (defun gnus-summary-save-in-folder (&optional folder) "Save this article to MH folder (using `rcvstore' in MH library). Optional argument FOLDER specifies folder name." ;; Thanks to yuki@flab.Fujitsu.JUNET and ohm@kaba.junet. (mh-find-path) (let ((folder (cond ((and (eq folder 'default) gnus-newsgroup-last-folder) gnus-newsgroup-last-folder) (folder folder) (t (mh-prompt-for-folder "Save article in" (funcall gnus-folder-save-name gnus-newsgroup-name gnus-current-headers gnus-newsgroup-last-folder) t)))) (errbuf (gnus-get-buffer-create " *Gnus rcvstore*")) ;; Find the rcvstore program. (exec-path (cond ((and (boundp 'mh-lib-progs) mh-lib-progs) (cons mh-lib-progs exec-path)) (mh-lib (cons mh-lib exec-path)) (t exec-path)))) (with-current-buffer gnus-original-article-buffer (save-restriction (widen) (unwind-protect (call-process-region (point-min) (point-max) "rcvstore" nil errbuf nil folder) (set-buffer errbuf) (if (zerop (buffer-size)) (message "Article saved in folder: %s" folder) (message "%s" (buffer-string))) (kill-buffer errbuf)))) (setq gnus-newsgroup-last-folder folder))) (defun gnus-Folder-save-name (newsgroup headers &optional last-folder) "Generate folder name from NEWSGROUP, HEADERS, and optional LAST-FOLDER. If variable `gnus-use-long-file-name' is nil, it is +News.group. Otherwise, it is like +news/group." (or last-folder (concat "+" (if gnus-use-long-file-name (gnus-capitalize-newsgroup newsgroup) (gnus-newsgroup-directory-form newsgroup))))) (defun gnus-folder-save-name (newsgroup headers &optional last-folder) "Generate folder name from NEWSGROUP, HEADERS, and optional LAST-FOLDER. If variable `gnus-use-long-file-name' is nil, it is +news.group. Otherwise, it is like +news/group." (or last-folder (concat "+" (if gnus-use-long-file-name newsgroup (gnus-newsgroup-directory-form newsgroup))))) (provide 'gnus-mh) ;; arch-tag: 2d5696d3-b363-48e5-8749-c256be56acca ;;; gnus-mh.el ends here gnus-5.11+v0.10.dfsg/lisp/spam.el0000644000175000017500000030203011004005111016502 0ustar tvainikatvainika;;; spam.el --- Identifying spam ;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; Maintainer: Ted Zlatanov ;; Keywords: network, spam, mail, bogofilter, BBDB, dspam, dig, whitelist, blacklist, gmane, hashcash, spamassassin, bsfilter, ifile, stat, crm114, spamoracle ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 3, or (at your option) ;; any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Commentary: ;;; This module addresses a few aspects of spam control under Gnus. Page ;;; breaks are used for grouping declarations and documentation relating to ;;; each particular aspect. ;;; The integration with Gnus is not yet complete. See various `FIXME' ;;; comments, below, for supplementary explanations or discussions. ;;; Several TODO items are marked as such ;; TODO: cross-server splitting, remote processing, training through files ;;; Code: ;;{{{ compilation directives and autoloads/requires ;; For Emacs < 22.2. (eval-and-compile (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) (eval-when-compile (require 'cl)) (require 'message) ;for the message-fetch-field functions (require 'gnus-sum) (require 'gnus-uu) ; because of key prefix issues ;;; for the definitions of group content classification and spam processors (require 'gnus) (eval-when-compile (require 'spam-report)) (eval-when-compile (require 'hashcash)) ;; for nnimap-split-download-body-default (eval-when-compile (require 'nnimap)) ;; autoload query-dig (eval-and-compile (autoload 'query-dig "dig")) ;; autoload spam-report (eval-and-compile (autoload 'spam-report-gmane "spam-report") (autoload 'spam-report-gmane-spam "spam-report") (autoload 'spam-report-gmane-ham "spam-report") (autoload 'spam-report-resend "spam-report")) ;; autoload gnus-registry (eval-and-compile (autoload 'gnus-registry-group-count "gnus-registry") (autoload 'gnus-registry-add-group "gnus-registry") (autoload 'gnus-registry-store-extra-entry "gnus-registry") (autoload 'gnus-registry-fetch-extra "gnus-registry")) ;; autoload query-dns (eval-and-compile (autoload 'query-dns "dns")) ;;}}} ;;{{{ Main parameters. (defvar spam-backends nil "List of spam.el backends with all the pertinent data. Populated by `spam-install-backend-super'.") (defgroup spam nil "Spam configuration." :version "22.1" :group 'mail :group 'news) (defcustom spam-summary-exit-behavior 'default "Exit behavior at the time of summary exit. Note that setting the `spam-use-move' or `spam-use-copy' backends on a group through group/topic parameters overrides this mechanism." :type '(choice (const 'default :tag "Move spam out of all groups. Move ham out of spam groups.") (const 'move-all :tag "Move spam out of all groups. Move ham out of all groups.") (const 'move-none :tag "Never move spam or ham out of any groups.")) :group 'spam) (defcustom spam-directory (nnheader-concat gnus-directory "spam/") "Directory for spam whitelists and blacklists." :type 'directory :group 'spam) (defcustom spam-mark-new-messages-in-spam-group-as-spam t "Whether new messages in a spam group should get the spam-mark." :type 'boolean ;; :version "22.1" ;; Gnus 5.10.8 / No Gnus 0.3 :group 'spam) (defcustom spam-log-to-registry nil "Whether spam/ham processing should be logged in the registry." :type 'boolean :group 'spam) (defcustom spam-split-symbolic-return nil "Whether `spam-split' should work with symbols or group names." :type 'boolean :group 'spam) (defcustom spam-split-symbolic-return-positive nil "Whether `spam-split' should ALWAYS work with symbols or group names. Do not set this if you use `spam-split' in a fancy split method." :type 'boolean :group 'spam) (defcustom spam-mark-only-unseen-as-spam t "Whether only unseen articles should be marked as spam in spam groups. When nil, all unread articles in a spam group are marked as spam. Set this if you want to leave an article unread in a spam group without losing it to the automatic spam-marking process." :type 'boolean :group 'spam) (defcustom spam-mark-ham-unread-before-move-from-spam-group nil "Whether ham should be marked unread before it's moved. The article is moved out of a spam group according to `ham-process-destination'. This variable is an official entry in the international Longest Variable Name Competition." :type 'boolean :group 'spam) (defcustom spam-disable-spam-split-during-ham-respool nil "Whether `spam-split' should be ignored while resplitting ham. This is useful to prevent ham from ending up in the same spam group after the resplit. Don't set this to t if you have `spam-split' as the last rule in your split configuration." :type 'boolean :group 'spam) (defcustom spam-autodetect-recheck-messages nil "Should spam.el recheck all meessages when autodetecting? Normally this is nil, so only unseen messages will be checked." :type 'boolean :group 'spam) (defcustom spam-whitelist (expand-file-name "whitelist" spam-directory) "The location of the whitelist. The file format is one regular expression per line. The regular expression is matched against the address." :type 'file :group 'spam) (defcustom spam-blacklist (expand-file-name "blacklist" spam-directory) "The location of the blacklist. The file format is one regular expression per line. The regular expression is matched against the address." :type 'file :group 'spam) (defcustom spam-use-dig t "Whether `query-dig' should be used instead of `query-dns'." :type 'boolean :group 'spam) (defcustom spam-use-gmane-xref nil "Whether the Gmane spam xref should be used by `spam-split'." :type 'boolean :group 'spam) (defcustom spam-use-blacklist nil "Whether the blacklist should be used by `spam-split'." :type 'boolean :group 'spam) (defcustom spam-blacklist-ignored-regexes nil "Regular expressions that the blacklist should ignore." :type '(repeat (regexp :tag "Regular expression to ignore when blacklisting")) :group 'spam) (defcustom spam-use-whitelist nil "Whether the whitelist should be used by `spam-split'." :type 'boolean :group 'spam) (defcustom spam-use-whitelist-exclusive nil "Whether whitelist-exclusive should be used by `spam-split'. Exclusive whitelisting means that all messages from senders not in the whitelist are considered spam." :type 'boolean :group 'spam) (defcustom spam-use-blackholes nil "Whether blackholes should be used by `spam-split'." :type 'boolean :group 'spam) (defcustom spam-use-hashcash nil "Whether hashcash payments should be detected by `spam-split'." :type 'boolean :group 'spam) (defcustom spam-use-regex-headers nil "Whether a header regular expression match should be used by `spam-split'. Also see the variables `spam-regex-headers-spam' and `spam-regex-headers-ham'." :type 'boolean :group 'spam) (defcustom spam-use-regex-body nil "Whether a body regular expression match should be used by `spam-split'. Also see the variables `spam-regex-body-spam' and `spam-regex-body-ham'." :type 'boolean :group 'spam) (defcustom spam-use-bogofilter-headers nil "Whether bogofilter headers should be used by `spam-split'. Enable this if you pre-process messages with Bogofilter BEFORE Gnus sees them." :type 'boolean :group 'spam) (defcustom spam-use-bogofilter nil "Whether bogofilter should be invoked by `spam-split'. Enable this if you want Gnus to invoke Bogofilter on new messages." :type 'boolean :group 'spam) (defcustom spam-use-bsfilter-headers nil "Whether bsfilter headers should be used by `spam-split'. Enable this if you pre-process messages with Bsfilter BEFORE Gnus sees them." :type 'boolean :group 'spam) (defcustom spam-use-bsfilter nil "Whether bsfilter should be invoked by `spam-split'. Enable this if you want Gnus to invoke Bsfilter on new messages." :type 'boolean :group 'spam) (defcustom spam-use-BBDB nil "Whether BBDB should be used by `spam-split'." :type 'boolean :group 'spam) (defcustom spam-use-BBDB-exclusive nil "Whether BBDB-exclusive should be used by `spam-split'. Exclusive BBDB means that all messages from senders not in the BBDB are considered spam." :type 'boolean :group 'spam) (defcustom spam-use-ifile nil "Whether ifile should be used by `spam-split'." :type 'boolean :group 'spam) (defcustom spam-use-stat nil "Whether `spam-stat' should be used by `spam-split'." :type 'boolean :group 'spam) (defcustom spam-use-spamoracle nil "Whether spamoracle should be used by `spam-split'." :type 'boolean :group 'spam) (defcustom spam-use-spamassassin nil "Whether spamassassin should be invoked by `spam-split'. Enable this if you want Gnus to invoke SpamAssassin on new messages." :type 'boolean :group 'spam) (defcustom spam-use-spamassassin-headers nil "Whether spamassassin headers should be checked by `spam-split'. Enable this if you pre-process messages with SpamAssassin BEFORE Gnus sees them." :type 'boolean :group 'spam) (defcustom spam-use-crm114 nil "Whether the CRM114 Mailfilter should be used by `spam-split'." :type 'boolean :group 'spam) (defcustom spam-install-hooks (or spam-use-dig spam-use-gmane-xref spam-use-blacklist spam-use-whitelist spam-use-whitelist-exclusive spam-use-blackholes spam-use-hashcash spam-use-regex-headers spam-use-regex-body spam-use-bogofilter spam-use-bogofilter-headers spam-use-spamassassin spam-use-spamassassin-headers spam-use-bsfilter spam-use-bsfilter-headers spam-use-BBDB spam-use-BBDB-exclusive spam-use-ifile spam-use-stat spam-use-spamoracle spam-use-crm114) "Whether the spam hooks should be installed. Default to t if one of the spam-use-* variables is set." :group 'spam :type 'boolean) (defcustom spam-split-group "spam" "Group name where incoming spam should be put by `spam-split'." :type 'string :group 'spam) ;;; TODO: deprecate this variable, it's confusing since it's a list of strings, ;;; not regular expressions (defcustom spam-junk-mailgroups (cons spam-split-group '("mail.junk" "poste.pourriel")) "Mailgroups with spam contents. All unmarked article in such group receive the spam mark on group entry." :type '(repeat (string :tag "Group")) :group 'spam) (defcustom spam-gmane-xref-spam-group "gmane.spam.detected" "The group where spam xrefs can be found on Gmane. Only meaningful if you enable `spam-use-gmane-xref'." :type 'string :group 'spam) (defcustom spam-blackhole-servers '("bl.spamcop.net" "relays.ordb.org" "dev.null.dk" "relays.visi.com") "List of blackhole servers. Only meaningful if you enable `spam-use-blackholes'." :type '(repeat (string :tag "Server")) :group 'spam) (defcustom spam-blackhole-good-server-regex nil "String matching IP addresses that should not be checked in the blackholes. Only meaningful if you enable `spam-use-blackholes'." :type '(radio (const nil) regexp) :group 'spam) (defface spam '((((class color) (type tty) (background dark)) (:foreground "gray80" :background "gray50")) (((class color) (type tty) (background light)) (:foreground "gray50" :background "gray80")) (((class color) (background dark)) (:foreground "ivory2")) (((class color) (background light)) (:foreground "ivory4")) (t :inverse-video t)) "Face for spam-marked articles." :group 'spam) ;; backward-compatibility alias (put 'spam-face 'face-alias 'spam) (defcustom spam-face 'spam "Face for spam-marked articles." :type 'face :group 'spam) (defcustom spam-regex-headers-spam '("^X-Spam-Flag: YES") "Regular expression for positive header spam matches. Only meaningful if you enable `spam-use-regex-headers'." :type '(repeat (regexp :tag "Regular expression to match spam header")) :group 'spam) (defcustom spam-regex-headers-ham '("^X-Spam-Flag: NO") "Regular expression for positive header ham matches. Only meaningful if you enable `spam-use-regex-headers'." :type '(repeat (regexp :tag "Regular expression to match ham header")) :group 'spam) (defcustom spam-regex-body-spam '() "Regular expression for positive body spam matches. Only meaningful if you enable `spam-use-regex-body'." :type '(repeat (regexp :tag "Regular expression to match spam body")) :group 'spam) (defcustom spam-regex-body-ham '() "Regular expression for positive body ham matches. Only meaningful if you enable `spam-use-regex-body'." :type '(repeat (regexp :tag "Regular expression to match ham body")) :group 'spam) (defcustom spam-summary-score-preferred-header nil "Preferred header to use for `spam-summary-score'." :type '(choice :tag "Header name" (symbol :tag "SpamAssassin etc" X-Spam-Status) (symbol :tag "Bogofilter" X-Bogosity) (const :tag "No preference, take best guess." nil)) :group 'spam) (defgroup spam-ifile nil "Spam ifile configuration." :group 'spam) (make-obsolete-variable 'spam-ifile-path 'spam-ifile-program) ;; "22.1" ;; Gnus 5.10.9 (defcustom spam-ifile-program (executable-find "ifile") "Name of the ifile program." :type '(choice (file :tag "Location of ifile") (const :tag "ifile is not installed")) :group 'spam-ifile) (make-obsolete-variable 'spam-ifile-database-path 'spam-ifile-database) ;; "22.1" ;; Gnus 5.10.9 (defcustom spam-ifile-database nil "File name of the ifile database." :type '(choice (file :tag "Location of the ifile database") (const :tag "Use the default")) :group 'spam-ifile) (defcustom spam-ifile-spam-category "spam" "Name of the spam ifile category." :type 'string :group 'spam-ifile) (defcustom spam-ifile-ham-category nil "Name of the ham ifile category. If nil, the current group name will be used." :type '(choice (string :tag "Use a fixed category") (const :tag "Use the current group name")) :group 'spam-ifile) (defcustom spam-ifile-all-categories nil "Whether the ifile check will return all categories, or just spam. Set this to t if you want to use the `spam-split' invocation of ifile as your main source of newsgroup names." :type 'boolean :group 'spam-ifile) (defgroup spam-bogofilter nil "Spam bogofilter configuration." :group 'spam) (make-obsolete-variable 'spam-bogofilter-path 'spam-bogofilter-program) ;; "22.1" ;; Gnus 5.10.9 (defcustom spam-bogofilter-program (executable-find "bogofilter") "Name of the Bogofilter program." :type '(choice (file :tag "Location of bogofilter") (const :tag "Bogofilter is not installed")) :group 'spam-bogofilter) (defvar spam-bogofilter-valid 'unknown "Is the bogofilter version valid?") (defcustom spam-bogofilter-header "X-Bogosity" "The header that Bogofilter inserts in messages." :type 'string :group 'spam-bogofilter) (defcustom spam-bogofilter-spam-switch "-s" "The switch that Bogofilter uses to register spam messages." :type 'string :group 'spam-bogofilter) (defcustom spam-bogofilter-ham-switch "-n" "The switch that Bogofilter uses to register ham messages." :type 'string :group 'spam-bogofilter) (defcustom spam-bogofilter-spam-strong-switch "-S" "The switch that Bogofilter uses to unregister ham messages." :type 'string :group 'spam-bogofilter) (defcustom spam-bogofilter-ham-strong-switch "-N" "The switch that Bogofilter uses to unregister spam messages." :type 'string :group 'spam-bogofilter) (defcustom spam-bogofilter-bogosity-positive-spam-header "^\\(Yes\\|Spam\\)" "The regex on `spam-bogofilter-header' for positive spam identification." :type 'regexp :group 'spam-bogofilter) (defcustom spam-bogofilter-database-directory nil "Location of the Bogofilter database. When nil, use the default location." :type '(choice (directory :tag "Location of the Bogofilter database directory") (const :tag "Use the default")) :group 'spam-bogofilter) (defgroup spam-bsfilter nil "Spam bsfilter configuration." :group 'spam) (make-obsolete-variable 'spam-bsfilter-path 'spam-bsfilter-program) ;; "22.1" ;; Gnus 5.10.9 (defcustom spam-bsfilter-program (executable-find "bsfilter") "Name of the Bsfilter program." :type '(choice (file :tag "Location of bsfilter") (const :tag "Bsfilter is not installed")) :group 'spam-bsfilter) (defcustom spam-bsfilter-header "X-Spam-Flag" "The header inserted by Bsfilter to flag spam." :type 'string :group 'spam-bsfilter) (defcustom spam-bsfilter-probability-header "X-Spam-Probability" "The header that Bsfilter inserts in messages." :type 'string :group 'spam-bsfilter) (defcustom spam-bsfilter-spam-switch "--add-spam" "The switch that Bsfilter uses to register spam messages." :type 'string :group 'spam-bsfilter) (defcustom spam-bsfilter-ham-switch "--add-clean" "The switch that Bsfilter uses to register ham messages." :type 'string :group 'spam-bsfilter) (defcustom spam-bsfilter-spam-strong-switch "--sub-spam" "The switch that Bsfilter uses to unregister ham messages." :type 'string :group 'spam-bsfilter) (defcustom spam-bsfilter-ham-strong-switch "--sub-clean" "The switch that Bsfilter uses to unregister spam messages." :type 'string :group 'spam-bsfilter) (defcustom spam-bsfilter-database-directory nil "Directory path of the Bsfilter databases." :type '(choice (directory :tag "Location of the Bsfilter database directory") (const :tag "Use the default")) :group 'spam-bsfilter) (defgroup spam-spamoracle nil "Spam spamoracle configuration." :group 'spam) (defcustom spam-spamoracle-database nil "Location of spamoracle database file. When nil, use the default spamoracle database." :type '(choice (directory :tag "Location of spamoracle database file.") (const :tag "Use the default")) :group 'spam-spamoracle) (defcustom spam-spamoracle-binary (executable-find "spamoracle") "Location of the spamoracle binary." :type '(choice (directory :tag "Location of the spamoracle binary") (const :tag "Use the default")) :group 'spam-spamoracle) (defgroup spam-spamassassin nil "Spam SpamAssassin configuration." :group 'spam) (make-obsolete-variable 'spam-spamassassin-path 'spam-spamassassin-program) ;; "22.1" ;; Gnus 5.10.9 (defcustom spam-assassin-program (executable-find "spamassassin") "Name of the spamassassin program. Hint: set this to \"spamc\" if you have spamd running. See the spamc and spamd man pages for more information on these programs." :type '(choice (file :tag "Location of spamc") (const :tag "spamassassin is not installed")) :group 'spam-spamassassin) (defcustom spam-spamassassin-arguments () "Arguments to pass to the spamassassin executable. This must be a list. For example, `(\"-C\" \"configfile\")'." :type '(restricted-sexp :match-alternatives (listp)) :group 'spam-spamassassin) (defcustom spam-spamassassin-spam-flag-header "X-Spam-Flag" "The header inserted by SpamAssassin to flag spam." :type 'string :group 'spam-spamassassin) (defcustom spam-spamassassin-positive-spam-flag-header "YES" "The regex on `spam-spamassassin-spam-flag-header' for positive spam identification" :type 'string :group 'spam-spamassassin) (defcustom spam-spamassassin-spam-status-header "X-Spam-Status" "The header inserted by SpamAssassin, giving extended scoring information" :type 'string :group 'spam-spamassassin) (make-obsolete-variable 'spam-sa-learn-path 'spam-sa-learn-program) ;; "22.1" ;; Gnus 5.10.9 (defcustom spam-sa-learn-program (executable-find "sa-learn") "Name of the sa-learn program." :type '(choice (file :tag "Location of spamassassin") (const :tag "spamassassin is not installed")) :group 'spam-spamassassin) (defcustom spam-sa-learn-rebuild t "Whether sa-learn should rebuild the database every time it is called Enable this if you want sa-learn to rebuild the database automatically. Doing this will slightly increase the running time of the spam registration process. If you choose not to do this, you will have to run \"sa-learn --rebuild\" in order for SpamAssassin to recognize the new registered spam." :type 'boolean :group 'spam-spamassassin) (defcustom spam-sa-learn-spam-switch "--spam" "The switch that sa-learn uses to register spam messages." :type 'string :group 'spam-spamassassin) (defcustom spam-sa-learn-ham-switch "--ham" "The switch that sa-learn uses to register ham messages." :type 'string :group 'spam-spamassassin) (defcustom spam-sa-learn-unregister-switch "--forget" "The switch that sa-learn uses to unregister messages messages." :type 'string :group 'spam-spamassassin) (defgroup spam-crm114 nil "Spam CRM114 Mailfilter configuration." :group 'spam) (defcustom spam-crm114-program (executable-find "mailfilter.crm") "File path of the CRM114 Mailfilter executable program." :type '(choice (file :tag "Location of CRM114 Mailfilter") (const :tag "CRM114 Mailfilter is not installed")) :group 'spam-crm114) (defcustom spam-crm114-header "X-CRM114-Status" "The header that CRM114 Mailfilter inserts in messages." :type 'string :group 'spam-crm114) (defcustom spam-crm114-spam-switch "--learnspam" "The switch that CRM114 Mailfilter uses to register spam messages." :type 'string :group 'spam-crm114) (defcustom spam-crm114-ham-switch "--learnnonspam" "The switch that CRM114 Mailfilter uses to register ham messages." :type 'string :group 'spam-crm114) (defcustom spam-crm114-spam-strong-switch "--UNKNOWN" "The switch that CRM114 Mailfilter uses to unregister ham messages." :type 'string :group 'spam-crm114) (defcustom spam-crm114-ham-strong-switch "--UNKNOWN" "The switch that CRM114 Mailfilter uses to unregister spam messages." :type 'string :group 'spam-crm114) (defcustom spam-crm114-positive-spam-header "^SPAM" "The regex on `spam-crm114-header' for positive spam identification." :type 'regexp :group 'spam-crm114) (defcustom spam-crm114-database-directory nil "Directory path of the CRM114 Mailfilter databases." :type '(choice (directory :tag "Location of the CRM114 Mailfilter database directory") (const :tag "Use the default")) :group 'spam-crm114) ;;; Key bindings for spam control. (gnus-define-keys gnus-summary-mode-map "St" spam-generic-score "Sx" gnus-summary-mark-as-spam "Mst" spam-generic-score "Msx" gnus-summary-mark-as-spam "\M-d" gnus-summary-mark-as-spam) (defvar spam-cache-lookups t "Whether spam.el will try to cache lookups using `spam-caches'.") (defvar spam-caches (make-hash-table :size 10 :test 'equal) "Cache of spam detection entries.") (defvar spam-old-articles nil "List of old ham and spam articles, generated when a group is entered.") (defvar spam-split-disabled nil "If non-nil, `spam-split' is disabled, and always returns nil.") (defvar spam-split-last-successful-check nil "Internal variable. `spam-split' will set this to nil or a spam-use-XYZ check if it finds ham or spam.") ;; internal variables for backends ;; TODO: find a way to create these on the fly in spam-install-backend-super (defvar spam-use-copy nil) (defvar spam-use-move nil) (defvar spam-use-gmane nil) (defvar spam-use-resend nil) ;;}}} ;;{{{ convenience functions (defun spam-clear-cache (symbol) "Clear the `spam-caches' entry for a check." (remhash symbol spam-caches)) (defun spam-xor (a b) "Logical A xor B." (and (or a b) (not (and a b)))) (defun spam-set-difference (list1 list2) "Return a set difference of LIST1 and LIST2. When either list is nil, the other is returned." (if (and list1 list2) ;; we have two non-nil lists (progn (dolist (item (append list1 list2)) (when (and (memq item list1) (memq item list2)) (setq list1 (delq item list1)) (setq list2 (delq item list2)))) (append list1 list2)) ;; if either of the lists was nil, return the other one (if list1 list1 list2))) (defun spam-group-ham-mark-p (group mark &optional spam) "Checks if MARK is considered a ham mark in GROUP." (when (stringp group) (let* ((marks (spam-group-ham-marks group spam)) (marks (if (symbolp mark) marks (mapcar 'symbol-value marks)))) (memq mark marks)))) (defun spam-group-spam-mark-p (group mark) "Checks if MARK is considered a spam mark in GROUP." (spam-group-ham-mark-p group mark t)) (defun spam-group-ham-marks (group &optional spam) "In GROUP, get all the ham marks." (when (stringp group) (let* ((marks (if spam (gnus-parameter-spam-marks group) (gnus-parameter-ham-marks group))) (marks (car marks)) (marks (if (listp (car marks)) (car marks) marks))) marks))) (defun spam-group-spam-marks (group) "In GROUP, get all the spam marks." (spam-group-ham-marks group t)) (defun spam-group-spam-contents-p (group) "Is GROUP a spam group?" (if (and (stringp group) (< 0 (length group))) (or (member group spam-junk-mailgroups) (memq 'gnus-group-spam-classification-spam (gnus-parameter-spam-contents group))) nil)) (defun spam-group-ham-contents-p (group) "Is GROUP a ham group?" (if (stringp group) (memq 'gnus-group-spam-classification-ham (gnus-parameter-spam-contents group)) nil)) (defun spam-classifications () "Return list of valid classifications" '(spam ham)) (defun spam-classification-valid-p (classification) "Is CLASSIFICATION a valid spam/ham classification?" (memq classification (spam-classifications))) (defun spam-backend-properties () "Return list of valid classifications." '(statistical mover check hrf srf huf suf)) (defun spam-backend-property-valid-p (property) "Is PROPERTY a valid backend property?" (memq property (spam-backend-properties))) (defun spam-backend-function-type-valid-p (type) (or (eq type 'registration) (eq type 'unregistration))) (defun spam-process-type-valid-p (process-type) (or (eq process-type 'incoming) (eq process-type 'process))) (defun spam-list-articles (articles classification) (let ((mark-check (if (eq classification 'spam) 'spam-group-spam-mark-p 'spam-group-ham-mark-p)) alist mark-cache-yes mark-cache-no) (dolist (article articles) (let ((mark (gnus-summary-article-mark article))) (unless (or (memq mark mark-cache-yes) (memq mark mark-cache-no)) (if (funcall mark-check gnus-newsgroup-name mark) (push mark mark-cache-yes) (push mark mark-cache-no))) (when (memq mark mark-cache-yes) (push article alist)))) alist)) ;;}}} ;;{{{ backend installation functions and procedures (defun spam-install-backend-super (backend &rest properties) "Install BACKEND for spam.el. Accepts incoming CHECK, ham registration function HRF, spam registration function SRF, ham unregistration function HUF, spam unregistration function SUF, and an indication whether the backend is STATISTICAL." (setq spam-backends (add-to-list 'spam-backends backend)) (while properties (let ((property (pop properties)) (value (pop properties))) (if (spam-backend-property-valid-p property) (put backend property value) (gnus-error 5 "spam-install-backend-super got an invalid property %s" property))))) (defun spam-backend-list (&optional type) "Return a list of all the backend symbols, constrained by TYPE. When TYPE is 'non-mover, only non-mover backends are returned. When TYPE is 'mover, only mover backends are returned." (let (list) (dolist (backend spam-backends) (when (or (null type) ;either no type was requested ;; or the type is 'mover and the backend is a mover (and (eq type 'mover) (spam-backend-mover-p backend)) ;; or the type is 'non-mover and the backend is not a mover (and (eq type 'non-mover) (not (spam-backend-mover-p backend)))) (push backend list))) list)) (defun spam-backend-check (backend) "Get the check function for BACKEND. Each individual check may return nil, t, or a mailgroup name. The value nil means that the check does not yield a decision, and so, that further checks are needed. The value t means that the message is definitely not spam, and that further spam checks should be inhibited. Otherwise, a mailgroup name or the symbol 'spam (depending on `spam-split-symbolic-return') is returned where the mail should go, and further checks are also inhibited. The usual mailgroup name is the value of `spam-split-group', meaning that the message is definitely a spam." (get backend 'check)) (defun spam-backend-valid-p (backend) "Is BACKEND valid?" (member backend (spam-backend-list))) (defun spam-backend-info (backend) "Return information about BACKEND." (if (spam-backend-valid-p backend) (let (info) (setq info (format "Backend %s has the following properties:\n" backend)) (dolist (property (spam-backend-properties)) (setq info (format "%s%s=%s\n" info property (get backend property)))) info) (gnus-error 5 "spam-backend-info was asked about an invalid backend %s" backend))) (defun spam-backend-function (backend classification type) "Get the BACKEND function for CLASSIFICATION and TYPE. TYPE is 'registration or 'unregistration. CLASSIFICATION is 'ham or 'spam." (if (and (spam-classification-valid-p classification) (spam-backend-function-type-valid-p type)) (let ((retrieval (intern (format "spam-backend-%s-%s-function" classification type)))) (funcall retrieval backend)) (gnus-error 5 "%s was passed invalid backend %s, classification %s, or type %s" "spam-backend-function" backend classification type))) (defun spam-backend-article-list-property (classification &optional unregister) "Property name of article list with CLASSIFICATION and UNREGISTER." (let* ((r (if unregister "unregister" "register")) (prop (format "%s-%s" classification r))) prop)) (defun spam-backend-get-article-todo-list (backend classification &optional unregister) "Get the articles to be processed for BACKEND and CLASSIFICATION. With UNREGISTER, get articles to be unregistered. This is a temporary storage function - nothing here persists." (get backend (intern (spam-backend-article-list-property classification unregister)))) (defun spam-backend-put-article-todo-list (backend classification list &optional unregister) "Set the LIST of articles to be processed for BACKEND and CLASSIFICATION. With UNREGISTER, set articles to be unregistered. This is a temporary storage function - nothing here persists." (put backend (intern (spam-backend-article-list-property classification unregister)) list)) (defun spam-backend-ham-registration-function (backend) "Get the ham registration function for BACKEND." (get backend 'hrf)) (defun spam-backend-spam-registration-function (backend) "Get the spam registration function for BACKEND." (get backend 'srf)) (defun spam-backend-ham-unregistration-function (backend) "Get the ham unregistration function for BACKEND." (get backend 'huf)) (defun spam-backend-spam-unregistration-function (backend) "Get the spam unregistration function for BACKEND." (get backend 'suf)) (defun spam-backend-statistical-p (backend) "Is BACKEND statistical?" (get backend 'statistical)) (defun spam-backend-mover-p (backend) "Is BACKEND a mover?" (get backend 'mover)) (defun spam-install-backend-alias (backend alias) "Add ALIAS to an existing BACKEND. The previous backend settings for ALIAS are erased." ;; install alias with no properties at first (spam-install-backend-super alias) (dolist (property (spam-backend-properties)) (put alias property (get backend property)))) (defun spam-install-checkonly-backend (backend check) "Install a BACKEND than can only CHECK for spam." (spam-install-backend-super backend 'check check)) (defun spam-install-mover-backend (backend hrf srf huf suf) "Install a BACKEND than can move articles at summary exit. Accepts ham registration function HRF, spam registration function SRF, ham unregistration function HUF, spam unregistration function SUF. The backend has no incoming check and can't be statistical." (spam-install-backend-super backend 'hrf hrf 'srf srf 'huf huf 'suf suf 'mover t)) (defun spam-install-nocheck-backend (backend hrf srf huf suf) "Install a BACKEND than has no check. Accepts ham registration function HRF, spam registration function SRF, ham unregistration function HUF, spam unregistration function SUF. The backend has no incoming check and can't be statistical (it could be, but in practice that doesn't happen)." (spam-install-backend-super backend 'hrf hrf 'srf srf 'huf huf 'suf suf)) (defun spam-install-backend (backend check hrf srf huf suf) "Install a BACKEND. Accepts incoming CHECK, ham registration function HRF, spam registration function SRF, ham unregistration function HUF, spam unregistration function SUF. The backend won't be statistical (use `spam-install-statistical-backend' for that)." (spam-install-backend-super backend 'check check 'hrf hrf 'srf srf 'huf huf 'suf suf)) (defun spam-install-statistical-backend (backend check hrf srf huf suf) "Install a BACKEND. Accepts incoming CHECK, ham registration function HRF, spam registration function SRF, ham unregistration function HUF, spam unregistration function SUF. The backend will be statistical (use `spam-install-backend' for non-statistical backends)." (spam-install-backend-super backend 'check check 'statistical t 'hrf hrf 'srf srf 'huf huf 'suf suf)) (defun spam-install-statistical-checkonly-backend (backend check) "Install a statistical BACKEND than can only CHECK for spam." (spam-install-backend-super backend 'check check 'statistical t)) ;;}}} ;;{{{ backend installations (spam-install-checkonly-backend 'spam-use-blackholes 'spam-check-blackholes) (spam-install-checkonly-backend 'spam-use-hashcash 'spam-check-hashcash) (spam-install-checkonly-backend 'spam-use-spamassassin-headers 'spam-check-spamassassin-headers) (spam-install-checkonly-backend 'spam-use-bogofilter-headers 'spam-check-bogofilter-headers) (spam-install-checkonly-backend 'spam-use-bsfilter-headers 'spam-check-bsfilter-headers) (spam-install-checkonly-backend 'spam-use-gmane-xref 'spam-check-gmane-xref) (spam-install-checkonly-backend 'spam-use-regex-headers 'spam-check-regex-headers) (spam-install-statistical-checkonly-backend 'spam-use-regex-body 'spam-check-regex-body) ;; TODO: NOTE: spam-use-ham-copy is now obsolete, use (ham spam-use-copy) instead (spam-install-mover-backend 'spam-use-move 'spam-move-ham-routine 'spam-move-spam-routine nil nil) (spam-install-nocheck-backend 'spam-use-copy 'spam-copy-ham-routine 'spam-copy-spam-routine nil nil) (spam-install-nocheck-backend 'spam-use-gmane 'spam-report-gmane-unregister-routine 'spam-report-gmane-register-routine 'spam-report-gmane-register-routine 'spam-report-gmane-unregister-routine) (spam-install-nocheck-backend 'spam-use-resend 'spam-report-resend-register-ham-routine 'spam-report-resend-register-routine nil nil) (spam-install-backend 'spam-use-BBDB 'spam-check-BBDB 'spam-BBDB-register-routine nil 'spam-BBDB-unregister-routine nil) (spam-install-backend-alias 'spam-use-BBDB 'spam-use-BBDB-exclusive) (spam-install-backend 'spam-use-blacklist 'spam-check-blacklist nil 'spam-blacklist-register-routine nil 'spam-blacklist-unregister-routine) (spam-install-backend 'spam-use-whitelist 'spam-check-whitelist 'spam-whitelist-register-routine nil 'spam-whitelist-unregister-routine nil) (spam-install-statistical-backend 'spam-use-ifile 'spam-check-ifile 'spam-ifile-register-ham-routine 'spam-ifile-register-spam-routine 'spam-ifile-unregister-ham-routine 'spam-ifile-unregister-spam-routine) (spam-install-statistical-backend 'spam-use-spamoracle 'spam-check-spamoracle 'spam-spamoracle-learn-ham 'spam-spamoracle-learn-spam 'spam-spamoracle-unlearn-ham 'spam-spamoracle-unlearn-spam) (spam-install-statistical-backend 'spam-use-stat 'spam-check-stat 'spam-stat-register-ham-routine 'spam-stat-register-spam-routine 'spam-stat-unregister-ham-routine 'spam-stat-unregister-spam-routine) (spam-install-statistical-backend 'spam-use-spamassassin 'spam-check-spamassassin 'spam-spamassassin-register-ham-routine 'spam-spamassassin-register-spam-routine 'spam-spamassassin-unregister-ham-routine 'spam-spamassassin-unregister-spam-routine) (spam-install-statistical-backend 'spam-use-bogofilter 'spam-check-bogofilter 'spam-bogofilter-register-ham-routine 'spam-bogofilter-register-spam-routine 'spam-bogofilter-unregister-ham-routine 'spam-bogofilter-unregister-spam-routine) (spam-install-statistical-backend 'spam-use-bsfilter 'spam-check-bsfilter 'spam-bsfilter-register-ham-routine 'spam-bsfilter-register-spam-routine 'spam-bsfilter-unregister-ham-routine 'spam-bsfilter-unregister-spam-routine) (spam-install-statistical-backend 'spam-use-crm114 'spam-check-crm114 'spam-crm114-register-ham-routine 'spam-crm114-register-spam-routine ;; does CRM114 Mailfilter support unregistration? nil nil) ;;}}} ;;{{{ scoring and summary formatting (defun spam-necessary-extra-headers () "Return the extra headers spam.el thinks are necessary." (let (list) (when (or spam-use-spamassassin spam-use-spamassassin-headers spam-use-regex-headers) (push 'X-Spam-Status list)) (when (or spam-use-bogofilter spam-use-regex-headers) (push 'X-Bogosity list)) (when (or spam-use-crm114 spam-use-regex-headers) (push 'X-CRM114-Status list)) list)) (defun spam-user-format-function-S (headers) (when headers (format "%3.2f" (spam-summary-score headers spam-summary-score-preferred-header)))) (defun spam-article-sort-by-spam-status (h1 h2) "Sort articles by score." (let (result) (dolist (header (spam-necessary-extra-headers)) (let ((s1 (spam-summary-score h1 header)) (s2 (spam-summary-score h2 header))) (unless (= s1 s2) (setq result (< s1 s2)) (return)))) result)) (defvar spam-spamassassin-score-regexp ".*\\b\\(?:score\\|hits\\)=\\(-?[0-9.]+\\)" "Regexp matching SpamAssassin score header. The first group must match the number.") (defun spam-extra-header-to-number (header headers) "Transform an extra HEADER to a number, using list of HEADERS. Note this has to be fast." (let ((header-content (gnus-extra-header header headers))) (if header-content (cond ((eq header 'X-Spam-Status) (string-to-number (gnus-replace-in-string header-content spam-spamassassin-score-regexp "\\1"))) ;; for CRM checking, it's probably faster to just do the string match ((string-match "( pR: \\([0-9.-]+\\)" header-content) (- (string-to-number (match-string 1 header-content)))) ((eq header 'X-Bogosity) (string-to-number (gnus-replace-in-string (gnus-replace-in-string header-content ".*spamicity=" "") ",.*" ""))) (t nil)) nil))) (defun spam-summary-score (headers &optional specific-header) "Score an article for the summary buffer, as fast as possible. With SPECIFIC-HEADER, returns only that header's score. Will not return a nil score." (let (score) (dolist (header (if specific-header (list specific-header) (spam-necessary-extra-headers))) (setq score (spam-extra-header-to-number header headers)) (when score (return))) (or score 0))) (defun spam-generic-score (&optional recheck) "Invoke whatever scoring method we can." (interactive "P") (cond ((or spam-use-spamassassin spam-use-spamassassin-headers) (spam-spamassassin-score recheck)) ((or spam-use-bsfilter spam-use-bsfilter-headers) (spam-bsfilter-score recheck)) (spam-use-crm114 (spam-crm114-score)) (t (spam-bogofilter-score recheck)))) ;;}}} ;;{{{ set up widening, processor checks ;;; set up IMAP widening if it's necessary (defun spam-setup-widening () (when (spam-widening-needed-p) (setq nnimap-split-download-body-default t))) (defun spam-widening-needed-p (&optional force-symbols) (let (found) (dolist (backend (spam-backend-list)) (when (and (spam-backend-statistical-p backend) (or (symbol-value backend) (memq backend force-symbols))) (setq found backend))) found)) (defvar spam-list-of-processors ;; note the nil processors are not defined in gnus.el '((gnus-group-spam-exit-processor-bogofilter spam spam-use-bogofilter) (gnus-group-spam-exit-processor-bsfilter spam spam-use-bsfilter) (gnus-group-spam-exit-processor-blacklist spam spam-use-blacklist) (gnus-group-spam-exit-processor-ifile spam spam-use-ifile) (gnus-group-spam-exit-processor-stat spam spam-use-stat) (gnus-group-spam-exit-processor-spamoracle spam spam-use-spamoracle) (gnus-group-spam-exit-processor-spamassassin spam spam-use-spamassassin) (gnus-group-spam-exit-processor-report-gmane spam spam-use-gmane) ;; Buggy? (gnus-group-ham-exit-processor-ifile ham spam-use-ifile) (gnus-group-ham-exit-processor-bogofilter ham spam-use-bogofilter) (gnus-group-ham-exit-processor-bsfilter ham spam-use-bsfilter) (gnus-group-ham-exit-processor-stat ham spam-use-stat) (gnus-group-ham-exit-processor-whitelist ham spam-use-whitelist) (gnus-group-ham-exit-processor-BBDB ham spam-use-BBDB) (gnus-group-ham-exit-processor-copy ham spam-use-ham-copy) (gnus-group-ham-exit-processor-spamassassin ham spam-use-spamassassin) (gnus-group-ham-exit-processor-spamoracle ham spam-use-spamoracle)) "The OBSOLETE `spam-list-of-processors' list. This list contains pairs associating the obsolete ham/spam exit processor variables with a classification and a spam-use-* variable. When the processor variable is nil, just the classification and spam-use-* check variable are used. This is superseded by the new spam backend code, so it's only consulted for backwards compatibility.") (defun spam-group-processor-p (group backend &optional classification) "Checks if GROUP has a BACKEND with CLASSIFICATION registered. Also accepts the obsolete processors, which can be found in gnus.el and in spam-list-of-processors. In the case of mover backends, checks the setting of `spam-summary-exit-behavior' in addition to the set values for the group." (if (and (stringp group) (symbolp backend)) (let ((old-style (assq backend spam-list-of-processors)) (parameters (nth 0 (gnus-parameter-spam-process group))) found) (if old-style ; old-style processor (spam-group-processor-p group (nth 2 old-style) (nth 1 old-style)) ;; now search for the parameter (dolist (parameter parameters) (when (and (null found) (listp parameter) (eq classification (nth 0 parameter)) (eq backend (nth 1 parameter))) (setq found t))) ;; now, if the parameter was not found, do the ;; spam-summary-exit-behavior-logic for mover backends (unless found (when (spam-backend-mover-p backend) (setq found (cond ((eq spam-summary-exit-behavior 'move-all) t) ((eq spam-summary-exit-behavior 'move-none) nil) ((eq spam-summary-exit-behavior 'default) (or (eq classification 'spam) ;move spam out of all groups ;; move ham out of spam groups (and (eq classification 'ham) (spam-group-spam-contents-p group)))) (t (gnus-error 5 "Unknown spam-summary-exit-behavior: %s" spam-summary-exit-behavior)))))) found)) nil)) ;;}}} ;;{{{ Summary entry and exit processing. (defun spam-mark-junk-as-spam-routine () ;; check the global list of group names spam-junk-mailgroups and the ;; group parameters (when (spam-group-spam-contents-p gnus-newsgroup-name) (gnus-message 6 "Marking %s articles as spam" (if spam-mark-only-unseen-as-spam "unseen" "unread")) (let ((articles (if spam-mark-only-unseen-as-spam gnus-newsgroup-unseen gnus-newsgroup-unreads))) (if spam-mark-new-messages-in-spam-group-as-spam (dolist (article articles) (gnus-summary-mark-article article gnus-spam-mark)) (gnus-message 9 "Did not mark new messages as spam."))))) (defun spam-summary-prepare () (setq spam-old-articles (list (cons 'ham (spam-list-articles gnus-newsgroup-articles 'ham)) (cons 'spam (spam-list-articles gnus-newsgroup-articles 'spam)))) (spam-mark-junk-as-spam-routine)) ;; The spam processors are invoked for any group, spam or ham or neither (defun spam-summary-prepare-exit () (unless gnus-group-is-exiting-without-update-p (gnus-message 6 "Exiting summary buffer and applying spam rules") ;; before we begin, remove any article limits ; (ignore-errors ; (gnus-summary-pop-limit t)) ;; first of all, unregister any articles that are no longer ham or spam ;; we have to iterate over the processors, or else we'll be too slow (dolist (classification (spam-classifications)) (let* ((old-articles (cdr-safe (assq classification spam-old-articles))) (new-articles (spam-list-articles gnus-newsgroup-articles classification)) (changed-articles (spam-set-difference new-articles old-articles))) ;; now that we have the changed articles, we go through the processors (dolist (backend (spam-backend-list)) (let (unregister-list) (dolist (article changed-articles) (let ((id (spam-fetch-field-message-id-fast article))) (when (spam-log-unregistration-needed-p id 'process classification backend) (push article unregister-list)))) ;; call spam-register-routine with specific articles to unregister, ;; when there are articles to unregister and the check is enabled (when (and unregister-list (symbol-value backend)) (spam-backend-put-article-todo-list backend classification unregister-list t)))))) ;; do the non-moving backends first, then the moving ones (dolist (backend-type '(non-mover mover)) (dolist (classification (spam-classifications)) (dolist (backend (spam-backend-list backend-type)) (when (spam-group-processor-p gnus-newsgroup-name backend classification) (spam-backend-put-article-todo-list backend classification (spam-list-articles gnus-newsgroup-articles classification)))))) (spam-resolve-registrations-routine) ; do the registrations now ;; we mark all the leftover spam articles as expired at the end (dolist (article (spam-list-articles gnus-newsgroup-articles 'spam)) (gnus-summary-mark-article article gnus-expirable-mark))) (setq spam-old-articles nil)) ;;}}} ;;{{{ spam-use-move and spam-use-copy backend support functions (defun spam-copy-or-move-routine (copy groups articles classification) (when (and (car-safe groups) (listp (car-safe groups))) (setq groups (pop groups))) (unless (listp groups) (setq groups (list groups))) ;; remove the current process mark (gnus-summary-kill-process-mark) (let ((backend-supports-deletions (gnus-check-backend-function 'request-move-article gnus-newsgroup-name)) (respool-method (gnus-find-method-for-group gnus-newsgroup-name)) article mark deletep respool) (when (member 'respool groups) (setq respool t) ; boolean for later (setq groups '("fake"))) ; when respooling, groups are dynamic so fake it ;; now do the actual move (dolist (group groups) (when (and articles (stringp group)) ;; first, mark the article with the process mark and, if needed, ;; the unread or expired mark (for ham and spam respectively) (dolist (article articles) (when (and (eq classification 'ham) spam-mark-ham-unread-before-move-from-spam-group) (gnus-message 9 "Marking ham article %d unread before move" article) (gnus-summary-mark-article article gnus-unread-mark)) (when (and (eq classification 'spam) (not copy)) (gnus-message 9 "Marking spam article %d expirable before move" article) (gnus-summary-mark-article article gnus-expirable-mark)) (gnus-summary-set-process-mark article) (if respool ; respooling is with a "fake" group (let ((spam-split-disabled (or spam-split-disabled (and (eq classification 'ham) spam-disable-spam-split-during-ham-respool)))) (gnus-message 9 "Respooling article %d with method %s" article respool-method) (gnus-summary-respool-article nil respool-method)) (if (or (not backend-supports-deletions) ; else, we are not respooling (> (length groups) 1)) (progn ; if copying, copy and set deletep (gnus-message 9 "Copying article %d to group %s" article group) (gnus-summary-copy-article nil group) (setq deletep t)) (gnus-message 9 "Moving article %d to group %s" article group) (gnus-summary-move-article nil group))))) ; else move articles ;; now delete the articles, unless a) copy is t, and there was a copy done ;; b) a move was done to a single group ;; c) backend-supports-deletions is nil (unless copy (when (and deletep backend-supports-deletions) (dolist (article articles) (gnus-summary-set-process-mark article) (gnus-message 9 "Deleting article %d" article)) (when articles (let ((gnus-novice-user nil)) ; don't ask me if I'm sure (gnus-summary-delete-article nil))))) (gnus-summary-yank-process-mark) (length articles)))) (defun spam-copy-spam-routine (articles) (spam-copy-or-move-routine t (gnus-parameter-spam-process-destination gnus-newsgroup-name) articles 'spam)) (defun spam-move-spam-routine (articles) (spam-copy-or-move-routine nil (gnus-parameter-spam-process-destination gnus-newsgroup-name) articles 'spam)) (defun spam-copy-ham-routine (articles) (spam-copy-or-move-routine t (gnus-parameter-ham-process-destination gnus-newsgroup-name) articles 'ham)) (defun spam-move-ham-routine (articles) (spam-copy-or-move-routine nil (gnus-parameter-ham-process-destination gnus-newsgroup-name) articles 'ham)) ;;}}} ;;{{{ article and field retrieval code (defun spam-get-article-as-string (article) (when (numberp article) (with-temp-buffer (gnus-request-article-this-buffer article gnus-newsgroup-name) (buffer-string)))) ;; disabled for now ;; (defun spam-get-article-as-filename (article) ;; (let ((article-filename)) ;; (when (numberp article) ;; (nnml-possibly-change-directory ;; (gnus-group-real-name gnus-newsgroup-name)) ;; (setq article-filename (expand-file-name ;; (int-to-string article) nnml-current-directory))) ;; (if (file-exists-p article-filename) ;; article-filename ;; nil))) (defun spam-fetch-field-fast (article field &optional prepared-data-header) "Fetch a FIELD for ARTICLE quickly, using the internal gnus-data-list function. When PREPARED-DATA-HEADER is given, don't look in the Gnus data. When FIELD is 'number, ARTICLE can be any number (since we want to find it out)." (when (numberp article) (let* ((data-header (or prepared-data-header (spam-fetch-article-header article)))) (if (arrayp data-header) (cond ((equal field 'number) (mail-header-number data-header)) ((equal field 'from) (mail-header-from data-header)) ((equal field 'message-id) (mail-header-message-id data-header)) ((equal field 'subject) (mail-header-subject data-header)) ((equal field 'references) (mail-header-references data-header)) ((equal field 'date) (mail-header-date data-header)) ((equal field 'xref) (mail-header-xref data-header)) ((equal field 'extra) (mail-header-extra data-header)) (t (gnus-error 5 "spam-fetch-field-fast: unknown field %s requested" field) nil)) (gnus-message 6 "Article %d has a nil data header" article))))) (defun spam-fetch-field-from-fast (article &optional prepared-data-header) (spam-fetch-field-fast article 'from prepared-data-header)) (defun spam-fetch-field-subject-fast (article &optional prepared-data-header) (spam-fetch-field-fast article 'subject prepared-data-header)) (defun spam-fetch-field-message-id-fast (article &optional prepared-data-header) (spam-fetch-field-fast article 'message-id prepared-data-header)) (defun spam-generate-fake-headers (article) (let ((dh (spam-fetch-article-header article))) (if dh (concat (format ;; 80-character limit makes for strange constructs (concat "From: %s\nSubject: %s\nMessage-ID: %s\n" "Date: %s\nReferences: %s\nXref: %s\n") (spam-fetch-field-fast article 'from dh) (spam-fetch-field-fast article 'subject dh) (spam-fetch-field-fast article 'message-id dh) (spam-fetch-field-fast article 'date dh) (spam-fetch-field-fast article 'references dh) (spam-fetch-field-fast article 'xref dh)) (when (spam-fetch-field-fast article 'extra dh) (format "%s\n" (spam-fetch-field-fast article 'extra dh)))) (gnus-message 5 "spam-generate-fake-headers: article %d didn't have a valid header" article)))) (defun spam-fetch-article-header (article) (save-excursion (set-buffer gnus-summary-buffer) (gnus-read-header article) (nth 3 (assq article gnus-newsgroup-data)))) ;;}}} ;;{{{ Spam determination. (defun spam-split (&rest specific-checks) "Split this message into the `spam' group if it is spam. This function can be used as an entry in the variable `nnmail-split-fancy', for example like this: (: spam-split). It can take checks as parameters. A string as a parameter will set the `spam-split-group' to that string. See the Info node `(gnus)Fancy Mail Splitting' for more details." (interactive) (setq spam-split-last-successful-check nil) (unless spam-split-disabled (let ((spam-split-group-choice spam-split-group)) (dolist (check specific-checks) (when (stringp check) (setq spam-split-group-choice check) (setq specific-checks (delq check specific-checks)))) (let ((spam-split-group spam-split-group-choice) (widening-needed-check (spam-widening-needed-p specific-checks))) (save-excursion (save-restriction (when widening-needed-check (widen) (gnus-message 8 "spam-split: widening the buffer (%s requires it)" widening-needed-check)) (let ((backends (spam-backend-list)) decision) (while (and backends (not decision)) (let* ((backend (pop backends)) (check-function (spam-backend-check backend)) (spam-split-group (if spam-split-symbolic-return 'spam spam-split-group))) (when (or ;; either, given specific checks, this is one of them (memq backend specific-checks) ;; or, given no specific checks, spam-use-CHECK is set (and (null specific-checks) (symbol-value backend))) (gnus-message 6 "spam-split: calling the %s function" check-function) (setq decision (funcall check-function)) ;; if we got a decision at all, save the current check (when decision (setq spam-split-last-successful-check backend)) (when (eq decision 'spam) (unless spam-split-symbolic-return (gnus-error 5 (format "spam-split got %s but %s is nil" decision spam-split-symbolic-return))))))) (if (eq decision t) (if spam-split-symbolic-return-positive 'ham nil) decision)))))))) (defun spam-find-spam () "Detect spam in the current newsgroup using `spam-split'." (interactive) (let* ((group gnus-newsgroup-name) (autodetect (gnus-parameter-spam-autodetect group)) (methods (gnus-parameter-spam-autodetect-methods group)) (first-method (nth 0 methods)) (articles (if spam-autodetect-recheck-messages gnus-newsgroup-articles gnus-newsgroup-unseen)) article-cannot-be-faked) (dolist (backend methods) (when (spam-backend-statistical-p backend) (setq article-cannot-be-faked t) (return))) (when (memq 'default methods) (setq article-cannot-be-faked t)) (when (and autodetect (not (equal first-method 'none))) (mapcar (lambda (article) (let ((id (spam-fetch-field-message-id-fast article)) (subject (spam-fetch-field-subject-fast article)) (sender (spam-fetch-field-from-fast article)) registry-lookup) (unless id (gnus-message 6 "Article %d has no message ID!" article)) (when (and id spam-log-to-registry) (setq registry-lookup (spam-log-registration-type id 'incoming)) (when registry-lookup (gnus-message 9 "spam-find-spam: message %s was already registered incoming" id))) (let* ((spam-split-symbolic-return t) (spam-split-symbolic-return-positive t) (fake-headers (spam-generate-fake-headers article)) (split-return (or registry-lookup (with-temp-buffer (if article-cannot-be-faked (gnus-request-article-this-buffer article group) ;; else, we fake the article (when fake-headers (insert fake-headers))) (if (or (null first-method) (equal first-method 'default)) (spam-split) (apply 'spam-split methods)))))) (if (equal split-return 'spam) (gnus-summary-mark-article article gnus-spam-mark)) (when (and id split-return spam-log-to-registry) (when (zerop (gnus-registry-group-count id)) (gnus-registry-add-group id group subject sender)) (unless registry-lookup (spam-log-processing-to-registry id 'incoming split-return spam-split-last-successful-check group)))))) articles)))) ;;}}} ;;{{{ registration/unregistration functions (defun spam-resolve-registrations-routine () "Go through the backends and register or unregister articles as needed." (dolist (backend-type '(non-mover mover)) (dolist (classification (spam-classifications)) (dolist (backend (spam-backend-list backend-type)) (let ((rlist (spam-backend-get-article-todo-list backend classification)) (ulist (spam-backend-get-article-todo-list backend classification t)) (delcount 0)) ;; clear the old lists right away (spam-backend-put-article-todo-list backend classification nil nil) (spam-backend-put-article-todo-list backend classification nil t) ;; eliminate duplicates (dolist (article (copy-sequence ulist)) (when (memq article rlist) (incf delcount) (setq rlist (delq article rlist)) (setq ulist (delq article ulist)))) (unless (zerop delcount) (gnus-message 9 "%d messages were saved the trouble of unregistering and then registering" delcount)) ;; unregister articles (unless (zerop (length ulist)) (let ((num (spam-unregister-routine classification backend ulist))) (when (> num 0) (gnus-message 6 "%d %s messages were unregistered by backend %s." num classification backend)))) ;; register articles (unless (zerop (length rlist)) (let ((num (spam-register-routine classification backend rlist))) (when (> num 0) (gnus-message 6 "%d %s messages were registered by backend %s." num classification backend))))))))) (defun spam-unregister-routine (classification backend specific-articles) (spam-register-routine classification backend specific-articles t)) (defun spam-register-routine (classification backend specific-articles &optional unregister) (when (and (spam-classification-valid-p classification) (spam-backend-valid-p backend)) (let* ((register-function (spam-backend-function backend classification 'registration)) (unregister-function (spam-backend-function backend classification 'unregistration)) (run-function (if unregister unregister-function register-function)) (log-function (if unregister 'spam-log-undo-registration 'spam-log-processing-to-registry)) article articles) (when run-function ;; make list of articles, using specific-articles if given (setq articles (or specific-articles (spam-list-articles gnus-newsgroup-articles classification))) ;; process them (when (> (length articles) 0) (gnus-message 5 "%s %d %s articles as %s using backend %s" (if unregister "Unregistering" "Registering") (length articles) (if specific-articles "specific" "") classification backend) (funcall run-function articles) ;; now log all the registrations (or undo them, depending on ;; unregister) (dolist (article articles) (funcall log-function (spam-fetch-field-message-id-fast article) 'process classification backend gnus-newsgroup-name)))) ;; return the number of articles processed (length articles)))) ;;; log a ham- or spam-processor invocation to the registry (defun spam-log-processing-to-registry (id type classification backend group) (when spam-log-to-registry (if (and (stringp id) (stringp group) (spam-process-type-valid-p type) (spam-classification-valid-p classification) (spam-backend-valid-p backend)) (let ((cell-list (cdr-safe (gnus-registry-fetch-extra id type))) (cell (list classification backend group))) (push cell cell-list) (gnus-registry-store-extra-entry id type cell-list)) (gnus-error 7 (format "%s call with bad ID, type, classification, spam-backend, or group" "spam-log-processing-to-registry"))))) ;;; check if a ham- or spam-processor registration has been done (defun spam-log-registered-p (id type) (when spam-log-to-registry (if (and (stringp id) (spam-process-type-valid-p type)) (cdr-safe (gnus-registry-fetch-extra id type)) (progn (gnus-error 7 (format "%s called with bad ID, type, classification, or spam-backend" "spam-log-registered-p")) nil)))) ;;; check what a ham- or spam-processor registration says ;;; returns nil if conflicting registrations are found (defun spam-log-registration-type (id type) (let ((count 0) decision) (dolist (reg (spam-log-registered-p id type)) (let ((classification (nth 0 reg))) (when (spam-classification-valid-p classification) (when (and decision (not (eq classification decision))) (setq count (+ 1 count))) (setq decision classification)))) (if (< 0 count) nil decision))) ;;; check if a ham- or spam-processor registration needs to be undone (defun spam-log-unregistration-needed-p (id type classification backend) (when spam-log-to-registry (if (and (stringp id) (spam-process-type-valid-p type) (spam-classification-valid-p classification) (spam-backend-valid-p backend)) (let ((cell-list (cdr-safe (gnus-registry-fetch-extra id type))) found) (dolist (cell cell-list) (unless found (when (and (eq classification (nth 0 cell)) (eq backend (nth 1 cell))) (setq found t)))) found) (progn (gnus-error 7 (format "%s called with bad ID, type, classification, or spam-backend" "spam-log-unregistration-needed-p")) nil)))) ;;; undo a ham- or spam-processor registration (the group is not used) (defun spam-log-undo-registration (id type classification backend &optional group) (when (and spam-log-to-registry (spam-log-unregistration-needed-p id type classification backend)) (if (and (stringp id) (spam-process-type-valid-p type) (spam-classification-valid-p classification) (spam-backend-valid-p backend)) (let ((cell-list (cdr-safe (gnus-registry-fetch-extra id type))) new-cell-list found) (dolist (cell cell-list) (unless (and (eq classification (nth 0 cell)) (eq backend (nth 1 cell))) (push cell new-cell-list))) (gnus-registry-store-extra-entry id type new-cell-list)) (progn (gnus-error 7 (format "%s call with bad ID, type, spam-backend, or group" "spam-log-undo-registration")) nil)))) ;;}}} ;;{{{ backend functions ;;{{{ Gmane xrefs (defun spam-check-gmane-xref () (let ((header (or (message-fetch-field "Xref") (message-fetch-field "Newsgroups")))) (when header ; return nil when no header (when (string-match spam-gmane-xref-spam-group header) spam-split-group)))) ;;}}} ;;{{{ Regex body (defun spam-check-regex-body () (let ((spam-regex-headers-ham spam-regex-body-ham) (spam-regex-headers-spam spam-regex-body-spam)) (spam-check-regex-headers t))) ;;}}} ;;{{{ Regex headers (defun spam-check-regex-headers (&optional body) (let ((type (if body "body" "header")) ret found) (dolist (h-regex spam-regex-headers-ham) (unless found (goto-char (point-min)) (when (re-search-forward h-regex nil t) (message "Ham regex %s search positive." type) (setq found t)))) (dolist (s-regex spam-regex-headers-spam) (unless found (goto-char (point-min)) (when (re-search-forward s-regex nil t) (message "Spam regex %s search positive." type) (setq found t) (setq ret spam-split-group)))) ret)) ;;}}} ;;{{{ Blackholes. (defun spam-reverse-ip-string (ip) (when (stringp ip) (mapconcat 'identity (nreverse (split-string ip "\\.")) "."))) (defun spam-check-blackholes () "Check the Received headers for blackholed relays." (let ((headers (message-fetch-field "received")) ips matches) (when headers (with-temp-buffer (insert headers) (goto-char (point-min)) (gnus-message 6 "Checking headers for relay addresses") (while (re-search-forward "\\([0-9]+\\.[0-9]+\\.[0-9]+\\.[0-9]+\\)" nil t) (gnus-message 9 "Blackhole search found host IP %s." (match-string 1)) (push (spam-reverse-ip-string (match-string 1)) ips))) (dolist (server spam-blackhole-servers) (dolist (ip ips) (unless (and spam-blackhole-good-server-regex ;; match the good-server-regex against the reversed (again) IP string (string-match spam-blackhole-good-server-regex (spam-reverse-ip-string ip))) (unless matches (let ((query-string (concat ip "." server))) (if spam-use-dig (let ((query-result (query-dig query-string))) (when query-result (gnus-message 6 "(DIG): positive blackhole check '%s'" query-result) (push (list ip server query-result) matches))) ;; else, if not using dig.el (when (query-dns query-string) (gnus-message 6 "positive blackhole check") (push (list ip server (query-dns query-string 'TXT)) matches))))))))) (when matches spam-split-group))) ;;}}} ;;{{{ Hashcash. (defun spam-check-hashcash () "Check the headers for hashcash payments." (ignore-errors (mail-check-payment))) ;mail-check-payment returns a boolean ;;}}} ;;{{{ BBDB ;;; original idea for spam-check-BBDB from Alexander Kotelnikov ;;; ;; all this is done inside a condition-case to trap errors (eval-when-compile (autoload 'bbdb-buffer "bbdb") (autoload 'bbdb-create-internal "bbdb") (autoload 'bbdb-search-simple "bbdb")) ;; Autoloaded in message, which we require. (declare-function gnus-extract-address-components "gnus-util" (from)) (eval-and-compile (when (condition-case nil (progn (require 'bbdb) (require 'bbdb-com)) (file-error ;; `bbdb-records' should not be bound as an autoload function ;; before loading bbdb because of `bbdb-hashtable-size'. (defalias 'bbdb-records 'ignore) (defalias 'spam-BBDB-register-routine 'ignore) (defalias 'spam-enter-ham-BBDB 'ignore) nil)) ;; when the BBDB changes, we want to clear out our cache (defun spam-clear-cache-BBDB (&rest immaterial) (spam-clear-cache 'spam-use-BBDB)) (add-hook 'bbdb-change-hook 'spam-clear-cache-BBDB) (defun spam-enter-ham-BBDB (addresses &optional remove) "Enter an address into the BBDB; implies ham (non-spam) sender" (dolist (from addresses) (when (stringp from) (let* ((parsed-address (gnus-extract-address-components from)) (name (or (nth 0 parsed-address) "Ham Sender")) (remove-function (if remove 'bbdb-delete-record-internal 'ignore)) (net-address (nth 1 parsed-address)) (record (and net-address (bbdb-search-simple nil net-address)))) (when net-address (gnus-message 6 "%s address %s %s BBDB" (if remove "Deleting" "Adding") from (if remove "from" "to")) (if record (funcall remove-function record) (bbdb-create-internal name nil net-address nil nil "ham sender added by spam.el"))))))) (defun spam-BBDB-register-routine (articles &optional unregister) (let (addresses) (dolist (article articles) (when (stringp (spam-fetch-field-from-fast article)) (push (spam-fetch-field-from-fast article) addresses))) ;; now do the register/unregister action (spam-enter-ham-BBDB addresses unregister))) (defun spam-BBDB-unregister-routine (articles) (spam-BBDB-register-routine articles t)) (defun spam-check-BBDB () "Mail from people in the BBDB is classified as ham or non-spam" (let ((who (message-fetch-field "from")) bbdb-cache bbdb-hashtable) (when spam-cache-lookups (setq bbdb-cache (gethash 'spam-use-BBDB spam-caches)) (unless bbdb-cache (setq bbdb-cache (make-vector 17 0)) ; a good starting hash value ;; this is based on the expanded (bbdb-hashtable) macro ;; without the debugging support (with-current-buffer (bbdb-buffer) (save-excursion (save-window-excursion (bbdb-records nil t) (mapatoms (lambda (symbol) (intern (downcase (symbol-name symbol)) bbdb-cache)) bbdb-hashtable)))) (puthash 'spam-use-BBDB bbdb-cache spam-caches))) (when who (setq who (nth 1 (gnus-extract-address-components who))) (if (if spam-cache-lookups (intern-soft (downcase who) bbdb-cache) (bbdb-search-simple nil who)) t (if spam-use-BBDB-exclusive spam-split-group nil))))))) ;;}}} ;;{{{ ifile ;;; check the ifile backend; return nil if the mail was NOT classified ;;; as spam (defun spam-get-ifile-database-parameter () "Return the command-line parameter for ifile's database. See `spam-ifile-database'." (if spam-ifile-database (format "--db-file=%s" spam-ifile-database) nil)) (defun spam-check-ifile () "Check the ifile backend for the classification of this message." (let ((article-buffer-name (buffer-name)) category return) (with-temp-buffer (let ((temp-buffer-name (buffer-name)) (db-param (spam-get-ifile-database-parameter))) (save-excursion (set-buffer article-buffer-name) (apply 'call-process-region (point-min) (point-max) spam-ifile-program nil temp-buffer-name nil "-c" (if db-param `(,db-param "-q") `("-q")))) ;; check the return now (we're back in the temp buffer) (goto-char (point-min)) (if (not (eobp)) (setq category (buffer-substring (point) (point-at-eol)))) (when (not (zerop (length category))) ; we need a category here (if spam-ifile-all-categories (setq return category) ;; else, if spam-ifile-all-categories is not set... (when (string-equal spam-ifile-spam-category category) (setq return spam-split-group)))))) ; note return is nil otherwise return)) (defun spam-ifile-register-with-ifile (articles category &optional unregister) "Register an article, given as a string, with a category. Uses `gnus-newsgroup-name' if category is nil (for ham registration)." (let ((category (or category gnus-newsgroup-name)) (add-or-delete-option (if unregister "-d" "-i")) (db (spam-get-ifile-database-parameter)) parameters) (with-temp-buffer (dolist (article articles) (let ((article-string (spam-get-article-as-string article))) (when (stringp article-string) (insert article-string)))) (apply 'call-process-region (point-min) (point-max) spam-ifile-program nil nil nil add-or-delete-option category (if db `(,db "-h") `("-h")))))) (defun spam-ifile-register-spam-routine (articles &optional unregister) (spam-ifile-register-with-ifile articles spam-ifile-spam-category unregister)) (defun spam-ifile-unregister-spam-routine (articles) (spam-ifile-register-spam-routine articles t)) (defun spam-ifile-register-ham-routine (articles &optional unregister) (spam-ifile-register-with-ifile articles spam-ifile-ham-category unregister)) (defun spam-ifile-unregister-ham-routine (articles) (spam-ifile-register-ham-routine articles t)) ;;}}} ;;{{{ spam-stat (eval-when-compile (autoload 'spam-stat-buffer-change-to-non-spam "spam-stat") (autoload 'spam-stat-buffer-change-to-spam "spam-stat") (autoload 'spam-stat-buffer-is-non-spam "spam-stat") (autoload 'spam-stat-buffer-is-spam "spam-stat") (autoload 'spam-stat-load "spam-stat") (autoload 'spam-stat-save "spam-stat") (autoload 'spam-stat-split-fancy "spam-stat")) (eval-and-compile (when (condition-case nil (let ((spam-stat-install-hooks nil)) (require 'spam-stat)) (file-error (defalias 'spam-stat-register-ham-routine 'ignore) (defalias 'spam-stat-register-spam-routine 'ignore) nil)) (defun spam-check-stat () "Check the spam-stat backend for the classification of this message" (let ((spam-stat-split-fancy-spam-group spam-split-group) ; override (spam-stat-buffer (buffer-name)) ; stat the current buffer category return) (spam-stat-split-fancy))) (defun spam-stat-register-spam-routine (articles &optional unregister) (dolist (article articles) (let ((article-string (spam-get-article-as-string article))) (with-temp-buffer (insert article-string) (if unregister (spam-stat-buffer-change-to-non-spam) (spam-stat-buffer-is-spam)))))) (defun spam-stat-unregister-spam-routine (articles) (spam-stat-register-spam-routine articles t)) (defun spam-stat-register-ham-routine (articles &optional unregister) (dolist (article articles) (let ((article-string (spam-get-article-as-string article))) (with-temp-buffer (insert article-string) (if unregister (spam-stat-buffer-change-to-spam) (spam-stat-buffer-is-non-spam)))))) (defun spam-stat-unregister-ham-routine (articles) (spam-stat-register-ham-routine articles t)) (defun spam-maybe-spam-stat-load () (when spam-use-stat (spam-stat-load))) (defun spam-maybe-spam-stat-save () (when spam-use-stat (spam-stat-save))))) ;;}}} ;;{{{ Blacklists and whitelists. (defvar spam-whitelist-cache nil) (defvar spam-blacklist-cache nil) (defun spam-kill-whole-line () (beginning-of-line) (let ((kill-whole-line t)) (kill-line))) ;;; address can be a list, too (defun spam-enter-whitelist (address &optional remove) "Enter ADDRESS (list or single) into the whitelist. With a non-nil REMOVE, remove them." (interactive "sAddress: ") (spam-enter-list address spam-whitelist remove) (setq spam-whitelist-cache nil) (spam-clear-cache 'spam-use-whitelist)) ;;; address can be a list, too (defun spam-enter-blacklist (address &optional remove) "Enter ADDRESS (list or single) into the blacklist. With a non-nil REMOVE, remove them." (interactive "sAddress: ") (spam-enter-list address spam-blacklist remove) (setq spam-blacklist-cache nil) (spam-clear-cache 'spam-use-whitelist)) (defun spam-enter-list (addresses file &optional remove) "Enter ADDRESSES into the given FILE. Either the whitelist or the blacklist files can be used. With a non-nil REMOVE, remove the ADDRESSES." (if (stringp addresses) (spam-enter-list (list addresses) file remove) ;; else, we have a list of addresses here (unless (file-exists-p (file-name-directory file)) (make-directory (file-name-directory file) t)) (save-excursion (set-buffer (find-file-noselect file)) (dolist (a addresses) (when (stringp a) (goto-char (point-min)) (if (re-search-forward (regexp-quote a) nil t) ;; found the address (when remove (spam-kill-whole-line)) ;; else, the address was not found (unless remove (goto-char (point-max)) (unless (bobp) (insert "\n")) (insert a "\n"))))) (save-buffer)))) (defun spam-filelist-build-cache (type) (let ((cache (if (eq type 'spam-use-blacklist) spam-blacklist-cache spam-whitelist-cache)) parsed-cache) (unless (gethash type spam-caches) (while cache (let ((address (pop cache))) (unless (zerop (length address)) ; 0 for a nil address too (setq address (regexp-quote address)) ;; fix regexp-quote's treatment of user-intended regexes (while (string-match "\\\\\\*" address) (setq address (replace-match ".*" t t address)))) (push address parsed-cache))) (puthash type parsed-cache spam-caches)))) (defun spam-filelist-check-cache (type from) (when (stringp from) (spam-filelist-build-cache type) (let (found) (dolist (address (gethash type spam-caches)) (when (and address (string-match address from)) (setq found t) (return))) found))) ;;; returns t if the sender is in the whitelist, nil or ;;; spam-split-group otherwise (defun spam-check-whitelist () ;; FIXME! Should it detect when file timestamps change? (unless spam-whitelist-cache (setq spam-whitelist-cache (spam-parse-list spam-whitelist))) (if (spam-from-listed-p 'spam-use-whitelist) t (if spam-use-whitelist-exclusive spam-split-group nil))) (defun spam-check-blacklist () ;; FIXME! Should it detect when file timestamps change? (unless spam-blacklist-cache (setq spam-blacklist-cache (spam-parse-list spam-blacklist))) (and (spam-from-listed-p 'spam-use-blacklist) spam-split-group)) (defun spam-parse-list (file) (when (file-readable-p file) (let (contents address) (with-temp-buffer (insert-file-contents file) (while (not (eobp)) (setq address (buffer-substring (point) (point-at-eol))) (forward-line 1) ;; insert the e-mail address if detected, otherwise the raw data (unless (zerop (length address)) (let ((pure-address (nth 1 (gnus-extract-address-components address)))) (push (or pure-address address) contents))))) (nreverse contents)))) (defun spam-from-listed-p (type) (let ((from (message-fetch-field "from")) found) (spam-filelist-check-cache type from))) (defun spam-filelist-register-routine (articles blacklist &optional unregister) (let ((de-symbol (if blacklist 'spam-use-whitelist 'spam-use-blacklist)) (declassification (if blacklist 'ham 'spam)) (enter-function (if blacklist 'spam-enter-blacklist 'spam-enter-whitelist)) (remove-function (if blacklist 'spam-enter-whitelist 'spam-enter-blacklist)) from addresses unregister-list article-unregister-list) (dolist (article articles) (let ((from (spam-fetch-field-from-fast article)) (id (spam-fetch-field-message-id-fast article)) sender-ignored) (when (stringp from) (dolist (ignore-regex spam-blacklist-ignored-regexes) (when (and (not sender-ignored) (stringp ignore-regex) (string-match ignore-regex from)) (setq sender-ignored t))) ;; remember the messages we need to unregister, unless remove is set (when (and (null unregister) (spam-log-unregistration-needed-p id 'process declassification de-symbol)) (push article article-unregister-list) (push from unregister-list)) (unless sender-ignored (push from addresses))))) (if unregister (funcall enter-function addresses t) ; unregister all these addresses ;; else, register normally and unregister what we need to (funcall remove-function unregister-list t) (dolist (article article-unregister-list) (spam-log-undo-registration (spam-fetch-field-message-id-fast article) 'process declassification de-symbol)) (funcall enter-function addresses nil)))) (defun spam-blacklist-unregister-routine (articles) (spam-blacklist-register-routine articles t)) (defun spam-blacklist-register-routine (articles &optional unregister) (spam-filelist-register-routine articles t unregister)) (defun spam-whitelist-unregister-routine (articles) (spam-whitelist-register-routine articles t)) (defun spam-whitelist-register-routine (articles &optional unregister) (spam-filelist-register-routine articles nil unregister)) ;;}}} ;;{{{ Spam-report glue (gmane and resend reporting) (defun spam-report-gmane-register-routine (articles) (when articles (apply 'spam-report-gmane-spam articles))) (defun spam-report-gmane-unregister-routine (articles) (when articles (apply 'spam-report-gmane-ham articles))) (defun spam-report-resend-register-ham-routine (articles) (spam-report-resend-register-routine articles t)) (defun spam-report-resend-register-routine (articles &optional ham) (let* ((resend-to-gp (if ham (gnus-parameter-ham-resend-to gnus-newsgroup-name) (gnus-parameter-spam-resend-to gnus-newsgroup-name))) (spam-report-resend-to (or (car-safe resend-to-gp) spam-report-resend-to))) (spam-report-resend articles ham))) ;;}}} ;;{{{ Bogofilter (defun spam-check-bogofilter-headers (&optional score) (let ((header (message-fetch-field spam-bogofilter-header))) (when header ; return nil when no header (if score ; scoring mode (if (string-match "spamicity=\\([0-9.]+\\)" header) (match-string 1 header) "0") ;; spam detection mode (when (string-match spam-bogofilter-bogosity-positive-spam-header header) spam-split-group))))) ;; return something sensible if the score can't be determined (defun spam-bogofilter-score (&optional recheck) "Get the Bogofilter spamicity score." (interactive "P") (save-window-excursion (gnus-summary-show-article t) (set-buffer gnus-article-buffer) (let ((score (or (unless recheck (spam-check-bogofilter-headers t)) (spam-check-bogofilter t)))) (gnus-summary-show-article) (message "Spamicity score %s" score) (or score "0")))) (defun spam-verify-bogofilter () "Verify the Bogofilter version is sufficient." (when (eq spam-bogofilter-valid 'unknown) (setq spam-bogofilter-valid (not (string-match "^bogofilter version 0\\.\\([0-9]\\|1[01]\\)\\." (shell-command-to-string (format "%s -V" spam-bogofilter-program)))))) spam-bogofilter-valid) (defun spam-check-bogofilter (&optional score) "Check the Bogofilter backend for the classification of this message." (if (spam-verify-bogofilter) (let ((article-buffer-name (buffer-name)) (db spam-bogofilter-database-directory) return) (with-temp-buffer (let ((temp-buffer-name (buffer-name))) (save-excursion (set-buffer article-buffer-name) (apply 'call-process-region (point-min) (point-max) spam-bogofilter-program nil temp-buffer-name nil (if db `("-d" ,db "-v") `("-v")))) (setq return (spam-check-bogofilter-headers score)))) return) (gnus-error 5 "`spam.el' doesn't support obsolete bogofilter versions"))) (defun spam-bogofilter-register-with-bogofilter (articles spam &optional unregister) "Register an article, given as a string, as spam or non-spam." (if (spam-verify-bogofilter) (dolist (article articles) (let ((article-string (spam-get-article-as-string article)) (db spam-bogofilter-database-directory) (switch (if unregister (if spam spam-bogofilter-spam-strong-switch spam-bogofilter-ham-strong-switch) (if spam spam-bogofilter-spam-switch spam-bogofilter-ham-switch)))) (when (stringp article-string) (with-temp-buffer (insert article-string) (apply 'call-process-region (point-min) (point-max) spam-bogofilter-program nil nil nil switch (if db `("-d" ,db "-v") `("-v"))))))) (gnus-error 5 "`spam.el' doesn't support obsolete bogofilter versions"))) (defun spam-bogofilter-register-spam-routine (articles &optional unregister) (spam-bogofilter-register-with-bogofilter articles t unregister)) (defun spam-bogofilter-unregister-spam-routine (articles) (spam-bogofilter-register-spam-routine articles t)) (defun spam-bogofilter-register-ham-routine (articles &optional unregister) (spam-bogofilter-register-with-bogofilter articles nil unregister)) (defun spam-bogofilter-unregister-ham-routine (articles) (spam-bogofilter-register-ham-routine articles t)) ;;}}} ;;{{{ spamoracle (defun spam-check-spamoracle () "Run spamoracle on an article to determine whether it's spam." (let ((article-buffer-name (buffer-name))) (with-temp-buffer (let ((temp-buffer-name (buffer-name))) (save-excursion (set-buffer article-buffer-name) (let ((status (apply 'call-process-region (point-min) (point-max) spam-spamoracle-binary nil temp-buffer-name nil (if spam-spamoracle-database `("-f" ,spam-spamoracle-database "mark") '("mark"))))) (if (eq 0 status) (progn (set-buffer temp-buffer-name) (goto-char (point-min)) (when (re-search-forward "^X-Spam: yes;" nil t) spam-split-group)) (error "Error running spamoracle: %s" status)))))))) (defun spam-spamoracle-learn (articles article-is-spam-p &optional unregister) "Run spamoracle in training mode." (with-temp-buffer (let ((temp-buffer-name (buffer-name))) (save-excursion (goto-char (point-min)) (dolist (article articles) (insert (spam-get-article-as-string article))) (let* ((arg (if (spam-xor unregister article-is-spam-p) "-spam" "-good")) (status (apply 'call-process-region (point-min) (point-max) spam-spamoracle-binary nil temp-buffer-name nil (if spam-spamoracle-database `("-f" ,spam-spamoracle-database "add" ,arg) `("add" ,arg))))) (unless (eq 0 status) (error "Error running spamoracle: %s" status))))))) (defun spam-spamoracle-learn-ham (articles &optional unregister) (spam-spamoracle-learn articles nil unregister)) (defun spam-spamoracle-unlearn-ham (articles &optional unregister) (spam-spamoracle-learn-ham articles t)) (defun spam-spamoracle-learn-spam (articles &optional unregister) (spam-spamoracle-learn articles t unregister)) (defun spam-spamoracle-unlearn-spam (articles &optional unregister) (spam-spamoracle-learn-spam articles t)) ;;}}} ;;{{{ SpamAssassin ;;; based mostly on the bogofilter code (defun spam-check-spamassassin-headers (&optional score) "Check the SpamAssassin headers for the classification of this message." (if score ; scoring mode (let ((header (message-fetch-field spam-spamassassin-spam-status-header))) (when header (if (string-match spam-spamassassin-score-regexp header) (match-string 1 header) "0"))) ;; spam detection mode (let ((header (message-fetch-field spam-spamassassin-spam-flag-header))) (when header ; return nil when no header (when (string-match spam-spamassassin-positive-spam-flag-header header) spam-split-group))))) (defun spam-check-spamassassin (&optional score) "Check the SpamAssassin backend for the classification of this message." (let ((article-buffer-name (buffer-name))) (with-temp-buffer (let ((temp-buffer-name (buffer-name))) (save-excursion (set-buffer article-buffer-name) (apply 'call-process-region (point-min) (point-max) spam-assassin-program nil temp-buffer-name nil spam-spamassassin-arguments)) ;; check the return now (we're back in the temp buffer) (goto-char (point-min)) (spam-check-spamassassin-headers score))))) ;; return something sensible if the score can't be determined (defun spam-spamassassin-score (&optional recheck) "Get the SpamAssassin score" (interactive "P") (save-window-excursion (gnus-summary-show-article t) (set-buffer gnus-article-buffer) (let ((score (or (unless recheck (spam-check-spamassassin-headers t)) (spam-check-spamassassin t)))) (gnus-summary-show-article) (message "SpamAssassin score %s" score) (or score "0")))) (defun spam-spamassassin-register-with-sa-learn (articles spam &optional unregister) "Register articles with spamassassin's sa-learn as spam or non-spam." (if articles (let ((action (if unregister spam-sa-learn-unregister-switch (if spam spam-sa-learn-spam-switch spam-sa-learn-ham-switch))) (summary-buffer-name (buffer-name))) (with-temp-buffer ;; group the articles into mbox format (dolist (article articles) (let (article-string) (save-excursion (set-buffer summary-buffer-name) (setq article-string (spam-get-article-as-string article))) (when (stringp article-string) (insert "From \n") ; mbox separator (sa-learn only checks the ; first five chars, so we can get away with ; a bogus line)) (insert article-string) (insert "\n")))) ;; call sa-learn on all messages at the same time (apply 'call-process-region (point-min) (point-max) spam-sa-learn-program nil nil nil "--mbox" (if spam-sa-learn-rebuild (list action) `("--no-rebuild" ,action))))))) (defun spam-spamassassin-register-spam-routine (articles &optional unregister) (spam-spamassassin-register-with-sa-learn articles t unregister)) (defun spam-spamassassin-register-ham-routine (articles &optional unregister) (spam-spamassassin-register-with-sa-learn articles nil unregister)) (defun spam-spamassassin-unregister-spam-routine (articles) (spam-spamassassin-register-with-sa-learn articles t t)) (defun spam-spamassassin-unregister-ham-routine (articles) (spam-spamassassin-register-with-sa-learn articles nil t)) ;;}}} ;;{{{ Bsfilter ;;; based mostly on the bogofilter code (defun spam-check-bsfilter-headers (&optional score) (if score (or (nnmail-fetch-field spam-bsfilter-probability-header) "0") (let ((header (nnmail-fetch-field spam-bsfilter-header))) (when header ; return nil when no header (when (string-match "YES" header) spam-split-group))))) ;; return something sensible if the score can't be determined (defun spam-bsfilter-score (&optional recheck) "Get the Bsfilter spamicity score." (interactive "P") (save-window-excursion (gnus-summary-show-article t) (set-buffer gnus-article-buffer) (let ((score (or (unless recheck (spam-check-bsfilter-headers t)) (spam-check-bsfilter t)))) (gnus-summary-show-article) (message "Spamicity score %s" score) (or score "0")))) (defun spam-check-bsfilter (&optional score) "Check the Bsfilter backend for the classification of this message." (let ((article-buffer-name (buffer-name)) (dir spam-bsfilter-database-directory) return) (with-temp-buffer (let ((temp-buffer-name (buffer-name))) (save-excursion (set-buffer article-buffer-name) (apply 'call-process-region (point-min) (point-max) spam-bsfilter-program nil temp-buffer-name nil "--pipe" "--insert-flag" "--insert-probability" (when dir (list "--homedir" dir)))) (setq return (spam-check-bsfilter-headers score)))) return)) (defun spam-bsfilter-register-with-bsfilter (articles spam &optional unregister) "Register an article, given as a string, as spam or non-spam." (dolist (article articles) (let ((article-string (spam-get-article-as-string article)) (switch (if unregister (if spam spam-bsfilter-spam-strong-switch spam-bsfilter-ham-strong-switch) (if spam spam-bsfilter-spam-switch spam-bsfilter-ham-switch)))) (when (stringp article-string) (with-temp-buffer (insert article-string) (apply 'call-process-region (point-min) (point-max) spam-bsfilter-program nil nil nil switch "--update" (when spam-bsfilter-database-directory (list "--homedir" spam-bsfilter-database-directory)))))))) (defun spam-bsfilter-register-spam-routine (articles &optional unregister) (spam-bsfilter-register-with-bsfilter articles t unregister)) (defun spam-bsfilter-unregister-spam-routine (articles) (spam-bsfilter-register-spam-routine articles t)) (defun spam-bsfilter-register-ham-routine (articles &optional unregister) (spam-bsfilter-register-with-bsfilter articles nil unregister)) (defun spam-bsfilter-unregister-ham-routine (articles) (spam-bsfilter-register-ham-routine articles t)) ;;}}} ;;{{{ CRM114 Mailfilter (defun spam-check-crm114-headers (&optional score) (let ((header (message-fetch-field spam-crm114-header))) (when header ; return nil when no header (if score ; scoring mode (if (string-match "( pR: \\([0-9.-]+\\)" header) (match-string 1 header) "0") ;; spam detection mode (when (string-match spam-crm114-positive-spam-header header) spam-split-group))))) ;; return something sensible if the score can't be determined (defun spam-crm114-score () "Get the CRM114 Mailfilter pR." (interactive) (save-window-excursion (gnus-summary-show-article t) (set-buffer gnus-article-buffer) (let ((score (or (spam-check-crm114-headers t) (spam-check-crm114 t)))) (gnus-summary-show-article) (message "pR: %s" score) (or score "0")))) (defun spam-check-crm114 (&optional score) "Check the CRM114 Mailfilter backend for the classification of this message." (let ((article-buffer-name (buffer-name)) (db spam-crm114-database-directory) return) (with-temp-buffer (let ((temp-buffer-name (buffer-name))) (save-excursion (set-buffer article-buffer-name) (apply 'call-process-region (point-min) (point-max) spam-crm114-program nil temp-buffer-name nil (when db (list (concat "--fileprefix=" db))))) (setq return (spam-check-crm114-headers score)))) return)) (defun spam-crm114-register-with-crm114 (articles spam &optional unregister) "Register an article, given as a string, as spam or non-spam." (dolist (article articles) (let ((article-string (spam-get-article-as-string article)) (db spam-crm114-database-directory) (switch (if unregister (if spam spam-crm114-spam-strong-switch spam-crm114-ham-strong-switch) (if spam spam-crm114-spam-switch spam-crm114-ham-switch)))) (when (stringp article-string) (with-temp-buffer (insert article-string) (apply 'call-process-region (point-min) (point-max) spam-crm114-program nil nil nil (when db (list switch (concat "--fileprefix=" db))))))))) (defun spam-crm114-register-spam-routine (articles &optional unregister) (spam-crm114-register-with-crm114 articles t unregister)) (defun spam-crm114-unregister-spam-routine (articles) (spam-crm114-register-spam-routine articles t)) (defun spam-crm114-register-ham-routine (articles &optional unregister) (spam-crm114-register-with-crm114 articles nil unregister)) (defun spam-crm114-unregister-ham-routine (articles) (spam-crm114-register-ham-routine articles t)) ;;}}} ;;}}} ;;{{{ Hooks ;;;###autoload (defun spam-initialize (&rest symbols) "Install the spam.el hooks and do other initialization. When SYMBOLS is given, set those variables to t. This is so you can call `spam-initialize' before you set spam-use-* variables on explicitly, and matters only if you need the extra headers installed through `spam-necessary-extra-headers'." (interactive) (dolist (var symbols) (set var t)) (dolist (header (spam-necessary-extra-headers)) (add-to-list 'nnmail-extra-headers header) (add-to-list 'gnus-extra-headers header)) (setq spam-install-hooks t) ;; TODO: How do we redo this every time the `spam' face is customized? (push '((eq mark gnus-spam-mark) . spam) gnus-summary-highlight) ;; Add hooks for loading and saving the spam stats (add-hook 'gnus-save-newsrc-hook 'spam-maybe-spam-stat-save) (add-hook 'gnus-get-top-new-news-hook 'spam-maybe-spam-stat-load) (add-hook 'gnus-startup-hook 'spam-maybe-spam-stat-load) (add-hook 'gnus-summary-prepare-exit-hook 'spam-summary-prepare-exit) (add-hook 'gnus-summary-prepare-hook 'spam-summary-prepare) (add-hook 'gnus-get-new-news-hook 'spam-setup-widening) (add-hook 'gnus-summary-prepared-hook 'spam-find-spam)) (defun spam-unload-hook () "Uninstall the spam.el hooks." (interactive) (remove-hook 'gnus-save-newsrc-hook 'spam-maybe-spam-stat-save) (remove-hook 'gnus-get-top-new-news-hook 'spam-maybe-spam-stat-load) (remove-hook 'gnus-startup-hook 'spam-maybe-spam-stat-load) (remove-hook 'gnus-summary-prepare-exit-hook 'spam-summary-prepare-exit) (remove-hook 'gnus-summary-prepare-hook 'spam-summary-prepare) (remove-hook 'gnus-get-new-news-hook 'spam-setup-widening) (remove-hook 'gnus-summary-prepare-hook 'spam-find-spam)) (add-hook 'spam-unload-hook 'spam-unload-hook) (when spam-install-hooks (spam-initialize)) ;;}}} (provide 'spam) ;; arch-tag: 07e6e0ca-ab0a-4412-b445-1f6c72a4f27f ;;; spam.el ends here gnus-5.11+v0.10.dfsg/lisp/ietf-drums.el0000644000175000017500000002101211004005110017616 0ustar tvainikatvainika;;; ietf-drums.el --- Functions for parsing RFC822bis headers ;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, ;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 3, or (at your option) ;; any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Commentary: ;; DRUMS is an IETF Working Group that works (or worked) on the ;; successor to RFC822, "Standard For The Format Of Arpa Internet Text ;; Messages". This library is based on ;; draft-ietf-drums-msg-fmt-05.txt, released on 1998-08-05. ;; Pending a real regression self test suite, Simon Josefsson added ;; various self test expressions snipped from bug reports, and their ;; expected value, below. I you believe it could be useful, please ;; add your own test cases, or write a real self test suite, or just ;; remove this. ;; ;; (ietf-drums-parse-address "'foo' ") ;; => ("foo@example.com" . "'foo'") ;;; Code: (eval-when-compile (require 'cl)) (require 'time-date) (require 'mm-util) (defvar ietf-drums-no-ws-ctl-token "\001-\010\013\014\016-\037\177" "US-ASCII control characters excluding CR, LF and white space.") (defvar ietf-drums-text-token "\001-\011\013\014\016-\177" "US-ASCII characters excluding CR and LF.") (defvar ietf-drums-specials-token "()<>[]:;@\\,.\"" "Special characters.") (defvar ietf-drums-quote-token "\\" "Quote character.") (defvar ietf-drums-wsp-token " \t" "White space.") (defvar ietf-drums-fws-regexp (concat "[" ietf-drums-wsp-token "]*\n[" ietf-drums-wsp-token "]+") "Folding white space.") (defvar ietf-drums-atext-token "-^a-zA-Z0-9!#$%&'*+/=?_`{|}~" "Textual token.") (defvar ietf-drums-dot-atext-token "-^a-zA-Z0-9!#$%&'*+/=?_`{|}~." "Textual token including full stop.") (defvar ietf-drums-qtext-token (concat ietf-drums-no-ws-ctl-token "\041\043-\133\135-\177") "Non-white-space control characters, plus the rest of ASCII excluding backslash and doublequote.") (defvar ietf-drums-tspecials "][()<>@,;:\\\"/?=" "Tspecials.") (defvar ietf-drums-syntax-table (let ((table (copy-syntax-table emacs-lisp-mode-syntax-table))) (modify-syntax-entry ?\\ "/" table) (modify-syntax-entry ?< "(" table) (modify-syntax-entry ?> ")" table) (modify-syntax-entry ?@ "w" table) (modify-syntax-entry ?/ "w" table) (modify-syntax-entry ?* "_" table) (modify-syntax-entry ?\; "_" table) (modify-syntax-entry ?\' "_" table) (if (featurep 'xemacs) (let ((i 128)) (while (< i 256) (modify-syntax-entry i "w" table) (setq i (1+ i))))) table)) (defun ietf-drums-token-to-list (token) "Translate TOKEN into a list of characters." (let ((i 0) b e c out range) (while (< i (length token)) (setq c (mm-char-int (aref token i))) (incf i) (cond ((eq c (mm-char-int ?-)) (if b (setq range t) (push c out))) (range (while (<= b c) (push (make-char 'ascii b) out) (incf b)) (setq range nil)) ((= i (length token)) (push (make-char 'ascii c) out)) (t (when b (push (make-char 'ascii b) out)) (setq b c)))) (nreverse out))) (defsubst ietf-drums-init (string) (set-syntax-table ietf-drums-syntax-table) (insert string) (ietf-drums-unfold-fws) (goto-char (point-min))) (defun ietf-drums-remove-comments (string) "Remove comments from STRING." (with-temp-buffer (let (c) (ietf-drums-init string) (while (not (eobp)) (setq c (char-after)) (cond ((eq c ?\") (forward-sexp 1)) ((eq c ?\() (delete-region (point) (progn (forward-sexp 1) (point)))) (t (forward-char 1)))) (buffer-string)))) (defun ietf-drums-remove-whitespace (string) "Remove whitespace from STRING." (with-temp-buffer (ietf-drums-init string) (let (c) (while (not (eobp)) (setq c (char-after)) (cond ((eq c ?\") (forward-sexp 1)) ((eq c ?\() (forward-sexp 1)) ((memq c '(?\ ?\t ?\n)) (delete-char 1)) (t (forward-char 1)))) (buffer-string)))) (defun ietf-drums-get-comment (string) "Return the first comment in STRING." (with-temp-buffer (ietf-drums-init string) (let (result c) (while (not (eobp)) (setq c (char-after)) (cond ((eq c ?\") (forward-sexp 1)) ((eq c ?\() (setq result (buffer-substring (1+ (point)) (progn (forward-sexp 1) (1- (point)))))) (t (forward-char 1)))) result))) (defun ietf-drums-strip (string) "Remove comments and whitespace from STRING." (ietf-drums-remove-whitespace (ietf-drums-remove-comments string))) (defun ietf-drums-parse-address (string) "Parse STRING and return a MAILBOX / DISPLAY-NAME pair." (with-temp-buffer (let (display-name mailbox c display-string) (ietf-drums-init string) (while (not (eobp)) (setq c (char-after)) (cond ((or (eq c ? ) (eq c ?\t)) (forward-char 1)) ((eq c ?\() (forward-sexp 1)) ((eq c ?\") (push (buffer-substring (1+ (point)) (progn (forward-sexp 1) (1- (point)))) display-name)) ((looking-at (concat "[" ietf-drums-atext-token "@" "]")) (push (buffer-substring (point) (progn (forward-sexp 1) (point))) display-name)) ((eq c ?<) (setq mailbox (ietf-drums-remove-whitespace (ietf-drums-remove-comments (buffer-substring (1+ (point)) (progn (forward-sexp 1) (1- (point)))))))) (t (message "Unknown symbol: %c" c) (forward-char 1)))) ;; If we found no display-name, then we look for comments. (if display-name (setq display-string (mapconcat 'identity (reverse display-name) " ")) (setq display-string (ietf-drums-get-comment string))) (if (not mailbox) (when (string-match "@" display-string) (cons (mapconcat 'identity (nreverse display-name) "") (ietf-drums-get-comment string))) (cons mailbox display-string))))) (defun ietf-drums-parse-addresses (string &optional rawp) "Parse STRING and return a list of MAILBOX / DISPLAY-NAME pairs. If RAWP, don't actually parse the addresses, but instead return a list of address strings." (if (null string) nil (with-temp-buffer (ietf-drums-init string) (let ((beg (point)) pairs c address) (while (not (eobp)) (setq c (char-after)) (cond ((memq c '(?\" ?< ?\()) (condition-case nil (forward-sexp 1) (error (skip-chars-forward "^,")))) ((eq c ?,) (setq address (if rawp (buffer-substring beg (point)) (condition-case nil (ietf-drums-parse-address (buffer-substring beg (point))) (error nil)))) (if address (push address pairs)) (forward-char 1) (setq beg (point))) (t (forward-char 1)))) (setq address (if rawp (buffer-substring beg (point)) (condition-case nil (ietf-drums-parse-address (buffer-substring beg (point))) (error nil)))) (if address (push address pairs)) (nreverse pairs))))) (defun ietf-drums-unfold-fws () "Unfold folding white space in the current buffer." (goto-char (point-min)) (while (re-search-forward ietf-drums-fws-regexp nil t) (replace-match " " t t)) (goto-char (point-min))) (defun ietf-drums-parse-date (string) "Return an Emacs time spec from STRING." (apply 'encode-time (parse-time-string string))) (defun ietf-drums-narrow-to-header () "Narrow to the header section in the current buffer." (narrow-to-region (goto-char (point-min)) (if (re-search-forward "^\r?$" nil 1) (match-beginning 0) (point-max))) (goto-char (point-min))) (defun ietf-drums-quote-string (string) "Quote string if it needs quoting to be displayed in a header." (if (string-match (concat "[^" ietf-drums-atext-token "]") string) (concat "\"" string "\"") string)) (defun ietf-drums-make-address (name address) (if name (concat (ietf-drums-quote-string name) " <" address ">") address)) (provide 'ietf-drums) ;; arch-tag: 379a0191-dbae-4ca6-a0f5-d4202c209ef9 ;;; ietf-drums.el ends here gnus-5.11+v0.10.dfsg/lisp/sasl-cram.el0000644000175000017500000000317711004005110017435 0ustar tvainikatvainika;;; sasl-cram.el --- CRAM-MD5 module for the SASL client framework ;; Copyright (C) 2000, 2007, 2008 Free Software Foundation, Inc. ;; Author: Daiki Ueno ;; Kenichi OKADA ;; Keywords: SASL, CRAM-MD5 ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 3, or (at your option) ;; any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Commentary: (require 'sasl) (require 'hmac-md5) (defconst sasl-cram-md5-steps '(ignore ;no initial response sasl-cram-md5-response)) (defun sasl-cram-md5-response (client step) (let ((passphrase (sasl-read-passphrase (format "CRAM-MD5 passphrase for %s: " (sasl-client-name client))))) (unwind-protect (concat (sasl-client-name client) " " (encode-hex-string (hmac-md5 (sasl-step-data step) passphrase))) (fillarray passphrase 0)))) (put 'sasl-cram 'sasl-mechanism (sasl-make-mechanism "CRAM-MD5" sasl-cram-md5-steps)) (provide 'sasl-cram) ;; arch-tag: 46cb281b-975a-4fe0-a39f-3018691b1b05 ;;; sasl-cram.el ends here gnus-5.11+v0.10.dfsg/lisp/rfc1843.el0000644000175000017500000001437611004005111016651 0ustar tvainikatvainika;;; rfc1843.el --- HZ (rfc1843) decoding ;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, ;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc. ;; Author: Shenghuo Zhu ;; Keywords: news HZ HZ+ mail i18n ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published ;; by the Free Software Foundation; either version 3, or (at your ;; option) any later version. ;; GNU Emacs is distributed in the hope that it will be useful, but ;; WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Commentary: ;; Usage: ;; (require 'rfc1843) ;; (rfc1843-gnus-setup) ;; ;; Test: ;; (rfc1843-decode-string "~{<:Ky2;S{#,NpJ)l6HK!#~}") ;;; Code: ;; For Emacs < 22.2. (eval-and-compile (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) (eval-when-compile (require 'cl)) (require 'mm-util) (defvar gnus-decode-encoded-word-function) (defvar gnus-decode-header-function) (defvar gnus-newsgroup-name) (defvar rfc1843-word-regexp "~\\({\\([\041-\167][\041-\176]\\| \\)+\\)\\(~}\\|$\\)") (defvar rfc1843-word-regexp-strictly "~\\({\\([\041-\167][\041-\176]\\)+\\)\\(~}\\|$\\)") (defvar rfc1843-hzp-word-regexp "~\\({\\([\041-\167][\041-\176]\\| \\)+\\|\ \[<>]\\([\041-\175][\041-\176]\\| \\)+\\)\\(~}\\|$\\)") (defvar rfc1843-hzp-word-regexp-strictly "~\\({\\([\041-\167][\041-\176]\\)+\\|\ \[<>]\\([\041-\175][\041-\176]\\)+\\)\\(~}\\|$\\)") (defcustom rfc1843-decode-loosely nil "Loosely check HZ encoding if non-nil. When it is set non-nil, only buffers or strings with strictly HZ-encoded are decoded." :type 'boolean :group 'mime) (defcustom rfc1843-decode-hzp t "HZ+ decoding support if non-nil. HZ+ specification (also known as HZP) is to provide a standardized 7-bit representation of mixed Big5, GB, and ASCII text for convenient e-mail transmission, news posting, etc. The document of HZ+ 0.78 specification can be found at ftp://ftp.math.psu.edu/pub/simpson/chinese/hzp/hzp.doc" :type 'boolean :group 'mime) (defcustom rfc1843-newsgroups-regexp "chinese\\|hz" "Regexp of newsgroups in which might be HZ encoded." :type 'string :group 'mime) (defun rfc1843-decode-region (from to) "Decode HZ in the region between FROM and TO." (interactive "r") (let (str firstc) (save-excursion (goto-char from) (if (or rfc1843-decode-loosely (re-search-forward (if rfc1843-decode-hzp rfc1843-hzp-word-regexp-strictly rfc1843-word-regexp-strictly) to t)) (save-restriction (narrow-to-region from to) (goto-char (point-min)) (while (re-search-forward (if rfc1843-decode-hzp rfc1843-hzp-word-regexp rfc1843-word-regexp) (point-max) t) ;;; Text with extents may cause XEmacs crash (setq str (buffer-substring-no-properties (match-beginning 1) (match-end 1))) (setq firstc (aref str 0)) (insert (mm-decode-coding-string (rfc1843-decode (prog1 (substring str 1) (delete-region (match-beginning 0) (match-end 0))) firstc) (if (eq firstc ?{) 'cn-gb-2312 'cn-big5)))) (goto-char (point-min)) (while (search-forward "~" (point-max) t) (cond ((eq (char-after) ?\n) (delete-char -1) (delete-char 1)) ((eq (char-after) ?~) (delete-char 1))))))))) (defun rfc1843-decode-string (string) "Decode HZ STRING and return the results." (let ((m (mm-multibyte-p))) (with-temp-buffer (when m (mm-enable-multibyte)) (insert string) (inline (rfc1843-decode-region (point-min) (point-max))) (buffer-string)))) (defun rfc1843-decode (word &optional firstc) "Decode HZ WORD and return it." (let ((i -1) (s (substring word 0)) v) (if (or (not firstc) (eq firstc ?{)) (while (< (incf i) (length s)) (if (eq (setq v (aref s i)) ? ) nil (aset s i (+ 128 v)))) (while (< (incf i) (length s)) (if (eq (setq v (aref s i)) ? ) nil (setq v (+ (* 94 v) (aref s (1+ i)) -3135)) (aset s i (+ (/ v 157) (if (eq firstc ?<) 201 161))) (setq v (% v 157)) (aset s (incf i) (+ v (if (< v 63) 64 98)))))) s)) (autoload 'mail-header-parse-content-type "mail-parse") (autoload 'message-narrow-to-head "message") (declare-function message-fetch-field "message" (header &optional not-all)) (defun rfc1843-decode-article-body () "Decode HZ encoded text in the article body." (if (string-match (concat "\\<\\(" rfc1843-newsgroups-regexp "\\)\\>") (or gnus-newsgroup-name "")) (save-excursion (save-restriction (message-narrow-to-head) (let* ((inhibit-point-motion-hooks t) (case-fold-search t) (ct (message-fetch-field "Content-Type" t)) (ctl (and ct (mail-header-parse-content-type ct)))) (if (and ctl (not (string-match "/" (car ctl)))) (setq ctl nil)) (goto-char (point-max)) (widen) (forward-line 1) (narrow-to-region (point) (point-max)) (when (or (not ctl) (equal (car ctl) "text/plain")) (rfc1843-decode-region (point) (point-max)))))))) (defvar rfc1843-old-gnus-decode-header-function nil) (defvar gnus-decode-header-methods) (defvar gnus-decode-encoded-word-methods) (defun rfc1843-gnus-setup () "Setup HZ decoding for Gnus." (require 'gnus-art) (require 'gnus-sum) (add-hook 'gnus-article-decode-hook 'rfc1843-decode-article-body t) (setq gnus-decode-encoded-word-function 'gnus-multi-decode-encoded-word-string gnus-decode-header-function 'gnus-multi-decode-header gnus-decode-encoded-word-methods (nconc gnus-decode-encoded-word-methods (list (cons (concat "\\<\\(" rfc1843-newsgroups-regexp "\\)\\>") 'rfc1843-decode-string))) gnus-decode-header-methods (nconc gnus-decode-header-methods (list (cons (concat "\\<\\(" rfc1843-newsgroups-regexp "\\)\\>") 'rfc1843-decode-region))))) (provide 'rfc1843) ;; arch-tag: 5149c301-a6ca-4731-9c9d-ba616e2cb687 ;;; rfc1843.el ends here gnus-5.11+v0.10.dfsg/lisp/gnus-draft.el0000644000175000017500000002654111004005111017626 0ustar tvainikatvainika;;; gnus-draft.el --- draft message support for Gnus ;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, ;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; Keywords: news ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 3, or (at your option) ;; any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Commentary: ;;; Code: (require 'gnus) (require 'gnus-sum) (require 'message) (require 'gnus-msg) (require 'nndraft) (require 'gnus-agent) (eval-when-compile (require 'cl)) ;;; Draft minor mode (defvar gnus-draft-mode nil "Minor mode for providing a draft summary buffers.") (defvar gnus-draft-mode-map nil) (unless gnus-draft-mode-map (setq gnus-draft-mode-map (make-sparse-keymap)) (gnus-define-keys gnus-draft-mode-map "Dt" gnus-draft-toggle-sending "e" gnus-draft-edit-message ;; Use `B w' for `gnus-summary-edit-article' "De" gnus-draft-edit-message "Ds" gnus-draft-send-message "DS" gnus-draft-send-all-messages)) (defun gnus-draft-make-menu-bar () (unless (boundp 'gnus-draft-menu) (easy-menu-define gnus-draft-menu gnus-draft-mode-map "" '("Drafts" ["Toggle whether to send" gnus-draft-toggle-sending t] ["Edit" gnus-draft-edit-message t] ["Send selected message(s)" gnus-draft-send-message t] ["Send all messages" gnus-draft-send-all-messages t] ["Delete draft" gnus-summary-delete-article t])))) (defun gnus-draft-mode (&optional arg) "Minor mode for providing a draft summary buffers. \\{gnus-draft-mode-map}" (interactive "P") (when (eq major-mode 'gnus-summary-mode) (when (set (make-local-variable 'gnus-draft-mode) (if (null arg) (not gnus-draft-mode) (> (prefix-numeric-value arg) 0))) ;; Set up the menu. (when (gnus-visual-p 'draft-menu 'menu) (gnus-draft-make-menu-bar)) (add-minor-mode 'gnus-draft-mode " Draft" gnus-draft-mode-map) (gnus-run-hooks 'gnus-draft-mode-hook)))) ;;; Commands (defun gnus-draft-toggle-sending (article) "Toggle whether to send an article or not." (interactive (list (gnus-summary-article-number))) (if (gnus-draft-article-sendable-p article) (progn (push article gnus-newsgroup-unsendable) (gnus-summary-mark-article article gnus-unsendable-mark)) (setq gnus-newsgroup-unsendable (delq article gnus-newsgroup-unsendable)) (gnus-summary-mark-article article gnus-unread-mark)) (gnus-summary-position-point)) (defun gnus-draft-edit-message () "Enter a mail/post buffer to edit and send the draft." (interactive) (let ((article (gnus-summary-article-number)) (group gnus-newsgroup-name)) (gnus-draft-check-draft-articles (list article)) (gnus-summary-mark-as-read article gnus-canceled-mark) (gnus-draft-setup article group t) (set-buffer-modified-p t) (save-excursion (save-restriction (message-narrow-to-headers) (message-remove-header "date"))) (let ((message-draft-headers (delq 'Date (copy-sequence message-draft-headers)))) (save-buffer)) (let ((gnus-verbose-backends nil)) (gnus-request-expire-articles (list article) group t)) (push `((lambda () (when (gnus-buffer-exists-p ,gnus-summary-buffer) (save-excursion (set-buffer ,gnus-summary-buffer) (gnus-cache-possibly-remove-article ,article nil nil nil t))))) message-send-actions))) (defun gnus-draft-send-message (&optional n) "Send the current draft(s). Obeys the standard process/prefix convention." (interactive "P") (let* ((articles (gnus-summary-work-articles n)) (total (length articles)) article) (gnus-draft-check-draft-articles articles) (while (setq article (pop articles)) (gnus-summary-remove-process-mark article) (unless (memq article gnus-newsgroup-unsendable) (let ((message-sending-message (format "Sending message %d of %d..." (- total (length articles)) total))) (gnus-draft-send article gnus-newsgroup-name t)) (gnus-summary-mark-article article gnus-canceled-mark))))) (defun gnus-draft-send (article &optional group interactive) "Send message ARTICLE." (let* ((is-queue (or (not group) (equal group "nndraft:queue"))) (message-syntax-checks (if interactive message-syntax-checks 'dont-check-for-anything-just-trust-me)) (message-hidden-headers nil) (message-inhibit-body-encoding (or is-queue message-inhibit-body-encoding)) (message-send-hook (and (not is-queue) message-send-hook)) (message-setup-hook (and (not is-queue) message-setup-hook)) (message-signature (and (not is-queue) message-signature)) (gnus-agent-queue-mail (and (not is-queue) gnus-agent-queue-mail)) (rfc2047-encode-encoded-words nil) type method move-to) (gnus-draft-setup article (or group "nndraft:queue")) ;; We read the meta-information that says how and where ;; this message is to be sent. (save-restriction (message-narrow-to-headers) (when (re-search-forward (concat "^" (regexp-quote gnus-agent-target-move-group-header) ":") nil t) (skip-syntax-forward "-") (setq move-to (buffer-substring (point) (point-at-eol))) (message-remove-header gnus-agent-target-move-group-header)) (goto-char (point-min)) (when (re-search-forward (concat "^" (regexp-quote gnus-agent-meta-information-header) ":") nil t) (setq type (ignore-errors (read (current-buffer))) method (ignore-errors (read (current-buffer)))) (message-remove-header gnus-agent-meta-information-header))) ;; Let Agent restore any GCC lines and have message.el perform them. (gnus-agent-restore-gcc) ;; Then we send it. If we have no meta-information, we just send ;; it and let Message figure out how. (when (and (or (null method) (gnus-server-opened method) (gnus-open-server method)) (if type (let ((message-this-is-news (eq type 'news)) (message-this-is-mail (eq type 'mail)) (gnus-post-method method) (message-post-method method)) (if move-to (gnus-inews-do-gcc move-to) (message-send-and-exit))) (if move-to (gnus-inews-do-gcc move-to) (message-send-and-exit)))) (let ((gnus-verbose-backends nil)) (gnus-request-expire-articles (list article) (or group "nndraft:queue") t))))) (defun gnus-draft-send-all-messages () "Send all the sendable drafts." (interactive) (when (or gnus-expert-user (gnus-y-or-n-p "Send all drafts? ")) (gnus-uu-mark-buffer) (gnus-draft-send-message))) (defun gnus-group-send-queue () "Send all sendable articles from the queue group." (interactive) (when (or gnus-plugged (not gnus-agent-prompt-send-queue) (gnus-y-or-n-p "Gnus is unplugged; really send queue? ")) (gnus-activate-group "nndraft:queue") (save-excursion (let* ((articles (nndraft-articles)) (unsendable (gnus-uncompress-range (cdr (assq 'unsend (gnus-info-marks (gnus-get-info "nndraft:queue")))))) (gnus-posting-styles nil) (total (length articles)) article) (while (setq article (pop articles)) (unless (memq article unsendable) (let ((message-sending-message (format "Sending message %d of %d..." (- total (length articles)) total))) (gnus-draft-send article)))))))) ;;;###autoload (defun gnus-draft-reminder () "Reminder user if there are unsent drafts." (interactive) (if (gnus-alive-p) (let (active) (catch 'continue (dolist (group '("nndraft:drafts" "nndraft:queue")) (setq active (gnus-activate-group group)) (if (and active (>= (cdr active) (car active))) (if (y-or-n-p "There are unsent drafts. Confirm to exit? ") (throw 'continue t) (error "Stop!")))))))) (defcustom gnus-draft-setup-hook nil "Hook run after setting up a draft buffer." :group 'gnus-message :version "23.1" ;; No Gnus :type 'hook) ;;; Utility functions ;;;!!!If this is byte-compiled, it fails miserably. ;;;!!!This is because `gnus-setup-message' uses uninterned symbols. ;;;!!!This has been fixed in recent versions of Emacs and XEmacs, ;;;!!!but for the time being, we'll just run this tiny function uncompiled. (progn (defun gnus-draft-setup (narticle group &optional restore) (let (ga) (gnus-setup-message 'forward (let ((article narticle)) (message-mail) (erase-buffer) (if (not (gnus-request-restore-buffer article group)) (error "Couldn't restore the article") (when (and restore (equal group "nndraft:queue")) (mime-to-mml)) ;; Insert the separator. (goto-char (point-min)) (search-forward "\n\n") (forward-char -1) (save-restriction (narrow-to-region (point-min) (point)) (setq ga (message-fetch-field gnus-draft-meta-information-header))) (insert mail-header-separator) (forward-line 1) (message-set-auto-save-file-name)))) (gnus-backlog-remove-article group narticle) (when (and ga (ignore-errors (setq ga (car (read-from-string ga))))) (setq gnus-newsgroup-name (if (equal (car ga) "") nil (car ga))) (gnus-configure-posting-styles) (setq gnus-message-group-art (cons gnus-newsgroup-name (cadr ga))) (setq message-post-method `(lambda (arg) (gnus-post-method arg ,(car ga)))) (unless (equal (cadr ga) "") (dolist (article (cdr ga)) (message-add-action `(progn (gnus-add-mark ,(car ga) 'replied ,article) (gnus-request-set-mark ,(car ga) (list (list (list ,article) 'add '(reply))))) 'send)))) (run-hooks 'gnus-draft-setup-hook)))) (defun gnus-draft-article-sendable-p (article) "Say whether ARTICLE is sendable." (not (memq article gnus-newsgroup-unsendable))) (defun gnus-draft-check-draft-articles (articles) "Check whether the draft articles ARTICLES are under edit." (when (equal gnus-newsgroup-name "nndraft:drafts") (let ((buffers (buffer-list)) file buffs buff) (save-current-buffer (while (and articles (not buff)) (setq file (nndraft-article-filename (pop articles)) buffs buffers) (while buffs (set-buffer (setq buff (pop buffs))) (if (and buffer-file-name (string-equal (file-truename buffer-file-name) (file-truename file)) (buffer-modified-p)) (setq buffs nil) (setq buff nil))))) (when buff (let* ((window (get-buffer-window buff t)) (frame (and window (window-frame window)))) (if frame (gnus-select-frame-set-input-focus frame) (pop-to-buffer buff t))) (error "The draft %s is under edit" file))))) (provide 'gnus-draft) ;; arch-tag: 3d92af58-8c97-4a5c-9db4-a98e85198022 ;;; gnus-draft.el ends here gnus-5.11+v0.10.dfsg/lisp/assistant.el0000644000175000017500000003421710701233057017603 0ustar tvainikatvainika;;; assistant.el --- guiding users through Emacs setup ;; Copyright (C) 2004, 2005 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; Keywords: util ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 3, or (at your option) ;; any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Commentary: ;;; Code: (eval-when-compile (require 'cl)) (require 'widget) (require 'wid-edit) (autoload 'gnus-error "gnus-util") (autoload 'netrc-get "netrc") (autoload 'netrc-machine "netrc") (autoload 'netrc-parse "netrc") (defvar assistant-readers '(("variable" assistant-variable-reader) ("validate" assistant-sexp-reader) ("result" assistant-list-reader) ("next" assistant-list-reader) ("text" assistant-text-reader))) (defface assistant-field '((t (:bold t))) "Face used for editable fields." :group 'gnus-article-emphasis) ;; backward-compatibility alias (put 'assistant-field-face 'face-alias 'assistant-field) ;;; Internal variables (defvar assistant-data nil) (defvar assistant-current-node nil) (defvar assistant-previous-nodes nil) (defvar assistant-widgets nil) (defun assistant-parse-buffer () (let (results command value) (goto-char (point-min)) (while (search-forward "@" nil t) (if (not (looking-at "[^ \t\n]+")) (error "Dangling @") (setq command (downcase (match-string 0))) (goto-char (match-end 0))) (setq value (if (looking-at "[ \t]*\n") (let (start) (forward-line 1) (setq start (point)) (unless (re-search-forward (concat "^@end " command) nil t) (error "No @end %s found" command)) (beginning-of-line) (prog1 (buffer-substring start (point)) (forward-line 1))) (skip-chars-forward " \t") (prog1 (buffer-substring (point) (point-at-eol)) (forward-line 1)))) (push (list command (assistant-reader command value)) results)) (assistant-segment (nreverse results)))) (defun assistant-text-reader (text) (with-temp-buffer (insert text) (goto-char (point-min)) (let ((start (point)) (sections nil)) (while (re-search-forward "@\\([^{]+\\){\\([^}]+\\)}" nil t) (push (buffer-substring start (match-beginning 0)) sections) (push (list (match-string 1) (match-string 2)) sections) (setq start (point))) (push (buffer-substring start (point-max)) sections) (nreverse sections)))) ;; Segment the raw assistant data into a list of nodes. (defun assistant-segment (list) (let ((ast nil) (node nil) (title (pop list))) (dolist (elem list) (when (and (equal (car elem) "node") node) (push (list "save" nil) node) (push (nreverse node) ast) (setq node nil)) (push elem node)) (when node (push (list "save" nil) node) (push (nreverse node) ast)) (cons title (nreverse ast)))) (defun assistant-reader (command value) (let ((formatter (cadr (assoc command assistant-readers)))) (if (not formatter) value (funcall formatter value)))) (defun assistant-list-reader (value) (car (read-from-string (concat "(" value ")")))) (defun assistant-variable-reader (value) (let ((section (car (read-from-string (concat "(" value ")"))))) (append section (list 'default)))) (defun assistant-sexp-reader (value) (if (zerop (length value)) nil (car (read-from-string value)))) (defun assistant-buffer-name (title) (format "*Assistant %s*" title)) (defun assistant-get (ast command) (cadr (assoc command ast))) (defun assistant-set (ast command value) (let ((elem (assoc command ast))) (when elem (setcar (cdr elem) value)))) (defun assistant-get-list (ast command) (let ((result nil)) (dolist (elem ast) (when (equal (car elem) command) (push elem result))) (nreverse result))) ;;;###autoload (defun assistant (file) "Assist setting up Emacs based on FILE." (interactive "fAssistant file name: ") (let ((ast (with-temp-buffer (insert-file-contents file) (assistant-parse-buffer)))) (pop-to-buffer (assistant-buffer-name (assistant-get ast "title"))) (assistant-render ast))) (defun assistant-render (ast) (let ((first-node (assistant-get (nth 1 ast) "node"))) (set (make-local-variable 'assistant-data) ast) (set (make-local-variable 'assistant-current-node) nil) (set (make-local-variable 'assistant-previous-nodes) nil) (assistant-render-node first-node))) (defun assistant-find-node (node-name) (let ((ast (cdr assistant-data))) (while (and ast (not (string= node-name (assistant-get (car ast) "node")))) (pop ast)) (car ast))) (defun assistant-node-name (node) (assistant-get node "node")) (defun assistant-previous-node-text (node) (format "<< Go back to %s" node)) (defun assistant-next-node-text (node) (if (and node (not (eq node 'finish))) (format "Proceed to %s >>" node) "Finish")) (defun assistant-set-defaults (node &optional forcep) (dolist (variable (assistant-get-list node "variable")) (setq variable (cadr variable)) (when (or (eq (nth 3 variable) 'default) forcep) (setcar (nthcdr 3 variable) (assistant-eval (nth 2 variable)))))) (defun assistant-get-variable (node variable &optional type raw) (let ((variables (assistant-get-list node "variable")) (result nil) elem) (while (and (setq elem (pop variables)) (not result)) (setq elem (cadr elem)) (when (eq (intern variable) (car elem)) (if type (setq result (nth 1 elem)) (setq result (if raw (nth 3 elem) (format "%s" (nth 3 elem))))))) result)) (defun assistant-set-variable (node variable value) (let ((variables (assistant-get-list node "variable")) elem) (while (setq elem (pop variables)) (setq elem (cadr elem)) (when (eq (intern variable) (car elem)) (setcar (nthcdr 3 elem) value))))) (defun assistant-render-text (text node) (unless (and text node) (gnus-error 5 "The assistant was asked to render invalid text or node data")) (dolist (elem text) (if (stringp elem) ;; Ordinary text (insert elem) ;; A variable to be inserted as a widget. (let* ((start (point)) (variable (cadr elem)) (type (assistant-get-variable node variable 'type))) (cond ((eq (car-safe type) :radio) (push (apply #'widget-create 'radio-button-choice :assistant-variable variable :assistant-node node :value (assistant-get-variable node variable) :notify (lambda (widget &rest ignore) (assistant-set-variable (widget-get widget :assistant-node) (widget-get widget :assistant-variable) (widget-value widget)) (assistant-render-node (assistant-get (widget-get widget :assistant-node) "node"))) (cadr type)) assistant-widgets)) ((eq (car-safe type) :set) (push (apply #'widget-create 'set :assistant-variable variable :assistant-node node :value (assistant-get-variable node variable nil t) :notify (lambda (widget &rest ignore) (assistant-set-variable (widget-get widget :assistant-node) (widget-get widget :assistant-variable) (widget-value widget)) (assistant-render-node (assistant-get (widget-get widget :assistant-node) "node"))) (cadr type)) assistant-widgets)) (t (push (widget-create 'editable-field :value-face 'assistant-field :assistant-variable variable (assistant-get-variable node variable)) assistant-widgets) ;; The editable-field widget apparently inserts a newline; ;; remove it. (delete-char -1) (add-text-properties start (point) (list 'bold t 'face 'assistant-field 'not-read-only t)))))))) (defun assistant-render-node (node-name) (let ((node (assistant-find-node node-name)) (inhibit-read-only t) (previous assistant-current-node) (buffer-read-only nil)) (unless node (gnus-error 5 "The node for %s could not be found" node-name)) (set (make-local-variable 'assistant-widgets) nil) (assistant-set-defaults node) (if (equal (assistant-get node "type") "interstitial") (assistant-render-node (nth 0 (assistant-find-next-nodes node-name))) (setq assistant-current-node node-name) (when previous (push previous assistant-previous-nodes)) (erase-buffer) (insert (cadar assistant-data) "\n\n") (insert node-name "\n\n") (assistant-render-text (assistant-get node "text") node) (insert "\n\n") (when assistant-previous-nodes (assistant-node-button 'previous (car assistant-previous-nodes))) (widget-create 'push-button :assistant-node node-name :notify (lambda (widget &rest ignore) (let* ((node (widget-get widget :assistant-node))) (assistant-set-defaults (assistant-find-node node) 'force) (assistant-render-node node))) "Reset") (insert "\n") (dolist (nnode (assistant-find-next-nodes)) (assistant-node-button 'next nnode) (insert "\n")) (goto-char (point-min)) (assistant-make-read-only)))) (defun assistant-make-read-only () (let ((start (point-min)) end) (while (setq end (text-property-any start (point-max) 'not-read-only t)) (put-text-property start end 'read-only t) (put-text-property start end 'rear-nonsticky t) (while (get-text-property end 'not-read-only) (incf end)) (setq start end)) (put-text-property start (point-max) 'read-only t))) (defun assistant-node-button (type node) (let ((text (if (eq type 'next) (assistant-next-node-text node) (assistant-previous-node-text node)))) (widget-create 'push-button :assistant-node node :assistant-type type :notify (lambda (widget &rest ignore) (let* ((node (widget-get widget :assistant-node)) (type (widget-get widget :assistant-type))) (if (eq type 'previous) (progn (setq assistant-current-node nil) (pop assistant-previous-nodes)) (assistant-get-widget-values) (assistant-validate)) (if (null node) (assistant-finish) (assistant-render-node node)))) text) (use-local-map widget-keymap))) (defun assistant-validate-types (node) (dolist (variable (assistant-get-list node "variable")) (setq variable (cadr variable)) (let ((type (nth 1 variable)) (value (nth 3 variable))) (when (cond ((eq type :number) (string-match "[^0-9]" value)) (t nil)) (error "%s is not of type %s: %s" (car variable) type value))))) (defun assistant-get-widget-values () (let ((node (assistant-find-node assistant-current-node))) (dolist (widget assistant-widgets) (assistant-set-variable node (widget-get widget :assistant-variable) (widget-value widget))))) (defun assistant-validate () (let* ((node (assistant-find-node assistant-current-node)) (validation (assistant-get node "validate")) result) (assistant-validate-types node) (when validation (when (setq result (assistant-eval validation)) (unless (y-or-n-p (format "Error: %s. Continue? " result)) (error "%s" result)))) (assistant-set node "save" t))) ;; (defun assistant-find-next-node (&optional node) ;; (let* ((node (assistant-find-node (or node assistant-current-node))) ;; (node-name (assistant-node-name node)) ;; (nexts (assistant-get-list node "next")) ;; next elem applicable) ;; (while (setq elem (pop nexts)) ;; (when (assistant-eval (car (cadr elem))) ;; (setq applicable (cons elem applicable)))) ;; ;; return the first thing we can ;; (cadr (cadr (pop applicable))))) (defun assistant-find-next-nodes (&optional node) (let* ((node (assistant-find-node (or node assistant-current-node))) (nexts (assistant-get-list node "next")) next elem applicable return) (while (setq elem (pop nexts)) (when (assistant-eval (car (cadr elem))) (setq applicable (cons elem applicable)))) ;; return the first thing we can (while (setq elem (pop applicable)) (push (cadr (cadr elem)) return)) return)) (defun assistant-get-all-variables () (let ((variables nil)) (dolist (node (cdr assistant-data)) (setq variables (append (assistant-get-list node "variable") variables))) variables)) (defun assistant-eval (form) (let ((bindings nil)) (dolist (variable (assistant-get-all-variables)) (setq variable (cadr variable)) (push (list (car variable) (if (eq (nth 3 variable) 'default) nil (if (listp (nth 3 variable)) `(list ,@(nth 3 variable)) (nth 3 variable)))) bindings)) (eval `(let ,bindings ,form)))) (defun assistant-finish () (let ((results nil) result) (dolist (node (cdr assistant-data)) (when (assistant-get node "save") (setq result (assistant-get node "result")) (push (list (car result) (assistant-eval (cadr result))) results))) (message "Results: %s" (nreverse results)))) ;;; Validation functions. (defun assistant-validate-connect-to-server (server port) (let* ((error nil) (stream (condition-case err (open-network-stream "nntpd" nil server port) (error (setq error err))))) (if (and (processp stream) (memq (process-status stream) '(open run))) (progn (delete-process stream) nil) error))) (defun assistant-authinfo-data (server port type) (when (file-exists-p "~/.authinfo") (netrc-get (netrc-machine (netrc-parse "~/.authinfo") server port) (if (eq type 'user) "login" "password")))) (defun assistant-password-required-p () nil) (provide 'assistant) ;;; arch-tag: 0404bfa2-9226-4611-8d3f-335c2416175b ;;; assistant.el ends here gnus-5.11+v0.10.dfsg/lisp/mail-prsvr.el0000644000175000017500000000333311004005111017642 0ustar tvainikatvainika;;; mail-prsvr.el --- Interface variables for parsing mail ;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, ;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 3, or (at your option) ;; any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Commentary: ;;; Code: (defvar mail-parse-charset nil "Default charset used by low-level libraries. This variable should never be set. Instead, it should be bound by functions that wish to call mail-parse functions and let them know what the desired charset is to be.") (defvar mail-parse-mule-charset nil "Default MULE charset used by low-level libraries. This variable should never be set.") (defvar mail-parse-ignored-charsets nil "Ignored charsets used by low-level libraries. This variable should never be set. Instead, it should be bound by functions that wish to call mail-parse functions and let them know what the desired charsets is to be ignored.") (provide 'mail-prsvr) ;; arch-tag: 9ba878cc-8b43-4f7a-85b1-69b1a9a5d9f5 ;;; mail-prsvr.el ends here gnus-5.11+v0.10.dfsg/lisp/gnus-util.el0000644000175000017500000017240611004005110017504 0ustar tvainikatvainika;;; gnus-util.el --- utility functions for Gnus ;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, ;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; Keywords: news ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 3, or (at your option) ;; any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Commentary: ;; Nothing in this file depends on any other parts of Gnus -- all ;; functions and macros in this file are utility functions that are ;; used by Gnus and may be used by any other package without loading ;; Gnus first. ;; [Unfortunately, it does depend on other parts of Gnus, e.g. the ;; autoloads and defvars below...] ;;; Code: ;; For Emacs < 22.2. (eval-and-compile (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) (eval-when-compile (require 'cl)) ;; Fixme: this should be a gnus variable, not nnmail-. (defvar nnmail-pathname-coding-system) (defvar nnmail-active-file-coding-system) ;; Inappropriate references to other parts of Gnus. (defvar gnus-emphasize-whitespace-regexp) (defvar gnus-original-article-buffer) (defvar gnus-user-agent) (require 'time-date) (require 'netrc) (eval-and-compile (autoload 'message-fetch-field "message") (autoload 'gnus-get-buffer-window "gnus-win") (autoload 'rmail-insert-rmail-file-header "rmail") (autoload 'rmail-count-new-messages "rmail") (autoload 'rmail-show-message "rmail") (autoload 'nnheader-narrow-to-headers "nnheader") (autoload 'nnheader-replace-chars-in-string "nnheader")) (eval-and-compile (cond ;; Prefer `replace-regexp-in-string' (present in Emacs, XEmacs 21.5, ;; SXEmacs 22.1.4) over `replace-in-string'. The later leads to inf-loops ;; on empty matches: ;; (replace-in-string "foo" "/*$" "/") ;; (replace-in-string "xe" "\\(x\\)?" "") ((fboundp 'replace-regexp-in-string) (defun gnus-replace-in-string (string regexp newtext &optional literal) "Replace all matches for REGEXP with NEWTEXT in STRING. If LITERAL is non-nil, insert NEWTEXT literally. Return a new string containing the replacements. This is a compatibility function for different Emacsen." (replace-regexp-in-string regexp newtext string nil literal))) ((fboundp 'replace-in-string) (defalias 'gnus-replace-in-string 'replace-in-string)))) (defun gnus-boundp (variable) "Return non-nil if VARIABLE is bound and non-nil." (and (boundp variable) (symbol-value variable))) (defmacro gnus-eval-in-buffer-window (buffer &rest forms) "Pop to BUFFER, evaluate FORMS, and then return to the original window." (let ((tempvar (make-symbol "GnusStartBufferWindow")) (w (make-symbol "w")) (buf (make-symbol "buf"))) `(let* ((,tempvar (selected-window)) (,buf ,buffer) (,w (gnus-get-buffer-window ,buf 'visible))) (unwind-protect (progn (if ,w (progn (select-window ,w) (set-buffer (window-buffer ,w))) (pop-to-buffer ,buf)) ,@forms) (select-window ,tempvar))))) (put 'gnus-eval-in-buffer-window 'lisp-indent-function 1) (put 'gnus-eval-in-buffer-window 'edebug-form-spec '(form body)) (defmacro gnus-intern-safe (string hashtable) "Get hash value. Arguments are STRING and HASHTABLE." `(let ((symbol (intern ,string ,hashtable))) (or (boundp symbol) (set symbol nil)) symbol)) (defsubst gnus-goto-char (point) (and point (goto-char point))) (defmacro gnus-buffer-exists-p (buffer) `(let ((buffer ,buffer)) (when buffer (funcall (if (stringp buffer) 'get-buffer 'buffer-name) buffer)))) ;; The LOCAL arg to `add-hook' is interpreted differently in Emacs and ;; XEmacs. In Emacs we don't need to call `make-local-hook' first. ;; It's harmless, though, so the main purpose of this alias is to shut ;; up the byte compiler. (defalias 'gnus-make-local-hook (if (eq (get 'make-local-hook 'byte-compile) 'byte-compile-obsolete) 'ignore ; Emacs 'make-local-hook)) ; XEmacs (defun gnus-delete-first (elt list) "Delete by side effect the first occurrence of ELT as a member of LIST." (if (equal (car list) elt) (cdr list) (let ((total list)) (while (and (cdr list) (not (equal (cadr list) elt))) (setq list (cdr list))) (when (cdr list) (setcdr list (cddr list))) total))) ;; Delete the current line (and the next N lines). (defmacro gnus-delete-line (&optional n) `(delete-region (point-at-bol) (progn (forward-line ,(or n 1)) (point)))) (defun gnus-byte-code (func) "Return a form that can be `eval'ed based on FUNC." (let ((fval (indirect-function func))) (if (byte-code-function-p fval) (let ((flist (append fval nil))) (setcar flist 'byte-code) flist) (cons 'progn (cddr fval))))) (defun gnus-extract-address-components (from) "Extract address components from a From header. Given an RFC-822 address FROM, extract full name and canonical address. Returns a list of the form (FULL-NAME CANONICAL-ADDRESS). Much more simple solution than `mail-extract-address-components', which works much better, but is slower." (let (name address) ;; First find the address - the thing with the @ in it. This may ;; not be accurate in mail addresses, but does the trick most of ;; the time in news messages. (cond (;; Check ``'' first in order to handle the quite common ;; form ``"abc@xyz" '' (i.e. ``@'' as part of a comment) ;; correctly. (string-match "<\\([^@ \t<>]+[!@][^@ \t<>]+\\)>" from) (setq address (substring from (match-beginning 1) (match-end 1)))) ((string-match "\\b[^@ \t<>]+[!@][^@ \t<>]+\\b" from) (setq address (substring from (match-beginning 0) (match-end 0))))) ;; Then we check whether the "name

    " format is used. (and address ;; Linear white space is not required. (string-match (concat "[ \t]*<" (regexp-quote address) ">") from) (and (setq name (substring from 0 (match-beginning 0))) ;; Strip any quotes from the name. (string-match "^\".*\"$" name) (setq name (substring name 1 (1- (match-end 0)))))) ;; If not, then "address (name)" is used. (or name (and (string-match "(.+)" from) (setq name (substring from (1+ (match-beginning 0)) (1- (match-end 0))))) (and (string-match "()" from) (setq name address)) ;; XOVER might not support folded From headers. (and (string-match "(.*" from) (setq name (substring from (1+ (match-beginning 0)) (match-end 0))))) (list (if (string= name "") nil name) (or address from)))) (defun gnus-fetch-field (field) "Return the value of the header FIELD of current article." (save-excursion (save-restriction (let ((inhibit-point-motion-hooks t)) (nnheader-narrow-to-headers) (message-fetch-field field))))) (defun gnus-fetch-original-field (field) "Fetch FIELD from the original version of the current article." (with-current-buffer gnus-original-article-buffer (gnus-fetch-field field))) (defun gnus-goto-colon () (beginning-of-line) (let ((eol (point-at-eol))) (goto-char (or (text-property-any (point) eol 'gnus-position t) (search-forward ":" eol t) (point))))) (declare-function gnus-find-method-for-group "gnus" (group &optional info)) (autoload 'gnus-group-name-decode "gnus-group") (declare-function gnus-group-name-charset "gnus-group" (method group)) ;; gnus-group requires gnus-int which requires message. (declare-function message-tokenize-header "message" (header &optional separator)) (defun gnus-decode-newsgroups (newsgroups group &optional method) (let ((method (or method (gnus-find-method-for-group group)))) (mapconcat (lambda (group) (gnus-group-name-decode group (gnus-group-name-charset method group))) (message-tokenize-header newsgroups) ","))) (defun gnus-remove-text-with-property (prop) "Delete all text in the current buffer with text property PROP." (let ((start (point-min)) end) (unless (get-text-property start prop) (setq start (next-single-property-change start prop))) (while start (setq end (text-property-any start (point-max) prop nil)) (delete-region start (or end (point-max))) (setq start (when end (next-single-property-change start prop)))))) (defun gnus-newsgroup-directory-form (newsgroup) "Make hierarchical directory name from NEWSGROUP name." (let* ((newsgroup (gnus-newsgroup-savable-name newsgroup)) (idx (string-match ":" newsgroup))) (concat (if idx (substring newsgroup 0 idx)) (if idx "/") (nnheader-replace-chars-in-string (if idx (substring newsgroup (1+ idx)) newsgroup) ?. ?/)))) (defun gnus-newsgroup-savable-name (group) ;; Replace any slashes in a group name (eg. an ange-ftp nndoc group) ;; with dots. (nnheader-replace-chars-in-string group ?/ ?.)) (defun gnus-string> (s1 s2) (not (or (string< s1 s2) (string= s1 s2)))) (defun gnus-string< (s1 s2) "Return t if first arg string is less than second in lexicographic order. Case is significant if and only if `case-fold-search' is nil. Symbols are also allowed; their print names are used instead." (if case-fold-search (string-lessp (downcase (if (symbolp s1) (symbol-name s1) s1)) (downcase (if (symbolp s2) (symbol-name s2) s2))) (string-lessp s1 s2))) ;;; Time functions. (defun gnus-file-newer-than (file date) (let ((fdate (nth 5 (file-attributes file)))) (or (> (car fdate) (car date)) (and (= (car fdate) (car date)) (> (nth 1 fdate) (nth 1 date)))))) ;;; Keymap macros. (defmacro gnus-local-set-keys (&rest plist) "Set the keys in PLIST in the current keymap." `(gnus-define-keys-1 (current-local-map) ',plist)) (defmacro gnus-define-keys (keymap &rest plist) "Define all keys in PLIST in KEYMAP." `(gnus-define-keys-1 (quote ,keymap) (quote ,plist))) (defmacro gnus-define-keys-safe (keymap &rest plist) "Define all keys in PLIST in KEYMAP without overwriting previous definitions." `(gnus-define-keys-1 (quote ,keymap) (quote ,plist) t)) (put 'gnus-define-keys 'lisp-indent-function 1) (put 'gnus-define-keys-safe 'lisp-indent-function 1) (put 'gnus-local-set-keys 'lisp-indent-function 1) (defmacro gnus-define-keymap (keymap &rest plist) "Define all keys in PLIST in KEYMAP." `(gnus-define-keys-1 ,keymap (quote ,plist))) (put 'gnus-define-keymap 'lisp-indent-function 1) (defun gnus-define-keys-1 (keymap plist &optional safe) (when (null keymap) (error "Can't set keys in a null keymap")) (cond ((symbolp keymap) (setq keymap (symbol-value keymap))) ((keymapp keymap)) ((listp keymap) (set (car keymap) nil) (define-prefix-command (car keymap)) (define-key (symbol-value (caddr keymap)) (cadr keymap) (car keymap)) (setq keymap (symbol-value (car keymap))))) (let (key) (while plist (when (symbolp (setq key (pop plist))) (setq key (symbol-value key))) (if (or (not safe) (eq (lookup-key keymap key) 'undefined)) (define-key keymap key (pop plist)) (pop plist))))) (defun gnus-completing-read-with-default (default prompt &rest args) ;; Like `completing-read', except that DEFAULT is the default argument. (let* ((prompt (if default (concat prompt " (default " default "): ") (concat prompt ": "))) (answer (apply 'completing-read prompt args))) (if (or (null answer) (zerop (length answer))) default answer))) ;; Two silly functions to ensure that all `y-or-n-p' questions clear ;; the echo area. ;; ;; Do we really need these functions? Workarounds for bugs in the corresponding ;; Emacs functions? Maybe these bugs are no longer present in any supported ;; (X)Emacs version? Alias them to the original functions and see if anyone ;; reports a problem. If not, replace with original functions. --rsteib, ;; 2007-12-14 ;; ;; All supported Emacsen clear the echo area after `yes-or-no-p', so we can ;; remove `yes-or-no-p'. RMS says that not clearing after `y-or-n-p' is ;; intentional (see below), so we could remove `gnus-y-or-n-p' too. ;; Objections? --rsteib, 2008-02-16 ;; ;; ,----[ http://thread.gmane.org/gmane.emacs.gnus.general/65099/focus=66070 ] ;; | From: Richard Stallman ;; | Subject: Re: Do we need gnus-yes-or-no-p and gnus-y-or-n-p? ;; | To: Katsumi Yamaoka [...] ;; | Cc: emacs-devel@[...], xemacs-beta@[...], ding@[...] ;; | Date: Mon, 07 Jan 2008 12:16:05 -0500 ;; | Message-ID: ;; | ;; | The behavior of `y-or-n-p' that it doesn't clear the question ;; | and the answer is not serious of course, but I feel it is not ;; | cool. ;; | ;; | It is intentional. ;; | ;; | Currently, it is commented out in the trunk by Reiner Steib. He ;; | also wrote the benefit of leaving the question and the answer in ;; | the echo area as follows: ;; | ;; | (http://article.gmane.org/gmane.emacs.gnus.general/66061) ;; | > In contrast to yes-or-no-p it is much easier to type y, n, ;; | > SPC, DEL, etc accidentally, so it might be useful for the user ;; | > to see what he has typed. ;; | ;; | Yes, that is the reason. ;; `---- ;; (defun gnus-y-or-n-p (prompt) ;; (prog1 ;; (y-or-n-p prompt) ;; (message ""))) ;; (defun gnus-yes-or-no-p (prompt) ;; (prog1 ;; (yes-or-no-p prompt) ;; (message ""))) (defalias 'gnus-y-or-n-p 'y-or-n-p) (defalias 'gnus-yes-or-no-p 'yes-or-no-p) ;; By Frank Schmitt . Allows to have ;; age-depending date representations. (e.g. just the time if it's ;; from today, the day of the week if it's within the last 7 days and ;; the full date if it's older) (defun gnus-seconds-today () "Return the number of seconds passed today." (let ((now (decode-time (current-time)))) (+ (car now) (* (car (cdr now)) 60) (* (car (nthcdr 2 now)) 3600)))) (defun gnus-seconds-month () "Return the number of seconds passed this month." (let ((now (decode-time (current-time)))) (+ (car now) (* (car (cdr now)) 60) (* (car (nthcdr 2 now)) 3600) (* (- (car (nthcdr 3 now)) 1) 3600 24)))) (defun gnus-seconds-year () "Return the number of seconds passed this year." (let ((now (decode-time (current-time))) (days (format-time-string "%j" (current-time)))) (+ (car now) (* (car (cdr now)) 60) (* (car (nthcdr 2 now)) 3600) (* (- (string-to-number days) 1) 3600 24)))) (defvar gnus-user-date-format-alist '(((gnus-seconds-today) . "%k:%M") (604800 . "%a %k:%M") ;;that's one week ((gnus-seconds-month) . "%a %d") ((gnus-seconds-year) . "%b %d") (t . "%b %d '%y")) ;;this one is used when no ;;other does match "Specifies date format depending on age of article. This is an alist of items (AGE . FORMAT). AGE can be a number (of seconds) or a Lisp expression evaluating to a number. When the age of the article is less than this number, then use `format-time-string' with the corresponding FORMAT for displaying the date of the article. If AGE is not a number or a Lisp expression evaluating to a non-number, then the corresponding FORMAT is used as a default value. Note that the list is processed from the beginning, so it should be sorted by ascending AGE. Also note that items following the first non-number AGE will be ignored. You can use the functions `gnus-seconds-today', `gnus-seconds-month' and `gnus-seconds-year' in the AGE spec. They return the number of seconds passed since the start of today, of this month, of this year, respectively.") (defun gnus-user-date (messy-date) "Format the messy-date according to gnus-user-date-format-alist. Returns \" ? \" if there's bad input or if an other error occurs. Input should look like this: \"Sun, 14 Oct 2001 13:34:39 +0200\"." (condition-case () (let* ((messy-date (time-to-seconds (safe-date-to-time messy-date))) (now (time-to-seconds (current-time))) ;;If we don't find something suitable we'll use this one (my-format "%b %d '%y")) (let* ((difference (- now messy-date)) (templist gnus-user-date-format-alist) (top (eval (caar templist)))) (while (if (numberp top) (< top difference) (not top)) (progn (setq templist (cdr templist)) (setq top (eval (caar templist))))) (if (stringp (cdr (car templist))) (setq my-format (cdr (car templist))))) (format-time-string (eval my-format) (seconds-to-time messy-date))) (error " ? "))) (defun gnus-dd-mmm (messy-date) "Return a string like DD-MMM from a big messy string." (condition-case () (format-time-string "%d-%b" (safe-date-to-time messy-date)) (error " - "))) (defmacro gnus-date-get-time (date) "Convert DATE string to Emacs time. Cache the result as a text property stored in DATE." ;; Either return the cached value... `(let ((d ,date)) (if (equal "" d) '(0 0) (or (get-text-property 0 'gnus-time d) ;; or compute the value... (let ((time (safe-date-to-time d))) ;; and store it back in the string. (put-text-property 0 1 'gnus-time time d) time))))) (defsubst gnus-time-iso8601 (time) "Return a string of TIME in YYYYMMDDTHHMMSS format." (format-time-string "%Y%m%dT%H%M%S" time)) (defun gnus-date-iso8601 (date) "Convert the DATE to YYYYMMDDTHHMMSS." (condition-case () (gnus-time-iso8601 (gnus-date-get-time date)) (error ""))) (defun gnus-mode-string-quote (string) "Quote all \"%\"'s in STRING." (gnus-replace-in-string string "%" "%%")) ;; Make a hash table (default and minimum size is 256). ;; Optional argument HASHSIZE specifies the table size. (defun gnus-make-hashtable (&optional hashsize) (make-vector (if hashsize (max (gnus-create-hash-size hashsize) 256) 256) 0)) ;; Make a number that is suitable for hashing; bigger than MIN and ;; equal to some 2^x. Many machines (such as sparcs) do not have a ;; hardware modulo operation, so they implement it in software. On ;; many sparcs over 50% of the time to intern is spent in the modulo. ;; Yes, it's slower than actually computing the hash from the string! ;; So we use powers of 2 so people can optimize the modulo to a mask. (defun gnus-create-hash-size (min) (let ((i 1)) (while (< i min) (setq i (* 2 i))) i)) (defcustom gnus-verbose 7 "*Integer that says how verbose Gnus should be. The higher the number, the more messages Gnus will flash to say what it's doing. At zero, Gnus will be totally mute; at five, Gnus will display most important messages; and at ten, Gnus will keep on jabbering all the time." :group 'gnus-start :type 'integer) (defcustom gnus-add-timestamp-to-message nil "Non-nil means add timestamps to messages that Gnus issues. If it is `log', add timestamps to only the messages that go into the \"*Messages*\" buffer (in XEmacs, it is the \" *Message-Log*\" buffer). If it is neither nil nor `log', add timestamps not only to log messages but also to the ones displayed in the echo area." :version "23.1" ;; No Gnus :group 'gnus-various :type '(choice :format "%{%t%}:\n %[Value Menu%] %v" (const :tag "Logged messages only" log) (sexp :tag "All messages" :match (lambda (widget value) value) :value t) (const :tag "No timestamp" nil))) (eval-when-compile (defmacro gnus-message-with-timestamp-1 (format-string args) (let ((timestamp '((format-time-string "%Y%m%dT%H%M%S" time) "." (format "%03d" (/ (nth 2 time) 1000)) "> "))) (if (featurep 'xemacs) `(let (str time) (if (or (and (null ,format-string) (null ,args)) (progn (setq str (apply 'format ,format-string ,args)) (zerop (length str)))) (prog1 (and ,format-string str) (clear-message nil)) (cond ((eq gnus-add-timestamp-to-message 'log) (setq time (current-time)) (display-message 'no-log str) (log-message 'message (concat ,@timestamp str))) (gnus-add-timestamp-to-message (setq time (current-time)) (display-message 'message (concat ,@timestamp str))) (t (display-message 'message str)))) str) `(let (str time) (cond ((eq gnus-add-timestamp-to-message 'log) (setq str (let (message-log-max) (apply 'message ,format-string ,args))) (when (and message-log-max (> message-log-max 0) (/= (length str) 0)) (setq time (current-time)) (with-current-buffer (get-buffer-create "*Messages*") (goto-char (point-max)) (insert ,@timestamp str "\n") (forward-line (- message-log-max)) (delete-region (point-min) (point)) (goto-char (point-max)))) str) (gnus-add-timestamp-to-message (if (or (and (null ,format-string) (null ,args)) (progn (setq str (apply 'format ,format-string ,args)) (zerop (length str)))) (prog1 (and ,format-string str) (message nil)) (setq time (current-time)) (message "%s" (concat ,@timestamp str)) str)) (t (apply 'message ,format-string ,args)))))))) (defun gnus-message-with-timestamp (format-string &rest args) "Display message with timestamp. Arguments are the same as `message'. The `gnus-add-timestamp-to-message' variable controls how to add timestamp to message." (gnus-message-with-timestamp-1 format-string args)) (defun gnus-message (level &rest args) "If LEVEL is lower than `gnus-verbose' print ARGS using `message'. Guideline for numbers: 1 - error messages, 3 - non-serious error messages, 5 - messages for things that take a long time, 7 - not very important messages on stuff, 9 - messages inside loops." (if (<= level gnus-verbose) (if gnus-add-timestamp-to-message (apply 'gnus-message-with-timestamp args) (apply 'message args)) ;; We have to do this format thingy here even if the result isn't ;; shown - the return value has to be the same as the return value ;; from `message'. (apply 'format args))) (defun gnus-error (level &rest args) "Beep an error if LEVEL is equal to or less than `gnus-verbose'. ARGS are passed to `message'." (when (<= (floor level) gnus-verbose) (apply 'message args) (ding) (let (duration) (when (and (floatp level) (not (zerop (setq duration (* 10 (- level (floor level))))))) (sit-for duration)))) nil) (defun gnus-split-references (references) "Return a list of Message-IDs in REFERENCES." (let ((beg 0) (references (or references "")) ids) (while (string-match "<[^<]+[^< \t]" references beg) (push (substring references (match-beginning 0) (setq beg (match-end 0))) ids)) (nreverse ids))) (defun gnus-extract-references (references) "Return a list of Message-IDs in REFERENCES (in In-Reply-To format), trimmed to only contain the Message-IDs." (let ((ids (gnus-split-references references)) refs) (dolist (id ids) (when (string-match "<[^<>]+>" id) (push (match-string 0 id) refs))) refs)) (defsubst gnus-parent-id (references &optional n) "Return the last Message-ID in REFERENCES. If N, return the Nth ancestor instead." (when (and references (not (zerop (length references)))) (if n (let ((ids (inline (gnus-split-references references)))) (while (nthcdr n ids) (setq ids (cdr ids))) (car ids)) (when (string-match "\\(<[^<]+>\\)[ \t]*\\'" references) (match-string 1 references))))) (defun gnus-buffer-live-p (buffer) "Say whether BUFFER is alive or not." (and buffer (get-buffer buffer) (buffer-name (get-buffer buffer)))) (defun gnus-horizontal-recenter () "Recenter the current buffer horizontally." (if (< (current-column) (/ (window-width) 2)) (set-window-hscroll (gnus-get-buffer-window (current-buffer) t) 0) (let* ((orig (point)) (end (window-end (gnus-get-buffer-window (current-buffer) t))) (max 0)) (when end ;; Find the longest line currently displayed in the window. (goto-char (window-start)) (while (and (not (eobp)) (< (point) end)) (end-of-line) (setq max (max max (current-column))) (forward-line 1)) (goto-char orig) ;; Scroll horizontally to center (sort of) the point. (if (> max (window-width)) (set-window-hscroll (gnus-get-buffer-window (current-buffer) t) (min (- (current-column) (/ (window-width) 3)) (+ 2 (- max (window-width))))) (set-window-hscroll (gnus-get-buffer-window (current-buffer) t) 0)) max)))) (defun gnus-read-event-char (&optional prompt) "Get the next event." (let ((event (read-event prompt))) ;; should be gnus-characterp, but this can't be called in XEmacs anyway (cons (and (numberp event) event) event))) (defun gnus-sortable-date (date) "Make string suitable for sorting from DATE." (gnus-time-iso8601 (date-to-time date))) (defun gnus-copy-file (file &optional to) "Copy FILE to TO." (interactive (list (read-file-name "Copy file: " default-directory) (read-file-name "Copy file to: " default-directory))) (unless to (setq to (read-file-name "Copy file to: " default-directory))) (when (file-directory-p to) (setq to (concat (file-name-as-directory to) (file-name-nondirectory file)))) (copy-file file to)) (defvar gnus-work-buffer " *gnus work*") (declare-function gnus-get-buffer-create "gnus" (name)) ;; gnus.el requires mm-util. (declare-function mm-enable-multibyte "mm-util") (defun gnus-set-work-buffer () "Put point in the empty Gnus work buffer." (if (get-buffer gnus-work-buffer) (progn (set-buffer gnus-work-buffer) (erase-buffer)) (set-buffer (gnus-get-buffer-create gnus-work-buffer)) (kill-all-local-variables) (mm-enable-multibyte))) (defmacro gnus-group-real-name (group) "Find the real name of a foreign newsgroup." `(let ((gname ,group)) (if (string-match "^[^:]+:" gname) (substring gname (match-end 0)) gname))) (defmacro gnus-group-server (group) "Find the server name of a foreign newsgroup. For example, (gnus-group-server \"nnimap+yxa:INBOX.foo\") would yield \"nnimap:yxa\"." `(let ((gname ,group)) (if (string-match "^\\([^:+]+\\)\\(?:\\+\\([^:]*\\)\\)?:" gname) (format "%s:%s" (match-string 1 gname) (or (match-string 2 gname) "")) (format "%s:%s" (car gnus-select-method) (cadr gnus-select-method))))) (defun gnus-make-sort-function (funs) "Return a composite sort condition based on the functions in FUNS." (cond ;; Just a simple function. ((functionp funs) funs) ;; No functions at all. ((null funs) funs) ;; A list of functions. ((or (cdr funs) (listp (car funs))) (gnus-byte-compile `(lambda (t1 t2) ,(gnus-make-sort-function-1 (reverse funs))))) ;; A list containing just one function. (t (car funs)))) (defun gnus-make-sort-function-1 (funs) "Return a composite sort condition based on the functions in FUNS." (let ((function (car funs)) (first 't1) (last 't2)) (when (consp function) (cond ;; Reversed spec. ((eq (car function) 'not) (setq function (cadr function) first 't2 last 't1)) ((functionp function) ;; Do nothing. ) (t (error "Invalid sort spec: %s" function)))) (if (cdr funs) `(or (,function ,first ,last) (and (not (,function ,last ,first)) ,(gnus-make-sort-function-1 (cdr funs)))) `(,function ,first ,last)))) (defun gnus-turn-off-edit-menu (type) "Turn off edit menu in `gnus-TYPE-mode-map'." (define-key (symbol-value (intern (format "gnus-%s-mode-map" type))) [menu-bar edit] 'undefined)) (defmacro gnus-bind-print-variables (&rest forms) "Bind print-* variables and evaluate FORMS. This macro is used with `prin1', `pp', etc. in order to ensure printed Lisp objects are loadable. Bind `print-quoted' and `print-readably' to t, and `print-escape-multibyte', `print-escape-newlines', `print-escape-nonascii', `print-length', `print-level' and `print-string-length' to nil." `(let ((print-quoted t) (print-readably t) ;;print-circle ;;print-continuous-numbering print-escape-multibyte print-escape-newlines print-escape-nonascii ;;print-gensym print-length print-level print-string-length) ,@forms)) (defun gnus-prin1 (form) "Use `prin1' on FORM in the current buffer. Bind `print-quoted' and `print-readably' to t, and `print-length' and `print-level' to nil. See also `gnus-bind-print-variables'." (gnus-bind-print-variables (prin1 form (current-buffer)))) (defun gnus-prin1-to-string (form) "The same as `prin1'. Bind `print-quoted' and `print-readably' to t, and `print-length' and `print-level' to nil. See also `gnus-bind-print-variables'." (gnus-bind-print-variables (prin1-to-string form))) (defun gnus-pp (form &optional stream) "Use `pp' on FORM in the current buffer. Bind `print-quoted' and `print-readably' to t, and `print-length' and `print-level' to nil. See also `gnus-bind-print-variables'." (gnus-bind-print-variables (pp form (or stream (current-buffer))))) (defun gnus-pp-to-string (form) "The same as `pp-to-string'. Bind `print-quoted' and `print-readably' to t, and `print-length' and `print-level' to nil. See also `gnus-bind-print-variables'." (gnus-bind-print-variables (pp-to-string form))) (defun gnus-make-directory (directory) "Make DIRECTORY (and all its parents) if it doesn't exist." (require 'nnmail) (let ((file-name-coding-system nnmail-pathname-coding-system)) (when (and directory (not (file-exists-p directory))) (make-directory directory t))) t) (defun gnus-write-buffer (file) "Write the current buffer's contents to FILE." (let ((file-name-coding-system nnmail-pathname-coding-system)) ;; Make sure the directory exists. (gnus-make-directory (file-name-directory file)) ;; Write the buffer. (write-region (point-min) (point-max) file nil 'quietly))) (defun gnus-delete-file (file) "Delete FILE if it exists." (when (file-exists-p file) (delete-file file))) (defun gnus-delete-directory (directory) "Delete files in DIRECTORY. Subdirectories remain. If there's no subdirectory, delete DIRECTORY as well." (when (file-directory-p directory) (let ((files (directory-files directory t "^\\([^.]\\|\\.\\([^.]\\|\\..\\)\\).*")) file dir) (while files (setq file (pop files)) (if (eq t (car (file-attributes file))) ;; `file' is a subdirectory. (setq dir t) ;; `file' is a file or a symlink. (delete-file file))) (unless dir (delete-directory directory))))) ;; The following two functions are used in gnus-registry. ;; They were contributed by Andreas Fuchs . (defun gnus-alist-to-hashtable (alist) "Build a hashtable from the values in ALIST." (let ((ht (make-hash-table :size 4096 :test 'equal))) (mapc (lambda (kv-pair) (puthash (car kv-pair) (cdr kv-pair) ht)) alist) ht)) (defun gnus-hashtable-to-alist (hash) "Build an alist from the values in HASH." (let ((list nil)) (maphash (lambda (key value) (setq list (cons (cons key value) list))) hash) list)) (defun gnus-strip-whitespace (string) "Return STRING stripped of all whitespace." (while (string-match "[\r\n\t ]+" string) (setq string (replace-match "" t t string))) string) (declare-function gnus-put-text-property "gnus" (start end property value &optional object)) (defsubst gnus-put-text-property-excluding-newlines (beg end prop val) "The same as `put-text-property', but don't put this prop on any newlines in the region." (save-match-data (save-excursion (save-restriction (goto-char beg) (while (re-search-forward gnus-emphasize-whitespace-regexp end 'move) (gnus-put-text-property beg (match-beginning 0) prop val) (setq beg (point))) (gnus-put-text-property beg (point) prop val))))) (declare-function gnus-overlay-put "gnus" (overlay prop value)) (declare-function gnus-make-overlay "gnus" (beg end &optional buffer front-advance rear-advance)) (defsubst gnus-put-overlay-excluding-newlines (beg end prop val) "The same as `put-text-property', but don't put this prop on any newlines in the region." (save-match-data (save-excursion (save-restriction (goto-char beg) (while (re-search-forward gnus-emphasize-whitespace-regexp end 'move) (gnus-overlay-put (gnus-make-overlay beg (match-beginning 0)) prop val) (setq beg (point))) (gnus-overlay-put (gnus-make-overlay beg (point)) prop val))))) (defun gnus-put-text-property-excluding-characters-with-faces (beg end prop val) "The same as `put-text-property', but don't put props on characters with the `gnus-face' property." (let ((b beg)) (while (/= b end) (when (get-text-property b 'gnus-face) (setq b (next-single-property-change b 'gnus-face nil end))) (when (/= b end) (inline (gnus-put-text-property b (setq b (next-single-property-change b 'gnus-face nil end)) prop val)))))) (defmacro gnus-faces-at (position) "Return a list of faces at POSITION." (if (featurep 'xemacs) `(let ((pos ,position)) (mapcar-extents 'extent-face nil (current-buffer) pos pos nil 'face)) `(let ((pos ,position)) (delq nil (cons (get-text-property pos 'face) (mapcar (lambda (overlay) (overlay-get overlay 'face)) (overlays-at pos))))))) ;;; Protected and atomic operations. dmoore@ucsd.edu 21.11.1996 ;;; The primary idea here is to try to protect internal datastructures ;;; from becoming corrupted when the user hits C-g, or if a hook or ;;; similar blows up. Often in Gnus multiple tables/lists need to be ;;; updated at the same time, or information can be lost. (defvar gnus-atomic-be-safe t "If t, certain operations will be protected from interruption by C-g.") (defmacro gnus-atomic-progn (&rest forms) "Evaluate FORMS atomically, which means to protect the evaluation from being interrupted by the user. An error from the forms themselves will return without finishing the operation. Since interrupts from the user are disabled, it is recommended that only the most minimal operations are performed by FORMS. If you wish to assign many complicated values atomically, compute the results into temporary variables and then do only the assignment atomically." `(let ((inhibit-quit gnus-atomic-be-safe)) ,@forms)) (put 'gnus-atomic-progn 'lisp-indent-function 0) (defmacro gnus-atomic-progn-assign (protect &rest forms) "Evaluate FORMS, but insure that the variables listed in PROTECT are not changed if anything in FORMS signals an error or otherwise non-locally exits. The variables listed in PROTECT are updated atomically. It is safe to use gnus-atomic-progn-assign with long computations. Note that if any of the symbols in PROTECT were unbound, they will be set to nil on a successful assignment. In case of an error or other non-local exit, it will still be unbound." (let* ((temp-sym-map (mapcar (lambda (x) (list (make-symbol (concat (symbol-name x) "-tmp")) x)) protect)) (sym-temp-map (mapcar (lambda (x) (list (cadr x) (car x))) temp-sym-map)) (temp-sym-let (mapcar (lambda (x) (list (car x) `(and (boundp ',(cadr x)) ,(cadr x)))) temp-sym-map)) (sym-temp-let sym-temp-map) (temp-sym-assign (apply 'append temp-sym-map)) (sym-temp-assign (apply 'append sym-temp-map)) (result (make-symbol "result-tmp"))) `(let (,@temp-sym-let ,result) (let ,sym-temp-let (setq ,result (progn ,@forms)) (setq ,@temp-sym-assign)) (let ((inhibit-quit gnus-atomic-be-safe)) (setq ,@sym-temp-assign)) ,result))) (put 'gnus-atomic-progn-assign 'lisp-indent-function 1) ;(put 'gnus-atomic-progn-assign 'edebug-form-spec '(sexp body)) (defmacro gnus-atomic-setq (&rest pairs) "Similar to setq, except that the real symbols are only assigned when there are no errors. And when the real symbols are assigned, they are done so atomically. If other variables might be changed via side-effect, see gnus-atomic-progn-assign. It is safe to use gnus-atomic-setq with potentially long computations." (let ((tpairs pairs) syms) (while tpairs (push (car tpairs) syms) (setq tpairs (cddr tpairs))) `(gnus-atomic-progn-assign ,syms (setq ,@pairs)))) ;(put 'gnus-atomic-setq 'edebug-form-spec '(body)) ;;; Functions for saving to babyl/mail files. (eval-when-compile (condition-case nil (progn (require 'rmail) (autoload 'rmail-update-summary "rmailsum")) (error (define-compiler-macro rmail-select-summary (&rest body) ;; Rmail of the XEmacs version is supplied by the package, and ;; requires tm and apel packages. However, there may be those ;; who haven't installed those packages. This macro helps such ;; people even if they install those packages later. `(eval '(rmail-select-summary ,@body))) ;; If there's rmail but there's no tm (or there's apel of the ;; mainstream, not the XEmacs version), loading rmail of the XEmacs ;; version fails halfway, however it provides the rmail-select-summary ;; macro which uses the following functions: (autoload 'rmail-summary-displayed "rmail") (autoload 'rmail-maybe-display-summary "rmail")))) (defvar rmail-default-rmail-file) (defvar mm-text-coding-system) (declare-function mm-append-to-file "mm-util" (start end filename &optional codesys inhibit)) (defun gnus-output-to-rmail (filename &optional ask) "Append the current article to an Rmail file named FILENAME." (require 'rmail) (require 'mm-util) ;; Most of these codes are borrowed from rmailout.el. (setq filename (expand-file-name filename)) (setq rmail-default-rmail-file filename) (let ((artbuf (current-buffer)) (tmpbuf (get-buffer-create " *Gnus-output*"))) (save-excursion (or (get-file-buffer filename) (file-exists-p filename) (if (or (not ask) (gnus-yes-or-no-p (concat "\"" filename "\" does not exist, create it? "))) (let ((file-buffer (create-file-buffer filename))) (save-excursion (set-buffer file-buffer) (rmail-insert-rmail-file-header) (let ((require-final-newline nil) (coding-system-for-write mm-text-coding-system)) (gnus-write-buffer filename))) (kill-buffer file-buffer)) (error "Output file does not exist"))) (set-buffer tmpbuf) (erase-buffer) (insert-buffer-substring artbuf) (gnus-convert-article-to-rmail) ;; Decide whether to append to a file or to an Emacs buffer. (let ((outbuf (get-file-buffer filename))) (if (not outbuf) (let ((file-name-coding-system nnmail-pathname-coding-system)) (mm-append-to-file (point-min) (point-max) filename)) ;; File has been visited, in buffer OUTBUF. (set-buffer outbuf) (let ((buffer-read-only nil) (msg (and (boundp 'rmail-current-message) (symbol-value 'rmail-current-message)))) ;; If MSG is non-nil, buffer is in RMAIL mode. (when msg (widen) (narrow-to-region (point-max) (point-max))) (insert-buffer-substring tmpbuf) (when msg (goto-char (point-min)) (widen) (search-backward "\n\^_") (narrow-to-region (point) (point-max)) (rmail-count-new-messages t) (when (rmail-summary-exists) (rmail-select-summary (rmail-update-summary))) (rmail-count-new-messages t) (rmail-show-message msg)) (save-buffer))))) (kill-buffer tmpbuf))) (defun gnus-output-to-mail (filename &optional ask) "Append the current article to a mail file named FILENAME." (setq filename (expand-file-name filename)) (let ((artbuf (current-buffer)) (tmpbuf (get-buffer-create " *Gnus-output*"))) (save-excursion ;; Create the file, if it doesn't exist. (when (and (not (get-file-buffer filename)) (not (file-exists-p filename))) (if (or (not ask) (gnus-y-or-n-p (concat "\"" filename "\" does not exist, create it? "))) (let ((file-buffer (create-file-buffer filename))) (save-excursion (set-buffer file-buffer) (let ((require-final-newline nil) (coding-system-for-write mm-text-coding-system)) (gnus-write-buffer filename))) (kill-buffer file-buffer)) (error "Output file does not exist"))) (set-buffer tmpbuf) (erase-buffer) (insert-buffer-substring artbuf) (goto-char (point-min)) (if (looking-at "From ") (forward-line 1) (insert "From nobody " (current-time-string) "\n")) (let (case-fold-search) (while (re-search-forward "^From " nil t) (beginning-of-line) (insert ">"))) ;; Decide whether to append to a file or to an Emacs buffer. (let ((outbuf (get-file-buffer filename))) (if (not outbuf) (let ((buffer-read-only nil)) (save-excursion (goto-char (point-max)) (forward-char -2) (unless (looking-at "\n\n") (goto-char (point-max)) (unless (bolp) (insert "\n")) (insert "\n")) (goto-char (point-max)) (let ((file-name-coding-system nnmail-pathname-coding-system)) (mm-append-to-file (point-min) (point-max) filename)))) ;; File has been visited, in buffer OUTBUF. (set-buffer outbuf) (let ((buffer-read-only nil)) (goto-char (point-max)) (unless (eobp) (insert "\n")) (insert "\n") (insert-buffer-substring tmpbuf))))) (kill-buffer tmpbuf))) (defun gnus-convert-article-to-rmail () "Convert article in current buffer to Rmail message format." (let ((buffer-read-only nil)) ;; Convert article directly into Babyl format. (goto-char (point-min)) (insert "\^L\n0, unseen,,\n*** EOOH ***\n") (while (search-forward "\n\^_" nil t) ;single char (replace-match "\n^_" t t)) ;2 chars: "^" and "_" (goto-char (point-max)) (insert "\^_"))) (defun gnus-map-function (funs arg) "Apply the result of the first function in FUNS to the second, and so on. ARG is passed to the first function." (while funs (setq arg (funcall (pop funs) arg))) arg) (defun gnus-run-hooks (&rest funcs) "Does the same as `run-hooks', but saves the current buffer." (save-current-buffer (apply 'run-hooks funcs))) (defun gnus-run-mode-hooks (&rest funcs) "Run `run-mode-hooks' if it is available, otherwise `run-hooks'. This function saves the current buffer." (if (fboundp 'run-mode-hooks) (save-current-buffer (apply 'run-mode-hooks funcs)) (save-current-buffer (apply 'run-hooks funcs)))) ;;; Various (defvar gnus-group-buffer) ; Compiler directive (defun gnus-alive-p () "Say whether Gnus is running or not." (and (boundp 'gnus-group-buffer) (get-buffer gnus-group-buffer) (save-excursion (set-buffer gnus-group-buffer) (eq major-mode 'gnus-group-mode)))) (defun gnus-remove-if (predicate list) "Return a copy of LIST with all items satisfying PREDICATE removed." (let (out) (while list (unless (funcall predicate (car list)) (push (car list) out)) (setq list (cdr list))) (nreverse out))) (if (fboundp 'assq-delete-all) (defalias 'gnus-delete-alist 'assq-delete-all) (defun gnus-delete-alist (key alist) "Delete from ALIST all elements whose car is KEY. Return the modified alist." (let (entry) (while (setq entry (assq key alist)) (setq alist (delq entry alist))) alist))) (defmacro gnus-pull (key alist &optional assoc-p) "Modify ALIST to be without KEY." (unless (symbolp alist) (error "Not a symbol: %s" alist)) (let ((fun (if assoc-p 'assoc 'assq))) `(setq ,alist (delq (,fun ,key ,alist) ,alist)))) (defun gnus-globalify-regexp (re) "Return a regexp that matches a whole line, if RE matches a part of it." (concat (unless (string-match "^\\^" re) "^.*") re (unless (string-match "\\$$" re) ".*$"))) (defun gnus-set-window-start (&optional point) "Set the window start to POINT, or (point) if nil." (let ((win (gnus-get-buffer-window (current-buffer) t))) (when win (set-window-start win (or point (point)))))) (defun gnus-annotation-in-region-p (b e) (if (= b e) (eq (cadr (memq 'gnus-undeletable (text-properties-at b))) t) (text-property-any b e 'gnus-undeletable t))) (defun gnus-or (&rest elems) "Return non-nil if any of the elements are non-nil." (catch 'found (while elems (when (pop elems) (throw 'found t))))) (defun gnus-and (&rest elems) "Return non-nil if all of the elements are non-nil." (catch 'found (while elems (unless (pop elems) (throw 'found nil))) t)) ;; gnus.el requires mm-util. (declare-function mm-disable-multibyte "mm-util") (defun gnus-write-active-file (file hashtb &optional full-names) ;; `coding-system-for-write' should be `raw-text' or equivalent. (let ((coding-system-for-write nnmail-active-file-coding-system)) (with-temp-file file ;; The buffer should be in the unibyte mode because group names ;; are ASCII text or encoded non-ASCII text (i.e., unibyte). (mm-disable-multibyte) (mapatoms (lambda (sym) (when (and sym (boundp sym) (symbol-value sym)) (insert (format "%S %d %d y\n" (if full-names sym (intern (gnus-group-real-name (symbol-name sym)))) (or (cdr (symbol-value sym)) (car (symbol-value sym))) (car (symbol-value sym)))))) hashtb) (goto-char (point-max)) (while (search-backward "\\." nil t) (delete-char 1))))) ;; Fixme: Why not use `with-output-to-temp-buffer'? (defmacro gnus-with-output-to-file (file &rest body) (let ((buffer (make-symbol "output-buffer")) (size (make-symbol "output-buffer-size")) (leng (make-symbol "output-buffer-length")) (append (make-symbol "output-buffer-append"))) `(let* ((,size 131072) (,buffer (make-string ,size 0)) (,leng 0) (,append nil) (standard-output (lambda (c) (aset ,buffer ,leng c) (if (= ,size (setq ,leng (1+ ,leng))) (progn (write-region ,buffer nil ,file ,append 'no-msg) (setq ,leng 0 ,append t)))))) ,@body (when (> ,leng 0) (let ((coding-system-for-write 'no-conversion)) (write-region (substring ,buffer 0 ,leng) nil ,file ,append 'no-msg)))))) (put 'gnus-with-output-to-file 'lisp-indent-function 1) (put 'gnus-with-output-to-file 'edebug-form-spec '(form body)) (if (fboundp 'union) (defalias 'gnus-union 'union) (defun gnus-union (l1 l2) "Set union of lists L1 and L2." (cond ((null l1) l2) ((null l2) l1) ((equal l1 l2) l1) (t (or (>= (length l1) (length l2)) (setq l1 (prog1 l2 (setq l2 l1)))) (while l2 (or (member (car l2) l1) (push (car l2) l1)) (pop l2)) l1)))) (declare-function gnus-add-text-properties "gnus" (start end properties &optional object)) (defun gnus-add-text-properties-when (property value start end properties &optional object) "Like `gnus-add-text-properties', only applied on where PROPERTY is VALUE." (let (point) (while (and start (< start end) ;; XEmacs will loop for every when start=end. (setq point (text-property-not-all start end property value))) (gnus-add-text-properties start point properties object) (setq start (text-property-any point end property value))) (if start (gnus-add-text-properties start end properties object)))) (defun gnus-remove-text-properties-when (property value start end properties &optional object) "Like `remove-text-properties', only applied on where PROPERTY is VALUE." (let (point) (while (and start (< start end) (setq point (text-property-not-all start end property value))) (remove-text-properties start point properties object) (setq start (text-property-any point end property value))) (if start (remove-text-properties start end properties object)) t)) (defun gnus-string-remove-all-properties (string) (condition-case () (let ((s string)) (set-text-properties 0 (length string) nil string) s) (error string))) ;; This might use `compare-strings' to reduce consing in the ;; case-insensitive case, but it has to cope with null args. ;; (`string-equal' uses symbol print names.) (defun gnus-string-equal (x y) "Like `string-equal', except it compares case-insensitively." (and (= (length x) (length y)) (or (string-equal x y) (string-equal (downcase x) (downcase y))))) (defcustom gnus-use-byte-compile t "If non-nil, byte-compile crucial run-time code. Setting it to nil has no effect after the first time `gnus-byte-compile' is run." :type 'boolean :version "22.1" :group 'gnus-various) (defun gnus-byte-compile (form) "Byte-compile FORM if `gnus-use-byte-compile' is non-nil." (if gnus-use-byte-compile (progn (condition-case nil ;; Work around a bug in XEmacs 21.4 (require 'byte-optimize) (error)) (require 'bytecomp) (defalias 'gnus-byte-compile (lambda (form) (let ((byte-compile-warnings '(unresolved callargs redefine))) (byte-compile form)))) (gnus-byte-compile form)) form)) (defun gnus-remassoc (key alist) "Delete by side effect any elements of LIST whose car is `equal' to KEY. The modified LIST is returned. If the first member of LIST has a car that is `equal' to KEY, there is no way to remove it by side effect; therefore, write `(setq foo (gnus-remassoc key foo))' to be sure of changing the value of `foo'." (when alist (if (equal key (caar alist)) (cdr alist) (setcdr alist (gnus-remassoc key (cdr alist))) alist))) (defun gnus-update-alist-soft (key value alist) (if value (cons (cons key value) (gnus-remassoc key alist)) (gnus-remassoc key alist))) (defun gnus-create-info-command (node) "Create a command that will go to info NODE." `(lambda () (interactive) ,(concat "Enter the info system at node " node) (Info-goto-node ,node) (setq gnus-info-buffer (current-buffer)) (gnus-configure-windows 'info))) (defun gnus-not-ignore (&rest args) t) (defvar gnus-directory-sep-char-regexp "/" "The regexp of directory separator character. If you find some problem with the directory separator character, try \"[/\\\\\]\" for some systems.") (defun gnus-url-unhex (x) (if (> x ?9) (if (>= x ?a) (+ 10 (- x ?a)) (+ 10 (- x ?A))) (- x ?0))) ;; Fixme: Do it like QP. (defun gnus-url-unhex-string (str &optional allow-newlines) "Remove %XX, embedded spaces, etc in a url. If optional second argument ALLOW-NEWLINES is non-nil, then allow the decoding of carriage returns and line feeds in the string, which is normally forbidden in URL encoding." (let ((tmp "") (case-fold-search t)) (while (string-match "%[0-9a-f][0-9a-f]" str) (let* ((start (match-beginning 0)) (ch1 (gnus-url-unhex (elt str (+ start 1)))) (code (+ (* 16 ch1) (gnus-url-unhex (elt str (+ start 2)))))) (setq tmp (concat tmp (substring str 0 start) (cond (allow-newlines (char-to-string code)) ((or (= code ?\n) (= code ?\r)) " ") (t (char-to-string code)))) str (substring str (match-end 0))))) (setq tmp (concat tmp str)) tmp)) (defun gnus-make-predicate (spec) "Transform SPEC into a function that can be called. SPEC is a predicate specifier that contains stuff like `or', `and', `not', lists and functions. The functions all take one parameter." `(lambda (elem) ,(gnus-make-predicate-1 spec))) (defun gnus-make-predicate-1 (spec) (cond ((symbolp spec) `(,spec elem)) ((listp spec) (if (memq (car spec) '(or and not)) `(,(car spec) ,@(mapcar 'gnus-make-predicate-1 (cdr spec))) (error "Invalid predicate specifier: %s" spec))))) (defun gnus-completing-read (prompt table &optional predicate require-match history) (when (and history (not (boundp history))) (set history nil)) (completing-read (if (symbol-value history) (concat prompt " (" (car (symbol-value history)) "): ") (concat prompt ": ")) table predicate require-match nil history (car (symbol-value history)))) (defun gnus-graphic-display-p () (or (and (fboundp 'display-graphic-p) (display-graphic-p)) ;;;!!!This is bogus. Fixme! (and (featurep 'xemacs) t))) (put 'gnus-parse-without-error 'lisp-indent-function 0) (put 'gnus-parse-without-error 'edebug-form-spec '(body)) (defmacro gnus-parse-without-error (&rest body) "Allow continuing onto the next line even if an error occurs." `(while (not (eobp)) (condition-case () (progn ,@body (goto-char (point-max))) (error (gnus-error 4 "Invalid data on line %d" (count-lines (point-min) (point))) (forward-line 1))))) (defun gnus-cache-file-contents (file variable function) "Cache the contents of FILE in VARIABLE. The contents come from FUNCTION." (let ((time (nth 5 (file-attributes file))) contents value) (if (or (null (setq value (symbol-value variable))) (not (equal (car value) file)) (not (equal (nth 1 value) time))) (progn (setq contents (funcall function file)) (set variable (list file time contents)) contents) (nth 2 value)))) (defun gnus-multiple-choice (prompt choice &optional idx) "Ask user a multiple choice question. CHOICE is a list of the choice char and help message at IDX." (let (tchar buf) (save-window-excursion (save-excursion (while (not tchar) (message "%s (%s): " prompt (concat (mapconcat (lambda (s) (char-to-string (car s))) choice ", ") ", ?")) (setq tchar (read-char)) (when (not (assq tchar choice)) (setq tchar nil) (setq buf (get-buffer-create "*Gnus Help*")) (pop-to-buffer buf) (fundamental-mode) ; for Emacs 20.4+ (buffer-disable-undo) (erase-buffer) (insert prompt ":\n\n") (let ((max -1) (list choice) (alist choice) (idx (or idx 1)) (i 0) n width pad format) ;; find the longest string to display (while list (setq n (length (nth idx (car list)))) (unless (> max n) (setq max n)) (setq list (cdr list))) (setq max (+ max 4)) ; %c, `:', SPACE, a SPACE at end (setq n (/ (1- (window-width)) max)) ; items per line (setq width (/ (1- (window-width)) n)) ; width of each item ;; insert `n' items, each in a field of width `width' (while alist (if (< i n) () (setq i 0) (delete-char -1) ; the `\n' takes a char (insert "\n")) (setq pad (- width 3)) (setq format (concat "%c: %-" (int-to-string pad) "s")) (insert (format format (caar alist) (nth idx (car alist)))) (setq alist (cdr alist)) (setq i (1+ i)))))))) (if (buffer-live-p buf) (kill-buffer buf)) tchar)) (declare-function w32-focus-frame "../term/w32-win" (frame)) (defun gnus-select-frame-set-input-focus (frame) "Select FRAME, raise it, and set input focus, if possible." (cond ((featurep 'xemacs) (if (fboundp 'select-frame-set-input-focus) (select-frame-set-input-focus frame) (raise-frame frame) (select-frame frame) (focus-frame frame))) ;; `select-frame-set-input-focus' defined in Emacs 21 will not ;; set the input focus. ((>= emacs-major-version 22) (select-frame-set-input-focus frame)) (t (raise-frame frame) (select-frame frame) (cond ((memq window-system '(x mac)) (x-focus-frame frame)) ((eq window-system 'w32) (w32-focus-frame frame))) (when focus-follows-mouse (set-mouse-position frame (1- (frame-width frame)) 0))))) (defun gnus-frame-or-window-display-name (object) "Given a frame or window, return the associated display name. Return nil otherwise." (if (featurep 'xemacs) (device-connection (dfw-device object)) (if (or (framep object) (and (windowp object) (setq object (window-frame object)))) (let ((display (frame-parameter object 'display))) (if (and (stringp display) ;; Exclude invalid display names. (string-match "\\`[^:]*:[0-9]+\\(\\.[0-9]+\\)?\\'" display)) display))))) (defvar tool-bar-mode) (defun gnus-tool-bar-update (&rest ignore) "Update the tool bar." (when (and (boundp 'tool-bar-mode) tool-bar-mode) (let* ((args nil) (func (cond ((featurep 'xemacs) 'ignore) ((fboundp 'tool-bar-update) 'tool-bar-update) ((fboundp 'force-window-update) 'force-window-update) ((fboundp 'redraw-frame) (setq args (list (selected-frame))) 'redraw-frame) (t 'ignore)))) (apply func args)))) ;; Fixme: This has only one use (in gnus-agent), which isn't worthwhile. (defmacro gnus-mapcar (function seq1 &rest seqs2_n) "Apply FUNCTION to each element of the sequences, and make a list of the results. If there are several sequences, FUNCTION is called with that many arguments, and mapping stops as soon as the shortest sequence runs out. With just one sequence, this is like `mapcar'. With several, it is like the Common Lisp `mapcar' function extended to arbitrary sequence types." (if seqs2_n (let* ((seqs (cons seq1 seqs2_n)) (cnt 0) (heads (mapcar (lambda (seq) (make-symbol (concat "head" (int-to-string (setq cnt (1+ cnt)))))) seqs)) (result (make-symbol "result")) (result-tail (make-symbol "result-tail"))) `(let* ,(let* ((bindings (cons nil nil)) (heads heads)) (nconc bindings (list (list result '(cons nil nil)))) (nconc bindings (list (list result-tail result))) (while heads (nconc bindings (list (list (pop heads) (pop seqs))))) (cdr bindings)) (while (and ,@heads) (setcdr ,result-tail (cons (funcall ,function ,@(mapcar (lambda (h) (list 'car h)) heads)) nil)) (setq ,result-tail (cdr ,result-tail) ,@(apply 'nconc (mapcar (lambda (h) (list h (list 'cdr h))) heads)))) (cdr ,result))) `(mapcar ,function ,seq1))) (if (fboundp 'merge) (defalias 'gnus-merge 'merge) ;; Adapted from cl-seq.el (defun gnus-merge (type list1 list2 pred) "Destructively merge lists LIST1 and LIST2 to produce a new list. Argument TYPE is for compatibility and ignored. Ordering of the elements is preserved according to PRED, a `less-than' predicate on the elements." (let ((res nil)) (while (and list1 list2) (if (funcall pred (car list2) (car list1)) (push (pop list2) res) (push (pop list1) res))) (nconc (nreverse res) list1 list2)))) (defvar xemacs-codename) (defvar sxemacs-codename) (defvar emacs-program-version) (defun gnus-emacs-version () "Stringified Emacs version." (let* ((lst (if (listp gnus-user-agent) gnus-user-agent '(gnus emacs type))) (system-v (cond ((memq 'config lst) system-configuration) ((memq 'type lst) (symbol-name system-type)) (t nil))) codename emacsname) (cond ((featurep 'sxemacs) (setq emacsname "SXEmacs" codename sxemacs-codename)) ((featurep 'xemacs) (setq emacsname "XEmacs" codename xemacs-codename)) (t (setq emacsname "Emacs"))) (cond ((not (memq 'emacs lst)) nil) ((string-match "^\\(\\([.0-9]+\\)*\\)\\.[0-9]+$" emacs-version) ;; Emacs: (concat "Emacs/" (match-string 1 emacs-version) (if system-v (concat " (" system-v ")") ""))) ((or (featurep 'sxemacs) (featurep 'xemacs)) ;; XEmacs or SXEmacs: (concat emacsname "/" emacs-program-version (let (plst) (when (memq 'codename lst) (push codename plst)) (when system-v (push system-v plst)) (unless (featurep 'mule) (push "no MULE" plst)) (when (> (length plst) 0) (concat " (" (mapconcat 'identity (reverse plst) ", ") ")"))))) (t emacs-version)))) (defun gnus-rename-file (old-path new-path &optional trim) "Rename OLD-PATH as NEW-PATH. If TRIM, recursively delete empty directories from OLD-PATH." (when (file-exists-p old-path) (let* ((old-dir (file-name-directory old-path)) (old-name (file-name-nondirectory old-path)) (new-dir (file-name-directory new-path)) (new-name (file-name-nondirectory new-path)) temp) (gnus-make-directory new-dir) (rename-file old-path new-path t) (when trim (while (progn (setq temp (directory-files old-dir)) (while (member (car temp) '("." "..")) (setq temp (cdr temp))) (= (length temp) 0)) (delete-directory old-dir) (setq old-dir (file-name-as-directory (file-truename (concat old-dir ".."))))))))) (defun gnus-set-file-modes (filename mode) "Wrapper for set-file-modes." (ignore-errors (set-file-modes filename mode))) (if (fboundp 'set-process-query-on-exit-flag) (defalias 'gnus-set-process-query-on-exit-flag 'set-process-query-on-exit-flag) (defalias 'gnus-set-process-query-on-exit-flag 'process-kill-without-query)) (if (fboundp 'with-local-quit) (defalias 'gnus-with-local-quit 'with-local-quit) (defmacro gnus-with-local-quit (&rest body) "Execute BODY, allowing quits to terminate BODY but not escape further. When a quit terminates BODY, `gnus-with-local-quit' returns nil but requests another quit. That quit will be processed as soon as quitting is allowed once again. (Immediately, if `inhibit-quit' is nil.)" ;;(declare (debug t) (indent 0)) `(condition-case nil (let ((inhibit-quit nil)) ,@body) (quit (setq quit-flag t) ;; This call is to give a chance to handle quit-flag ;; in case inhibit-quit is nil. ;; Without this, it will not be handled until the next function ;; call, and that might allow it to exit thru a condition-case ;; that intends to handle the quit signal next time. (eval '(ignore nil)))))) (provide 'gnus-util) ;; arch-tag: f94991af-d32b-4c97-8c26-ca12a934de49 ;;; gnus-util.el ends here gnus-5.11+v0.10.dfsg/lisp/mml-smime.el0000644000175000017500000004503611004005110017450 0ustar tvainikatvainika;;; mml-smime.el --- S/MIME support for MML ;; Copyright (C) 2000, 2001, 2002, 2003, 2004, ;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc. ;; Author: Simon Josefsson ;; Keywords: Gnus, MIME, S/MIME, MML ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published ;; by the Free Software Foundation; either version 3, or (at your ;; option) any later version. ;; GNU Emacs is distributed in the hope that it will be useful, but ;; WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Commentary: ;;; Code: ;; For Emacs < 22.2. (eval-and-compile (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) (eval-when-compile (require 'cl)) (require 'smime) (require 'mm-decode) (require 'mml-sec) (autoload 'message-narrow-to-headers "message") (autoload 'message-fetch-field "message") (defvar mml-smime-use 'openssl) (defvar mml-smime-function-alist '((openssl mml-smime-openssl-sign mml-smime-openssl-encrypt mml-smime-openssl-sign-query mml-smime-openssl-encrypt-query mml-smime-openssl-verify mml-smime-openssl-verify-test) (epg mml-smime-epg-sign mml-smime-epg-encrypt nil nil mml-smime-epg-verify mml-smime-epg-verify-test))) (defcustom mml-smime-verbose mml-secure-verbose "If non-nil, ask the user about the current operation more verbosely." :group 'mime-security :type 'boolean) (defcustom mml-smime-cache-passphrase mml-secure-cache-passphrase "If t, cache passphrase." :group 'mime-security :type 'boolean) (defcustom mml-smime-passphrase-cache-expiry mml-secure-passphrase-cache-expiry "How many seconds the passphrase is cached. Whether the passphrase is cached at all is controlled by `mml-smime-cache-passphrase'." :group 'mime-security :type 'integer) (defcustom mml-smime-signers nil "A list of your own key ID which will be used to sign a message." :group 'mime-security :type '(repeat (string :tag "Key ID"))) (defun mml-smime-sign (cont) (let ((func (nth 1 (assq mml-smime-use mml-smime-function-alist)))) (if func (funcall func cont) (error "Cannot find sign function")))) (defun mml-smime-encrypt (cont) (let ((func (nth 2 (assq mml-smime-use mml-smime-function-alist)))) (if func (funcall func cont) (error "Cannot find encrypt function")))) (defun mml-smime-sign-query () (let ((func (nth 3 (assq mml-smime-use mml-smime-function-alist)))) (if func (funcall func)))) (defun mml-smime-encrypt-query () (let ((func (nth 4 (assq mml-smime-use mml-smime-function-alist)))) (if func (funcall func)))) (defun mml-smime-verify (handle ctl) (let ((func (nth 5 (assq mml-smime-use mml-smime-function-alist)))) (if func (funcall func handle ctl) handle))) (defun mml-smime-verify-test (handle ctl) (let ((func (nth 6 (assq mml-smime-use mml-smime-function-alist)))) (if func (funcall func handle ctl)))) (defun mml-smime-openssl-sign (cont) (when (null smime-keys) (customize-variable 'smime-keys) (error "No S/MIME keys configured, use customize to add your key")) (smime-sign-buffer (cdr (assq 'keyfile cont))) (goto-char (point-min)) (while (search-forward "\r\n" nil t) (replace-match "\n" t t)) (goto-char (point-max))) (defun mml-smime-openssl-encrypt (cont) (let (certnames certfiles tmp file tmpfiles) ;; xxx tmp files are always an security issue (while (setq tmp (pop cont)) (if (and (consp tmp) (eq (car tmp) 'certfile)) (push (cdr tmp) certnames))) (while (setq tmp (pop certnames)) (if (not (and (not (file-exists-p tmp)) (get-buffer tmp))) (push tmp certfiles) (setq file (mm-make-temp-file (expand-file-name "mml." mm-tmp-directory))) (with-current-buffer tmp (write-region (point-min) (point-max) file)) (push file certfiles) (push file tmpfiles))) (if (smime-encrypt-buffer certfiles) (progn (while (setq tmp (pop tmpfiles)) (delete-file tmp)) t) (while (setq tmp (pop tmpfiles)) (delete-file tmp)) nil)) (goto-char (point-max))) (defvar gnus-extract-address-components) (defun mml-smime-openssl-sign-query () ;; query information (what certificate) from user when MML tag is ;; added, for use later by the signing process (when (null smime-keys) (customize-variable 'smime-keys) (error "No S/MIME keys configured, use customize to add your key")) (list 'keyfile (if (= (length smime-keys) 1) (cadar smime-keys) (or (let ((from (cadr (funcall (if (boundp 'gnus-extract-address-components) gnus-extract-address-components 'mail-extract-address-components) (or (save-excursion (save-restriction (message-narrow-to-headers) (message-fetch-field "from"))) ""))))) (and from (smime-get-key-by-email from))) (smime-get-key-by-email (completing-read "Sign this part with what signature? " smime-keys nil nil (and (listp (car-safe smime-keys)) (caar smime-keys)))))))) (defun mml-smime-get-file-cert () (ignore-errors (list 'certfile (read-file-name "File with recipient's S/MIME certificate: " smime-certificate-directory nil t "")))) (defun mml-smime-get-dns-cert () ;; todo: deal with comma separated multiple recipients (let (result who bad cert) (condition-case () (while (not result) (setq who (read-from-minibuffer (format "%sLookup certificate for: " (or bad "")) (cadr (funcall (if (boundp 'gnus-extract-address-components) gnus-extract-address-components 'mail-extract-address-components) (or (save-excursion (save-restriction (message-narrow-to-headers) (message-fetch-field "to"))) ""))))) (if (setq cert (smime-cert-by-dns who)) (setq result (list 'certfile (buffer-name cert))) (setq bad (format "`%s' not found. " who)))) (quit)) result)) (defun mml-smime-get-ldap-cert () ;; todo: deal with comma separated multiple recipients (let (result who bad cert) (condition-case () (while (not result) (setq who (read-from-minibuffer (format "%sLookup certificate for: " (or bad "")) (cadr (funcall gnus-extract-address-components (or (save-excursion (save-restriction (message-narrow-to-headers) (message-fetch-field "to"))) ""))))) (if (setq cert (smime-cert-by-ldap who)) (setq result (list 'certfile (buffer-name cert))) (setq bad (format "`%s' not found. " who)))) (quit)) result)) (autoload 'gnus-completing-read-with-default "gnus-util") (defun mml-smime-openssl-encrypt-query () ;; todo: try dns/ldap automatically first, before prompting user (let (certs done) (while (not done) (ecase (read (gnus-completing-read-with-default "ldap" "Fetch certificate from" '(("dns") ("ldap") ("file")) nil t)) (dns (setq certs (append certs (mml-smime-get-dns-cert)))) (ldap (setq certs (append certs (mml-smime-get-ldap-cert)))) (file (setq certs (append certs (mml-smime-get-file-cert))))) (setq done (not (y-or-n-p "Add more recipients? ")))) certs)) (defun mml-smime-openssl-verify (handle ctl) (with-temp-buffer (insert-buffer-substring (mm-handle-multipart-original-buffer ctl)) (goto-char (point-min)) (insert (format "Content-Type: %s; " (mm-handle-media-type ctl))) (insert (format "protocol=\"%s\"; " (mm-handle-multipart-ctl-parameter ctl 'protocol))) (insert (format "micalg=\"%s\"; " (mm-handle-multipart-ctl-parameter ctl 'micalg))) (insert (format "boundary=\"%s\"\n\n" (mm-handle-multipart-ctl-parameter ctl 'boundary))) (when (get-buffer smime-details-buffer) (kill-buffer smime-details-buffer)) (let ((buf (current-buffer)) (good-signature (smime-noverify-buffer)) (good-certificate (and (or smime-CA-file smime-CA-directory) (smime-verify-buffer))) addresses openssl-output) (setq openssl-output (with-current-buffer smime-details-buffer (buffer-string))) (if (not good-signature) (progn ;; we couldn't verify message, fail with openssl output as message (mm-set-handle-multipart-parameter mm-security-handle 'gnus-info "Failed") (mm-set-handle-multipart-parameter mm-security-handle 'gnus-details (concat "OpenSSL failed to verify message integrity:\n" "-------------------------------------------\n" openssl-output))) ;; verify mail addresses in mail against those in certificate (when (and (smime-pkcs7-region (point-min) (point-max)) (smime-pkcs7-certificates-region (point-min) (point-max))) (with-temp-buffer (insert-buffer-substring buf) (goto-char (point-min)) (while (re-search-forward "-----END CERTIFICATE-----" nil t) (when (smime-pkcs7-email-region (point-min) (point)) (setq addresses (append (smime-buffer-as-string-region (point-min) (point)) addresses))) (delete-region (point-min) (point))) (setq addresses (mapcar 'downcase addresses)))) (if (not (member (downcase (or (mm-handle-multipart-from ctl) "")) addresses)) (mm-set-handle-multipart-parameter mm-security-handle 'gnus-info "Sender address forged") (if good-certificate (mm-set-handle-multipart-parameter mm-security-handle 'gnus-info "Ok (sender authenticated)") (mm-set-handle-multipart-parameter mm-security-handle 'gnus-info "Ok (sender not trusted)"))) (mm-set-handle-multipart-parameter mm-security-handle 'gnus-details (concat "Sender claimed to be: " (mm-handle-multipart-from ctl) "\n" (if addresses (concat "Addresses in certificate: " (mapconcat 'identity addresses ", ")) "No addresses found in certificate. (Requires OpenSSL 0.9.6 or later.)") "\n" "\n" "OpenSSL output:\n" "---------------\n" openssl-output "\n" "Certificate(s) inside S/MIME signature:\n" "---------------------------------------\n" (buffer-string) "\n"))))) handle) (defun mml-smime-openssl-verify-test (handle ctl) smime-openssl-program) (defvar epg-user-id-alist) (defvar epg-digest-algorithm-alist) (defvar inhibit-redisplay) (defvar password-cache-expiry) (eval-when-compile (autoload 'epg-make-context "epg") (autoload 'epg-context-set-armor "epg") (autoload 'epg-context-set-signers "epg") (autoload 'epg-context-result-for "epg") (autoload 'epg-new-signature-digest-algorithm "epg") (autoload 'epg-verify-result-to-string "epg") (autoload 'epg-list-keys "epg") (autoload 'epg-decrypt-string "epg") (autoload 'epg-verify-string "epg") (autoload 'epg-sign-string "epg") (autoload 'epg-encrypt-string "epg") (autoload 'epg-passphrase-callback-function "epg") (autoload 'epg-context-set-passphrase-callback "epg") (autoload 'epg-configuration "epg-config") (autoload 'epg-expand-group "epg-config") (autoload 'epa-select-keys "epa")) (defvar mml-smime-epg-secret-key-id-list nil) (defun mml-smime-epg-passphrase-callback (context key-id ignore) (if (eq key-id 'SYM) (epg-passphrase-callback-function context key-id nil) (let* (entry (passphrase (password-read (if (eq key-id 'PIN) "Passphrase for PIN: " (if (setq entry (assoc key-id epg-user-id-alist)) (format "Passphrase for %s %s: " key-id (cdr entry)) (format "Passphrase for %s: " key-id))) (if (eq key-id 'PIN) "PIN" key-id)))) (when passphrase (let ((password-cache-expiry mml-smime-passphrase-cache-expiry)) (password-cache-add key-id passphrase)) (setq mml-smime-epg-secret-key-id-list (cons key-id mml-smime-epg-secret-key-id-list)) (copy-sequence passphrase))))) (declare-function epg-key-sub-key-list "ext:epg" (key)) (declare-function epg-sub-key-capability "ext:epg" (sub-key)) (declare-function epg-sub-key-validity "ext:epg" (sub-key)) (defun mml-smime-epg-find-usable-key (keys usage) (catch 'found (while keys (let ((pointer (epg-key-sub-key-list (car keys)))) (while pointer (if (and (memq usage (epg-sub-key-capability (car pointer))) (not (memq (epg-sub-key-validity (car pointer)) '(revoked expired)))) (throw 'found (car keys))) (setq pointer (cdr pointer)))) (setq keys (cdr keys))))) (autoload 'mml-compute-boundary "mml") ;; We require mm-decode, which requires mm-bodies, which autoloads ;; message-options-get (!). (declare-function message-options-set "message" (symbol value)) (defun mml-smime-epg-sign (cont) (let* ((inhibit-redisplay t) (context (epg-make-context 'CMS)) (boundary (mml-compute-boundary cont)) signer-key (signers (or (message-options-get 'mml-smime-epg-signers) (message-options-set 'mml-smime-epg-signers (if mml-smime-verbose (epa-select-keys context "\ Select keys for signing. If no one is selected, default secret key is used. " mml-smime-signers t) (if mml-smime-signers (mapcar (lambda (signer) (setq signer-key (mml-smime-epg-find-usable-key (epg-list-keys context signer t) 'sign)) (unless (or signer-key (y-or-n-p (format "No secret key for %s; skip it? " signer))) (error "No secret key for %s" signer)) signer-key) mml-smime-signers)))))) signature micalg) (epg-context-set-signers context signers) (if mml-smime-cache-passphrase (epg-context-set-passphrase-callback context #'mml-smime-epg-passphrase-callback)) (condition-case error (setq signature (epg-sign-string context (mm-replace-in-string (buffer-string) "\n" "\r\n") t) mml-smime-epg-secret-key-id-list nil) (error (while mml-smime-epg-secret-key-id-list (password-cache-remove (car mml-smime-epg-secret-key-id-list)) (setq mml-smime-epg-secret-key-id-list (cdr mml-smime-epg-secret-key-id-list))) (signal (car error) (cdr error)))) (if (epg-context-result-for context 'sign) (setq micalg (epg-new-signature-digest-algorithm (car (epg-context-result-for context 'sign))))) (goto-char (point-min)) (insert (format "Content-Type: multipart/signed; boundary=\"%s\";\n" boundary)) (if micalg (insert (format "\tmicalg=%s; " (downcase (cdr (assq micalg epg-digest-algorithm-alist)))))) (insert "protocol=\"application/pkcs7-signature\"\n") (insert (format "\n--%s\n" boundary)) (goto-char (point-max)) (insert (format "\n--%s\n" boundary)) (insert "Content-Type: application/pkcs7-signature; name=smime.p7s Content-Transfer-Encoding: base64 Content-Disposition: attachment; filename=smime.p7s ") (insert (base64-encode-string signature) "\n") (goto-char (point-max)) (insert (format "--%s--\n" boundary)) (goto-char (point-max)))) (defun mml-smime-epg-encrypt (cont) (let ((inhibit-redisplay t) (context (epg-make-context 'CMS)) (config (epg-configuration)) (recipients (message-options-get 'mml-smime-epg-recipients)) cipher signers (boundary (mml-compute-boundary cont)) recipient-key) (unless recipients (setq recipients (apply #'nconc (mapcar (lambda (recipient) (or (epg-expand-group config recipient) (list recipient))) (split-string (or (message-options-get 'message-recipients) (message-options-set 'message-recipients (read-string "Recipients: "))) "[ \f\t\n\r\v,]+")))) (if mml-smime-verbose (setq recipients (epa-select-keys context "\ Select recipients for encryption. If no one is selected, symmetric encryption will be performed. " recipients)) (setq recipients (mapcar (lambda (recipient) (setq recipient-key (mml-smime-epg-find-usable-key (epg-list-keys context recipient) 'encrypt)) (unless (or recipient-key (y-or-n-p (format "No public key for %s; skip it? " recipient))) (error "No public key for %s" recipient)) recipient-key) recipients)) (unless recipients (error "No recipient specified"))) (message-options-set 'mml-smime-epg-recipients recipients)) (if mml-smime-cache-passphrase (epg-context-set-passphrase-callback context #'mml-smime-epg-passphrase-callback)) (condition-case error (setq cipher (epg-encrypt-string context (buffer-string) recipients) mml-smime-epg-secret-key-id-list nil) (error (while mml-smime-epg-secret-key-id-list (password-cache-remove (car mml-smime-epg-secret-key-id-list)) (setq mml-smime-epg-secret-key-id-list (cdr mml-smime-epg-secret-key-id-list))) (signal (car error) (cdr error)))) (delete-region (point-min) (point-max)) (goto-char (point-min)) (insert "\ Content-Type: application/pkcs7-mime; smime-type=enveloped-data; name=smime.p7m Content-Transfer-Encoding: base64 Content-Disposition: attachment; filename=smime.p7m ") (insert (base64-encode-string cipher)) (goto-char (point-max)))) (defun mml-smime-epg-verify (handle ctl) (catch 'error (let ((inhibit-redisplay t) context plain signature-file part signature) (when (or (null (setq part (mm-find-raw-part-by-type ctl (or (mm-handle-multipart-ctl-parameter ctl 'protocol) "application/pkcs7-signature") t))) (null (setq signature (mm-find-part-by-type (cdr handle) "application/pkcs7-signature" nil t)))) (mm-set-handle-multipart-parameter mm-security-handle 'gnus-info "Corrupted") (throw 'error handle)) (setq part (mm-replace-in-string part "\n" "\r\n" t) context (epg-make-context 'CMS)) (condition-case error (setq plain (epg-verify-string context (mm-get-part signature) part)) (error (mm-set-handle-multipart-parameter mm-security-handle 'gnus-info "Failed") (if (eq (car error) 'quit) (mm-set-handle-multipart-parameter mm-security-handle 'gnus-details "Quit.") (mm-set-handle-multipart-parameter mm-security-handle 'gnus-details (format "%S" error))) (throw 'error handle))) (mm-set-handle-multipart-parameter mm-security-handle 'gnus-info (epg-verify-result-to-string (epg-context-result-for context 'verify))) handle))) (defun mml-smime-epg-verify-test (handle ctl) t) (provide 'mml-smime) ;; arch-tag: f1bf94d4-f2cd-4c6f-b059-ad69492817e2 ;;; mml-smime.el ends here gnus-5.11+v0.10.dfsg/lisp/mm-partial.el0000644000175000017500000001166211004005111017615 0ustar tvainikatvainika;;; mm-partial.el --- showing message/partial ;; Copyright (C) 2000, 2001, 2002, 2003, 2004, ;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc. ;; Author: Shenghuo Zhu ;; Keywords: message partial ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published ;; by the Free Software Foundation; either version 3, or (at your ;; option) any later version. ;; GNU Emacs is distributed in the hope that it will be useful, but ;; WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Commentary: ;;; Code: (eval-when-compile (require 'cl)) (require 'gnus-sum) (require 'mm-util) (require 'mm-decode) (defun mm-partial-find-parts (id &optional art) (let ((headers (with-current-buffer gnus-summary-buffer gnus-newsgroup-headers)) phandles header) (while (setq header (pop headers)) (unless (eq (aref header 0) art) (mm-with-unibyte-buffer (gnus-request-article-this-buffer (aref header 0) gnus-newsgroup-name) (when (search-forward id nil t) (let ((nhandles (mm-dissect-buffer nil gnus-article-loose-mime)) nid) (if (consp (car nhandles)) (mm-destroy-parts nhandles) (setq nid (cdr (assq 'id (cdr (mm-handle-type nhandles))))) (if (not (equal id nid)) (mm-destroy-parts nhandles) (push nhandles phandles)))))))) phandles)) ;;;###autoload (defun mm-inline-partial (handle &optional no-display) "Show the partial part of HANDLE. This function replaces the buffer of HANDLE with a buffer contains the entire message. If NO-DISPLAY is nil, display it. Otherwise, do nothing after replacing." (let ((id (cdr (assq 'id (cdr (mm-handle-type handle))))) phandles (b (point)) (n 1) total phandle nn ntotal gnus-displaying-mime handles buffer) (unless (mm-handle-cache handle) (unless id (error "Can not find message/partial id")) (setq phandles (sort (cons handle (mm-partial-find-parts id (save-excursion (set-buffer gnus-summary-buffer) (gnus-summary-article-number)))) #'(lambda (a b) (let ((anumber (string-to-number (cdr (assq 'number (cdr (mm-handle-type a)))))) (bnumber (string-to-number (cdr (assq 'number (cdr (mm-handle-type b))))))) (< anumber bnumber))))) (setq gnus-article-mime-handles (mm-merge-handles gnus-article-mime-handles phandles)) (save-excursion (set-buffer (generate-new-buffer " *mm*")) (while (setq phandle (pop phandles)) (setq nn (string-to-number (cdr (assq 'number (cdr (mm-handle-type phandle)))))) (setq ntotal (string-to-number (cdr (assq 'total (cdr (mm-handle-type phandle)))))) (if ntotal (if total (unless (eq total ntotal) (error "The numbers of total are different")) (setq total ntotal))) (unless (< nn n) (unless (eq nn n) (error "Missing part %d" n)) (mm-insert-part phandle) (goto-char (point-max)) (when (not (eq 0 (skip-chars-backward "\r\n"))) ;; remove tail blank spaces except one (if (looking-at "\r?\n") (goto-char (match-end 0))) (delete-region (point) (point-max))) (setq n (+ n 1)))) (unless total (error "Don't known the total number of")) (if (<= n total) (error "Missing part %d" n)) (kill-buffer (mm-handle-buffer handle)) (goto-char (point-min)) (let ((point (if (search-forward "\n\n" nil t) (1- (point)) (point-max)))) (goto-char (point-min)) (unless (re-search-forward "^mime-version:" point t) (insert "MIME-Version: 1.0\n"))) (setcar handle (current-buffer)) (mm-handle-set-cache handle t))) (unless no-display (save-excursion (save-restriction (narrow-to-region b b) (mm-insert-part handle) (let (gnus-article-mime-handles) (run-hooks 'gnus-article-decode-hook) (gnus-article-prepare-display) (setq handles gnus-article-mime-handles)) (when handles ;; It is in article buffer. (setq gnus-article-mime-handles (mm-merge-handles gnus-article-mime-handles handles))) (mm-handle-set-undisplayer handle `(lambda () (let (buffer-read-only) (condition-case nil ;; This is only valid on XEmacs. (mapcar (lambda (prop) (remove-specifier (face-property 'default prop) (current-buffer))) '(background background-pixmap foreground)) (error nil)) (delete-region ,(point-min-marker) ,(point-max-marker)))))))))) (provide 'mm-partial) ;; arch-tag: 460e7424-05f2-4a1d-a0f2-70ec081eff7d ;;; mm-partial.el ends here gnus-5.11+v0.10.dfsg/lisp/html2text.el0000644000175000017500000003675311004005110017514 0ustar tvainikatvainika;;; html2text.el --- a simple html to plain text converter ;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc. ;; Author: Joakim Hove ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 3, or (at your option) ;; any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Commentary: ;; These functions provide a simple way to wash/clean html infected ;; mails. Definitely do not work in all cases, but some improvement ;; in readability is generally obtained. Formatting is only done in ;; the buffer, so the next time you enter the article it will be ;; "re-htmlized". ;; ;; The main function is `html2text'. ;;; Code: ;; ;; ;; (eval-when-compile (require 'cl)) (defvar html2text-format-single-element-list '(("hr" . html2text-clean-hr))) (defvar html2text-replace-list '(("´" . "`") ("&" . "&") ("'" . "'") ("¦" . "|") ("¢" . "c") ("ˆ" . "^") ("©" . "(C)") ("¤" . "(#)") ("°" . "degree") ("÷" . "/") ("€" . "e") ("½" . "1/2") (">" . ">") ("¿" . "?") ("«" . "<<") ("&ldquo" . "\"") ("‹" . "(") ("‘" . "`") ("<" . "<") ("—" . "--") (" " . " ") ("–" . "-") ("‰" . "%%") ("±" . "+-") ("£" . "£") (""" . "\"") ("»" . ">>") ("&rdquo" . "\"") ("®" . "(R)") ("›" . ")") ("’" . "'") ("§" . "§") ("¹" . "^1") ("²" . "^2") ("³" . "^3") ("˜" . "~")) "The map of entity to text. This is an alist were each element is a dotted pair consisting of an old string, and a replacement string. This replacement is done by the function `html2text-substitute' which basically performs a `replace-string' operation for every element in the list. This is completely verbatim - without any use of REGEXP.") (defvar html2text-remove-tag-list '("html" "body" "p" "img" "dir" "head" "div" "br" "font" "title" "meta") "A list of removable tags. This is a list of tags which should be removed, without any formatting. Note that tags in the list are presented *without* any \"<\" or \">\". All occurrences of a tag appearing in this list are removed, irrespective of whether it is a closing or opening tag, or if the tag has additional attributes. The deletion is done by the function `html2text-remove-tags'. For instance the text: \"Here comes something big .\" will be reduced to: \"Here comes something big.\" If this list contains the element \"font\".") (defvar html2text-format-tag-list '(("b" . html2text-clean-bold) ("strong" . html2text-clean-bold) ("u" . html2text-clean-underline) ("i" . html2text-clean-italic) ("em" . html2text-clean-italic) ("blockquote" . html2text-clean-blockquote) ("a" . html2text-clean-anchor) ("ul" . html2text-clean-ul) ("ol" . html2text-clean-ol) ("dl" . html2text-clean-dl) ("center" . html2text-clean-center)) "An alist of tags and processing functions. This is an alist where each dotted pair consists of a tag, and then the name of a function to be called when this tag is found. The function is called with the arguments p1, p2, p3 and p4. These are demontrated below: \" This is bold text \" ^ ^ ^ ^ | | | | p1 p2 p3 p4 Then the called function will typically format the text somewhat and remove the tags.") (defvar html2text-remove-tag-list2 '("li" "dt" "dd" "meta") "Another list of removable tags. This is a list of tags which are removed similarly to the list `html2text-remove-tag-list' - but these tags are retained for the formatting, and then moved afterward.") ;; ;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; ;; (defun html2text-replace-string (from-string to-string min max) "Replace FROM-STRING with TO-STRING in region from MIN to MAX." (goto-char min) (let ((delta (- (string-width to-string) (string-width from-string))) (change 0)) (while (search-forward from-string max t) (replace-match to-string) (setq change (+ change delta))) change)) ;; ;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; i.e. ;; (defun html2text-attr-value (list attribute) "Get value of ATTRIBUTE from LIST." (nth 1 (assoc attribute list))) (defun html2text-get-attr (p1 p2) (goto-char p1) (re-search-forward " +[^ ]" p2 t) (let* ((attr-string (buffer-substring-no-properties (1- (point)) (1- p2))) (tmp-list (split-string attr-string)) (attr-list) (counter 0) (prev (car tmp-list)) (this (nth 1 tmp-list)) (next (nth 2 tmp-list)) (index 1)) (cond ;; size=3 ((string-match "[^ ]=[^ ]" prev) (let ((attr (nth 0 (split-string prev "="))) (value (nth 1 (split-string prev "=")))) (setq attr-list (cons (list attr value) attr-list)))) ;; size= 3 ((string-match "[^ ]=\\'" prev) (setq attr-list (cons (list (substring prev 0 -1) this) attr-list)))) (while (< index (length tmp-list)) (cond ;; size=3 ((string-match "[^ ]=[^ ]" this) (let ((attr (nth 0 (split-string this "="))) (value (nth 1 (split-string this "=")))) (setq attr-list (cons (list attr value) attr-list)))) ;; size =3 ((string-match "\\`=[^ ]" this) (setq attr-list (cons (list prev (substring this 1)) attr-list))) ;; size= 3 ((string-match "[^ ]=\\'" this) (setq attr-list (cons (list (substring this 0 -1) next) attr-list))) ;; size = 3 ((string= "=" this) (setq attr-list (cons (list prev next) attr-list)))) (setq index (1+ index)) (setq prev this) (setq this next) (setq next (nth (1+ index) tmp-list))) ;; ;; Tags with no accompanying "=" i.e. value=nil ;; (setq prev (car tmp-list)) (setq this (nth 1 tmp-list)) (setq next (nth 2 tmp-list)) (setq index 1) (when (and (not (string-match "=" prev)) (not (string= (substring this 0 1) "="))) (setq attr-list (cons (list prev nil) attr-list))) (while (< index (1- (length tmp-list))) (when (and (not (string-match "=" this)) (not (or (string= (substring next 0 1) "=") (string= (substring prev -1) "=")))) (setq attr-list (cons (list this nil) attr-list))) (setq index (1+ index)) (setq prev this) (setq this next) (setq next (nth (1+ index) tmp-list))) (when (and this (not (string-match "=" this)) (not (string= (substring prev -1) "="))) (setq attr-list (cons (list this nil) attr-list))) ;; return - value attr-list)) ;; ;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; ;; (defun html2text-clean-list-items (p1 p2 list-type) (goto-char p1) (let ((item-nr 0) (items 0)) (while (search-forward "
  • " p2 t) (setq items (1+ items))) (goto-char p1) (while (< item-nr items) (setq item-nr (1+ item-nr)) (search-forward "
  • " (point-max) t) (cond ((string= list-type "ul") (insert " o ")) ((string= list-type "ol") (insert (format " %s: " item-nr))) (t (insert " x ")))))) (defun html2text-clean-dtdd (p1 p2) (goto-char p1) (let ((items 0) (item-nr 0)) (while (search-forward "
    " p2 t) (setq items (1+ items))) (goto-char p1) (while (< item-nr items) (setq item-nr (1+ item-nr)) (re-search-forward "
    \\([ ]*\\)" (point-max) t) (when (match-string 1) (delete-region (point) (- (point) (string-width (match-string 1))))) (let ((def-p1 (point)) (def-p2 0)) (re-search-forward "\\([ ]*\\)\\(
    \\|
    \\)" (point-max) t) (if (match-string 1) (progn (let* ((mw1 (string-width (match-string 1))) (mw2 (string-width (match-string 2))) (mw (+ mw1 mw2))) (goto-char (- (point) mw)) (delete-region (point) (+ (point) mw1)) (setq def-p2 (point)))) (setq def-p2 (- (point) (string-width (match-string 2))))) (put-text-property def-p1 def-p2 'face 'bold))))) (defun html2text-delete-tags (p1 p2 p3 p4) (delete-region p1 p2) (delete-region (- p3 (- p2 p1)) (- p4 (- p2 p1)))) (defun html2text-delete-single-tag (p1 p2) (delete-region p1 p2)) (defun html2text-clean-hr (p1 p2) (html2text-delete-single-tag p1 p2) (goto-char p1) (newline 1) (insert (make-string fill-column ?-))) (defun html2text-clean-ul (p1 p2 p3 p4) (html2text-delete-tags p1 p2 p3 p4) (html2text-clean-list-items p1 (- p3 (- p1 p2)) "ul")) (defun html2text-clean-ol (p1 p2 p3 p4) (html2text-delete-tags p1 p2 p3 p4) (html2text-clean-list-items p1 (- p3 (- p1 p2)) "ol")) (defun html2text-clean-dl (p1 p2 p3 p4) (html2text-delete-tags p1 p2 p3 p4) (html2text-clean-dtdd p1 (- p3 (- p1 p2)))) (defun html2text-clean-center (p1 p2 p3 p4) (html2text-delete-tags p1 p2 p3 p4) (center-region p1 (- p3 (- p2 p1)))) (defun html2text-clean-bold (p1 p2 p3 p4) (put-text-property p2 p3 'face 'bold) (html2text-delete-tags p1 p2 p3 p4)) (defun html2text-clean-title (p1 p2 p3 p4) (put-text-property p2 p3 'face 'bold) (html2text-delete-tags p1 p2 p3 p4)) (defun html2text-clean-underline (p1 p2 p3 p4) (put-text-property p2 p3 'face 'underline) (html2text-delete-tags p1 p2 p3 p4)) (defun html2text-clean-italic (p1 p2 p3 p4) (put-text-property p2 p3 'face 'italic) (html2text-delete-tags p1 p2 p3 p4)) (defun html2text-clean-font (p1 p2 p3 p4) (html2text-delete-tags p1 p2 p3 p4)) (defun html2text-clean-blockquote (p1 p2 p3 p4) (html2text-delete-tags p1 p2 p3 p4)) (defun html2text-clean-anchor (p1 p2 p3 p4) ;; If someone can explain how to make the URL clickable I will surely ;; improve upon this. ;; Maybe `goto-addr.el' can be used here. (let* ((attr-list (html2text-get-attr p1 p2)) (href (html2text-attr-value attr-list "href"))) (delete-region p1 p4) (when href (goto-char p1) (insert (substring href 1 -1 )) (put-text-property p1 (point) 'face 'bold)))) ;; ;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; ;; (defun html2text-fix-paragraph (p1 p2) (goto-char p1) (let ((refill-start) (refill-stop)) (when (re-search-forward "
    $" p2 t) (goto-char p1) (when (re-search-forward ".+[^<][^b][^r][^>]$" p2 t) (beginning-of-line) (setq refill-start (point)) (goto-char p2) (re-search-backward ".+[^<][^b][^r][^>]$" refill-start t) (forward-line 1) (end-of-line) ;; refill-stop should ideally be adjusted to ;; accomodate the "
    " strings which are removed ;; between refill-start and refill-stop. Can simply ;; be returned from my-replace-string (setq refill-stop (+ (point) (html2text-replace-string "
    " "" refill-start (point)))) ;; (message "Point = %s refill-stop = %s" (point) refill-stop) ;; (sleep-for 4) (fill-region refill-start refill-stop)))) (html2text-replace-string "
    " "" p1 p2)) ;; ;; This one is interactive ... ;; (defun html2text-fix-paragraphs () "This _tries_ to fix up the paragraphs - this is done in quite a ad-hook fashion, quite close to pure guess-work. It does work in some cases though." (interactive) (goto-char (point-min)) (while (re-search-forward "^
    $" nil t) (delete-region (match-beginning 0) (match-end 0))) ;; Removing lonely
    on a single line, if they are left intact we ;; dont have any paragraphs at all. (goto-char (point-min)) (while (not (eobp)) (let ((p1 (point))) (forward-paragraph 1) ;;(message "Kaller fix med p1=%s p2=%s " p1 (1- (point))) (sleep-for 5) (html2text-fix-paragraph p1 (1- (point))) (goto-char p1) (when (not (eobp)) (forward-paragraph 1))))) ;; ;;     ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; ;; (defun html2text-remove-tags (tag-list) "Removes the tags listed in the list `html2text-remove-tag-list'. See the documentation for that variable." (interactive) (dolist (tag tag-list) (goto-char (point-min)) (while (re-search-forward (format "\\(]*>\\)" tag) (point-max) t) (delete-region (match-beginning 0) (match-end 0))))) (defun html2text-format-tags () "See the variable `html2text-format-tag-list' for documentation." (interactive) (dolist (tag-and-function html2text-format-tag-list) (let ((tag (car tag-and-function)) (function (cdr tag-and-function))) (goto-char (point-min)) (while (re-search-forward (format "\\(<%s\\( [^>]*\\)?>\\)" tag) (point-max) t) (let ((p1) (p2 (point)) (p3) (p4)) (search-backward "<" (point-min) t) (setq p1 (point)) (unless (search-forward (format "" tag) (point-max) t) (goto-char p2) (insert (format "" tag))) (setq p4 (point)) (search-backward "]*\\)?>\\)" tag) (point-max) t) (let ((p1) (p2 (point))) (search-backward "<" (point-min) t) (setq p1 (point)) (funcall function p1 p2)))))) ;; ;; Main function ;; ;;;###autoload (defun html2text () "Convert HTML to plain text in the current buffer." (interactive) (save-excursion (let ((case-fold-search t) (buffer-read-only)) (html2text-remove-tags html2text-remove-tag-list) (html2text-format-tags) (html2text-remove-tags html2text-remove-tag-list2) (html2text-substitute) (html2text-format-single-elements) (html2text-fix-paragraphs)))) ;; ;; ;; (provide 'html2text) ;; arch-tag: e9e57b79-35d4-4de1-a647-e7e01fe56d1e ;;; html2text.el ends here gnus-5.11+v0.10.dfsg/lisp/smime-ldap.el0000644000175000017500000001664410701233060017620 0ustar tvainikatvainika;;; smime-ldap.el --- client interface to LDAP for Emacs ;; Copyright (C) 1998, 1999, 2000, 2005 Free Software Foundation, Inc. ;; Author: Oscar Figueiredo ;; Maintainer: Arne J,Ax(Brgensen ;; Created: February 2005 ;; Keywords: comm ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 3, or (at your option) ;; any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Commentary: ;; This file has a slightly changed implementation of Emacs 21.3's ;; ldap-search and ldap-search-internal from ldap.el. The changes are ;; made to achieve compatibility with OpenLDAP v2 and to make it ;; possible to retrieve LDAP attributes that are tagged ie ";binary". ;; The file also adds a compatibility layer for Emacs and XEmacs. ;;; Code: (require 'ldap) (defun smime-ldap-search (filter &optional host attributes attrsonly withdn) "Perform an LDAP search. FILTER is the search filter in RFC1558 syntax. HOST is the LDAP host on which to perform the search. ATTRIBUTES are the specific attributes to retrieve, nil means retrieve all. ATTRSONLY, if non-nil, retrieves the attributes only, without the associated values. If WITHDN is non-nil, each entry in the result will be prepended with its distinguished name WITHDN. Additional search parameters can be specified through `ldap-host-parameters-alist', which see." (interactive "sFilter:") ;; for XEmacs (if (fboundp 'ldap-search-entries) (ldap-search-entries filter host attributes attrsonly) ;; for Emacs 22 (if (>= emacs-major-version 22) (cdr (ldap-search filter host attributes attrsonly)) ;; for Emacs 21.x (or host (setq host ldap-default-host) (error "No LDAP host specified")) (let ((host-plist (cdr (assoc host ldap-host-parameters-alist))) result) (setq result (smime-ldap-search-internal (append host-plist (list 'host host 'filter filter 'attributes attributes 'attrsonly attrsonly 'withdn withdn)))) (cdr (if ldap-ignore-attribute-codings result (mapcar (function (lambda (record) (mapcar 'ldap-decode-attribute record))) result))))))) (defun smime-ldap-search-internal (search-plist) "Perform a search on a LDAP server. SEARCH-PLIST is a property list describing the search request. Valid keys in that list are: `host' is a string naming one or more (blank-separated) LDAP servers to to try to connect to. Each host name may optionally be of the form HOST:PORT. `filter' is a filter string for the search as described in RFC 1558. `attributes' is a list of strings indicating which attributes to retrieve for each matching entry. If nil, return all available attributes. `attrsonly', if non-nil, indicates that only attributes are retrieved, not their associated values. `base' is the base for the search as described in RFC 1779. `scope' is one of the three symbols `sub', `base' or `one'. `binddn' is the distinguished name of the user to bind as (in RFC 1779 syntax). `passwd' is the password to use for simple authentication. `deref' is one of the symbols `never', `always', `search' or `find'. `timelimit' is the timeout limit for the connection in seconds. `sizelimit' is the maximum number of matches to return. `withdn' if non-nil each entry in the result will be prepended with its distinguished name DN. The function returns a list of matching entries. Each entry is itself an alist of attribute/value pairs." (let ((buf (get-buffer-create " *ldap-search*")) (bufval (get-buffer-create " *ldap-value*")) (host (or (plist-get search-plist 'host) ldap-default-host)) (filter (plist-get search-plist 'filter)) (attributes (plist-get search-plist 'attributes)) (attrsonly (plist-get search-plist 'attrsonly)) (base (or (plist-get search-plist 'base) ldap-default-base)) (scope (plist-get search-plist 'scope)) (binddn (plist-get search-plist 'binddn)) (passwd (plist-get search-plist 'passwd)) (deref (plist-get search-plist 'deref)) (timelimit (plist-get search-plist 'timelimit)) (sizelimit (plist-get search-plist 'sizelimit)) (withdn (plist-get search-plist 'withdn)) (numres 0) arglist dn name value record result) (if (or (null filter) (equal "" filter)) (error "No search filter")) (setq filter (cons filter attributes)) (save-excursion (set-buffer buf) (erase-buffer) (if (and host (not (equal "" host))) (setq arglist (nconc arglist (list (format "-h%s" host))))) (if (and attrsonly (not (equal "" attrsonly))) (setq arglist (nconc arglist (list "-A")))) (if (and base (not (equal "" base))) (setq arglist (nconc arglist (list (format "-b%s" base))))) (if (and scope (not (equal "" scope))) (setq arglist (nconc arglist (list (format "-s%s" scope))))) (if (and binddn (not (equal "" binddn))) (setq arglist (nconc arglist (list (format "-D%s" binddn))))) (if (and passwd (not (equal "" passwd))) (setq arglist (nconc arglist (list (format "-w%s" passwd))))) (if (and deref (not (equal "" deref))) (setq arglist (nconc arglist (list (format "-a%s" deref))))) (if (and timelimit (not (equal "" timelimit))) (setq arglist (nconc arglist (list (format "-l%s" timelimit))))) (if (and sizelimit (not (equal "" sizelimit))) (setq arglist (nconc arglist (list (format "-z%s" sizelimit))))) (eval `(call-process ldap-ldapsearch-prog nil buf nil ,@arglist "-tt" ; Write values to temp files "-x" "-LL" ; ,@ldap-ldapsearch-args ,@filter)) (insert "\n") (goto-char (point-min)) (while (re-search-forward "[\t\n\f]+ " nil t) (replace-match "" nil nil)) (goto-char (point-min)) (if (looking-at "usage") (error "Incorrect ldapsearch invocation") (message "Parsing results... ") (while (progn (skip-chars-forward " \t\n") (not (eobp))) (setq dn (buffer-substring (point) (save-excursion (end-of-line) (point)))) (forward-line 1) (while (looking-at (concat "^\\(\\w*\\)\\(;\\w*\\)?[=:\t ]+" "\\(<[\t ]*file://\\)?\\(.*\\)$")) (setq name (match-string 1) value (match-string 4)) (save-excursion (set-buffer bufval) (erase-buffer) (insert-file-contents-literally value) (delete-file value) (setq value (buffer-substring (point-min) (point-max)))) (setq record (cons (list name value) record)) (forward-line 1)) (setq result (cons (if withdn (cons dn (nreverse record)) (nreverse record)) result)) (setq record nil) (skip-chars-forward " \t\n") (message "Parsing results... %d" numres) (1+ numres)) (message "Parsing results... done") (nreverse result))))) (provide 'smime-ldap) ;; arch-tag: 87e6bc44-21fc-4e9b-a89b-f55f031f78f8 ;;; smime-ldap.el ends here gnus-5.11+v0.10.dfsg/lisp/compface.el0000644000175000017500000000435611004005111017331 0ustar tvainikatvainika;;; compface.el --- functions for converting X-Face headers ;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; Keywords: news ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 3, or (at your option) ;; any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Commentary: ;;; Code: ;;;### (defun uncompface (face) "Convert FACE to pbm. Requires the external programs `uncompface', and `icontopbm'. On a GNU/Linux system these might be in packages with names like `compface' or `faces-xface' and `netpbm' or `libgr-progs', for instance." (with-temp-buffer (unless (featurep 'xemacs) (set-buffer-multibyte nil)) (insert face) (let ((coding-system-for-read 'raw-text) ;; At least "icontopbm" doesn't work with Windows because ;; the line-break code is converted into CRLF by default. (coding-system-for-write 'binary)) (and (eq 0 (apply 'call-process-region (point-min) (point-max) "uncompface" 'delete '(t nil) nil)) (progn (goto-char (point-min)) (insert "/* Width=48, Height=48 */\n") ;; I just can't get "icontopbm" to work correctly on its ;; own in XEmacs. And Emacs doesn't understand un-raw pbm ;; files. (if (not (featurep 'xemacs)) (eq 0 (call-process-region (point-min) (point-max) "icontopbm" 'delete '(t nil))) (shell-command-on-region (point-min) (point-max) "icontopbm | pnmnoraw" (current-buffer) t) t)) (buffer-string))))) (provide 'compface) ;; arch-tag: f9c78e84-98c0-4142-9682-8ba4cf4c3441 ;;; compface.el ends here gnus-5.11+v0.10.dfsg/lisp/nnmaildir.el0000644000175000017500000017505111004005111017532 0ustar tvainikatvainika;;; nnmaildir.el --- maildir backend for Gnus ;; This file is in the public domain. ;; Author: Paul Jarc ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 3, or (at your option) ;; any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Commentary: ;; Maildir format is documented at ;; and in the maildir(5) man page from qmail (available at ;; ). nnmaildir also stores ;; extra information in the .nnmaildir/ directory within a maildir. ;; ;; Some goals of nnmaildir: ;; * Everything Just Works, and correctly. E.g., NOV data is automatically ;; regenerated when stale; no need for manually running ;; *-generate-nov-databases. ;; * Perfect reliability: [C-g] will never corrupt its data in memory, and ;; SIGKILL will never corrupt its data in the filesystem. ;; * Allow concurrent operation as much as possible. If files change out ;; from under us, adapt to the changes or degrade gracefully. ;; * We use the filesystem as a database, so that, e.g., it's easy to ;; manipulate marks from outside Gnus. ;; * All information about a group is stored in the maildir, for easy backup, ;; copying, restoring, etc. ;; ;; Todo: ;; * When moving an article for expiry, copy all the marks except 'expire ;; from the original article. ;; * Add a hook for when moving messages from new/ to cur/, to support ;; nnmail's duplicate detection. ;; * Improve generated Xrefs, so crossposts are detectable. ;; * Improve code readability. ;;; Code: ;; eval this before editing [(progn (put 'nnmaildir--with-nntp-buffer 'lisp-indent-function 0) (put 'nnmaildir--with-work-buffer 'lisp-indent-function 0) (put 'nnmaildir--with-nov-buffer 'lisp-indent-function 0) (put 'nnmaildir--with-move-buffer 'lisp-indent-function 0) (put 'nnmaildir--condcase 'lisp-indent-function 2) ) ] ;; For Emacs < 22.2. (eval-and-compile (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) (eval-and-compile (require 'nnheader) (require 'gnus) (require 'gnus-util) (require 'gnus-range) (require 'gnus-start) (require 'gnus-int) (require 'message)) (eval-when-compile (require 'cl) (require 'nnmail)) (defconst nnmaildir-version "Gnus") (defvar nnmaildir-article-file-name nil "*The filename of the most recently requested article. This variable is set by nnmaildir-request-article.") ;; The filename of the article being moved/copied: (defvar nnmaildir--file nil) ;; Variables to generate filenames of messages being delivered: (defvar nnmaildir--delivery-time "") (defconst nnmaildir--delivery-pid (concat "P" (number-to-string (emacs-pid)))) (defvar nnmaildir--delivery-count nil) ;; An obarry containing symbols whose names are server names and whose values ;; are servers: (defvar nnmaildir--servers (make-vector 3 0)) ;; The current server: (defvar nnmaildir--cur-server nil) ;; A copy of nnmail-extra-headers (defvar nnmaildir--extra nil) ;; A NOV structure looks like this (must be prin1-able, so no defstruct): ["subject\tfrom\tdate" "references\tchars\lines" "To: you\tIn-Reply-To: " (12345 67890) ;; modtime of the corresponding article file (to in-reply-to)] ;; contemporary value of nnmail-extra-headers (defconst nnmaildir--novlen 5) (defmacro nnmaildir--nov-new (beg mid end mtime extra) `(vector ,beg ,mid ,end ,mtime ,extra)) (defmacro nnmaildir--nov-get-beg (nov) `(aref ,nov 0)) (defmacro nnmaildir--nov-get-mid (nov) `(aref ,nov 1)) (defmacro nnmaildir--nov-get-end (nov) `(aref ,nov 2)) (defmacro nnmaildir--nov-get-mtime (nov) `(aref ,nov 3)) (defmacro nnmaildir--nov-get-extra (nov) `(aref ,nov 4)) (defmacro nnmaildir--nov-set-beg (nov value) `(aset ,nov 0 ,value)) (defmacro nnmaildir--nov-set-mid (nov value) `(aset ,nov 1 ,value)) (defmacro nnmaildir--nov-set-end (nov value) `(aset ,nov 2 ,value)) (defmacro nnmaildir--nov-set-mtime (nov value) `(aset ,nov 3 ,value)) (defmacro nnmaildir--nov-set-extra (nov value) `(aset ,nov 4 ,value)) (defstruct nnmaildir--art (prefix nil :type string) ;; "time.pid.host" (suffix nil :type string) ;; ":2,flags" (num nil :type natnum) ;; article number (msgid nil :type string) ;; "" (nov nil :type vector)) ;; cached nov structure, or nil (defstruct nnmaildir--grp (name nil :type string) ;; "group.name" (new nil :type list) ;; new/ modtime (cur nil :type list) ;; cur/ modtime (min 1 :type natnum) ;; minimum article number (count 0 :type natnum) ;; count of articles (nlist nil :type list) ;; list of articles, ordered descending by number (flist nil :type vector) ;; obarray mapping filename prefix->article (mlist nil :type vector) ;; obarray mapping message-id->article (cache nil :type vector) ;; nov cache (index nil :type natnum) ;; index of next cache entry to replace (mmth nil :type vector)) ;; obarray mapping mark name->dir modtime ; ("Mark Mod Time Hash") (defstruct nnmaildir--srv (address nil :type string) ;; server address string (method nil :type list) ;; (nnmaildir "address" ...) (prefix nil :type string) ;; "nnmaildir+address:" (dir nil :type string) ;; "/expanded/path/to/server/dir/" (ls nil :type function) ;; directory-files function (groups nil :type vector) ;; obarray mapping group name->group (curgrp nil :type nnmaildir--grp) ;; current group, or nil (error nil :type string) ;; last error message, or nil (mtime nil :type list) ;; modtime of dir (gnm nil) ;; flag: split from mail-sources? (target-prefix nil :type string)) ;; symlink target prefix (defun nnmaildir--expired-article (group article) (setf (nnmaildir--art-nov article) nil) (let ((flist (nnmaildir--grp-flist group)) (mlist (nnmaildir--grp-mlist group)) (min (nnmaildir--grp-min group)) (count (1- (nnmaildir--grp-count group))) (prefix (nnmaildir--art-prefix article)) (msgid (nnmaildir--art-msgid article)) (new-nlist nil) (nlist-pre '(nil . nil)) nlist-post num) (unless (zerop count) (setq nlist-post (nnmaildir--grp-nlist group) num (nnmaildir--art-num article)) (if (eq num (caar nlist-post)) (setq new-nlist (cdr nlist-post)) (setq new-nlist nlist-post nlist-pre nlist-post nlist-post (cdr nlist-post)) (while (/= num (caar nlist-post)) (setq nlist-pre nlist-post nlist-post (cdr nlist-post))) (setq nlist-post (cdr nlist-post)) (if (eq num min) (setq min (caar nlist-pre))))) (let ((inhibit-quit t)) (setf (nnmaildir--grp-min group) min) (setf (nnmaildir--grp-count group) count) (setf (nnmaildir--grp-nlist group) new-nlist) (setcdr nlist-pre nlist-post) (unintern prefix flist) (unintern msgid mlist)))) (defun nnmaildir--nlist-art (group num) (let ((entry (assq num (nnmaildir--grp-nlist group)))) (if entry (cdr entry)))) (defmacro nnmaildir--flist-art (list file) `(symbol-value (intern-soft ,file ,list))) (defmacro nnmaildir--mlist-art (list msgid) `(symbol-value (intern-soft ,msgid ,list))) (defun nnmaildir--pgname (server gname) (let ((prefix (nnmaildir--srv-prefix server))) (if prefix (concat prefix gname) (setq gname (gnus-group-prefixed-name gname (nnmaildir--srv-method server))) (setf (nnmaildir--srv-prefix server) (gnus-group-real-prefix gname)) gname))) (defun nnmaildir--param (pgname param) (setq param (gnus-group-find-parameter pgname param 'allow-list)) (if (vectorp param) (setq param (aref param 0))) (eval param)) (defmacro nnmaildir--with-nntp-buffer (&rest body) `(save-excursion (set-buffer nntp-server-buffer) ,@body)) (defmacro nnmaildir--with-work-buffer (&rest body) `(save-excursion (set-buffer (get-buffer-create " *nnmaildir work*")) ,@body)) (defmacro nnmaildir--with-nov-buffer (&rest body) `(save-excursion (set-buffer (get-buffer-create " *nnmaildir nov*")) ,@body)) (defmacro nnmaildir--with-move-buffer (&rest body) `(save-excursion (set-buffer (get-buffer-create " *nnmaildir move*")) ,@body)) (defmacro nnmaildir--subdir (dir subdir) `(file-name-as-directory (concat ,dir ,subdir))) (defmacro nnmaildir--srvgrp-dir (srv-dir gname) `(nnmaildir--subdir ,srv-dir ,gname)) (defmacro nnmaildir--tmp (dir) `(nnmaildir--subdir ,dir "tmp")) (defmacro nnmaildir--new (dir) `(nnmaildir--subdir ,dir "new")) (defmacro nnmaildir--cur (dir) `(nnmaildir--subdir ,dir "cur")) (defmacro nnmaildir--nndir (dir) `(nnmaildir--subdir ,dir ".nnmaildir")) (defmacro nnmaildir--nov-dir (dir) `(nnmaildir--subdir ,dir "nov")) (defmacro nnmaildir--marks-dir (dir) `(nnmaildir--subdir ,dir "marks")) (defmacro nnmaildir--num-dir (dir) `(nnmaildir--subdir ,dir "num")) (defmacro nnmaildir--unlink (file-arg) `(let ((file ,file-arg)) (if (file-attributes file) (delete-file file)))) (defun nnmaildir--mkdir (dir) (or (file-exists-p (file-name-as-directory dir)) (make-directory-internal (directory-file-name dir)))) (defun nnmaildir--mkfile (file) (write-region "" nil file nil 'no-message)) (defun nnmaildir--delete-dir-files (dir ls) (when (file-attributes dir) (mapc 'delete-file (funcall ls dir 'full "\\`[^.]" 'nosort)) (delete-directory dir))) (defun nnmaildir--group-maxnum (server group) (catch 'return (if (zerop (nnmaildir--grp-count group)) (throw 'return 0)) (let ((dir (nnmaildir--srvgrp-dir (nnmaildir--srv-dir server) (nnmaildir--grp-name group))) (number-opened 1) attr ino-opened nlink number-linked) (setq dir (nnmaildir--nndir dir) dir (nnmaildir--num-dir dir)) (while t (setq attr (file-attributes (concat dir (number-to-string number-opened)))) (or attr (throw 'return (1- number-opened))) (setq ino-opened (nth 10 attr) nlink (nth 1 attr) number-linked (+ number-opened nlink)) (if (or (< nlink 1) (< number-linked nlink)) (signal 'error '("Arithmetic overflow"))) (setq attr (file-attributes (concat dir (number-to-string number-linked)))) (or attr (throw 'return (1- number-linked))) (if (/= ino-opened (nth 10 attr)) (setq number-opened number-linked)))))) ;; Make the given server, if non-nil, be the current server. Then make the ;; given group, if non-nil, be the current group of the current server. Then ;; return the group object for the current group. (defun nnmaildir--prepare (server group) (let (x groups) (catch 'return (if (null server) (unless (setq server nnmaildir--cur-server) (throw 'return nil)) (unless (setq server (intern-soft server nnmaildir--servers)) (throw 'return nil)) (setq server (symbol-value server) nnmaildir--cur-server server)) (unless (setq groups (nnmaildir--srv-groups server)) (throw 'return nil)) (unless (nnmaildir--srv-method server) (setq x (concat "nnmaildir:" (nnmaildir--srv-address server)) x (gnus-server-to-method x)) (unless x (throw 'return nil)) (setf (nnmaildir--srv-method server) x)) (if (null group) (unless (setq group (nnmaildir--srv-curgrp server)) (throw 'return nil)) (unless (setq group (intern-soft group groups)) (throw 'return nil)) (setq group (symbol-value group))) group))) (defun nnmaildir--tab-to-space (string) (let ((pos 0)) (while (string-match "\t" string pos) (aset string (match-beginning 0) ? ) (setq pos (match-end 0)))) string) (defmacro nnmaildir--condcase (errsym body &rest handler) `(condition-case ,errsym (let ((system-messages-locale "C")) ,body) (error . ,handler))) (defun nnmaildir--emlink-p (err) (and (eq (car err) 'file-error) (string= (downcase (caddr err)) "too many links"))) (defun nnmaildir--enoent-p (err) (and (eq (car err) 'file-error) (string= (downcase (caddr err)) "no such file or directory"))) (defun nnmaildir--eexist-p (err) (eq (car err) 'file-already-exists)) (defun nnmaildir--new-number (nndir) "Allocate a new article number by atomically creating a file under NNDIR." (let ((numdir (nnmaildir--num-dir nndir)) (make-new-file t) (number-open 1) number-link previous-number-link path-open path-link ino-open) (nnmaildir--mkdir numdir) (catch 'return (while t (setq path-open (concat numdir (number-to-string number-open))) (if (not make-new-file) (setq previous-number-link number-link) (nnmaildir--mkfile path-open) ;; If Emacs had O_CREAT|O_EXCL, we could return number-open here. (setq make-new-file nil previous-number-link 0)) (let* ((attr (file-attributes path-open)) (nlink (nth 1 attr))) (setq ino-open (nth 10 attr) number-link (+ number-open nlink)) (if (or (< nlink 1) (< number-link nlink)) (signal 'error '("Arithmetic overflow")))) (if (= number-link previous-number-link) ;; We've already tried this number, in the previous loop iteration, ;; and failed. (signal 'error `("Corrupt internal nnmaildir data" ,path-open))) (setq path-link (concat numdir (number-to-string number-link))) (nnmaildir--condcase err (progn (add-name-to-file path-open path-link) (throw 'return number-link)) (cond ((nnmaildir--emlink-p err) (setq make-new-file t number-open number-link)) ((nnmaildir--eexist-p err) (let ((attr (file-attributes path-link))) (if (/= (nth 10 attr) ino-open) (setq number-open number-link number-link 0)))) (t (signal (car err) (cdr err))))))))) (defun nnmaildir--update-nov (server group article) (let ((nnheader-file-coding-system 'binary) (srv-dir (nnmaildir--srv-dir server)) (storage-version 1) ;; [version article-number msgid [...nov...]] dir gname pgname msgdir prefix suffix file attr mtime novdir novfile nov msgid nov-beg nov-mid nov-end field val old-extra num numdir deactivate-mark) (catch 'return (setq gname (nnmaildir--grp-name group) pgname (nnmaildir--pgname server gname) dir (nnmaildir--srvgrp-dir srv-dir gname) msgdir (if (nnmaildir--param pgname 'read-only) (nnmaildir--new dir) (nnmaildir--cur dir)) prefix (nnmaildir--art-prefix article) suffix (nnmaildir--art-suffix article) file (concat msgdir prefix suffix) attr (file-attributes file)) (unless attr (nnmaildir--expired-article group article) (throw 'return nil)) (setq mtime (nth 5 attr) attr (nth 7 attr) nov (nnmaildir--art-nov article) dir (nnmaildir--nndir dir) novdir (nnmaildir--nov-dir dir) novfile (concat novdir prefix)) (unless (equal nnmaildir--extra nnmail-extra-headers) (setq nnmaildir--extra (copy-sequence nnmail-extra-headers))) (nnmaildir--with-nov-buffer ;; First we'll check for already-parsed NOV data. (cond ((not (file-exists-p novfile)) ;; The NOV file doesn't exist; we have to parse the message. (setq nov nil)) ((not nov) ;; The file exists, but the data isn't in memory; read the file. (erase-buffer) (nnheader-insert-file-contents novfile) (setq nov (read (current-buffer))) (if (not (and (vectorp nov) (/= 0 (length nov)) (equal storage-version (aref nov 0)))) ;; This NOV data seems to be in the wrong format. (setq nov nil) (unless (nnmaildir--art-num article) (setf (nnmaildir--art-num article) (aref nov 1))) (unless (nnmaildir--art-msgid article) (setf (nnmaildir--art-msgid article) (aref nov 2))) (setq nov (aref nov 3))))) ;; Now check whether the already-parsed data (if we have any) is ;; usable: if the message has been edited or if nnmail-extra-headers ;; has been augmented since this data was parsed from the message, ;; then we have to reparse. Otherwise it's up-to-date. (when (and nov (equal mtime (nnmaildir--nov-get-mtime nov))) ;; The timestamp matches. Now check nnmail-extra-headers. (setq old-extra (nnmaildir--nov-get-extra nov)) (when (equal nnmaildir--extra old-extra) ;; common case ;; Save memory; use a single copy of the list value. (nnmaildir--nov-set-extra nov nnmaildir--extra) (throw 'return nov)) ;; They're not equal, but maybe the new is a subset of the old. (if (null nnmaildir--extra) ;; The empty set is a subset of every set. (throw 'return nov)) (if (not (memq nil (mapcar (lambda (e) (memq e old-extra)) nnmaildir--extra))) (throw 'return nov))) ;; Parse the NOV data out of the message. (erase-buffer) (nnheader-insert-file-contents file) (insert "\n") (goto-char (point-min)) (save-restriction (if (search-forward "\n\n" nil 'noerror) (progn (setq nov-mid (count-lines (point) (point-max))) (narrow-to-region (point-min) (1- (point)))) (setq nov-mid 0)) (goto-char (point-min)) (delete-char 1) (setq nov (nnheader-parse-naked-head) field (or (mail-header-lines nov) 0))) (unless (or (zerop field) (nnmaildir--param pgname 'distrust-Lines:)) (setq nov-mid field)) (setq nov-mid (number-to-string nov-mid) nov-mid (concat (number-to-string attr) "\t" nov-mid)) (save-match-data (setq field (or (mail-header-references nov) "")) (nnmaildir--tab-to-space field) (setq nov-mid (concat field "\t" nov-mid) nov-beg (mapconcat (lambda (f) (nnmaildir--tab-to-space (or f ""))) (list (mail-header-subject nov) (mail-header-from nov) (mail-header-date nov)) "\t") nov-end (mapconcat (lambda (extra) (setq field (symbol-name (car extra)) val (cdr extra)) (nnmaildir--tab-to-space field) (nnmaildir--tab-to-space val) (concat field ": " val)) (mail-header-extra nov) "\t"))) (setq msgid (mail-header-id nov)) (if (or (null msgid) (nnheader-fake-message-id-p msgid)) (setq msgid (concat "<" prefix "@nnmaildir>"))) (nnmaildir--tab-to-space msgid) ;; The data is parsed; create an nnmaildir NOV structure. (setq nov (nnmaildir--nov-new nov-beg nov-mid nov-end mtime nnmaildir--extra) num (nnmaildir--art-num article)) (unless num (setq num (nnmaildir--new-number dir)) (setf (nnmaildir--art-num article) num)) ;; Store this new NOV data in a file (erase-buffer) (prin1 (vector storage-version num msgid nov) (current-buffer)) (setq file (concat novfile ":")) (nnmaildir--unlink file) (gmm-write-region (point-min) (point-max) file nil 'no-message nil 'excl)) (rename-file file novfile 'replace) (setf (nnmaildir--art-msgid article) msgid) nov))) (defun nnmaildir--cache-nov (group article nov) (let ((cache (nnmaildir--grp-cache group)) (index (nnmaildir--grp-index group)) goner) (unless (nnmaildir--art-nov article) (setq goner (aref cache index)) (if goner (setf (nnmaildir--art-nov goner) nil)) (aset cache index article) (setf (nnmaildir--grp-index group) (% (1+ index) (length cache)))) (setf (nnmaildir--art-nov article) nov))) (defun nnmaildir--grp-add-art (server group article) (let ((nov (nnmaildir--update-nov server group article)) count num min nlist nlist-cdr insert-nlist) (when nov (setq count (1+ (nnmaildir--grp-count group)) num (nnmaildir--art-num article) min (if (= count 1) num (min num (nnmaildir--grp-min group))) nlist (nnmaildir--grp-nlist group)) (if (or (null nlist) (> num (caar nlist))) (setq nlist (cons (cons num article) nlist)) (setq insert-nlist t nlist-cdr (cdr nlist)) (while (and nlist-cdr (< num (caar nlist-cdr))) (setq nlist nlist-cdr nlist-cdr (cdr nlist)))) (let ((inhibit-quit t)) (setf (nnmaildir--grp-count group) count) (setf (nnmaildir--grp-min group) min) (if insert-nlist (setcdr nlist (cons (cons num article) nlist-cdr)) (setf (nnmaildir--grp-nlist group) nlist)) (set (intern (nnmaildir--art-prefix article) (nnmaildir--grp-flist group)) article) (set (intern (nnmaildir--art-msgid article) (nnmaildir--grp-mlist group)) article) (set (intern (nnmaildir--grp-name group) (nnmaildir--srv-groups server)) group)) (nnmaildir--cache-nov group article nov) t))) (defun nnmaildir--group-ls (server pgname) (or (nnmaildir--param pgname 'directory-files) (nnmaildir--srv-ls server))) (defun nnmaildir-article-number-to-file-name (number group-name server-address-string) (let ((group (nnmaildir--prepare server-address-string group-name)) article dir pgname) (catch 'return (unless group ;; The given group or server does not exist. (throw 'return nil)) (setq article (nnmaildir--nlist-art group number)) (unless article ;; The given article number does not exist in this group. (throw 'return nil)) (setq pgname (nnmaildir--pgname nnmaildir--cur-server group-name) dir (nnmaildir--srv-dir nnmaildir--cur-server) dir (nnmaildir--srvgrp-dir dir group-name) dir (if (nnmaildir--param pgname 'read-only) (nnmaildir--new dir) (nnmaildir--cur dir))) (concat dir (nnmaildir--art-prefix article) (nnmaildir--art-suffix article))))) (defun nnmaildir-article-number-to-base-name (number group-name server-address-string) (let ((x (nnmaildir--prepare server-address-string group-name))) (when x (setq x (nnmaildir--nlist-art x number)) (and x (cons (nnmaildir--art-prefix x) (nnmaildir--art-suffix x)))))) (defun nnmaildir-base-name-to-article-number (base-name group-name server-address-string) (let ((x (nnmaildir--prepare server-address-string group-name))) (when x (setq x (nnmaildir--grp-flist x) x (nnmaildir--flist-art x base-name)) (and x (nnmaildir--art-num x))))) (defun nnmaildir--nlist-iterate (nlist ranges func) (let (entry high low nlist2) (if (eq ranges 'all) (setq ranges `((1 . ,(caar nlist))))) (while ranges (setq entry (car ranges) ranges (cdr ranges)) (while (and ranges (eq entry (car ranges))) (setq ranges (cdr ranges))) ;; skip duplicates (if (numberp entry) (setq low entry high entry) (setq low (car entry) high (cdr entry))) (setq nlist2 nlist) ;; Don't assume any sorting of ranges (catch 'iterate-loop (while nlist2 (if (<= (caar nlist2) high) (throw 'iterate-loop nil)) (setq nlist2 (cdr nlist2)))) (catch 'iterate-loop (while nlist2 (setq entry (car nlist2) nlist2 (cdr nlist2)) (if (< (car entry) low) (throw 'iterate-loop nil)) (funcall func (cdr entry))))))) (defun nnmaildir--up2-1 (n) (if (zerop n) 1 (1- (lsh 1 (1+ (logb n)))))) (defun nnmaildir--system-name () (gnus-replace-in-string (gnus-replace-in-string (gnus-replace-in-string (system-name) "\\\\" "\\134" 'literal) "/" "\\057" 'literal) ":" "\\072" 'literal)) (defun nnmaildir-request-type (group &optional article) 'mail) (defun nnmaildir-status-message (&optional server) (nnmaildir--prepare server nil) (nnmaildir--srv-error nnmaildir--cur-server)) (defun nnmaildir-server-opened (&optional server) (and nnmaildir--cur-server (if server (string-equal server (nnmaildir--srv-address nnmaildir--cur-server)) t) (nnmaildir--srv-groups nnmaildir--cur-server) t)) (defun nnmaildir-open-server (server &optional defs) (let ((x server) dir size) (catch 'return (setq server (intern-soft x nnmaildir--servers)) (if server (and (setq server (symbol-value server)) (nnmaildir--srv-groups server) (setq nnmaildir--cur-server server) (throw 'return t)) (setq server (make-nnmaildir--srv :address x)) (let ((inhibit-quit t)) (set (intern x nnmaildir--servers) server))) (setq dir (assq 'directory defs)) (unless dir (setf (nnmaildir--srv-error server) "You must set \"directory\" in the select method") (throw 'return nil)) (setq dir (cadr dir) dir (eval dir) dir (expand-file-name dir) dir (file-name-as-directory dir)) (unless (file-exists-p dir) (setf (nnmaildir--srv-error server) (concat "No such directory: " dir)) (throw 'return nil)) (setf (nnmaildir--srv-dir server) dir) (setq x (assq 'directory-files defs)) (if (null x) (setq x (if nnheader-directory-files-is-safe 'directory-files 'nnheader-directory-files-safe)) (setq x (cadr x)) (unless (functionp x) (setf (nnmaildir--srv-error server) (concat "Not a function: " (prin1-to-string x))) (throw 'return nil))) (setf (nnmaildir--srv-ls server) x) (setq size (length (funcall x dir nil "\\`[^.]" 'nosort)) size (nnmaildir--up2-1 size)) (and (setq x (assq 'get-new-mail defs)) (setq x (cdr x)) (car x) (setf (nnmaildir--srv-gnm server) t) (require 'nnmail)) (setq x (assq 'target-prefix defs)) (if x (progn (setq x (cadr x) x (eval x)) (setf (nnmaildir--srv-target-prefix server) x)) (setq x (assq 'create-directory defs)) (if x (progn (setq x (cadr x) x (eval x) x (file-name-as-directory x)) (setf (nnmaildir--srv-target-prefix server) x)) (setf (nnmaildir--srv-target-prefix server) ""))) (setf (nnmaildir--srv-groups server) (make-vector size 0)) (setq nnmaildir--cur-server server) t))) (defun nnmaildir--parse-filename (file) (let ((prefix (car file)) timestamp len) (if (string-match "\\`\\([0-9]+\\)\\(\\..*\\)\\'" prefix) (progn (setq timestamp (concat "0000" (match-string 1 prefix)) len (- (length timestamp) 4)) (vector (string-to-number (substring timestamp 0 len)) (string-to-number (substring timestamp len)) (match-string 2 prefix) file)) file))) (defun nnmaildir--sort-files (a b) (catch 'return (if (consp a) (throw 'return (and (consp b) (string-lessp (car a) (car b))))) (if (consp b) (throw 'return t)) (if (< (aref a 0) (aref b 0)) (throw 'return t)) (if (> (aref a 0) (aref b 0)) (throw 'return nil)) (if (< (aref a 1) (aref b 1)) (throw 'return t)) (if (> (aref a 1) (aref b 1)) (throw 'return nil)) (string-lessp (aref a 2) (aref b 2)))) (defun nnmaildir--scan (gname scan-msgs groups method srv-dir srv-ls) (catch 'return (let ((36h-ago (- (car (current-time)) 2)) absdir nndir tdir ndir cdir nattr cattr isnew pgname read-only ls files num dir flist group x) (setq absdir (nnmaildir--srvgrp-dir srv-dir gname) nndir (nnmaildir--nndir absdir)) (unless (file-exists-p absdir) (setf (nnmaildir--srv-error nnmaildir--cur-server) (concat "No such directory: " absdir)) (throw 'return nil)) (setq tdir (nnmaildir--tmp absdir) ndir (nnmaildir--new absdir) cdir (nnmaildir--cur absdir) nattr (file-attributes ndir) cattr (file-attributes cdir)) (unless (and (file-exists-p tdir) nattr cattr) (setf (nnmaildir--srv-error nnmaildir--cur-server) (concat "Not a maildir: " absdir)) (throw 'return nil)) (setq group (nnmaildir--prepare nil gname) pgname (nnmaildir--pgname nnmaildir--cur-server gname)) (if group (setq isnew nil) (setq isnew t group (make-nnmaildir--grp :name gname :index 0)) (nnmaildir--mkdir nndir) (nnmaildir--mkdir (nnmaildir--nov-dir nndir)) (nnmaildir--mkdir (nnmaildir--marks-dir nndir))) (setq read-only (nnmaildir--param pgname 'read-only) ls (or (nnmaildir--param pgname 'directory-files) srv-ls)) (unless read-only (setq x (nth 11 (file-attributes tdir))) (unless (and (= x (nth 11 nattr)) (= x (nth 11 cattr))) (setf (nnmaildir--srv-error nnmaildir--cur-server) (concat "Maildir spans filesystems: " absdir)) (throw 'return nil)) (dolist (file (funcall ls tdir 'full "\\`[^.]" 'nosort)) (setq x (file-attributes file)) (if (or (> (cadr x) 1) (< (car (nth 4 x)) 36h-ago)) (delete-file file)))) (or scan-msgs isnew (throw 'return t)) (setq nattr (nth 5 nattr)) (if (equal nattr (nnmaildir--grp-new group)) (setq nattr nil)) (if read-only (setq dir (and (or isnew nattr) ndir)) (when (or isnew nattr) (dolist (file (funcall ls ndir nil "\\`[^.]" 'nosort)) (setq x (concat ndir file)) (and (time-less-p (nth 5 (file-attributes x)) (current-time)) (rename-file x (concat cdir file ":2,")))) (setf (nnmaildir--grp-new group) nattr)) (setq cattr (nth 5 (file-attributes cdir))) (if (equal cattr (nnmaildir--grp-cur group)) (setq cattr nil)) (setq dir (and (or isnew cattr) cdir))) (unless dir (throw 'return t)) (setq files (funcall ls dir nil "\\`[^.]" 'nosort) files (save-match-data (mapcar (lambda (f) (string-match "\\`\\([^:]*\\)\\(\\(:.*\\)?\\)\\'" f) (cons (match-string 1 f) (match-string 2 f))) files))) (when isnew (setq num (nnmaildir--up2-1 (length files))) (setf (nnmaildir--grp-flist group) (make-vector num 0)) (setf (nnmaildir--grp-mlist group) (make-vector num 0)) (setf (nnmaildir--grp-mmth group) (make-vector 1 0)) (setq num (nnmaildir--param pgname 'nov-cache-size)) (if (numberp num) (if (< num 1) (setq num 1)) (setq num 16 cdir (nnmaildir--marks-dir nndir) ndir (nnmaildir--subdir cdir "tick") cdir (nnmaildir--subdir cdir "read")) (dolist (file files) (setq file (car file)) (if (or (not (file-exists-p (concat cdir file))) (file-exists-p (concat ndir file))) (setq num (1+ num))))) (setf (nnmaildir--grp-cache group) (make-vector num nil)) (let ((inhibit-quit t)) (set (intern gname groups) group)) (or scan-msgs (throw 'return t))) (setq flist (nnmaildir--grp-flist group) files (mapcar (lambda (file) (and (null (nnmaildir--flist-art flist (car file))) file)) files) files (delq nil files) files (mapcar 'nnmaildir--parse-filename files) files (sort files 'nnmaildir--sort-files)) (dolist (file files) (setq file (if (consp file) file (aref file 3)) x (make-nnmaildir--art :prefix (car file) :suffix (cdr file))) (nnmaildir--grp-add-art nnmaildir--cur-server group x)) (if read-only (setf (nnmaildir--grp-new group) nattr) (setf (nnmaildir--grp-cur group) cattr))) t)) (defun nnmaildir-request-scan (&optional scan-group server) (let ((coding-system-for-write nnheader-file-coding-system) (buffer-file-coding-system nil) (file-coding-system-alist nil) (nnmaildir-get-new-mail t) (nnmaildir-group-alist nil) (nnmaildir-active-file nil) x srv-ls srv-dir method groups target-prefix group dirs grp-dir seen deactivate-mark) (nnmaildir--prepare server nil) (setq srv-ls (nnmaildir--srv-ls nnmaildir--cur-server) srv-dir (nnmaildir--srv-dir nnmaildir--cur-server) method (nnmaildir--srv-method nnmaildir--cur-server) groups (nnmaildir--srv-groups nnmaildir--cur-server) target-prefix (nnmaildir--srv-target-prefix nnmaildir--cur-server)) (nnmaildir--with-work-buffer (save-match-data (if (stringp scan-group) (if (nnmaildir--scan scan-group t groups method srv-dir srv-ls) (if (nnmaildir--srv-gnm nnmaildir--cur-server) (nnmail-get-new-mail 'nnmaildir nil nil scan-group)) (unintern scan-group groups)) (setq x (nth 5 (file-attributes srv-dir)) scan-group (null scan-group)) (if (equal x (nnmaildir--srv-mtime nnmaildir--cur-server)) (if scan-group (mapatoms (lambda (sym) (nnmaildir--scan (symbol-name sym) t groups method srv-dir srv-ls)) groups)) (setq dirs (funcall srv-ls srv-dir nil "\\`[^.]" 'nosort) dirs (if (zerop (length target-prefix)) dirs (gnus-remove-if (lambda (dir) (and (>= (length dir) (length target-prefix)) (string= (substring dir 0 (length target-prefix)) target-prefix))) dirs)) seen (nnmaildir--up2-1 (length dirs)) seen (make-vector seen 0)) (dolist (grp-dir dirs) (if (nnmaildir--scan grp-dir scan-group groups method srv-dir srv-ls) (intern grp-dir seen))) (setq x nil) (mapatoms (lambda (group) (setq group (symbol-name group)) (unless (intern-soft group seen) (setq x (cons group x)))) groups) (dolist (grp x) (unintern grp groups)) (setf (nnmaildir--srv-mtime nnmaildir--cur-server) (nth 5 (file-attributes srv-dir)))) (and scan-group (nnmaildir--srv-gnm nnmaildir--cur-server) (nnmail-get-new-mail 'nnmaildir nil nil)))))) t) (defun nnmaildir-request-list (&optional server) (nnmaildir-request-scan 'find-new-groups server) (let (pgname ro deactivate-mark) (nnmaildir--prepare server nil) (nnmaildir--with-nntp-buffer (erase-buffer) (mapatoms (lambda (group) (setq pgname (symbol-name group) pgname (nnmaildir--pgname nnmaildir--cur-server pgname) group (symbol-value group) ro (nnmaildir--param pgname 'read-only)) (insert (gnus-replace-in-string (nnmaildir--grp-name group) " " "\\ " t) " ") (princ (nnmaildir--group-maxnum nnmaildir--cur-server group) nntp-server-buffer) (insert " ") (princ (nnmaildir--grp-min group) nntp-server-buffer) (insert " " (if ro "n" "y") "\n")) (nnmaildir--srv-groups nnmaildir--cur-server)))) t) (defun nnmaildir-request-newgroups (date &optional server) (nnmaildir-request-list server)) (defun nnmaildir-retrieve-groups (groups &optional server) (let (group deactivate-mark) (nnmaildir--prepare server nil) (nnmaildir--with-nntp-buffer (erase-buffer) (dolist (gname groups) (setq group (nnmaildir--prepare nil gname)) (if (null group) (insert "411 no such news group\n") (insert "211 ") (princ (nnmaildir--grp-count group) nntp-server-buffer) (insert " ") (princ (nnmaildir--grp-min group) nntp-server-buffer) (insert " ") (princ (nnmaildir--group-maxnum nnmaildir--cur-server group) nntp-server-buffer) (insert " " (gnus-replace-in-string gname " " "\\ " t) "\n"))))) 'group) (defun nnmaildir-request-update-info (gname info &optional server) (let ((group (nnmaildir--prepare server gname)) pgname flist always-marks never-marks old-marks dotfile num dir markdirs marks mark ranges markdir article read end new-marks ls old-mmth new-mmth mtime mark-sym existing missing deactivate-mark article-list) (catch 'return (unless group (setf (nnmaildir--srv-error nnmaildir--cur-server) (concat "No such group: " gname)) (throw 'return nil)) (setq gname (nnmaildir--grp-name group) pgname (nnmaildir--pgname nnmaildir--cur-server gname) flist (nnmaildir--grp-flist group)) (when (zerop (nnmaildir--grp-count group)) (gnus-info-set-read info nil) (gnus-info-set-marks info nil 'extend) (throw 'return info)) (setq old-marks (cons 'read (gnus-info-read info)) old-marks (cons old-marks (gnus-info-marks info)) always-marks (nnmaildir--param pgname 'always-marks) never-marks (nnmaildir--param pgname 'never-marks) existing (nnmaildir--grp-nlist group) existing (mapcar 'car existing) existing (nreverse existing) existing (gnus-compress-sequence existing 'always-list) missing (list (cons 1 (nnmaildir--group-maxnum nnmaildir--cur-server group))) missing (gnus-range-difference missing existing) dir (nnmaildir--srv-dir nnmaildir--cur-server) dir (nnmaildir--srvgrp-dir dir gname) dir (nnmaildir--nndir dir) dir (nnmaildir--marks-dir dir) ls (nnmaildir--group-ls nnmaildir--cur-server pgname) markdirs (funcall ls dir nil "\\`[^.]" 'nosort) new-mmth (nnmaildir--up2-1 (length markdirs)) new-mmth (make-vector new-mmth 0) old-mmth (nnmaildir--grp-mmth group)) (dolist (mark markdirs) (setq markdir (nnmaildir--subdir dir mark) mark-sym (intern mark) ranges nil) (catch 'got-ranges (if (memq mark-sym never-marks) (throw 'got-ranges nil)) (when (memq mark-sym always-marks) (setq ranges existing) (throw 'got-ranges nil)) (setq mtime (nth 5 (file-attributes markdir))) (set (intern mark new-mmth) mtime) (when (equal mtime (symbol-value (intern-soft mark old-mmth))) (setq ranges (assq mark-sym old-marks)) (if ranges (setq ranges (cdr ranges))) (throw 'got-ranges nil)) (setq article-list nil) (dolist (prefix (funcall ls markdir nil "\\`[^.]" 'nosort)) (setq article (nnmaildir--flist-art flist prefix)) (if article (setq article-list (cons (nnmaildir--art-num article) article-list)))) (setq ranges (gnus-add-to-range ranges (sort article-list '<)))) (if (eq mark-sym 'read) (setq read ranges) (if ranges (setq marks (cons (cons mark-sym ranges) marks))))) (gnus-info-set-read info (gnus-range-add read missing)) (gnus-info-set-marks info marks 'extend) (setf (nnmaildir--grp-mmth group) new-mmth) info))) (defun nnmaildir-request-group (gname &optional server fast) (let ((group (nnmaildir--prepare server gname)) deactivate-mark) (catch 'return (unless group ;; (insert "411 no such news group\n") (setf (nnmaildir--srv-error nnmaildir--cur-server) (concat "No such group: " gname)) (throw 'return nil)) (setf (nnmaildir--srv-curgrp nnmaildir--cur-server) group) (if fast (throw 'return t)) (nnmaildir--with-nntp-buffer (erase-buffer) (insert "211 ") (princ (nnmaildir--grp-count group) nntp-server-buffer) (insert " ") (princ (nnmaildir--grp-min group) nntp-server-buffer) (insert " ") (princ (nnmaildir--group-maxnum nnmaildir--cur-server group) nntp-server-buffer) (insert " " (gnus-replace-in-string gname " " "\\ " t) "\n") t)))) (defun nnmaildir-request-create-group (gname &optional server args) (nnmaildir--prepare server nil) (catch 'return (let ((target-prefix (nnmaildir--srv-target-prefix nnmaildir--cur-server)) srv-dir dir groups) (when (zerop (length gname)) (setf (nnmaildir--srv-error nnmaildir--cur-server) "Invalid (empty) group name") (throw 'return nil)) (when (eq (aref "." 0) (aref gname 0)) (setf (nnmaildir--srv-error nnmaildir--cur-server) "Group names may not start with \".\"") (throw 'return nil)) (when (save-match-data (string-match "[\0/\t]" gname)) (setf (nnmaildir--srv-error nnmaildir--cur-server) (concat "Invalid characters (null, tab, or /) in group name: " gname)) (throw 'return nil)) (setq groups (nnmaildir--srv-groups nnmaildir--cur-server)) (when (intern-soft gname groups) (setf (nnmaildir--srv-error nnmaildir--cur-server) (concat "Group already exists: " gname)) (throw 'return nil)) (setq srv-dir (nnmaildir--srv-dir nnmaildir--cur-server)) (if (file-name-absolute-p target-prefix) (setq dir (expand-file-name target-prefix)) (setq dir srv-dir dir (file-truename dir) dir (concat dir target-prefix))) (setq dir (nnmaildir--subdir dir gname)) (nnmaildir--mkdir dir) (nnmaildir--mkdir (nnmaildir--tmp dir)) (nnmaildir--mkdir (nnmaildir--new dir)) (nnmaildir--mkdir (nnmaildir--cur dir)) (unless (string= target-prefix "") (make-symbolic-link (concat target-prefix gname) (concat srv-dir gname))) (nnmaildir-request-scan 'find-new-groups)))) (defun nnmaildir-request-rename-group (gname new-name &optional server) (let ((group (nnmaildir--prepare server gname)) (coding-system-for-write nnheader-file-coding-system) (buffer-file-coding-system nil) (file-coding-system-alist nil) srv-dir x groups) (catch 'return (unless group (setf (nnmaildir--srv-error nnmaildir--cur-server) (concat "No such group: " gname)) (throw 'return nil)) (when (zerop (length new-name)) (setf (nnmaildir--srv-error nnmaildir--cur-server) "Invalid (empty) group name") (throw 'return nil)) (when (eq (aref "." 0) (aref new-name 0)) (setf (nnmaildir--srv-error nnmaildir--cur-server) "Group names may not start with \".\"") (throw 'return nil)) (when (save-match-data (string-match "[\0/\t]" new-name)) (setf (nnmaildir--srv-error nnmaildir--cur-server) (concat "Invalid characters (null, tab, or /) in group name: " new-name)) (throw 'return nil)) (if (string-equal gname new-name) (throw 'return t)) (when (intern-soft new-name (nnmaildir--srv-groups nnmaildir--cur-server)) (setf (nnmaildir--srv-error nnmaildir--cur-server) (concat "Group already exists: " new-name)) (throw 'return nil)) (setq srv-dir (nnmaildir--srv-dir nnmaildir--cur-server)) (condition-case err (rename-file (concat srv-dir gname) (concat srv-dir new-name)) (error (setf (nnmaildir--srv-error nnmaildir--cur-server) (concat "Error renaming link: " (prin1-to-string err))) (throw 'return nil))) (setq x (nnmaildir--srv-groups nnmaildir--cur-server) groups (make-vector (length x) 0)) (mapatoms (lambda (sym) (unless (eq (symbol-value sym) group) (set (intern (symbol-name sym) groups) (symbol-value sym)))) x) (setq group (copy-sequence group)) (setf (nnmaildir--grp-name group) new-name) (set (intern new-name groups) group) (setf (nnmaildir--srv-groups nnmaildir--cur-server) groups) t))) (defun nnmaildir-request-delete-group (gname force &optional server) (let ((group (nnmaildir--prepare server gname)) pgname grp-dir target dir ls deactivate-mark) (catch 'return (unless group (setf (nnmaildir--srv-error nnmaildir--cur-server) (concat "No such group: " gname)) (throw 'return nil)) (setq gname (nnmaildir--grp-name group) pgname (nnmaildir--pgname nnmaildir--cur-server gname) grp-dir (nnmaildir--srv-dir nnmaildir--cur-server) target (car (file-attributes (concat grp-dir gname))) grp-dir (nnmaildir--srvgrp-dir grp-dir gname)) (unless (or force (stringp target)) (setf (nnmaildir--srv-error nnmaildir--cur-server) (concat "Not a symlink: " gname)) (throw 'return nil)) (if (eq group (nnmaildir--srv-curgrp nnmaildir--cur-server)) (setf (nnmaildir--srv-curgrp nnmaildir--cur-server) nil)) (unintern gname (nnmaildir--srv-groups nnmaildir--cur-server)) (if (not force) (progn (setq grp-dir (directory-file-name grp-dir)) (nnmaildir--unlink grp-dir)) (setq ls (nnmaildir--group-ls nnmaildir--cur-server pgname)) (if (nnmaildir--param pgname 'read-only) (progn (delete-directory (nnmaildir--tmp grp-dir)) (nnmaildir--unlink (nnmaildir--new grp-dir)) (delete-directory (nnmaildir--cur grp-dir))) (nnmaildir--delete-dir-files (nnmaildir--tmp grp-dir) ls) (nnmaildir--delete-dir-files (nnmaildir--new grp-dir) ls) (nnmaildir--delete-dir-files (nnmaildir--cur grp-dir) ls)) (setq dir (nnmaildir--nndir grp-dir)) (dolist (subdir `(,(nnmaildir--nov-dir dir) ,(nnmaildir--num-dir dir) ,@(funcall ls (nnmaildir--marks-dir dir) 'full "\\`[^.]" 'nosort))) (nnmaildir--delete-dir-files subdir ls)) (setq dir (nnmaildir--nndir grp-dir)) (nnmaildir--unlink (concat dir "markfile")) (nnmaildir--unlink (concat dir "markfile{new}")) (delete-directory (nnmaildir--marks-dir dir)) (delete-directory dir) (if (not (stringp target)) (delete-directory grp-dir) (setq grp-dir (directory-file-name grp-dir) dir target) (unless (eq (aref "/" 0) (aref dir 0)) (setq dir (concat (file-truename (nnmaildir--srv-dir nnmaildir--cur-server)) dir))) (delete-directory dir) (nnmaildir--unlink grp-dir))) t))) (defun nnmaildir-retrieve-headers (articles &optional gname server fetch-old) (let ((group (nnmaildir--prepare server gname)) srv-dir dir nlist mlist article num start stop nov nlist2 insert-nov deactivate-mark) (setq insert-nov (lambda (article) (setq nov (nnmaildir--update-nov nnmaildir--cur-server group article)) (when nov (nnmaildir--cache-nov group article nov) (setq num (nnmaildir--art-num article)) (princ num nntp-server-buffer) (insert "\t" (nnmaildir--nov-get-beg nov) "\t" (nnmaildir--art-msgid article) "\t" (nnmaildir--nov-get-mid nov) "\tXref: nnmaildir " (gnus-replace-in-string gname " " "\\ " t) ":") (princ num nntp-server-buffer) (insert "\t" (nnmaildir--nov-get-end nov) "\n")))) (catch 'return (unless group (setf (nnmaildir--srv-error nnmaildir--cur-server) (if gname (concat "No such group: " gname) "No current group")) (throw 'return nil)) (nnmaildir--with-nntp-buffer (erase-buffer) (setq mlist (nnmaildir--grp-mlist group) nlist (nnmaildir--grp-nlist group) gname (nnmaildir--grp-name group) srv-dir (nnmaildir--srv-dir nnmaildir--cur-server) dir (nnmaildir--srvgrp-dir srv-dir gname)) (cond ((null nlist)) ((and fetch-old (not (numberp fetch-old))) (nnmaildir--nlist-iterate nlist 'all insert-nov)) ((null articles)) ((stringp (car articles)) (dolist (msgid articles) (setq article (nnmaildir--mlist-art mlist msgid)) (if article (funcall insert-nov article)))) (t (if fetch-old ;; Assume the article range list is sorted ascending (setq stop (car articles) start (car (last articles)) stop (if (numberp stop) stop (car stop)) start (if (numberp start) start (cdr start)) stop (- stop fetch-old) stop (if (< stop 1) 1 stop) articles (list (cons stop start)))) (nnmaildir--nlist-iterate nlist articles insert-nov))) (sort-numeric-fields 1 (point-min) (point-max)) 'nov)))) (defun nnmaildir-request-article (num-msgid &optional gname server to-buffer) (let ((group (nnmaildir--prepare server gname)) (case-fold-search t) list article dir pgname deactivate-mark) (catch 'return (unless group (setf (nnmaildir--srv-error nnmaildir--cur-server) (if gname (concat "No such group: " gname) "No current group")) (throw 'return nil)) (if (numberp num-msgid) (setq article (nnmaildir--nlist-art group num-msgid)) (setq list (nnmaildir--grp-mlist group) article (nnmaildir--mlist-art list num-msgid)) (if article (setq num-msgid (nnmaildir--art-num article)) (catch 'found (mapatoms (lambda (group-sym) (setq group (symbol-value group-sym) list (nnmaildir--grp-mlist group) article (nnmaildir--mlist-art list num-msgid)) (when article (setq num-msgid (nnmaildir--art-num article)) (throw 'found nil))) (nnmaildir--srv-groups nnmaildir--cur-server)))) (unless article (setf (nnmaildir--srv-error nnmaildir--cur-server) "No such article") (throw 'return nil))) (setq gname (nnmaildir--grp-name group) pgname (nnmaildir--pgname nnmaildir--cur-server gname) dir (nnmaildir--srv-dir nnmaildir--cur-server) dir (nnmaildir--srvgrp-dir dir gname) dir (if (nnmaildir--param pgname 'read-only) (nnmaildir--new dir) (nnmaildir--cur dir)) nnmaildir-article-file-name (concat dir (nnmaildir--art-prefix article) (nnmaildir--art-suffix article))) (unless (file-exists-p nnmaildir-article-file-name) (nnmaildir--expired-article group article) (setf (nnmaildir--srv-error nnmaildir--cur-server) "Article has expired") (throw 'return nil)) (save-excursion (set-buffer (or to-buffer nntp-server-buffer)) (erase-buffer) (nnheader-insert-file-contents nnmaildir-article-file-name)) (cons gname num-msgid)))) (defun nnmaildir-request-post (&optional server) (let (message-required-mail-headers) (funcall message-send-mail-function))) (defun nnmaildir-request-replace-article (number gname buffer) (let ((group (nnmaildir--prepare nil gname)) (coding-system-for-write nnheader-file-coding-system) (buffer-file-coding-system nil) (file-coding-system-alist nil) dir file article suffix tmpfile deactivate-mark) (catch 'return (unless group (setf (nnmaildir--srv-error nnmaildir--cur-server) (concat "No such group: " gname)) (throw 'return nil)) (when (nnmaildir--param (nnmaildir--pgname nnmaildir--cur-server gname) 'read-only) (setf (nnmaildir--srv-error nnmaildir--cur-server) (concat "Read-only group: " group)) (throw 'return nil)) (setq dir (nnmaildir--srv-dir nnmaildir--cur-server) dir (nnmaildir--srvgrp-dir dir gname) article (nnmaildir--nlist-art group number)) (unless article (setf (nnmaildir--srv-error nnmaildir--cur-server) (concat "No such article: " (number-to-string number))) (throw 'return nil)) (setq suffix (nnmaildir--art-suffix article) file (nnmaildir--art-prefix article) tmpfile (concat (nnmaildir--tmp dir) file)) (when (file-exists-p tmpfile) (setf (nnmaildir--srv-error nnmaildir--cur-server) (concat "File exists: " tmpfile)) (throw 'return nil)) (save-excursion (set-buffer buffer) (gmm-write-region (point-min) (point-max) tmpfile nil 'no-message nil 'excl)) (unix-sync) ;; no fsync :( (rename-file tmpfile (concat (nnmaildir--cur dir) file suffix) 'replace) t))) (defun nnmaildir-request-move-article (article gname server accept-form &optional last move-is-internal) (let ((group (nnmaildir--prepare server gname)) pgname suffix result nnmaildir--file deactivate-mark) (catch 'return (unless group (setf (nnmaildir--srv-error nnmaildir--cur-server) (concat "No such group: " gname)) (throw 'return nil)) (setq gname (nnmaildir--grp-name group) pgname (nnmaildir--pgname nnmaildir--cur-server gname) article (nnmaildir--nlist-art group article)) (unless article (setf (nnmaildir--srv-error nnmaildir--cur-server) "No such article") (throw 'return nil)) (setq suffix (nnmaildir--art-suffix article) nnmaildir--file (nnmaildir--srv-dir nnmaildir--cur-server) nnmaildir--file (nnmaildir--srvgrp-dir nnmaildir--file gname) nnmaildir--file (if (nnmaildir--param pgname 'read-only) (nnmaildir--new nnmaildir--file) (nnmaildir--cur nnmaildir--file)) nnmaildir--file (concat nnmaildir--file (nnmaildir--art-prefix article) suffix)) (unless (file-exists-p nnmaildir--file) (nnmaildir--expired-article group article) (setf (nnmaildir--srv-error nnmaildir--cur-server) "Article has expired") (throw 'return nil)) (nnmaildir--with-move-buffer (erase-buffer) (nnheader-insert-file-contents nnmaildir--file) (setq result (eval accept-form))) (unless (or (null result) (nnmaildir--param pgname 'read-only)) (nnmaildir--unlink nnmaildir--file) (nnmaildir--expired-article group article)) result))) (defun nnmaildir-request-accept-article (gname &optional server last) (let ((group (nnmaildir--prepare server gname)) (coding-system-for-write nnheader-file-coding-system) (buffer-file-coding-system nil) (file-coding-system-alist nil) srv-dir dir file time tmpfile curfile 24h article) (catch 'return (unless group (setf (nnmaildir--srv-error nnmaildir--cur-server) (concat "No such group: " gname)) (throw 'return nil)) (setq gname (nnmaildir--grp-name group)) (when (nnmaildir--param (nnmaildir--pgname nnmaildir--cur-server gname) 'read-only) (setf (nnmaildir--srv-error nnmaildir--cur-server) (concat "Read-only group: " gname)) (throw 'return nil)) (setq srv-dir (nnmaildir--srv-dir nnmaildir--cur-server) dir (nnmaildir--srvgrp-dir srv-dir gname) time (current-time) file (format-time-string "%s." time)) (unless (string-equal nnmaildir--delivery-time file) (setq nnmaildir--delivery-time file nnmaildir--delivery-count 0)) (when (and (consp (cdr time)) (consp (cddr time))) (setq file (concat file "M" (number-to-string (caddr time))))) (setq file (concat file nnmaildir--delivery-pid) file (concat file "Q" (number-to-string nnmaildir--delivery-count)) file (concat file "." (nnmaildir--system-name)) tmpfile (concat (nnmaildir--tmp dir) file) curfile (concat (nnmaildir--cur dir) file ":2,")) (when (file-exists-p tmpfile) (setf (nnmaildir--srv-error nnmaildir--cur-server) (concat "File exists: " tmpfile)) (throw 'return nil)) (when (file-exists-p curfile) (setf (nnmaildir--srv-error nnmaildir--cur-server) (concat "File exists: " curfile)) (throw 'return nil)) (setq nnmaildir--delivery-count (1+ nnmaildir--delivery-count) 24h (run-with-timer 86400 nil (lambda () (nnmaildir--unlink tmpfile) (setf (nnmaildir--srv-error nnmaildir--cur-server) "24-hour timer expired") (throw 'return nil)))) (condition-case nil (add-name-to-file nnmaildir--file tmpfile) (error (gmm-write-region (point-min) (point-max) tmpfile nil 'no-message nil 'excl) (unix-sync))) ;; no fsync :( (nnheader-cancel-timer 24h) (condition-case err (add-name-to-file tmpfile curfile) (error (setf (nnmaildir--srv-error nnmaildir--cur-server) (concat "Error linking: " (prin1-to-string err))) (nnmaildir--unlink tmpfile) (throw 'return nil))) (nnmaildir--unlink tmpfile) (setq article (make-nnmaildir--art :prefix file :suffix ":2,")) (if (nnmaildir--grp-add-art nnmaildir--cur-server group article) (cons gname (nnmaildir--art-num article)))))) (defun nnmaildir-save-mail (group-art) (catch 'return (unless group-art (throw 'return nil)) (let (ga gname x groups nnmaildir--file deactivate-mark) (save-excursion (goto-char (point-min)) (save-match-data (while (looking-at "From ") (replace-match "X-From-Line: ") (forward-line 1)))) (setq groups (nnmaildir--srv-groups nnmaildir--cur-server) ga (car group-art) group-art (cdr group-art) gname (car ga)) (or (intern-soft gname groups) (nnmaildir-request-create-group gname) (throw 'return nil)) ;; not that nnmail bothers to check :( (unless (nnmaildir-request-accept-article gname) (throw 'return nil)) (setq nnmaildir--file (nnmaildir--srv-dir nnmaildir--cur-server) nnmaildir--file (nnmaildir--srvgrp-dir nnmaildir--file gname) x (nnmaildir--prepare nil gname) x (nnmaildir--grp-nlist x) x (cdar x) nnmaildir--file (concat nnmaildir--file (nnmaildir--art-prefix x) (nnmaildir--art-suffix x))) (delq nil (mapcar (lambda (ga) (setq gname (car ga)) (and (or (intern-soft gname groups) (nnmaildir-request-create-group gname)) (nnmaildir-request-accept-article gname) ga)) group-art))))) (defun nnmaildir-active-number (gname) 0) (declare-function gnus-group-mark-article-read "gnus-group" (group article)) (defun nnmaildir-request-expire-articles (ranges &optional gname server force) (let ((no-force (not force)) (group (nnmaildir--prepare server gname)) pgname time boundary bound-iter high low target dir nlist nlist2 stop article didnt nnmaildir--file nnmaildir-article-file-name deactivate-mark) (catch 'return (unless group (setf (nnmaildir--srv-error nnmaildir--cur-server) (if gname (concat "No such group: " gname) "No current group")) (throw 'return (gnus-uncompress-range ranges))) (setq gname (nnmaildir--grp-name group) pgname (nnmaildir--pgname nnmaildir--cur-server gname)) (if (nnmaildir--param pgname 'read-only) (throw 'return (gnus-uncompress-range ranges))) (setq time (nnmaildir--param pgname 'expire-age)) (unless time (setq time (or (and nnmail-expiry-wait-function (funcall nnmail-expiry-wait-function gname)) nnmail-expiry-wait)) (if (eq time 'immediate) (setq time 0) (if (numberp time) (setq time (* time 86400))))) (when no-force (unless (integerp time) ;; handle 'never (throw 'return (gnus-uncompress-range ranges))) (setq boundary (current-time) high (- (car boundary) (/ time 65536)) low (- (cadr boundary) (% time 65536))) (if (< low 0) (setq low (+ low 65536) high (1- high))) (setcar (cdr boundary) low) (setcar boundary high)) (setq dir (nnmaildir--srv-dir nnmaildir--cur-server) dir (nnmaildir--srvgrp-dir dir gname) dir (nnmaildir--cur dir) nlist (nnmaildir--grp-nlist group) ranges (reverse ranges)) (nnmaildir--with-move-buffer (nnmaildir--nlist-iterate nlist ranges (lambda (article) (setq nnmaildir--file (nnmaildir--art-prefix article) nnmaildir--file (concat dir nnmaildir--file (nnmaildir--art-suffix article)) time (file-attributes nnmaildir--file)) (cond ((null time) (nnmaildir--expired-article group article)) ((and no-force (progn (setq time (nth 5 time) bound-iter boundary) (while (and bound-iter time (= (car bound-iter) (car time))) (setq bound-iter (cdr bound-iter) time (cdr time))) (and bound-iter time (car-less-than-car bound-iter time)))) (setq didnt (cons (nnmaildir--art-num article) didnt))) (t (setq nnmaildir-article-file-name nnmaildir--file target (if force nil (save-excursion (save-restriction (nnmaildir--param pgname 'expire-group))))) (when (and (stringp target) (not (string-equal target pgname))) ;; Move it. (erase-buffer) (nnheader-insert-file-contents nnmaildir--file) (let ((group-art (gnus-request-accept-article target nil nil 'no-encode))) (when (consp group-art) ;; Maybe also copy: dormant forward reply save tick ;; (gnus-add-mark? gnus-request-set-mark?) (gnus-group-mark-article-read target (cdr group-art))))) (if (equal target pgname) ;; Leave it here. (setq didnt (cons (nnmaildir--art-num article) didnt)) (nnmaildir--unlink nnmaildir--file) (nnmaildir--expired-article group article)))))) (erase-buffer)) didnt))) (defun nnmaildir-request-set-mark (gname actions &optional server) (let ((group (nnmaildir--prepare server gname)) (coding-system-for-write nnheader-file-coding-system) (buffer-file-coding-system nil) (file-coding-system-alist nil) del-mark del-action add-action set-action marksdir nlist ranges begin end article all-marks todo-marks mdir mfile pgname ls permarkfile deactivate-mark) (setq del-mark (lambda (mark) (setq mfile (nnmaildir--subdir marksdir (symbol-name mark)) mfile (concat mfile (nnmaildir--art-prefix article))) (nnmaildir--unlink mfile)) del-action (lambda (article) (mapcar del-mark todo-marks)) add-action (lambda (article) (mapcar (lambda (mark) (setq mdir (nnmaildir--subdir marksdir (symbol-name mark)) permarkfile (concat mdir ":") mfile (concat mdir (nnmaildir--art-prefix article))) (nnmaildir--condcase err (add-name-to-file permarkfile mfile) (cond ((nnmaildir--eexist-p err)) ((nnmaildir--enoent-p err) (nnmaildir--mkdir mdir) (nnmaildir--mkfile permarkfile) (add-name-to-file permarkfile mfile)) ((nnmaildir--emlink-p err) (let ((permarkfilenew (concat permarkfile "{new}"))) (nnmaildir--mkfile permarkfilenew) (rename-file permarkfilenew permarkfile 'replace) (add-name-to-file permarkfile mfile))) (t (signal (car err) (cdr err)))))) todo-marks)) set-action (lambda (article) (funcall add-action) (mapcar (lambda (mark) (unless (memq mark todo-marks) (funcall del-mark mark))) all-marks))) (catch 'return (unless group (setf (nnmaildir--srv-error nnmaildir--cur-server) (concat "No such group: " gname)) (dolist (action actions) (setq ranges (gnus-range-add ranges (car action)))) (throw 'return ranges)) (setq nlist (nnmaildir--grp-nlist group) marksdir (nnmaildir--srv-dir nnmaildir--cur-server) marksdir (nnmaildir--srvgrp-dir marksdir gname) marksdir (nnmaildir--nndir marksdir) marksdir (nnmaildir--marks-dir marksdir) gname (nnmaildir--grp-name group) pgname (nnmaildir--pgname nnmaildir--cur-server gname) ls (nnmaildir--group-ls nnmaildir--cur-server pgname) all-marks (funcall ls marksdir nil "\\`[^.]" 'nosort) all-marks (mapcar 'intern all-marks)) (dolist (action actions) (setq ranges (car action) todo-marks (caddr action)) (dolist (mark todo-marks) (add-to-list 'all-marks mark)) (if (numberp (cdr ranges)) (setq ranges (list ranges))) (nnmaildir--nlist-iterate nlist ranges (cond ((eq 'del (cadr action)) del-action) ((eq 'add (cadr action)) add-action) (t set-action)))) nil))) (defun nnmaildir-close-group (gname &optional server) (let ((group (nnmaildir--prepare server gname)) pgname ls dir msgdir files flist dirs) (if (null group) (progn (setf (nnmaildir--srv-error nnmaildir--cur-server) (concat "No such group: " gname)) nil) (setq pgname (nnmaildir--pgname nnmaildir--cur-server gname) ls (nnmaildir--group-ls nnmaildir--cur-server pgname) dir (nnmaildir--srv-dir nnmaildir--cur-server) dir (nnmaildir--srvgrp-dir dir gname) msgdir (if (nnmaildir--param pgname 'read-only) (nnmaildir--new dir) (nnmaildir--cur dir)) dir (nnmaildir--nndir dir) dirs (cons (nnmaildir--nov-dir dir) (funcall ls (nnmaildir--marks-dir dir) 'full "\\`[^.]" 'nosort)) dirs (mapcar (lambda (dir) (cons dir (funcall ls dir nil "\\`[^.]" 'nosort))) dirs) files (funcall ls msgdir nil "\\`[^.]" 'nosort) flist (nnmaildir--up2-1 (length files)) flist (make-vector flist 0)) (save-match-data (dolist (file files) (string-match "\\`\\([^:]*\\)\\(:.*\\)?\\'" file) (intern (match-string 1 file) flist))) (dolist (dir dirs) (setq files (cdr dir) dir (file-name-as-directory (car dir))) (dolist (file files) (unless (or (intern-soft file flist) (string= file ":")) (setq file (concat dir file)) (delete-file file)))) t))) (defun nnmaildir-close-server (&optional server) (let (flist ls dirs dir files file x) (nnmaildir--prepare server nil) (when nnmaildir--cur-server (setq server nnmaildir--cur-server nnmaildir--cur-server nil) (unintern (nnmaildir--srv-address server) nnmaildir--servers))) t) (defun nnmaildir-request-close () (let (servers buffer) (mapatoms (lambda (server) (setq servers (cons (symbol-name server) servers))) nnmaildir--servers) (mapc 'nnmaildir-close-server servers) (setq buffer (get-buffer " *nnmaildir work*")) (if buffer (kill-buffer buffer)) (setq buffer (get-buffer " *nnmaildir nov*")) (if buffer (kill-buffer buffer)) (setq buffer (get-buffer " *nnmaildir move*")) (if buffer (kill-buffer buffer))) t) (provide 'nnmaildir) ;; Local Variables: ;; indent-tabs-mode: t ;; fill-column: 77 ;; End: ;; arch-tag: 0c4e44cd-dfde-4040-888e-5597ec771849 ;;; nnmaildir.el ends here gnus-5.11+v0.10.dfsg/lisp/nnbabyl.el0000644000175000017500000005333111004005111017176 0ustar tvainikatvainika;;; nnbabyl.el --- rmail mbox access for Gnus ;; Copyright (C) 1995, 1996, 1997, 1998, 1099, 2000, 2001, 2002, 2003, ;; 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; Masanobu UMEDA ;; Keywords: news, mail ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 3, or (at your option) ;; any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Commentary: ;; For an overview of what the interface functions do, please see the ;; Gnus sources. ;;; Code: (require 'nnheader) (condition-case nil (require 'rmail) (t (nnheader-message 5 "Ignore rmail errors from this file, you don't have rmail"))) (require 'nnmail) (require 'nnoo) (eval-when-compile (require 'cl)) (nnoo-declare nnbabyl) (defvoo nnbabyl-mbox-file (expand-file-name "~/RMAIL") "The name of the rmail box file in the users home directory.") (defvoo nnbabyl-active-file (expand-file-name "~/.rmail-active") "The name of the active file for the rmail box.") (defvoo nnbabyl-get-new-mail t "If non-nil, nnbabyl will check the incoming mail file and split the mail.") (defvoo nnbabyl-prepare-save-mail-hook nil "Hook run narrowed to an article before saving.") (defvar nnbabyl-mail-delimiter "\^_") (defconst nnbabyl-version "nnbabyl 1.0" "nnbabyl version.") (defvoo nnbabyl-mbox-buffer nil) (defvoo nnbabyl-current-group nil) (defvoo nnbabyl-status-string "") (defvoo nnbabyl-group-alist nil) (defvoo nnbabyl-active-timestamp nil) (defvoo nnbabyl-previous-buffer-mode nil) ;;; Interface functions (nnoo-define-basics nnbabyl) (deffoo nnbabyl-retrieve-headers (articles &optional group server fetch-old) (save-excursion (set-buffer nntp-server-buffer) (erase-buffer) (let ((number (length articles)) (count 0) (delim (concat "^" nnbabyl-mail-delimiter)) article art-string start stop) (nnbabyl-possibly-change-newsgroup group server) (while (setq article (pop articles)) (setq art-string (nnbabyl-article-string article)) (set-buffer nnbabyl-mbox-buffer) (end-of-line) (when (or (search-forward art-string nil t) (search-backward art-string nil t)) (unless (re-search-backward delim nil t) (goto-char (point-min))) (while (and (not (looking-at ".+:")) (zerop (forward-line 1)))) (setq start (point)) (search-forward "\n\n" nil t) (setq stop (1- (point))) (set-buffer nntp-server-buffer) (insert "221 ") (princ article (current-buffer)) (insert " Article retrieved.\n") (insert-buffer-substring nnbabyl-mbox-buffer start stop) (goto-char (point-max)) (insert ".\n")) (and (numberp nnmail-large-newsgroup) (> number nnmail-large-newsgroup) (zerop (% (incf count) 20)) (nnheader-message 5 "nnbabyl: Receiving headers... %d%%" (/ (* count 100) number)))) (and (numberp nnmail-large-newsgroup) (> number nnmail-large-newsgroup) (nnheader-message 5 "nnbabyl: Receiving headers...done")) (set-buffer nntp-server-buffer) (nnheader-fold-continuation-lines) 'headers))) (deffoo nnbabyl-open-server (server &optional defs) (nnoo-change-server 'nnbabyl server defs) (nnbabyl-create-mbox) (cond ((not (file-exists-p nnbabyl-mbox-file)) (nnbabyl-close-server) (nnheader-report 'nnbabyl "No such file: %s" nnbabyl-mbox-file)) ((file-directory-p nnbabyl-mbox-file) (nnbabyl-close-server) (nnheader-report 'nnbabyl "Not a regular file: %s" nnbabyl-mbox-file)) (t (nnheader-report 'nnbabyl "Opened server %s using mbox %s" server nnbabyl-mbox-file) t))) (deffoo nnbabyl-close-server (&optional server) ;; Restore buffer mode. (when (and (nnbabyl-server-opened) nnbabyl-previous-buffer-mode) (save-excursion (set-buffer nnbabyl-mbox-buffer) (narrow-to-region (caar nnbabyl-previous-buffer-mode) (cdar nnbabyl-previous-buffer-mode)) (funcall (cdr nnbabyl-previous-buffer-mode)))) (nnoo-close-server 'nnbabyl server) (setq nnbabyl-mbox-buffer nil) t) (deffoo nnbabyl-server-opened (&optional server) (and (nnoo-current-server-p 'nnbabyl server) nnbabyl-mbox-buffer (buffer-name nnbabyl-mbox-buffer) nntp-server-buffer (buffer-name nntp-server-buffer))) (deffoo nnbabyl-request-article (article &optional newsgroup server buffer) (nnbabyl-possibly-change-newsgroup newsgroup server) (save-excursion (set-buffer nnbabyl-mbox-buffer) (goto-char (point-min)) (when (search-forward (nnbabyl-article-string article) nil t) (let (start stop summary-line) (unless (re-search-backward (concat "^" nnbabyl-mail-delimiter) nil t) (goto-char (point-min)) (end-of-line)) (while (and (not (looking-at ".+:")) (zerop (forward-line 1)))) (setq start (point)) (or (when (re-search-forward (concat "^" nnbabyl-mail-delimiter) nil t) (beginning-of-line) t) (goto-char (point-max))) (setq stop (point)) (let ((nntp-server-buffer (or buffer nntp-server-buffer))) (set-buffer nntp-server-buffer) (erase-buffer) (insert-buffer-substring nnbabyl-mbox-buffer start stop) (goto-char (point-min)) ;; If there is an EOOH header, then we have to remove some ;; duplicated headers. (setq summary-line (looking-at "Summary-line:")) (when (search-forward "\n*** EOOH ***" nil t) (if summary-line ;; The headers to be deleted are located before the ;; EOOH line... (delete-region (point-min) (progn (forward-line 1) (point))) ;; ...or after. (delete-region (progn (beginning-of-line) (point)) (or (search-forward "\n\n" nil t) (point))))) (if (numberp article) (cons nnbabyl-current-group article) (nnbabyl-article-group-number))))))) (deffoo nnbabyl-request-group (group &optional server dont-check) (let ((active (cadr (assoc group nnbabyl-group-alist)))) (save-excursion (cond ((or (null active) (null (nnbabyl-possibly-change-newsgroup group server))) (nnheader-report 'nnbabyl "No such group: %s" group)) (dont-check (nnheader-report 'nnbabyl "Selected group %s" group) (nnheader-insert "")) (t (nnheader-report 'nnbabyl "Selected group %s" group) (nnheader-insert "211 %d %d %d %s\n" (1+ (- (cdr active) (car active))) (car active) (cdr active) group)))))) (deffoo nnbabyl-request-scan (&optional group server) (nnbabyl-possibly-change-newsgroup group server) (nnbabyl-read-mbox) (nnmail-get-new-mail 'nnbabyl (lambda () (save-excursion (set-buffer nnbabyl-mbox-buffer) (save-buffer))) (file-name-directory nnbabyl-mbox-file) group (lambda () (save-excursion (let ((in-buf (current-buffer))) (goto-char (point-min)) (while (search-forward "\n\^_\n" nil t) (delete-char -1)) (set-buffer nnbabyl-mbox-buffer) (goto-char (point-max)) (search-backward "\n\^_" nil t) (goto-char (match-end 0)) (insert-buffer-substring in-buf))) (nnmail-save-active nnbabyl-group-alist nnbabyl-active-file)))) (deffoo nnbabyl-close-group (group &optional server) t) (deffoo nnbabyl-request-create-group (group &optional server args) (nnmail-activate 'nnbabyl) (unless (assoc group nnbabyl-group-alist) (push (list group (cons 1 0)) nnbabyl-group-alist) (nnmail-save-active nnbabyl-group-alist nnbabyl-active-file)) t) (deffoo nnbabyl-request-list (&optional server) (save-excursion (nnmail-find-file nnbabyl-active-file) (setq nnbabyl-group-alist (nnmail-get-active)) t)) (deffoo nnbabyl-request-newgroups (date &optional server) (nnbabyl-request-list server)) (deffoo nnbabyl-request-list-newsgroups (&optional server) (nnheader-report 'nnbabyl "nnbabyl: LIST NEWSGROUPS is not implemented.")) (deffoo nnbabyl-request-expire-articles (articles newsgroup &optional server force) (nnbabyl-possibly-change-newsgroup newsgroup server) (let* ((is-old t) rest) (nnmail-activate 'nnbabyl) (save-excursion (set-buffer nnbabyl-mbox-buffer) (set-text-properties (point-min) (point-max) nil) (while (and articles is-old) (goto-char (point-min)) (when (search-forward (nnbabyl-article-string (car articles)) nil t) (if (setq is-old (nnmail-expired-article-p newsgroup (buffer-substring (point) (progn (end-of-line) (point))) force)) (progn (unless (eq nnmail-expiry-target 'delete) (with-temp-buffer (nnbabyl-request-article (car articles) newsgroup server (current-buffer)) (let ((nnml-current-directory nil)) (nnmail-expiry-target-group nnmail-expiry-target newsgroup))) (nnbabyl-possibly-change-newsgroup newsgroup server)) (nnheader-message 5 "Deleting article %d in %s..." (car articles) newsgroup) (nnbabyl-delete-mail)) (push (car articles) rest))) (setq articles (cdr articles))) (save-buffer) ;; Find the lowest active article in this group. (let ((active (nth 1 (assoc newsgroup nnbabyl-group-alist)))) (goto-char (point-min)) (while (and (not (search-forward (nnbabyl-article-string (car active)) nil t)) (<= (car active) (cdr active))) (setcar active (1+ (car active))) (goto-char (point-min)))) (nnmail-save-active nnbabyl-group-alist nnbabyl-active-file) (nconc rest articles)))) (deffoo nnbabyl-request-move-article (article group server accept-form &optional last move-is-internal) (let ((buf (get-buffer-create " *nnbabyl move*")) result) (and (nnbabyl-request-article article group server) (save-excursion (set-buffer buf) (insert-buffer-substring nntp-server-buffer) (goto-char (point-min)) (while (re-search-forward "^X-Gnus-Newsgroup:" (save-excursion (search-forward "\n\n" nil t) (point)) t) (delete-region (progn (beginning-of-line) (point)) (progn (forward-line 1) (point)))) (setq result (eval accept-form)) (kill-buffer (current-buffer)) result) (save-excursion (nnbabyl-possibly-change-newsgroup group server) (set-buffer nnbabyl-mbox-buffer) (goto-char (point-min)) (if (search-forward (nnbabyl-article-string article) nil t) (nnbabyl-delete-mail)) (and last (save-buffer)))) result)) (deffoo nnbabyl-request-accept-article (group &optional server last) (nnbabyl-possibly-change-newsgroup group server) (nnmail-check-syntax) (let ((buf (current-buffer)) result beg) (and (nnmail-activate 'nnbabyl) (save-excursion (goto-char (point-min)) (search-forward "\n\n" nil t) (forward-line -1) (save-excursion (while (re-search-backward "^X-Gnus-Newsgroup: " beg t) (delete-region (point) (progn (forward-line 1) (point))))) (when nnmail-cache-accepted-message-ids (nnmail-cache-insert (nnmail-fetch-field "message-id") group (nnmail-fetch-field "subject") (nnmail-fetch-field "from"))) (setq result (if (stringp group) (list (cons group (nnbabyl-active-number group))) (nnmail-article-group 'nnbabyl-active-number))) (if (and (null result) (yes-or-no-p "Moved to `junk' group; delete article? ")) (setq result 'junk) (setq result (car (nnbabyl-save-mail result)))) (set-buffer nnbabyl-mbox-buffer) (goto-char (point-max)) (search-backward "\n\^_") (goto-char (match-end 0)) (insert-buffer-substring buf) (when last (when nnmail-cache-accepted-message-ids (nnmail-cache-insert (nnmail-fetch-field "message-id") group (nnmail-fetch-field "subject") (nnmail-fetch-field "from"))) (save-buffer) (nnmail-save-active nnbabyl-group-alist nnbabyl-active-file)) result)))) (deffoo nnbabyl-request-replace-article (article group buffer) (nnbabyl-possibly-change-newsgroup group) (save-excursion (set-buffer nnbabyl-mbox-buffer) (goto-char (point-min)) (if (not (search-forward (nnbabyl-article-string article) nil t)) nil (nnbabyl-delete-mail t t) (insert-buffer-substring buffer) (save-buffer) t))) (deffoo nnbabyl-request-delete-group (group &optional force server) (nnbabyl-possibly-change-newsgroup group server) ;; Delete all articles in GROUP. (if (not force) () ; Don't delete the articles. (save-excursion (set-buffer nnbabyl-mbox-buffer) (goto-char (point-min)) ;; Delete all articles in this group. (let ((ident (concat "\nX-Gnus-Newsgroup: " nnbabyl-current-group ":")) found) (while (search-forward ident nil t) (setq found t) (nnbabyl-delete-mail)) (when found (save-buffer))))) ;; Remove the group from all structures. (setq nnbabyl-group-alist (delq (assoc group nnbabyl-group-alist) nnbabyl-group-alist) nnbabyl-current-group nil) ;; Save the active file. (nnmail-save-active nnbabyl-group-alist nnbabyl-active-file) t) (deffoo nnbabyl-request-rename-group (group new-name &optional server) (nnbabyl-possibly-change-newsgroup group server) (save-excursion (set-buffer nnbabyl-mbox-buffer) (goto-char (point-min)) (let ((ident (concat "\nX-Gnus-Newsgroup: " nnbabyl-current-group ":")) (new-ident (concat "\nX-Gnus-Newsgroup: " new-name ":")) found) (while (search-forward ident nil t) (replace-match new-ident t t) (setq found t)) (when found (save-buffer)))) (let ((entry (assoc group nnbabyl-group-alist))) (and entry (setcar entry new-name)) (setq nnbabyl-current-group nil) ;; Save the new group alist. (nnmail-save-active nnbabyl-group-alist nnbabyl-active-file) t)) ;;; Internal functions. ;; If FORCE, delete article no matter how many X-Gnus-Newsgroup ;; headers there are. If LEAVE-DELIM, don't delete the Unix mbox ;; delimiter line. (defun nnbabyl-delete-mail (&optional force leave-delim) ;; Delete the current X-Gnus-Newsgroup line. (unless force (delete-region (progn (beginning-of-line) (point)) (progn (forward-line 1) (point)))) ;; Beginning of the article. (save-excursion (save-restriction (widen) (narrow-to-region (save-excursion (unless (re-search-backward (concat "^" nnbabyl-mail-delimiter) nil t) (goto-char (point-min)) (end-of-line)) (if leave-delim (progn (forward-line 1) (point)) (match-beginning 0))) (progn (forward-line 1) (or (and (re-search-forward (concat "^" nnbabyl-mail-delimiter) nil t) (match-beginning 0)) (point-max)))) (goto-char (point-min)) ;; Only delete the article if no other groups owns it as well. (when (or force (not (re-search-forward "^X-Gnus-Newsgroup: " nil t))) (delete-region (point-min) (point-max)))))) (defun nnbabyl-possibly-change-newsgroup (newsgroup &optional server) (when (and server (not (nnbabyl-server-opened server))) (nnbabyl-open-server server)) (when (or (not nnbabyl-mbox-buffer) (not (buffer-name nnbabyl-mbox-buffer))) (save-excursion (nnbabyl-read-mbox))) (unless nnbabyl-group-alist (nnmail-activate 'nnbabyl)) (if newsgroup (if (assoc newsgroup nnbabyl-group-alist) (setq nnbabyl-current-group newsgroup) (nnheader-report 'nnbabyl "No such group in file")) t)) (defun nnbabyl-article-string (article) (if (numberp article) (concat "\nX-Gnus-Newsgroup: " nnbabyl-current-group ":" (int-to-string article) " ") (concat "\nMessage-ID: " article))) (defun nnbabyl-article-group-number () (save-excursion (goto-char (point-min)) (when (re-search-forward "^X-Gnus-Newsgroup: +\\([^:]+\\):\\([0-9]+\\) " nil t) (cons (buffer-substring (match-beginning 1) (match-end 1)) (string-to-number (buffer-substring (match-beginning 2) (match-end 2))))))) (defun nnbabyl-insert-lines () "Insert how many lines and chars there are in the body of the mail." (let (lines chars) (save-excursion (goto-char (point-min)) (when (search-forward "\n\n" nil t) ;; There may be an EOOH line here... (when (looking-at "\\*\\*\\* EOOH \\*\\*\\*") (search-forward "\n\n" nil t)) (setq chars (- (point-max) (point)) lines (max (- (count-lines (point) (point-max)) 1) 0)) ;; Move back to the end of the headers. (goto-char (point-min)) (search-forward "\n\n" nil t) (forward-char -1) (save-excursion (when (re-search-backward "^Lines: " nil t) (delete-region (point) (progn (forward-line 1) (point))))) (insert (format "Lines: %d\n" lines)) chars)))) (defun nnbabyl-save-mail (group-art) ;; Called narrowed to an article. (nnbabyl-insert-lines) (nnmail-insert-xref group-art) (nnbabyl-insert-newsgroup-line group-art) (run-hooks 'nnbabyl-prepare-save-mail-hook) group-art) (defun nnbabyl-insert-newsgroup-line (group-art) (save-excursion (goto-char (point-min)) (while (looking-at "From ") (replace-match "Mail-from: From " t t) (forward-line 1)) ;; If there is a C-l at the beginning of the narrowed region, this ;; isn't really a "save", but rather a "scan". (goto-char (point-min)) (unless (looking-at "\^L") (save-excursion (insert "\^L\n0, unseen,,\n*** EOOH ***\n") (goto-char (point-max)) (insert "\^_\n"))) (when (search-forward "\n\n" nil t) (forward-char -1) (while group-art (insert (format "X-Gnus-Newsgroup: %s:%d %s\n" (caar group-art) (cdar group-art) (current-time-string))) (setq group-art (cdr group-art)))) t)) (defun nnbabyl-active-number (group) ;; Find the next article number in GROUP. (let ((active (cadr (assoc group nnbabyl-group-alist)))) (if active (setcdr active (1+ (cdr active))) ;; This group is new, so we create a new entry for it. ;; This might be a bit naughty... creating groups on the drop of ;; a hat, but I don't know... (push (list group (setq active (cons 1 1))) nnbabyl-group-alist)) (cdr active))) (defun nnbabyl-create-mbox () (unless (file-exists-p nnbabyl-mbox-file) ;; Create a new, empty RMAIL mbox file. (save-excursion (set-buffer (setq nnbabyl-mbox-buffer (create-file-buffer nnbabyl-mbox-file))) (setq buffer-file-name nnbabyl-mbox-file) (insert "BABYL OPTIONS:\n\n\^_") (nnmail-write-region (point-min) (point-max) nnbabyl-mbox-file t 'nomesg)))) (defun nnbabyl-read-mbox () (nnmail-activate 'nnbabyl) (nnbabyl-create-mbox) (unless (and nnbabyl-mbox-buffer (buffer-name nnbabyl-mbox-buffer) (save-excursion (set-buffer nnbabyl-mbox-buffer) (= (buffer-size) (nnheader-file-size nnbabyl-mbox-file)))) ;; This buffer has changed since we read it last. Possibly. (save-excursion (let ((delim (concat "^" nnbabyl-mail-delimiter)) (alist nnbabyl-group-alist) start end number) (set-buffer (setq nnbabyl-mbox-buffer (nnheader-find-file-noselect nnbabyl-mbox-file nil t))) ;; Save previous buffer mode. (setq nnbabyl-previous-buffer-mode (cons (cons (point-min) (point-max)) major-mode)) (buffer-disable-undo) (widen) (setq buffer-read-only nil) (fundamental-mode) ;; Go through the group alist and compare against ;; the rmail file. (while alist (goto-char (point-max)) (when (and (re-search-backward (format "^X-Gnus-Newsgroup: %s:\\([0-9]+\\) " (caar alist)) nil t) (> (setq number (string-to-number (buffer-substring (match-beginning 1) (match-end 1)))) (cdadar alist))) (setcdr (cadar alist) number)) (setq alist (cdr alist))) ;; We go through the mbox and make sure that each and ;; every mail belongs to some group or other. (goto-char (point-min)) (if (looking-at "\^L") (setq start (point)) (re-search-forward delim nil t) (setq start (match-end 0))) (while (re-search-forward delim nil t) (setq end (match-end 0)) (unless (search-backward "\nX-Gnus-Newsgroup: " start t) (goto-char end) (save-excursion (save-restriction (narrow-to-region (goto-char start) end) (nnbabyl-save-mail (nnmail-article-group 'nnbabyl-active-number)) (setq end (point-max))))) (goto-char (setq start end))) (when (buffer-modified-p (current-buffer)) (save-buffer)) (nnmail-save-active nnbabyl-group-alist nnbabyl-active-file))))) (defun nnbabyl-remove-incoming-delims () (goto-char (point-min)) (while (search-forward "\^_" nil t) (replace-match "?" t t))) (defun nnbabyl-check-mbox () "Go through the nnbabyl mbox and make sure that no article numbers are reused." (interactive) (let ((idents (make-vector 1000 0)) id) (save-excursion (when (or (not nnbabyl-mbox-buffer) (not (buffer-name nnbabyl-mbox-buffer))) (nnbabyl-read-mbox)) (set-buffer nnbabyl-mbox-buffer) (goto-char (point-min)) (while (re-search-forward "^X-Gnus-Newsgroup: \\([^ ]+\\) " nil t) (if (intern-soft (setq id (match-string 1)) idents) (progn (delete-region (progn (beginning-of-line) (point)) (progn (forward-line 1) (point))) (nnheader-message 7 "Moving %s..." id) (nnbabyl-save-mail (nnmail-article-group 'nnbabyl-active-number))) (intern id idents))) (when (buffer-modified-p (current-buffer)) (save-buffer)) (nnmail-save-active nnbabyl-group-alist nnbabyl-active-file) (nnheader-message 5 "")))) (provide 'nnbabyl) ;; arch-tag: aa7ddedb-8c07-4c0e-beb0-58e795c2b81b ;;; nnbabyl.el ends here gnus-5.11+v0.10.dfsg/lisp/nngateway.el0000644000175000017500000000577611004005110017557 0ustar tvainikatvainika;;; nngateway.el --- posting news via mail gateways ;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, ;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; Keywords: news, mail ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 3, or (at your option) ;; any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Commentary: ;;; Code: (eval-when-compile (require 'cl)) (require 'nnoo) (require 'message) (nnoo-declare nngateway) (defvoo nngateway-address nil "Address of the mail-to-news gateway.") (defvoo nngateway-header-transformation 'nngateway-simple-header-transformation "Function to be called to rewrite the news headers into mail headers. It is called narrowed to the headers to be transformed with one parameter -- the gateway address.") ;;; Interface functions (nnoo-define-basics nngateway) (deffoo nngateway-open-server (server &optional defs) (if (nngateway-server-opened server) t (unless (assq 'nngateway-address defs) (setq defs (append defs (list (list 'nngateway-address server))))) (nnoo-change-server 'nngateway server defs))) (deffoo nngateway-request-post (&optional server) (when (or (nngateway-server-opened server) (nngateway-open-server server)) ;; Rewrite the header. (let ((buf (current-buffer))) (with-temp-buffer (insert-buffer-substring buf) (message-narrow-to-head) (funcall nngateway-header-transformation nngateway-address) (goto-char (point-max)) (insert mail-header-separator "\n") (widen) (let (message-required-mail-headers) (funcall (or message-send-mail-real-function message-send-mail-function))) t)))) ;;; Internal functions (defun nngateway-simple-header-transformation (gateway) "Transform the headers to use GATEWAY." (let ((newsgroups (mail-fetch-field "newsgroups"))) (message-remove-header "to") (message-remove-header "cc") (goto-char (point-min)) (insert "To: " (nnheader-replace-chars-in-string newsgroups ?. ?-) "@" gateway "\n"))) (defun nngateway-mail2news-header-transformation (gateway) "Transform the headers for sending to a mail2news gateway." (message-remove-header "to") (message-remove-header "cc") (goto-char (point-min)) (insert "To: " gateway "\n")) (nnoo-define-skeleton nngateway) (provide 'nngateway) ;; arch-tag: f7ecb92e-b10c-43d5-9a9b-1314233341fc ;;; nngateway.el ends here gnus-5.11+v0.10.dfsg/lisp/gnus-cache.el0000644000175000017500000010177011004005111017567 0ustar tvainikatvainika;;; gnus-cache.el --- cache interface for Gnus ;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, ;; 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; Keywords: news ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 3, or (at your option) ;; any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Commentary: ;;; Code: ;; For Emacs < 22.2. (eval-and-compile (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) (eval-when-compile (require 'cl)) (require 'gnus) (require 'gnus-sum) (eval-when-compile (unless (fboundp 'gnus-agent-load-alist) (defun gnus-agent-load-alist (group)))) (defcustom gnus-cache-active-file (expand-file-name "active" gnus-cache-directory) "*The cache active file." :group 'gnus-cache :type 'file) (defcustom gnus-cache-enter-articles '(ticked dormant) "Classes of articles to enter into the cache." :group 'gnus-cache :type '(set (const ticked) (const dormant) (const unread) (const read))) (defcustom gnus-cache-remove-articles '(read) "Classes of articles to remove from the cache." :group 'gnus-cache :type '(set (const ticked) (const dormant) (const unread) (const read))) (defcustom gnus-cacheable-groups nil "*Groups that match this regexp will be cached. If you only want to cache your nntp groups, you could set this variable to \"^nntp\". If a group matches both gnus-cacheable-groups and gnus-uncacheable-groups it's not cached." :group 'gnus-cache :type '(choice (const :tag "off" nil) regexp)) (defcustom gnus-uncacheable-groups nil "*Groups that match this regexp will not be cached. If you want to avoid caching your nnml groups, you could set this variable to \"^nnml\". If a group matches both gnus-cacheable-groups and gnus-uncacheable-groups it's not cached." :group 'gnus-cache :type '(choice (const :tag "off" nil) regexp)) (defvar gnus-cache-overview-coding-system 'raw-text "Coding system used on Gnus cache files.") (defvar gnus-cache-coding-system 'raw-text "Coding system used on Gnus cache files.") ;;; Internal variables. (defvar gnus-cache-removable-articles nil) (defvar gnus-cache-buffer nil) (defvar gnus-cache-active-hashtb nil) (defvar gnus-cache-active-altered nil) (defvar gnus-cache-total-fetched-hashtb nil) (declare-function nnvirtual-find-group-art "nnvirtual" (group article)) (eval-and-compile (autoload 'nnml-generate-nov-databases-directory "nnml") (autoload 'nnvirtual-find-group-art "nnvirtual")) ;;; Functions called from Gnus. (defun gnus-cache-open () "Initialize the cache." (when (or (file-exists-p gnus-cache-directory) (and gnus-use-cache (not (eq gnus-use-cache 'passive)))) (gnus-cache-read-active))) ;; Complexities of byte-compiling make this kludge necessary. Eeek. (ignore-errors (gnus-add-shutdown 'gnus-cache-close 'gnus)) (defun gnus-cache-close () "Shut down the cache." (gnus-cache-write-active) (gnus-cache-save-buffers) (setq gnus-cache-active-hashtb nil)) (defun gnus-cache-save-buffers () ;; save the overview buffer if it exists and has been modified ;; delete empty cache subdirectories (when gnus-cache-buffer (let ((buffer (cdr gnus-cache-buffer)) (overview-file (gnus-cache-file-name (car gnus-cache-buffer) ".overview"))) ;; write the overview only if it was modified (when (and (buffer-live-p buffer) (buffer-modified-p buffer)) (with-current-buffer buffer (if (> (buffer-size) 0) ;; Non-empty overview, write it to a file. (let ((coding-system-for-write gnus-cache-overview-coding-system)) (gnus-write-buffer overview-file)) (let ((file-name-coding-system nnmail-pathname-coding-system)) ;; Empty overview file, remove it (when (file-exists-p overview-file) (delete-file overview-file)) ;; If possible, remove group's cache subdirectory. (condition-case nil ;; FIXME: we can detect the error type and warn the user ;; of any inconsistencies (articles w/o nov entries?). ;; for now, just be conservative...delete only if safe -- sj (delete-directory (file-name-directory overview-file)) (error)))) (gnus-cache-update-overview-total-fetched-for (car gnus-cache-buffer) overview-file))) ;; Kill the buffer -- it's either unmodified or saved. (gnus-kill-buffer buffer) (setq gnus-cache-buffer nil)))) (defun gnus-cache-possibly-enter-article (group article ticked dormant unread &optional force) (when (and (or force (not (eq gnus-use-cache 'passive))) (numberp article) (> article 0)) ; This might be a dummy article. (let ((number article) file headers lines-chars (file-name-coding-system nnmail-pathname-coding-system)) ;; If this is a virtual group, we find the real group. (when (gnus-virtual-group-p group) (let ((result (nnvirtual-find-group-art (gnus-group-real-name group) article))) (setq group (car result) number (cdr result)))) (when (and number (> number 0) ; Reffed article. (or force (and (gnus-cache-fully-p group) (gnus-cache-member-of-class gnus-cache-enter-articles ticked dormant unread))) (not (file-exists-p (setq file (gnus-cache-file-name group number))))) ;; Possibly create the cache directory. (gnus-make-directory (file-name-directory file)) ;; Save the article in the cache. (if (file-exists-p file) t ; The article already is saved. (save-excursion (set-buffer nntp-server-buffer) (require 'gnus-art) (let ((gnus-use-cache nil) (gnus-article-decode-hook nil)) (gnus-request-article-this-buffer number group)) (when (> (buffer-size) 0) (let ((coding-system-for-write gnus-cache-coding-system)) (gnus-write-buffer file) (gnus-cache-update-file-total-fetched-for group file)) (setq lines-chars (nnheader-get-lines-and-char)) (nnheader-remove-body) (setq headers (nnheader-parse-naked-head)) (mail-header-set-number headers number) (mail-header-set-lines headers (car lines-chars)) (mail-header-set-chars headers (cadr lines-chars)) (gnus-cache-change-buffer group) (set-buffer (cdr gnus-cache-buffer)) (goto-char (point-max)) (forward-line -1) (while (condition-case () (when (not (bobp)) (> (read (current-buffer)) number)) (error ;; The line was malformed, so we just remove it!! (gnus-delete-line) t)) (forward-line -1)) (if (bobp) (if (not (eobp)) (progn (beginning-of-line) (when (< (read (current-buffer)) number) (forward-line 1))) (beginning-of-line)) (forward-line 1)) (beginning-of-line) (nnheader-insert-nov headers) ;; Update the active info. (set-buffer gnus-summary-buffer) (gnus-cache-possibly-update-active group (cons number number)) (setq gnus-newsgroup-cached (gnus-add-to-sorted-list gnus-newsgroup-cached article)) (gnus-summary-update-secondary-mark article)) t)))))) (defun gnus-cache-enter-remove-article (article) "Mark ARTICLE for later possible removal." (when article (push article gnus-cache-removable-articles))) (defun gnus-cache-possibly-remove-articles () "Possibly remove some of the removable articles." (if (not (gnus-virtual-group-p gnus-newsgroup-name)) (gnus-cache-possibly-remove-articles-1) (let ((arts gnus-cache-removable-articles) ga) (while arts (when (setq ga (nnvirtual-find-group-art (gnus-group-real-name gnus-newsgroup-name) (pop arts))) (let ((gnus-cache-removable-articles (list (cdr ga))) (gnus-newsgroup-name (car ga))) (gnus-cache-possibly-remove-articles-1))))) (setq gnus-cache-removable-articles nil))) (defun gnus-cache-possibly-remove-articles-1 () "Possibly remove some of the removable articles." (when (gnus-cache-fully-p gnus-newsgroup-name) (let ((cache-articles gnus-newsgroup-cached)) (gnus-cache-change-buffer gnus-newsgroup-name) (dolist (article gnus-cache-removable-articles) (when (memq article cache-articles) ;; The article was in the cache, so we see whether we are ;; supposed to remove it from the cache. (gnus-cache-possibly-remove-article article (memq article gnus-newsgroup-marked) (memq article gnus-newsgroup-dormant) (or (memq article gnus-newsgroup-unreads) (memq article gnus-newsgroup-unselected)))))) ;; The overview file might have been modified, save it ;; safe because we're only called at group exit anyway. (gnus-cache-save-buffers))) (defun gnus-cache-request-article (article group) "Retrieve ARTICLE in GROUP from the cache." (let ((file (gnus-cache-file-name group article)) (buffer-read-only nil) (file-name-coding-system nnmail-pathname-coding-system)) (when (file-exists-p file) (erase-buffer) (gnus-kill-all-overlays) (let ((coding-system-for-read gnus-cache-coding-system)) (insert-file-contents file)) t))) (defun gnus-cache-possibly-alter-active (group active) "Alter the ACTIVE info for GROUP to reflect the articles in the cache." (when gnus-cache-active-hashtb (let ((cache-active (gnus-gethash group gnus-cache-active-hashtb))) (when cache-active (when (< (car cache-active) (car active)) (setcar active (car cache-active))) (when (> (cdr cache-active) (cdr active)) (setcdr active (cdr cache-active))))))) (defun gnus-cache-retrieve-headers (articles group &optional fetch-old) "Retrieve the headers for ARTICLES in GROUP." (let ((cached (setq gnus-newsgroup-cached (gnus-cache-articles-in-group group)))) (if (not cached) ;; No cached articles here, so we just retrieve them ;; the normal way. (let ((gnus-use-cache nil)) (gnus-retrieve-headers articles group fetch-old)) (let ((uncached-articles (gnus-sorted-difference articles cached)) (cache-file (gnus-cache-file-name group ".overview")) type (file-name-coding-system nnmail-pathname-coding-system)) ;; We first retrieve all the headers that we don't have in ;; the cache. (let ((gnus-use-cache nil)) (when uncached-articles (setq type (and articles (gnus-retrieve-headers uncached-articles group fetch-old))))) (gnus-cache-save-buffers) ;; Then we insert the cached headers. (save-excursion (cond ((not (file-exists-p cache-file)) ;; There are no cached headers. type) ((null type) ;; There were no uncached headers (or retrieval was ;; unsuccessful), so we use the cached headers exclusively. (set-buffer nntp-server-buffer) (erase-buffer) (let ((coding-system-for-read gnus-cache-overview-coding-system)) (insert-file-contents cache-file)) 'nov) ((eq type 'nov) ;; We have both cached and uncached NOV headers, so we ;; braid them. (gnus-cache-braid-nov group cached) type) (t ;; We braid HEADs. (gnus-cache-braid-heads group (gnus-sorted-intersection cached articles)) type))))))) (defun gnus-cache-enter-article (&optional n) "Enter the next N articles into the cache. If not given a prefix, use the process marked articles instead. Returns the list of articles entered." (interactive "P") (let (out) (dolist (article (gnus-summary-work-articles n)) (gnus-summary-remove-process-mark article) (if (natnump article) (when (gnus-cache-possibly-enter-article gnus-newsgroup-name article nil nil nil t) (setq gnus-newsgroup-undownloaded (delq article gnus-newsgroup-undownloaded)) (push article out)) (gnus-message 2 "Can't cache article %d" article)) (gnus-summary-update-download-mark article) (gnus-summary-update-secondary-mark article)) (gnus-summary-next-subject 1) (gnus-summary-position-point) (nreverse out))) (defun gnus-cache-remove-article (&optional n) "Remove the next N articles from the cache. If not given a prefix, use the process marked articles instead. Returns the list of articles removed." (interactive "P") (gnus-cache-change-buffer gnus-newsgroup-name) (let (out) (dolist (article (gnus-summary-work-articles n)) (gnus-summary-remove-process-mark article) (when (gnus-cache-possibly-remove-article article nil nil nil t) (when gnus-newsgroup-agentized (let ((alist (gnus-agent-load-alist gnus-newsgroup-name))) (unless (cdr (assoc article alist)) (setq gnus-newsgroup-undownloaded (gnus-add-to-sorted-list gnus-newsgroup-undownloaded article))))) (push article out)) (gnus-summary-update-download-mark article) (gnus-summary-update-secondary-mark article)) (gnus-summary-next-subject 1) (gnus-summary-position-point) (nreverse out))) (defun gnus-cached-article-p (article) "Say whether ARTICLE is cached in the current group." (memq article gnus-newsgroup-cached)) (defun gnus-summary-insert-cached-articles () "Insert all the articles cached for this group into the current buffer." (interactive) (let ((gnus-verbose (max 6 gnus-verbose))) (if (not gnus-newsgroup-cached) (gnus-message 3 "No cached articles for this group") (gnus-summary-goto-subjects gnus-newsgroup-cached)))) (defun gnus-summary-limit-include-cached () "Limit the summary buffer to articles that are cached." (interactive) (let ((gnus-verbose (max 6 gnus-verbose))) (if gnus-newsgroup-cached (progn (gnus-summary-limit gnus-newsgroup-cached) (gnus-summary-position-point)) (gnus-message 3 "No cached articles for this group")))) ;;; Internal functions. (defun gnus-cache-change-buffer (group) (and gnus-cache-buffer ;; See if the current group's overview cache has been loaded. (or (string= group (car gnus-cache-buffer)) ;; Another overview cache is current, save it. (gnus-cache-save-buffers))) ;; if gnus-cache buffer is nil, create it (unless gnus-cache-buffer ;; Create cache buffer (save-excursion (setq gnus-cache-buffer (cons group (set-buffer (gnus-get-buffer-create " *gnus-cache-overview*")))) ;; Insert the contents of this group's cache overview. (erase-buffer) (let ((file (gnus-cache-file-name group ".overview")) (file-name-coding-system nnmail-pathname-coding-system)) (when (file-exists-p file) (nnheader-insert-file-contents file))) ;; We have a fresh (empty/just loaded) buffer, ;; mark it as unmodified to save a redundant write later. (set-buffer-modified-p nil)))) ;; Return whether an article is a member of a class. (defun gnus-cache-member-of-class (class ticked dormant unread) (or (and ticked (memq 'ticked class)) (and dormant (memq 'dormant class)) (and unread (memq 'unread class)) (and (not unread) (not ticked) (not dormant) (memq 'read class)))) (defvar gnus-cache-decoded-group-names nil "Alist of original group names and decoded group names. Decoding is done according to `gnus-group-name-charset-method-alist' or `gnus-group-name-charset-group-alist'.") (defvar gnus-cache-unified-group-names nil "Alist of unified decoded group names and original group names. A group name is decoded according to `gnus-group-name-charset-method-alist' or `gnus-group-name-charset-group-alist' first, and is encoded and decoded again according to `nnmail-pathname-coding-system', `file-name-coding-system', or `default-file-name-coding-system'. It is used when asking for a original group name from a cache directory name, in which non-ASCII characters might have been unified into the ones of a certain charset particularly if the `utf-8' coding system for example was used.") (defun gnus-cache-decoded-group-name (group) "Return a decoded group name of GROUP." (or (cdr (assoc group gnus-cache-decoded-group-names)) (let ((decoded (gnus-group-decoded-name group)) (coding (or nnmail-pathname-coding-system (and (boundp 'file-name-coding-system) file-name-coding-system) (and (boundp 'default-file-name-coding-system) default-file-name-coding-system)))) (push (cons group decoded) gnus-cache-decoded-group-names) (push (cons (mm-decode-coding-string (mm-encode-coding-string decoded coding) coding) group) gnus-cache-unified-group-names) decoded))) (defun gnus-cache-file-name (group article) (setq group (gnus-cache-decoded-group-name group)) (expand-file-name (if (stringp article) article (int-to-string article)) (file-name-as-directory (expand-file-name (nnheader-translate-file-chars (if (gnus-use-long-file-name 'not-cache) group (let ((group (nnheader-replace-duplicate-chars-in-string (nnheader-replace-chars-in-string group ?/ ?_) ?. ?_))) ;; Translate the first colon into a slash. (when (string-match ":" group) (setq group (concat (substring group 0 (match-beginning 0)) "/" (substring group (match-end 0))))) (nnheader-replace-chars-in-string group ?. ?/))) t) gnus-cache-directory)))) (defun gnus-cache-update-article (group article) "If ARTICLE is in the cache, remove it and re-enter it." (gnus-cache-change-buffer group) (when (gnus-cache-possibly-remove-article article nil nil nil t) (let ((gnus-use-cache nil)) (gnus-cache-possibly-enter-article gnus-newsgroup-name article nil nil nil t)))) (defun gnus-cache-possibly-remove-article (article ticked dormant unread &optional force) "Possibly remove ARTICLE from the cache." (let ((group gnus-newsgroup-name) (number article) file (file-name-coding-system nnmail-pathname-coding-system)) ;; If this is a virtual group, we find the real group. (when (gnus-virtual-group-p group) (let ((result (nnvirtual-find-group-art (gnus-group-real-name group) article))) (setq group (car result) number (cdr result)))) (setq file (gnus-cache-file-name group number)) (when (and (file-exists-p file) (or force (gnus-cache-member-of-class gnus-cache-remove-articles ticked dormant unread))) (save-excursion (gnus-cache-update-file-total-fetched-for group file t) (delete-file file) (set-buffer (cdr gnus-cache-buffer)) (goto-char (point-min)) (when (or (looking-at (concat (int-to-string number) "\t")) (search-forward (concat "\n" (int-to-string number) "\t") (point-max) t)) (gnus-delete-line))) (unless (setq gnus-newsgroup-cached (delq article gnus-newsgroup-cached)) (gnus-sethash gnus-newsgroup-name nil gnus-cache-active-hashtb) (setq gnus-cache-active-altered t)) (gnus-summary-update-secondary-mark article) t))) (defun gnus-cache-articles-in-group (group) "Return a sorted list of cached articles in GROUP." (let ((dir (file-name-directory (gnus-cache-file-name group 1))) articles (file-name-coding-system nnmail-pathname-coding-system)) (when (file-exists-p dir) (setq articles (sort (mapcar (lambda (name) (string-to-number name)) (directory-files dir nil "^[0-9]+$" t)) '<)) ;; Update the cache active file, just to synch more. (if articles (progn (gnus-cache-update-active group (car articles) t) (gnus-cache-update-active group (car (last articles)))) (when (gnus-gethash group gnus-cache-active-hashtb) (gnus-sethash group nil gnus-cache-active-hashtb) (setq gnus-cache-active-altered t))) articles))) (defun gnus-cache-braid-nov (group cached &optional file) (let ((cache-buf (gnus-get-buffer-create " *gnus-cache*")) beg end) (gnus-cache-save-buffers) (save-excursion (set-buffer cache-buf) (erase-buffer) (let ((coding-system-for-read gnus-cache-overview-coding-system) (file-name-coding-system nnmail-pathname-coding-system)) (insert-file-contents (or file (gnus-cache-file-name group ".overview")))) (goto-char (point-min)) (insert "\n") (goto-char (point-min))) (set-buffer nntp-server-buffer) (goto-char (point-min)) (while cached (while (and (not (eobp)) (< (read (current-buffer)) (car cached))) (forward-line 1)) (beginning-of-line) (set-buffer cache-buf) (if (search-forward (concat "\n" (int-to-string (car cached)) "\t") nil t) (setq beg (point-at-bol) end (progn (end-of-line) (point))) (setq beg nil)) (set-buffer nntp-server-buffer) (when beg (insert-buffer-substring cache-buf beg end) (insert "\n")) (setq cached (cdr cached))) (kill-buffer cache-buf))) (defun gnus-cache-braid-heads (group cached) (let ((cache-buf (gnus-get-buffer-create " *gnus-cache*"))) (with-current-buffer cache-buf (erase-buffer)) (set-buffer nntp-server-buffer) (goto-char (point-min)) (dolist (entry cached) (while (and (not (eobp)) (looking-at "2.. +\\([0-9]+\\) ") (< (progn (goto-char (match-beginning 1)) (read (current-buffer))) entry)) (search-forward "\n.\n" nil 'move)) (beginning-of-line) (set-buffer cache-buf) (erase-buffer) (let ((coding-system-for-read gnus-cache-coding-system) (file-name-coding-system nnmail-pathname-coding-system)) (insert-file-contents (gnus-cache-file-name group entry))) (goto-char (point-min)) (insert "220 ") (princ (car cached) (current-buffer)) (insert " Article retrieved.\n") (search-forward "\n\n" nil 'move) (delete-region (point) (point-max)) (forward-char -1) (insert ".") (set-buffer nntp-server-buffer) (insert-buffer-substring cache-buf)) (kill-buffer cache-buf))) ;;;###autoload (defun gnus-jog-cache () "Go through all groups and put the articles into the cache. Usage: $ emacs -batch -l ~/.emacs -l gnus -f gnus-jog-cache" (interactive) (let ((gnus-mark-article-hook nil) (gnus-expert-user t) (mail-sources nil) (gnus-use-dribble-file nil) (gnus-novice-user nil) (gnus-large-newsgroup nil)) ;; Start Gnus. (gnus) ;; Go through all groups... (gnus-group-mark-buffer) (gnus-group-iterate nil (lambda (group) (let (gnus-auto-select-next) (gnus-summary-read-group group nil t) ;; ... and enter the articles into the cache. (when (eq major-mode 'gnus-summary-mode) (gnus-uu-mark-buffer) (gnus-cache-enter-article) (kill-buffer (current-buffer)))))))) (defun gnus-cache-read-active (&optional force) "Read the cache active file." (gnus-make-directory gnus-cache-directory) (if (or (not (file-exists-p gnus-cache-active-file)) (zerop (nth 7 (file-attributes gnus-cache-active-file))) force) ;; There is no active file, so we generate one. (gnus-cache-generate-active) ;; We simply read the active file. (save-excursion (gnus-set-work-buffer) (nnheader-insert-file-contents gnus-cache-active-file) (gnus-active-to-gnus-format nil (setq gnus-cache-active-hashtb (gnus-make-hashtable (count-lines (point-min) (point-max))))) (setq gnus-cache-active-altered nil)))) (defun gnus-cache-write-active (&optional force) "Write the active hashtb to the active file." (when (or force (and gnus-cache-active-hashtb gnus-cache-active-altered)) (gnus-write-active-file gnus-cache-active-file gnus-cache-active-hashtb t) ;; Mark the active hashtb as unaltered. (setq gnus-cache-active-altered nil))) (defun gnus-cache-possibly-update-active (group active) "Update active info bounds of GROUP with ACTIVE if necessary. The update is performed if ACTIVE contains a higher or lower bound than the current." (let ((lower t) (higher t)) (if gnus-cache-active-hashtb (let ((cache-active (gnus-gethash group gnus-cache-active-hashtb))) (when cache-active (unless (< (car active) (car cache-active)) (setq lower nil)) (unless (> (cdr active) (cdr cache-active)) (setq higher nil)))) (gnus-cache-read-active)) (when lower (gnus-cache-update-active group (car active) t)) (when higher (gnus-cache-update-active group (cdr active))))) (defun gnus-cache-update-active (group number &optional low) "Update the upper bound of the active info of GROUP to NUMBER. If LOW, update the lower bound instead." (let ((active (gnus-gethash group gnus-cache-active-hashtb))) (if (null active) ;; We just create a new active entry for this group. (gnus-sethash group (cons number number) gnus-cache-active-hashtb) ;; Update the lower or upper bound. (if low (setcar active number) (setcdr active number))) ;; Mark the active hashtb as altered. (setq gnus-cache-active-altered t))) ;;;###autoload (defun gnus-cache-generate-active (&optional directory) "Generate the cache active file." (interactive) (let* ((top (null directory)) (directory (expand-file-name (or directory gnus-cache-directory))) (file-name-coding-system nnmail-pathname-coding-system) (files (directory-files directory 'full)) (group (if top "" (string-match (concat "^" (regexp-quote (file-name-as-directory (expand-file-name gnus-cache-directory)))) (directory-file-name directory)) (nnheader-replace-chars-in-string (substring (directory-file-name directory) (match-end 0)) ?/ ?.))) nums alphs) (when top (gnus-message 5 "Generating the cache active file...") (setq gnus-cache-active-hashtb (gnus-make-hashtable 123))) (when (string-match "^\\(nn[^_]+\\)_" group) (setq group (replace-match "\\1:" t nil group))) ;; Separate articles from all other files and directories. (while files (if (string-match "^[0-9]+$" (file-name-nondirectory (car files))) (push (string-to-number (file-name-nondirectory (pop files))) nums) (push (pop files) alphs))) ;; If we have nums, then this is probably a valid group. (when (setq nums (sort nums '<)) ;; Use non-decoded group name. ;; FIXME: this is kind of a workaround. The active file should ;; be updated at the time articles are cached. It will make ;; `gnus-cache-unified-group-names' needless. (gnus-sethash (or (cdr (assoc group gnus-cache-unified-group-names)) group) (cons (car nums) (gnus-last-element nums)) gnus-cache-active-hashtb)) ;; Go through all the other files. (dolist (file alphs) (when (and (file-directory-p file) (not (string-match "^\\." (file-name-nondirectory file)))) ;; We descend directories. (gnus-cache-generate-active file))) ;; Write the new active file. (when top (gnus-cache-write-active t) (gnus-message 5 "Generating the cache active file...done")))) ;;;###autoload (defun gnus-cache-generate-nov-databases (dir) "Generate NOV files recursively starting in DIR." (interactive (list gnus-cache-directory)) (gnus-cache-close) (let ((nnml-generate-active-function 'identity)) (nnml-generate-nov-databases-directory dir)) (setq gnus-cache-total-fetched-hashtb nil) (gnus-cache-open)) (defun gnus-cache-move-cache (dir) "Move the cache tree to somewhere else." (interactive "FMove the cache tree to: ") (rename-file gnus-cache-directory dir)) (defun gnus-cache-fully-p (&optional group) "Returns non-nil if the cache should be fully used. If GROUP is non-nil, also cater to `gnus-cacheable-groups' and `gnus-uncacheable-groups'." (and gnus-use-cache (not (eq gnus-use-cache 'passive)) (if (null group) t (and (or (not gnus-cacheable-groups) (string-match gnus-cacheable-groups group)) (or (not gnus-uncacheable-groups) (not (string-match gnus-uncacheable-groups group))))))) ;;;###autoload (defun gnus-cache-rename-group (old-group new-group) "Rename OLD-GROUP as NEW-GROUP. Always updates the cache, even when disabled, as the old cache files would corrupt Gnus when the cache was next enabled. It depends on the caller to determine whether group renaming is supported." (let ((old-dir (gnus-cache-file-name old-group "")) (new-dir (gnus-cache-file-name new-group "")) (file-name-coding-system nnmail-pathname-coding-system)) (gnus-rename-file old-dir new-dir t)) (gnus-cache-rename-group-total-fetched-for old-group new-group) (let ((no-save gnus-cache-active-hashtb)) (unless gnus-cache-active-hashtb (gnus-cache-read-active)) (let* ((old-group-hash-value (gnus-gethash old-group gnus-cache-active-hashtb)) (new-group-hash-value (gnus-gethash new-group gnus-cache-active-hashtb)) (delta (or old-group-hash-value new-group-hash-value))) (gnus-sethash new-group old-group-hash-value gnus-cache-active-hashtb) (gnus-sethash old-group nil gnus-cache-active-hashtb) (if no-save (setq gnus-cache-active-altered delta) (gnus-cache-write-active delta))))) ;;;###autoload (defun gnus-cache-delete-group (group) "Delete GROUP from the cache. Always updates the cache, even when disabled, as the old cache files would corrupt gnus when the cache was next enabled. Depends upon the caller to determine whether group deletion is supported." (let ((dir (gnus-cache-file-name group "")) (file-name-coding-system nnmail-pathname-coding-system)) (gnus-delete-directory dir)) (gnus-cache-delete-group-total-fetched-for group) (let ((no-save gnus-cache-active-hashtb)) (unless gnus-cache-active-hashtb (gnus-cache-read-active)) (let* ((group-hash-value (gnus-gethash group gnus-cache-active-hashtb))) (gnus-sethash group nil gnus-cache-active-hashtb) (if no-save (setq gnus-cache-active-altered group-hash-value) (gnus-cache-write-active group-hash-value))))) (defvar gnus-cache-inhibit-update-total-fetched-for nil) (defvar gnus-cache-need-update-total-fetched-for nil) (defmacro gnus-cache-with-refreshed-group (group &rest body) `(prog1 (let ((gnus-cache-inhibit-update-total-fetched-for t)) ,@body) (when (and gnus-cache-need-update-total-fetched-for (not gnus-cache-inhibit-update-total-fetched-for)) (save-excursion (set-buffer gnus-group-buffer) (setq gnus-cache-need-update-total-fetched-for nil) (gnus-group-update-group ,group t))))) (defun gnus-cache-update-file-total-fetched-for (group file &optional subtract) (when gnus-cache-total-fetched-hashtb (gnus-cache-with-refreshed-group group (let* ((entry (or (gnus-gethash group gnus-cache-total-fetched-hashtb) (gnus-sethash group (make-vector 2 0) gnus-cache-total-fetched-hashtb))) size) (if file (setq size (or (nth 7 (file-attributes file)) 0)) (let* ((file-name-coding-system nnmail-pathname-coding-system) (files (directory-files (gnus-cache-file-name group "") t nil t)) file attrs) (setq size 0.0) (while (setq file (pop files)) (setq attrs (file-attributes file)) (unless (nth 0 attrs) (incf size (float (nth 7 attrs))))))) (setq gnus-cache-need-update-total-fetched-for t) (incf (nth 1 entry) (if subtract (- size) size)))))) (defun gnus-cache-update-overview-total-fetched-for (group file) (when gnus-cache-total-fetched-hashtb (gnus-cache-with-refreshed-group group (let* ((entry (or (gnus-gethash group gnus-cache-total-fetched-hashtb) (gnus-sethash group (make-list 2 0) gnus-cache-total-fetched-hashtb))) (file-name-coding-system nnmail-pathname-coding-system) (size (or (nth 7 (file-attributes (or file (gnus-cache-file-name group ".overview")))) 0))) (setq gnus-cache-need-update-total-fetched-for t) (setf (nth 0 entry) size))))) (defun gnus-cache-rename-group-total-fetched-for (old-group new-group) "Record of disk space used by OLD-GROUP now associated with NEW-GROUP." (when gnus-cache-total-fetched-hashtb (let ((entry (gnus-gethash old-group gnus-cache-total-fetched-hashtb))) (gnus-sethash new-group entry gnus-cache-total-fetched-hashtb) (gnus-sethash old-group nil gnus-cache-total-fetched-hashtb)))) (defun gnus-cache-delete-group-total-fetched-for (group) "Delete record of disk space used by GROUP being deleted." (when gnus-cache-total-fetched-hashtb (gnus-sethash group nil gnus-cache-total-fetched-hashtb))) (defun gnus-cache-total-fetched-for (group &optional no-inhibit) "Get total disk space used by the cache for the specified GROUP." (unless (equal group "dummy.group") (unless gnus-cache-total-fetched-hashtb (setq gnus-cache-total-fetched-hashtb (gnus-make-hashtable 1024))) (let* ((entry (gnus-gethash group gnus-cache-total-fetched-hashtb))) (if entry (apply '+ entry) (let ((gnus-cache-inhibit-update-total-fetched-for (not no-inhibit))) (+ (gnus-cache-update-overview-total-fetched-for group nil) (gnus-cache-update-file-total-fetched-for group nil))))))) (provide 'gnus-cache) ;; arch-tag: 05a79442-8c58-4e65-bd0a-3cbb1b89a33a ;;; gnus-cache.el ends here gnus-5.11+v0.10.dfsg/lisp/gnus-topic.el0000644000175000017500000016724511004005110017652 0ustar tvainikatvainika;;; gnus-topic.el --- a folding minor mode for Gnus group buffers ;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, ;; 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc. ;; Author: Ilja Weis ;; Lars Magne Ingebrigtsen ;; Keywords: news ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 3, or (at your option) ;; any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Commentary: ;;; Code: (eval-when-compile (require 'cl)) (require 'gnus) (require 'gnus-group) (require 'gnus-start) (require 'gnus-util) (defgroup gnus-topic nil "Group topics." :group 'gnus-group) (defvar gnus-topic-mode nil "Minor mode for Gnus group buffers.") (defcustom gnus-topic-mode-hook nil "Hook run in topic mode buffers." :type 'hook :group 'gnus-topic) (when (featurep 'xemacs) (add-hook 'gnus-topic-mode-hook 'gnus-xmas-topic-menu-add)) (defcustom gnus-topic-line-format "%i[ %(%{%n%}%) -- %A ]%v\n" "Format of topic lines. It works along the same lines as a normal formatting string, with some simple extensions. %i Indentation based on topic level. %n Topic name. %v Nothing if the topic is visible, \"...\" otherwise. %g Number of groups in the topic. %a Number of unread articles in the groups in the topic. %A Number of unread articles in the groups in the topic and its subtopics. General format specifiers can also be used. See Info node `(gnus)Formatting Variables'." :link '(custom-manual "(gnus)Formatting Variables") :type 'string :group 'gnus-topic) (defcustom gnus-topic-indent-level 2 "*How much each subtopic should be indented." :type 'integer :group 'gnus-topic) (defcustom gnus-topic-display-empty-topics t "*If non-nil, display the topic lines even of topics that have no unread articles." :type 'boolean :group 'gnus-topic) ;; Internal variables. (defvar gnus-topic-active-topology nil) (defvar gnus-topic-active-alist nil) (defvar gnus-topic-unreads nil) (defvar gnus-topology-checked-p nil "Whether the topology has been checked in this session.") (defvar gnus-topic-killed-topics nil) (defvar gnus-topic-inhibit-change-level nil) (defconst gnus-topic-line-format-alist `((?n name ?s) (?v visible ?s) (?i indentation ?s) (?g number-of-groups ?d) (?a (gnus-topic-articles-in-topic entries) ?d) (?A total-number-of-articles ?d) (?l level ?d))) (defvar gnus-topic-line-format-spec nil) ;;; Utility functions (defun gnus-group-topic-name () "The name of the topic on the current line." (let ((topic (get-text-property (point-at-bol) 'gnus-topic))) (and topic (symbol-name topic)))) (defun gnus-group-topic-level () "The level of the topic on the current line." (get-text-property (point-at-bol) 'gnus-topic-level)) (defun gnus-group-topic-unread () "The number of unread articles in topic on the current line." (get-text-property (point-at-bol) 'gnus-topic-unread)) (defun gnus-topic-unread (topic) "Return the number of unread articles in TOPIC." (or (cdr (assoc topic gnus-topic-unreads)) 0)) (defun gnus-group-topic-p () "Return non-nil if the current line is a topic." (gnus-group-topic-name)) (defun gnus-topic-visible-p () "Return non-nil if the current topic is visible." (get-text-property (point-at-bol) 'gnus-topic-visible)) (defun gnus-topic-articles-in-topic (entries) (let ((total 0) number) (while entries (when (numberp (setq number (car (pop entries)))) (incf total number))) total)) (defun gnus-group-topic (group) "Return the topic GROUP is a member of." (let ((alist gnus-topic-alist) out) (while alist (when (member group (cdar alist)) (setq out (caar alist) alist nil)) (setq alist (cdr alist))) out)) (defun gnus-group-parent-topic (group) "Return the topic GROUP is member of by looking at the group buffer." (save-excursion (set-buffer gnus-group-buffer) (if (gnus-group-goto-group group) (gnus-current-topic) (gnus-group-topic group)))) (defun gnus-topic-goto-topic (topic) (when topic (gnus-goto-char (text-property-any (point-min) (point-max) 'gnus-topic (intern topic))))) (defun gnus-topic-jump-to-topic (topic) "Go to TOPIC." (interactive (list (completing-read "Go to topic: " (mapcar 'list (gnus-topic-list)) nil t))) (let ((buffer-read-only nil)) (dolist (topic (gnus-current-topics topic)) (unless (gnus-topic-goto-topic topic) (gnus-topic-goto-missing-topic topic) (gnus-topic-display-missing-topic topic)))) (gnus-topic-goto-topic topic)) (defun gnus-current-topic () "Return the name of the current topic." (let ((result (or (get-text-property (point) 'gnus-topic) (save-excursion (and (gnus-goto-char (previous-single-property-change (point) 'gnus-topic)) (get-text-property (max (1- (point)) (point-min)) 'gnus-topic)))))) (when result (symbol-name result)))) (defun gnus-current-topics (&optional topic) "Return a list of all current topics, lowest in hierarchy first. If TOPIC, start with that topic." (let ((topic (or topic (gnus-current-topic))) topics) (while topic (push topic topics) (setq topic (gnus-topic-parent-topic topic))) (nreverse topics))) (defun gnus-group-active-topic-p () "Say whether the current topic comes from the active topics." (get-text-property (point-at-bol) 'gnus-active)) (defun gnus-topic-find-groups (topic &optional level all lowest recursive) "Return entries for all visible groups in TOPIC. If RECURSIVE is t, return groups in its subtopics too." (let ((groups (cdr (assoc topic gnus-topic-alist))) info clevel unread group params visible-groups entry active) (setq lowest (or lowest 1)) (setq level (or level gnus-level-unsubscribed)) ;; We go through the newsrc to look for matches. (while groups (when (setq group (pop groups)) (setq entry (gnus-group-entry group) info (nth 2 entry) params (gnus-info-params info) active (gnus-active group) unread (or (car entry) (and (not (equal group "dummy.group")) active (- (1+ (cdr active)) (car active)))) clevel (or (gnus-info-level info) (if (member group gnus-zombie-list) gnus-level-zombie gnus-level-killed)))) (and info ; nil means that the group is dead. (<= clevel level) (>= clevel lowest) ; Is inside the level we want. (or all (if (or (eq unread t) (eq unread nil)) gnus-group-list-inactive-groups (> unread 0)) (and gnus-list-groups-with-ticked-articles (cdr (assq 'tick (gnus-info-marks info)))) ;; Has right readedness. ;; Check for permanent visibility. (and gnus-permanently-visible-groups (string-match gnus-permanently-visible-groups group)) (memq 'visible params) (cdr (assq 'visible params))) ;; Add this group to the list of visible groups. (push (or entry group) visible-groups))) (setq visible-groups (nreverse visible-groups)) (when recursive (if (eq recursive t) (setq recursive (cdr (gnus-topic-find-topology topic)))) (dolist (topic-topology (cdr recursive)) (setq visible-groups (nconc visible-groups (gnus-topic-find-groups (caar topic-topology) level all lowest topic-topology))))) visible-groups)) (defun gnus-topic-goto-previous-topic (n) "Go to the N'th previous topic." (interactive "p") (gnus-topic-goto-next-topic (- n))) (defun gnus-topic-goto-next-topic (n) "Go to the N'th next topic." (interactive "p") (let ((backward (< n 0)) (n (abs n)) (topic (gnus-current-topic))) (while (and (> n 0) (setq topic (if backward (gnus-topic-previous-topic topic) (gnus-topic-next-topic topic)))) (gnus-topic-goto-topic topic) (setq n (1- n))) (when (/= 0 n) (gnus-message 7 "No more topics")) n)) (defun gnus-topic-previous-topic (topic) "Return the previous topic on the same level as TOPIC." (let ((top (cddr (gnus-topic-find-topology (gnus-topic-parent-topic topic))))) (unless (equal topic (caaar top)) (while (and top (not (equal (caaadr top) topic))) (setq top (cdr top))) (caaar top)))) (defun gnus-topic-parent-topic (topic &optional topology) "Return the parent of TOPIC." (unless topology (setq topology gnus-topic-topology)) (let ((parent (car (pop topology))) result found) (while (and topology (not (setq found (equal (caaar topology) topic))) (not (setq result (gnus-topic-parent-topic topic (car topology))))) (setq topology (cdr topology))) (or result (and found parent)))) (defun gnus-topic-next-topic (topic &optional previous) "Return the next sibling of TOPIC." (let ((parentt (cddr (gnus-topic-find-topology (gnus-topic-parent-topic topic)))) prev) (while (and parentt (not (equal (caaar parentt) topic))) (setq prev (caaar parentt) parentt (cdr parentt))) (if previous prev (caaadr parentt)))) (defun gnus-topic-forward-topic (num) "Go to the next topic on the same level as the current one." (let* ((topic (gnus-current-topic)) (way (if (< num 0) 'gnus-topic-previous-topic 'gnus-topic-next-topic)) (num (abs num))) (while (and (not (zerop num)) (setq topic (funcall way topic))) (when (gnus-topic-goto-topic topic) (decf num))) (unless (zerop num) (goto-char (point-max))) num)) (defun gnus-topic-find-topology (topic &optional topology level remove) "Return the topology of TOPIC." (unless topology (setq topology gnus-topic-topology) (setq level 0)) (let ((top topology) result) (if (equal (caar topology) topic) (progn (when remove (delq topology remove)) (cons level topology)) (setq topology (cdr topology)) (while (and topology (not (setq result (gnus-topic-find-topology topic (car topology) (1+ level) (and remove top))))) (setq topology (cdr topology))) result))) (defvar gnus-tmp-topics nil) (defun gnus-topic-list (&optional topology) "Return a list of all topics in the topology." (unless topology (setq topology gnus-topic-topology gnus-tmp-topics nil)) (push (caar topology) gnus-tmp-topics) (mapc 'gnus-topic-list (cdr topology)) gnus-tmp-topics) ;;; Topic parameter jazz (defun gnus-topic-parameters (topic) "Return the parameters for TOPIC." (let ((top (gnus-topic-find-topology topic))) (when top (nth 3 (cadr top))))) (defun gnus-topic-set-parameters (topic parameters) "Set the topic parameters of TOPIC to PARAMETERS." (let ((top (gnus-topic-find-topology topic))) (unless top (error "No such topic: %s" topic)) ;; We may have to extend if there is no parameters here ;; to begin with. (unless (nthcdr 2 (cadr top)) (nconc (cadr top) (list nil))) (unless (nthcdr 3 (cadr top)) (nconc (cadr top) (list nil))) (setcar (nthcdr 3 (cadr top)) parameters) (gnus-dribble-enter (format "(gnus-topic-set-parameters %S '%S)" topic parameters)))) (defun gnus-group-topic-parameters (group) "Compute the group parameters for GROUP in topic mode. Possibly inherit parameters from topics above GROUP." (let ((params-list (copy-sequence (gnus-group-get-parameter group)))) (save-excursion (gnus-topic-hierarchical-parameters ;; First we try to go to the group within the group buffer and find the ;; topic for the group that way. This hopefully copes well with groups ;; that are in more than one topic. Failing that (i.e. when the group ;; isn't visible in the group buffer) we find a topic for the group via ;; gnus-group-topic. (or (and (gnus-group-goto-group group) (gnus-current-topic)) (gnus-group-topic group)) params-list)))) (defun gnus-topic-hierarchical-parameters (topic &optional group-params-list) "Compute the topic parameters for TOPIC. Possibly inherit parameters from topics above TOPIC. If optional argument GROUP-PARAMS-LIST is non-nil, use it as the basis for inheritance." (let ((params-list ;; We probably have lots of nil elements here, so we remove them. ;; Probably faster than doing this "properly". (delq nil (cons group-params-list (mapcar 'gnus-topic-parameters (gnus-current-topics topic))))) param out params) ;; Now we have all the parameters, so we go through them ;; and do inheritance in the obvious way. (let (posting-style) (while (setq params (pop params-list)) (while (setq param (pop params)) (when (atom param) (setq param (cons param t))) (cond ((eq (car param) 'posting-style) (let ((param (cdr param)) elt) (while (setq elt (pop param)) (unless (assoc (car elt) posting-style) (push elt posting-style))))) (t (unless (assq (car param) out) (push param out)))))) (and posting-style (push (cons 'posting-style posting-style) out))) ;; Return the resulting parameter list. out)) ;;; General utility functions (defun gnus-topic-enter-dribble () (gnus-dribble-enter (format "(setq gnus-topic-topology '%S)" gnus-topic-topology))) ;;; Generating group buffers (defun gnus-group-prepare-topics (level &optional predicate lowest regexp list-topic topic-level) "List all newsgroups with unread articles of level LEVEL or lower. Use the `gnus-group-topics' to sort the groups. If PREDICTE is a function, list groups that the function returns non-nil; if it is t, list groups that have no unread articles. If LOWEST is non-nil, list all newsgroups of level LOWEST or higher." (set-buffer gnus-group-buffer) (let ((buffer-read-only nil) (lowest (or lowest 1)) (not-in-list (and gnus-group-listed-groups (copy-sequence gnus-group-listed-groups)))) (gnus-update-format-specifications nil 'topic) (when (or (not gnus-topic-alist) (not gnus-topology-checked-p)) (gnus-topic-check-topology)) (unless list-topic (erase-buffer)) ;; List dead groups? (when (or gnus-group-listed-groups (and (>= level gnus-level-zombie) (<= lowest gnus-level-zombie))) (gnus-group-prepare-flat-list-dead (setq gnus-zombie-list (sort gnus-zombie-list 'string<)) gnus-level-zombie ?Z regexp)) (when (or gnus-group-listed-groups (and (>= level gnus-level-killed) (<= lowest gnus-level-killed))) (gnus-group-prepare-flat-list-dead (setq gnus-killed-list (sort gnus-killed-list 'string<)) gnus-level-killed ?K regexp) (when not-in-list (unless gnus-killed-hashtb (gnus-make-hashtable-from-killed)) (gnus-group-prepare-flat-list-dead (gnus-remove-if (lambda (group) (or (gnus-group-entry group) (gnus-gethash group gnus-killed-hashtb))) not-in-list) gnus-level-killed ?K regexp))) ;; Use topics. (prog1 (when (or (< lowest gnus-level-zombie) gnus-group-listed-groups) (if list-topic (let ((top (gnus-topic-find-topology list-topic))) (gnus-topic-prepare-topic (cdr top) (car top) (or topic-level level) predicate nil lowest regexp)) (gnus-topic-prepare-topic gnus-topic-topology 0 (or topic-level level) predicate nil lowest regexp))) (gnus-group-set-mode-line) (setq gnus-group-list-mode (cons level predicate)) (gnus-run-hooks 'gnus-group-prepare-hook)))) (defun gnus-topic-prepare-topic (topicl level &optional list-level predicate silent lowest regexp) "Insert TOPIC into the group buffer. If SILENT, don't insert anything. Return the number of unread articles in the topic and its subtopics." (let* ((type (pop topicl)) (entries (gnus-topic-find-groups (car type) (if gnus-group-listed-groups gnus-level-killed list-level) (or predicate gnus-group-listed-groups (cdr (assq 'visible (gnus-topic-hierarchical-parameters (car type))))) (if gnus-group-listed-groups 0 lowest))) (visiblep (and (eq (nth 1 type) 'visible) (not silent))) (gnus-group-indentation (make-string (* gnus-topic-indent-level level) ? )) (beg (progn (beginning-of-line) (point))) (topicl (reverse topicl)) (all-entries entries) (point-max (point-max)) (unread 0) (topic (car type)) info entry end active tick) ;; Insert any sub-topics. (while topicl (incf unread (gnus-topic-prepare-topic (pop topicl) (1+ level) list-level predicate (not visiblep) lowest regexp))) (setq end (point)) (goto-char beg) ;; Insert all the groups that belong in this topic. (while (setq entry (pop entries)) (when (if (stringp entry) (gnus-group-prepare-logic entry (and (or (not gnus-group-listed-groups) (if (< list-level gnus-level-zombie) nil (let ((entry-level (if (member entry gnus-zombie-list) gnus-level-zombie gnus-level-killed))) (and (<= entry-level list-level) (>= entry-level lowest))))) (cond ((stringp regexp) (string-match regexp entry)) ((functionp regexp) (funcall regexp entry)) ((null regexp) t) (t nil)))) (setq info (nth 2 entry)) (gnus-group-prepare-logic (gnus-info-group info) (and (or (not gnus-group-listed-groups) (let ((entry-level (gnus-info-level info))) (and (<= entry-level list-level) (>= entry-level lowest)))) (or (not (functionp predicate)) (funcall predicate info)) (or (not (stringp regexp)) (string-match regexp (gnus-info-group info)))))) (when visiblep (if (stringp entry) ;; Dead groups. (gnus-group-insert-group-line entry (if (member entry gnus-zombie-list) gnus-level-zombie gnus-level-killed) nil (- (1+ (cdr (setq active (gnus-active entry)))) (car active)) nil) ;; Living groups. (when (setq info (nth 2 entry)) (gnus-group-insert-group-line (gnus-info-group info) (gnus-info-level info) (gnus-info-marks info) (car entry) (gnus-info-method info))))) (when (and (listp entry) (numberp (car entry))) (incf unread (car entry))) (when (listp entry) (setq tick t)))) (goto-char beg) ;; Insert the topic line. (when (and (not silent) (or gnus-topic-display-empty-topics ;We want empty topics (not (zerop unread)) ;Non-empty tick ;Ticked articles (/= point-max (point-max)))) ;Unactivated groups (gnus-extent-start-open (point)) (gnus-topic-insert-topic-line (car type) visiblep (not (eq (nth 2 type) 'hidden)) level all-entries unread)) (gnus-topic-update-unreads (car type) unread) (when gnus-group-update-tool-bar (gnus-put-text-property beg end 'point-entered 'gnus-tool-bar-update) (gnus-put-text-property beg end 'point-left 'gnus-tool-bar-update)) (goto-char end) unread)) (defun gnus-topic-remove-topic (&optional insert total-remove hide in-level) "Remove the current topic." (let ((topic (gnus-group-topic-name)) (level (gnus-group-topic-level)) (beg (progn (beginning-of-line) (point))) buffer-read-only) (when topic (while (and (zerop (forward-line 1)) (> (or (gnus-group-topic-level) (1+ level)) level))) (delete-region beg (point)) ;; Do the change in this rather odd manner because it has been ;; reported that some topics share parts of some lists, for some ;; reason. I have been unable to determine why this is the ;; case, but this hack seems to take care of things. (let ((data (cadr (gnus-topic-find-topology topic)))) (setcdr data (list (if insert 'visible 'invisible) (caddr data) (cadddr data)))) (if total-remove (setq gnus-topic-alist (delq (assoc topic gnus-topic-alist) gnus-topic-alist)) (gnus-topic-insert-topic topic in-level))))) (defun gnus-topic-insert-topic (topic &optional level) "Insert TOPIC." (gnus-group-prepare-topics (car gnus-group-list-mode) (cdr gnus-group-list-mode) nil nil topic level)) (defun gnus-topic-fold (&optional insert topic) "Remove/insert the current topic." (let ((topic (or topic (gnus-group-topic-name)))) (when topic (save-excursion (if (not (gnus-group-active-topic-p)) (gnus-topic-remove-topic (or insert (not (gnus-topic-visible-p)))) (let ((gnus-topic-topology gnus-topic-active-topology) (gnus-topic-alist gnus-topic-active-alist) (gnus-group-list-mode (cons 5 t))) (gnus-topic-remove-topic (or insert (not (gnus-topic-visible-p))) nil nil 9) (gnus-topic-enter-dribble))))))) (defun gnus-topic-insert-topic-line (name visiblep shownp level entries &optional unread) (let* ((visible (if visiblep "" "...")) (indentation (make-string (* gnus-topic-indent-level level) ? )) (total-number-of-articles unread) (number-of-groups (length entries)) (active-topic (eq gnus-topic-alist gnus-topic-active-alist)) gnus-tmp-header) (gnus-topic-update-unreads name unread) (beginning-of-line) ;; Insert the text. (if shownp (gnus-add-text-properties (point) (prog1 (1+ (point)) (eval gnus-topic-line-format-spec)) (list 'gnus-topic (intern name) 'gnus-topic-level level 'gnus-topic-unread unread 'gnus-active active-topic 'gnus-topic-visible visiblep))))) (defun gnus-topic-update-unreads (topic unreads) (setq gnus-topic-unreads (delq (assoc topic gnus-topic-unreads) gnus-topic-unreads)) (push (cons topic unreads) gnus-topic-unreads)) (defun gnus-topic-update-topics-containing-group (group) "Update all topics that have GROUP as a member." (when (and (eq major-mode 'gnus-group-mode) gnus-topic-mode) (save-excursion (let ((alist gnus-topic-alist)) ;; This is probably not entirely correct. If a topic ;; isn't shown, then it's not updated. But the updating ;; should be performed in any case, since the topic's ;; parent should be updated. Pfft. (while alist (when (and (member group (cdar alist)) (gnus-topic-goto-topic (caar alist))) (gnus-topic-update-topic-line (caar alist))) (pop alist)))))) (defun gnus-topic-update-topic () "Update all parent topics to the current group." (when (and (eq major-mode 'gnus-group-mode) gnus-topic-mode) (let ((group (gnus-group-group-name)) (m (point-marker)) (buffer-read-only nil)) (when (and group (gnus-get-info group) (gnus-topic-goto-topic (gnus-current-topic))) (gnus-topic-update-topic-line (gnus-group-topic-name)) (goto-char m) (set-marker m nil) (gnus-group-position-point))))) (defun gnus-topic-goto-missing-group (group) "Place point where GROUP is supposed to be inserted." (let* ((topic (gnus-group-topic group)) (groups (cdr (assoc topic gnus-topic-alist))) (g (cdr (member group groups))) (unfound t) entry) ;; Try to jump to a visible group. (while (and g (not (gnus-group-goto-group (car g) t))) (pop g)) ;; It wasn't visible, so we try to see where to insert it. (when (not g) (setq g (cdr (member group (reverse groups)))) (while (and g unfound) (when (gnus-group-goto-group (pop g) t) (forward-line 1) (setq unfound nil))) (when (and unfound topic (not (gnus-topic-goto-missing-topic topic))) (gnus-topic-display-missing-topic topic))))) (defun gnus-topic-display-missing-topic (topic) "Insert topic lines recursively for missing topics." (let ((parent (gnus-topic-find-topology (gnus-topic-parent-topic topic)))) (when (and parent (not (gnus-topic-goto-missing-topic (caadr parent)))) (gnus-topic-display-missing-topic (caadr parent)))) (gnus-topic-goto-missing-topic topic) ;; Skip past all groups in the topic we're in. (while (gnus-group-group-name) (forward-line 1)) (let* ((top (gnus-topic-find-topology topic)) (children (cddr top)) (type (cadr top)) (unread 0) (entries (gnus-topic-find-groups (car type) (car gnus-group-list-mode) (cdr gnus-group-list-mode))) entry) (while children (incf unread (gnus-topic-unread (caar (pop children))))) (while (setq entry (pop entries)) (when (numberp (car entry)) (incf unread (car entry)))) (gnus-topic-insert-topic-line topic t t (car (gnus-topic-find-topology topic)) nil unread))) (defun gnus-topic-goto-missing-topic (topic) (if (gnus-topic-goto-topic topic) (forward-line 1) ;; Topic not displayed. (let* ((top (gnus-topic-find-topology (gnus-topic-parent-topic topic))) (tp (reverse (cddr top)))) (if (not top) (gnus-topic-insert-topic-line topic t t (car (gnus-topic-find-topology topic)) nil 0) (while (not (equal (caaar tp) topic)) (setq tp (cdr tp))) (pop tp) (while (and tp (not (gnus-topic-goto-topic (caaar tp)))) (pop tp)) (if tp (gnus-topic-forward-topic 1) (gnus-topic-goto-missing-topic (caadr top))))) nil)) (defun gnus-topic-update-topic-line (topic-name &optional reads) (let* ((top (gnus-topic-find-topology topic-name)) (type (cadr top)) (children (cddr top)) (entries (gnus-topic-find-groups (car type) (car gnus-group-list-mode) (cdr gnus-group-list-mode))) (parent (gnus-topic-parent-topic topic-name)) (all-entries entries) (unread 0) old-unread entry new-unread) (when (gnus-topic-goto-topic (car type)) ;; Tally all the groups that belong in this topic. (if reads (setq unread (- (gnus-group-topic-unread) reads)) (while children (incf unread (gnus-topic-unread (caar (pop children))))) (while (setq entry (pop entries)) (when (numberp (car entry)) (incf unread (car entry))))) (setq old-unread (gnus-group-topic-unread)) ;; Insert the topic line. (gnus-topic-insert-topic-line (car type) (gnus-topic-visible-p) (not (eq (nth 2 type) 'hidden)) (gnus-group-topic-level) all-entries unread) (gnus-delete-line) (forward-line -1) (setq new-unread (gnus-group-topic-unread))) (when parent (forward-line -1) (gnus-topic-update-topic-line parent (- (or old-unread 0) (or new-unread 0)))) unread)) (defun gnus-topic-group-indentation () (make-string (* gnus-topic-indent-level (or (save-excursion (forward-line -1) (gnus-topic-goto-topic (gnus-current-topic)) (gnus-group-topic-level)) 0)) ? )) ;;; Initialization (gnus-add-shutdown 'gnus-topic-close 'gnus) (defun gnus-topic-close () (setq gnus-topic-active-topology nil gnus-topic-active-alist nil gnus-topic-killed-topics nil gnus-topology-checked-p nil)) (defun gnus-topic-check-topology () ;; The first time we set the topology to whatever we have ;; gotten here, which can be rather random. (unless gnus-topic-alist (gnus-topic-init-alist)) (setq gnus-topology-checked-p t) ;; Go through the topic alist and make sure that all topics ;; are in the topic topology. (let ((topics (gnus-topic-list)) (alist gnus-topic-alist) changed) (while alist (unless (member (caar alist) topics) (nconc gnus-topic-topology (list (list (list (caar alist) 'visible)))) (setq changed t)) (setq alist (cdr alist))) (when changed (gnus-topic-enter-dribble)) ;; Conversely, go through the topology and make sure that all ;; topologies have alists. (while topics (unless (assoc (car topics) gnus-topic-alist) (push (list (car topics)) gnus-topic-alist)) (pop topics))) ;; Go through all living groups and make sure that ;; they belong to some topic. (let* ((tgroups (apply 'append (mapcar 'cdr gnus-topic-alist))) (entry (last (assoc (caar gnus-topic-topology) gnus-topic-alist))) (newsrc (cdr gnus-newsrc-alist)) group) (while newsrc (unless (member (setq group (gnus-info-group (pop newsrc))) tgroups) (setcdr entry (list group)) (setq entry (cdr entry))))) ;; Go through all topics and make sure they contain only living groups. (let ((alist gnus-topic-alist) topic) (while (setq topic (pop alist)) (while (cdr topic) (if (and (cadr topic) (gnus-group-entry (cadr topic))) (setq topic (cdr topic)) (setcdr topic (cddr topic))))))) (defun gnus-topic-init-alist () "Initialize the topic structures." (setq gnus-topic-topology (cons (list "Gnus" 'visible) (mapcar (lambda (topic) (list (list (car topic) 'visible))) '(("misc"))))) (setq gnus-topic-alist (list (cons "misc" (mapcar (lambda (info) (gnus-info-group info)) (cdr gnus-newsrc-alist))) (list "Gnus"))) (gnus-topic-enter-dribble)) ;;; Maintenance (defun gnus-topic-clean-alist () "Remove bogus groups from the topic alist." (let ((topic-alist gnus-topic-alist) result topic) (unless gnus-killed-hashtb (gnus-make-hashtable-from-killed)) (while (setq topic (pop topic-alist)) (let ((topic-name (pop topic)) group filtered-topic) (while (setq group (pop topic)) (when (and (or (gnus-active group) (gnus-info-method (gnus-get-info group))) (not (gnus-gethash group gnus-killed-hashtb))) (push group filtered-topic))) (push (cons topic-name (nreverse filtered-topic)) result))) (setq gnus-topic-alist (nreverse result)))) (defun gnus-topic-change-level (group level oldlevel &optional previous) "Run when changing levels to enter/remove groups from topics." (save-excursion (set-buffer gnus-group-buffer) (let ((buffer-read-only nil)) (unless gnus-topic-inhibit-change-level (gnus-group-goto-group (or (car (nth 2 previous)) group)) (when (and gnus-topic-mode gnus-topic-alist (not gnus-topic-inhibit-change-level)) ;; Remove the group from the topics. (if (and (< oldlevel gnus-level-zombie) (>= level gnus-level-zombie)) (let ((alist gnus-topic-alist)) (while (gnus-group-goto-group group) (gnus-delete-line)) (while alist (when (member group (car alist)) (setcdr (car alist) (delete group (cdar alist)))) (pop alist))) ;; If the group is subscribed we enter it into the topics. (when (and (< level gnus-level-zombie) (>= oldlevel gnus-level-zombie)) (let* ((prev (gnus-group-group-name)) (gnus-topic-inhibit-change-level t) (gnus-group-indentation (make-string (* gnus-topic-indent-level (or (save-excursion (gnus-topic-goto-topic (gnus-current-topic)) (gnus-group-topic-level)) 0)) ? )) (yanked (list group)) alist talist end) ;; Then we enter the yanked groups into the topics ;; they belong to. (when (setq alist (assoc (save-excursion (forward-line -1) (or (gnus-current-topic) (caar gnus-topic-topology))) gnus-topic-alist)) (setq talist alist) (when (stringp yanked) (setq yanked (list yanked))) (if (not prev) (nconc alist yanked) (if (not (cdr alist)) (setcdr alist (nconc yanked (cdr alist))) (while (and (not end) (cdr alist)) (when (equal (cadr alist) prev) (setcdr alist (nconc yanked (cdr alist))) (setq end t)) (setq alist (cdr alist))) (unless end (nconc talist yanked)))))) (gnus-topic-update-topic)))))))) (defun gnus-topic-goto-next-group (group props) "Go to group or the next group after group." (if (not group) (if (not (memq 'gnus-topic props)) (goto-char (point-max)) (gnus-topic-goto-topic (symbol-name (cadr (memq 'gnus-topic props))))) (if (gnus-group-goto-group group) t ;; The group is no longer visible. (let* ((list (assoc (gnus-group-topic group) gnus-topic-alist)) (after (cdr (member group (cdr list))))) ;; First try to put point on a group after the current one. (while (and after (not (gnus-group-goto-group (car after)))) (setq after (cdr after))) ;; Then try to put point on a group before point. (unless after (setq after (cdr (member group (reverse (cdr list))))) (while (and after (not (gnus-group-goto-group (car after)))) (setq after (cdr after)))) ;; Finally, just put point on the topic. (if (not (car list)) (goto-char (point-min)) (unless after (gnus-topic-goto-topic (car list)) (setq after nil))) t)))) ;;; Topic-active functions (defun gnus-topic-grok-active (&optional force) "Parse all active groups and create topic structures for them." ;; First we make sure that we have really read the active file. (when (or force (not gnus-topic-active-alist)) (let (groups) ;; Get a list of all groups available. (mapatoms (lambda (g) (when (symbol-value g) (push (symbol-name g) groups))) gnus-active-hashtb) (setq groups (sort groups 'string<)) ;; Init the variables. (setq gnus-topic-active-topology (list (list "" 'visible))) (setq gnus-topic-active-alist nil) ;; Descend the top-level hierarchy. (gnus-topic-grok-active-1 gnus-topic-active-topology groups) ;; Set the top-level topic names to something nice. (setcar (car gnus-topic-active-topology) "Gnus active") (setcar (car gnus-topic-active-alist) "Gnus active")))) (defun gnus-topic-grok-active-1 (topology groups) (let* ((name (caar topology)) (prefix (concat "^" (regexp-quote name))) tgroups ntopology group) (while (and groups (string-match prefix (setq group (car groups)))) (if (not (string-match "\\." group (match-end 0))) ;; There are no further hierarchies here, so we just ;; enter this group into the list belonging to this ;; topic. (push (pop groups) tgroups) ;; New sub-hierarchy, so we add it to the topology. (nconc topology (list (setq ntopology (list (list (substring group 0 (match-end 0)) 'invisible))))) ;; Descend the hierarchy. (setq groups (gnus-topic-grok-active-1 ntopology groups)))) ;; We remove the trailing "." from the topic name. (setq name (if (string-match "\\.$" name) (substring name 0 (match-beginning 0)) name)) ;; Add this topic and its groups to the topic alist. (push (cons name (nreverse tgroups)) gnus-topic-active-alist) (setcar (car topology) name) ;; We return the rest of the groups that didn't belong ;; to this topic. groups)) ;;; Topic mode, commands and keymap. (defvar gnus-topic-mode-map nil) (defvar gnus-group-topic-map nil) (unless gnus-topic-mode-map (setq gnus-topic-mode-map (make-sparse-keymap)) ;; Override certain group mode keys. (gnus-define-keys gnus-topic-mode-map "=" gnus-topic-select-group "\r" gnus-topic-select-group " " gnus-topic-read-group "\C-c\C-x" gnus-topic-expire-articles "c" gnus-topic-catchup-articles "\C-k" gnus-topic-kill-group "\C-y" gnus-topic-yank-group "\M-g" gnus-topic-get-new-news-this-topic "AT" gnus-topic-list-active "Gp" gnus-topic-edit-parameters "#" gnus-topic-mark-topic "\M-#" gnus-topic-unmark-topic [tab] gnus-topic-indent [(meta tab)] gnus-topic-unindent "\C-i" gnus-topic-indent "\M-\C-i" gnus-topic-unindent gnus-mouse-2 gnus-mouse-pick-topic) ;; Define a new submap. (gnus-define-keys (gnus-group-topic-map "T" gnus-group-mode-map) "#" gnus-topic-mark-topic "\M-#" gnus-topic-unmark-topic "n" gnus-topic-create-topic "m" gnus-topic-move-group "D" gnus-topic-remove-group "c" gnus-topic-copy-group "h" gnus-topic-hide-topic "s" gnus-topic-show-topic "j" gnus-topic-jump-to-topic "M" gnus-topic-move-matching "C" gnus-topic-copy-matching "\M-p" gnus-topic-goto-previous-topic "\M-n" gnus-topic-goto-next-topic "\C-i" gnus-topic-indent [tab] gnus-topic-indent "r" gnus-topic-rename "\177" gnus-topic-delete [delete] gnus-topic-delete "H" gnus-topic-toggle-display-empty-topics) (gnus-define-keys (gnus-topic-sort-map "S" gnus-group-topic-map) "s" gnus-topic-sort-groups "a" gnus-topic-sort-groups-by-alphabet "u" gnus-topic-sort-groups-by-unread "l" gnus-topic-sort-groups-by-level "e" gnus-topic-sort-groups-by-server "v" gnus-topic-sort-groups-by-score "r" gnus-topic-sort-groups-by-rank "m" gnus-topic-sort-groups-by-method)) (defun gnus-topic-make-menu-bar () (unless (boundp 'gnus-topic-menu) (easy-menu-define gnus-topic-menu gnus-topic-mode-map "" '("Topics" ["Toggle topics" gnus-topic-mode t] ("Groups" ["Copy..." gnus-topic-copy-group t] ["Move..." gnus-topic-move-group t] ["Remove" gnus-topic-remove-group t] ["Copy matching..." gnus-topic-copy-matching t] ["Move matching..." gnus-topic-move-matching t]) ("Topics" ["Goto..." gnus-topic-jump-to-topic t] ["Show" gnus-topic-show-topic t] ["Hide" gnus-topic-hide-topic t] ["Delete" gnus-topic-delete t] ["Rename..." gnus-topic-rename t] ["Create..." gnus-topic-create-topic t] ["Mark" gnus-topic-mark-topic t] ["Indent" gnus-topic-indent t] ["Sort" gnus-topic-sort-topics t] ["Previous topic" gnus-topic-goto-previous-topic t] ["Next topic" gnus-topic-goto-next-topic t] ["Toggle hide empty" gnus-topic-toggle-display-empty-topics t] ["Edit parameters" gnus-topic-edit-parameters t]) ["List active" gnus-topic-list-active t])))) (defun gnus-topic-mode (&optional arg redisplay) "Minor mode for topicsifying Gnus group buffers." (interactive (list current-prefix-arg t)) (when (eq major-mode 'gnus-group-mode) (make-local-variable 'gnus-topic-mode) (setq gnus-topic-mode (if (null arg) (not gnus-topic-mode) (> (prefix-numeric-value arg) 0))) ;; Infest Gnus with topics. (if (not gnus-topic-mode) (setq gnus-goto-missing-group-function nil) (when (gnus-visual-p 'topic-menu 'menu) (gnus-topic-make-menu-bar)) (gnus-set-format 'topic t) (add-minor-mode 'gnus-topic-mode " Topic" gnus-topic-mode-map) (add-hook 'gnus-group-catchup-group-hook 'gnus-topic-update-topic) (set (make-local-variable 'gnus-group-prepare-function) 'gnus-group-prepare-topics) (set (make-local-variable 'gnus-group-get-parameter-function) 'gnus-group-topic-parameters) (set (make-local-variable 'gnus-group-goto-next-group-function) 'gnus-topic-goto-next-group) (set (make-local-variable 'gnus-group-indentation-function) 'gnus-topic-group-indentation) (set (make-local-variable 'gnus-group-update-group-function) 'gnus-topic-update-topics-containing-group) (set (make-local-variable 'gnus-group-sort-alist-function) 'gnus-group-sort-topic) (setq gnus-group-change-level-function 'gnus-topic-change-level) (setq gnus-goto-missing-group-function 'gnus-topic-goto-missing-group) (gnus-make-local-hook 'gnus-check-bogus-groups-hook) (add-hook 'gnus-check-bogus-groups-hook 'gnus-topic-clean-alist nil 'local) (setq gnus-topology-checked-p nil) ;; We check the topology. (when gnus-newsrc-alist (gnus-topic-check-topology)) (gnus-run-hooks 'gnus-topic-mode-hook)) ;; Remove topic infestation. (unless gnus-topic-mode (remove-hook 'gnus-summary-exit-hook 'gnus-topic-update-topic) (setq gnus-group-change-level-function nil) (remove-hook 'gnus-check-bogus-groups-hook 'gnus-topic-clean-alist) (setq gnus-group-prepare-function 'gnus-group-prepare-flat) (setq gnus-group-sort-alist-function 'gnus-group-sort-flat)) (when redisplay (gnus-group-list-groups)))) (defun gnus-topic-select-group (&optional all) "Select this newsgroup. No article is selected automatically. If the group is opened, just switch the summary buffer. If ALL is non-nil, already read articles become readable. If ALL is a positive number, fetch this number of the latest articles in the group. If ALL is a negative number, fetch this number of the earliest articles in the group. If performed over a topic line, toggle folding the topic." (interactive "P") (when (and (eobp) (not (gnus-group-group-name))) (forward-line -1)) (if (gnus-group-topic-p) (let ((gnus-group-list-mode (if all (cons (if (numberp all) all 7) t) gnus-group-list-mode))) (gnus-topic-fold all) (gnus-dribble-touch)) (gnus-group-select-group all))) (defun gnus-mouse-pick-topic (e) "Select the group or topic under the mouse pointer." (interactive "e") (mouse-set-point e) (gnus-topic-read-group nil)) (defun gnus-topic-expire-articles (topic) "Expire articles in this topic or group." (interactive (list (gnus-group-topic-name))) (if (not topic) (call-interactively 'gnus-group-expire-articles) (save-excursion (gnus-message 5 "Expiring groups in %s..." topic) (let ((gnus-group-marked (mapcar (lambda (entry) (car (nth 2 entry))) (gnus-topic-find-groups topic gnus-level-killed t nil t)))) (gnus-group-expire-articles nil)) (gnus-message 5 "Expiring groups in %s...done" topic)))) (defun gnus-topic-catchup-articles (topic) "Catchup this topic or group. Also see `gnus-group-catchup'." (interactive (list (gnus-group-topic-name))) (if (not topic) (call-interactively 'gnus-group-catchup-current) (save-excursion (let* ((groups (mapcar (lambda (entry) (car (nth 2 entry))) (gnus-topic-find-groups topic gnus-level-killed t nil t))) (buffer-read-only nil) (gnus-group-marked groups)) (gnus-group-catchup-current) (mapcar 'gnus-topic-update-topics-containing-group groups))))) (defun gnus-topic-read-group (&optional all no-article group) "Read news in this newsgroup. If the prefix argument ALL is non-nil, already read articles become readable. If ALL is a positive number, fetch this number of the latest articles in the group. If ALL is a negative number, fetch this number of the earliest articles in the group. If the optional argument NO-ARTICLE is non-nil, no article will be auto-selected upon group entry. If GROUP is non-nil, fetch that group. If performed over a topic line, toggle folding the topic." (interactive "P") (if (gnus-group-topic-p) (let ((gnus-group-list-mode (if all (cons (if (numberp all) all 7) t) gnus-group-list-mode))) (gnus-topic-fold all)) (gnus-group-read-group all no-article group))) (defun gnus-topic-create-topic (topic parent &optional previous full-topic) "Create a new TOPIC under PARENT. When used interactively, PARENT will be the topic under point." (interactive (list (read-string "New topic: ") (gnus-current-topic))) ;; Check whether this topic already exists. (when (gnus-topic-find-topology topic) (error "Topic already exists")) (unless parent (setq parent (caar gnus-topic-topology))) (let ((top (cdr (gnus-topic-find-topology parent))) (full-topic (or full-topic (list (list topic 'visible nil nil))))) (unless top (error "No such parent topic: %s" parent)) (if previous (progn (while (and (cdr top) (not (equal (caaadr top) previous))) (setq top (cdr top))) (setcdr top (cons full-topic (cdr top)))) (nconc top (list full-topic))) (unless (assoc topic gnus-topic-alist) (push (list topic) gnus-topic-alist))) (gnus-topic-enter-dribble) (gnus-group-list-groups) (gnus-topic-goto-topic topic)) ;; FIXME: ;; 1. When the marked groups are overlapped with the process ;; region, the behavior of move or remove is not right. ;; 2. Can't process on several marked groups with a same name, ;; because gnus-group-marked only keeps one copy. (defun gnus-topic-move-group (n topic &optional copyp) "Move the next N groups to TOPIC. If COPYP, copy the groups instead." (interactive (list current-prefix-arg (gnus-completing-read "Move to topic" gnus-topic-alist nil t 'gnus-topic-history))) (let ((use-marked (and (not n) (not (gnus-region-active-p)) gnus-group-marked t)) (groups (gnus-group-process-prefix n)) (topicl (assoc topic gnus-topic-alist)) (start-topic (gnus-group-topic-name)) (start-group (progn (forward-line 1) (gnus-group-group-name))) entry) (if (and (not groups) (not copyp) start-topic) (gnus-topic-move start-topic topic) (dolist (g groups) (gnus-group-remove-mark g use-marked) (when (and (setq entry (assoc (gnus-current-topic) gnus-topic-alist)) (not copyp)) (setcdr entry (gnus-delete-first g (cdr entry)))) (nconc topicl (list g))) (gnus-topic-enter-dribble) (if start-group (gnus-group-goto-group start-group) (gnus-topic-goto-topic start-topic)) (gnus-group-list-groups)))) (defun gnus-topic-remove-group (&optional n) "Remove the current group from the topic." (interactive "P") (let ((use-marked (and (not n) (not (gnus-region-active-p)) gnus-group-marked t)) (groups (gnus-group-process-prefix n))) (mapc (lambda (group) (gnus-group-remove-mark group use-marked) (let ((topicl (assoc (gnus-current-topic) gnus-topic-alist)) (buffer-read-only nil)) (when (and topicl group) (gnus-delete-line) (gnus-delete-first group topicl)) (gnus-topic-update-topic))) groups) (gnus-topic-enter-dribble) (gnus-group-position-point))) (defun gnus-topic-copy-group (n topic) "Copy the current group to a topic." (interactive (list current-prefix-arg (completing-read "Copy to topic: " gnus-topic-alist nil t))) (gnus-topic-move-group n topic t)) (defun gnus-topic-kill-group (&optional n discard) "Kill the next N groups." (interactive "P") (if (gnus-group-topic-p) (let ((topic (gnus-group-topic-name))) (push (cons (gnus-topic-find-topology topic) (assoc topic gnus-topic-alist)) gnus-topic-killed-topics) (gnus-topic-remove-topic nil t) (gnus-topic-find-topology topic nil nil gnus-topic-topology) (gnus-topic-enter-dribble)) (gnus-group-kill-group n discard) (if (not (gnus-group-topic-p)) (gnus-topic-update-topic) ;; Move up one line so that we update the right topic. (forward-line -1) (gnus-topic-update-topic) (forward-line 1)))) (defun gnus-topic-yank-group (&optional arg) "Yank the last topic." (interactive "p") (if gnus-topic-killed-topics (let* ((previous (or (gnus-group-topic-name) (gnus-topic-next-topic (gnus-current-topic)))) (data (pop gnus-topic-killed-topics)) (alist (cdr data)) (item (cdar data))) (push alist gnus-topic-alist) (gnus-topic-create-topic (caar item) (gnus-topic-parent-topic previous) previous item) (gnus-topic-enter-dribble) (gnus-topic-goto-topic (caar item))) (let* ((prev (gnus-group-group-name)) (gnus-topic-inhibit-change-level t) (gnus-group-indentation (make-string (* gnus-topic-indent-level (or (save-excursion (gnus-topic-goto-topic (gnus-current-topic)) (gnus-group-topic-level)) 0)) ? )) yanked alist) ;; We first yank the groups the normal way... (setq yanked (gnus-group-yank-group arg)) ;; Then we enter the yanked groups into the topics they belong ;; to. (setq alist (assoc (save-excursion (forward-line -1) (gnus-current-topic)) gnus-topic-alist)) (when (stringp yanked) (setq yanked (list yanked))) (if (not prev) (nconc alist yanked) (if (not (cdr alist)) (setcdr alist (nconc yanked (cdr alist))) (while (cdr alist) (when (equal (cadr alist) prev) (setcdr alist (nconc yanked (cdr alist))) (setq alist nil)) (setq alist (cdr alist)))))) (gnus-topic-update-topic))) (defun gnus-topic-hide-topic (&optional permanent) "Hide the current topic. If PERMANENT, make it stay hidden in subsequent sessions as well." (interactive "P") (when (gnus-current-topic) (gnus-topic-goto-topic (gnus-current-topic)) (if permanent (setcar (cddr (cadr (gnus-topic-find-topology (gnus-current-topic)))) 'hidden)) (gnus-topic-remove-topic nil nil))) (defun gnus-topic-show-topic (&optional permanent) "Show the hidden topic. If PERMANENT, make it stay shown in subsequent sessions as well." (interactive "P") (when (gnus-group-topic-p) (if (not permanent) (gnus-topic-remove-topic t nil) (let ((topic (gnus-topic-find-topology (completing-read "Show topic: " gnus-topic-alist nil t)))) (setcar (cddr (cadr topic)) nil) (setcar (cdr (cadr topic)) 'visible) (gnus-group-list-groups))))) (defun gnus-topic-mark-topic (topic &optional unmark non-recursive) "Mark all groups in the TOPIC with the process mark. If NON-RECURSIVE (which is the prefix) is t, don't mark its subtopics." (interactive (list (gnus-group-topic-name) nil (and current-prefix-arg t))) (if (not topic) (call-interactively 'gnus-group-mark-group) (save-excursion (let ((groups (gnus-topic-find-groups topic gnus-level-killed t nil (not non-recursive)))) (while groups (funcall (if unmark 'gnus-group-remove-mark 'gnus-group-set-mark) (gnus-info-group (nth 2 (pop groups))))))))) (defun gnus-topic-unmark-topic (topic &optional dummy non-recursive) "Remove the process mark from all groups in the TOPIC. If NON-RECURSIVE (which is the prefix) is t, don't unmark its subtopics." (interactive (list (gnus-group-topic-name) nil (and current-prefix-arg t))) (if (not topic) (call-interactively 'gnus-group-unmark-group) (gnus-topic-mark-topic topic t non-recursive))) (defun gnus-topic-get-new-news-this-topic (&optional n) "Check for new news in the current topic." (interactive "P") (if (not (gnus-group-topic-p)) (gnus-group-get-new-news-this-group n) (let* ((topic (gnus-group-topic-name)) (data (cadr (gnus-topic-find-topology topic)))) (save-excursion (gnus-topic-mark-topic topic nil (and n t)) (gnus-group-get-new-news-this-group)) (gnus-topic-remove-topic (eq 'visible (cadr data)))))) (defun gnus-topic-move-matching (regexp topic &optional copyp) "Move all groups that match REGEXP to some topic." (interactive (let (topic) (nreverse (list (setq topic (completing-read "Move to topic: " gnus-topic-alist nil t)) (read-string (format "Move to %s (regexp): " topic)))))) (gnus-group-mark-regexp regexp) (gnus-topic-move-group nil topic copyp)) (defun gnus-topic-copy-matching (regexp topic &optional copyp) "Copy all groups that match REGEXP to some topic." (interactive (let (topic) (nreverse (list (setq topic (completing-read "Copy to topic: " gnus-topic-alist nil t)) (read-string (format "Copy to %s (regexp): " topic)))))) (gnus-topic-move-matching regexp topic t)) (defun gnus-topic-delete (topic) "Delete a topic." (interactive (list (gnus-group-topic-name))) (unless topic (error "No topic to be deleted")) (let ((entry (assoc topic gnus-topic-alist)) (buffer-read-only nil)) (when (cdr entry) (error "Topic not empty")) ;; Delete if visible. (when (gnus-topic-goto-topic topic) (gnus-delete-line)) ;; Remove from alist. (setq gnus-topic-alist (delq entry gnus-topic-alist)) ;; Remove from topology. (gnus-topic-find-topology topic nil nil 'delete) (gnus-dribble-touch))) (defun gnus-topic-rename (old-name new-name) "Rename a topic." (interactive (let ((topic (gnus-current-topic))) (list topic (read-string (format "Rename %s to: " topic) topic)))) ;; Check whether the new name exists. (when (gnus-topic-find-topology new-name) (error "Topic '%s' already exists" new-name)) ;; "nil" is an invalid name, for reasons I'd rather not go ;; into here. Trust me. (when (equal new-name "nil") (error "Invalid name: %s" nil)) ;; Do the renaming. (let ((top (gnus-topic-find-topology old-name)) (entry (assoc old-name gnus-topic-alist))) (when top (setcar (cadr top) new-name)) (when entry (setcar entry new-name)) (forward-line -1) (gnus-dribble-touch) (gnus-group-list-groups) (forward-line 1))) (defun gnus-topic-indent (&optional unindent) "Indent a topic -- make it a sub-topic of the previous topic. If UNINDENT, remove an indentation." (interactive "P") (if unindent (gnus-topic-unindent) (let* ((topic (gnus-current-topic)) (parent (gnus-topic-previous-topic topic)) (buffer-read-only nil)) (unless parent (error "Nothing to indent %s into" topic)) (when topic (gnus-topic-goto-topic topic) (gnus-topic-kill-group) (push (cdar gnus-topic-killed-topics) gnus-topic-alist) (gnus-topic-create-topic topic parent nil (cdar (car gnus-topic-killed-topics))) (pop gnus-topic-killed-topics) (or (gnus-topic-goto-topic topic) (gnus-topic-goto-topic parent)))))) (defun gnus-topic-unindent () "Unindent a topic." (interactive) (let* ((topic (gnus-current-topic)) (parent (gnus-topic-parent-topic topic)) (grandparent (gnus-topic-parent-topic parent))) (unless grandparent (error "Nothing to indent %s into" topic)) (when topic (gnus-topic-goto-topic topic) (gnus-topic-kill-group) (push (cdar gnus-topic-killed-topics) gnus-topic-alist) (gnus-topic-create-topic topic grandparent (gnus-topic-next-topic parent) (cdar (car gnus-topic-killed-topics))) (pop gnus-topic-killed-topics) (gnus-topic-goto-topic topic)))) (defun gnus-topic-list-active (&optional force) "List all groups that Gnus knows about in a topicsified fashion. If FORCE, always re-read the active file." (interactive "P") (when force (gnus-get-killed-groups)) (gnus-topic-grok-active force) (let ((gnus-topic-topology gnus-topic-active-topology) (gnus-topic-alist gnus-topic-active-alist) gnus-killed-list gnus-zombie-list) (gnus-group-list-groups gnus-level-killed nil 1))) (defun gnus-topic-toggle-display-empty-topics () "Show/hide topics that have no unread articles." (interactive) (setq gnus-topic-display-empty-topics (not gnus-topic-display-empty-topics)) (gnus-group-list-groups) (message "%s empty topics" (if gnus-topic-display-empty-topics "Showing" "Hiding"))) ;;; Topic sorting functions (defun gnus-topic-edit-parameters (group) "Edit the group parameters of GROUP. If performed on a topic, edit the topic parameters instead." (interactive (list (gnus-group-group-name))) (if group (gnus-group-edit-group-parameters group) (if (not (gnus-group-topic-p)) (error "Nothing to edit on the current line") (let ((topic (gnus-group-topic-name))) (gnus-edit-form (gnus-topic-parameters topic) (format "Editing the topic parameters for `%s'." (or group topic)) `(lambda (form) (gnus-topic-set-parameters ,topic form))))))) (defun gnus-group-sort-topic (func reverse) "Sort groups in the topics according to FUNC and REVERSE." (let ((alist gnus-topic-alist)) (while alist ;; !!!Sometimes nil elements sneak into the alist, ;; for some reason or other. (setcar alist (delq nil (car alist))) (setcar alist (delete "dummy.group" (car alist))) (gnus-topic-sort-topic (pop alist) func reverse)))) (defun gnus-topic-sort-topic (topic func reverse) ;; Each topic only lists the name of the group, while ;; the sort predicates expect group infos as inputs. ;; So we first transform the group names into infos, ;; then sort, and then transform back into group names. (setcdr topic (mapcar (lambda (info) (gnus-info-group info)) (sort (mapcar (lambda (group) (gnus-get-info group)) (cdr topic)) func))) ;; Do the reversal, if necessary. (when reverse (setcdr topic (nreverse (cdr topic))))) (defun gnus-topic-sort-groups (func &optional reverse) "Sort the current topic according to FUNC. If REVERSE, reverse the sorting order." (interactive (list gnus-group-sort-function current-prefix-arg)) (let ((topic (assoc (gnus-current-topic) gnus-topic-alist))) (gnus-topic-sort-topic topic (gnus-make-sort-function func) reverse) (gnus-group-list-groups))) (defun gnus-topic-sort-groups-by-alphabet (&optional reverse) "Sort the current topic alphabetically by group name. If REVERSE, sort in reverse order." (interactive "P") (gnus-topic-sort-groups 'gnus-group-sort-by-alphabet reverse)) (defun gnus-topic-sort-groups-by-unread (&optional reverse) "Sort the current topic by number of unread articles. If REVERSE, sort in reverse order." (interactive "P") (gnus-topic-sort-groups 'gnus-group-sort-by-unread reverse)) (defun gnus-topic-sort-groups-by-level (&optional reverse) "Sort the current topic by group level. If REVERSE, sort in reverse order." (interactive "P") (gnus-topic-sort-groups 'gnus-group-sort-by-level reverse)) (defun gnus-topic-sort-groups-by-score (&optional reverse) "Sort the current topic by group score. If REVERSE, sort in reverse order." (interactive "P") (gnus-topic-sort-groups 'gnus-group-sort-by-score reverse)) (defun gnus-topic-sort-groups-by-rank (&optional reverse) "Sort the current topic by group rank. If REVERSE, sort in reverse order." (interactive "P") (gnus-topic-sort-groups 'gnus-group-sort-by-rank reverse)) (defun gnus-topic-sort-groups-by-method (&optional reverse) "Sort the current topic alphabetically by backend name. If REVERSE, sort in reverse order." (interactive "P") (gnus-topic-sort-groups 'gnus-group-sort-by-method reverse)) (defun gnus-topic-sort-groups-by-server (&optional reverse) "Sort the current topic alphabetically by server name. If REVERSE, sort in reverse order." (interactive "P") (gnus-topic-sort-groups 'gnus-group-sort-by-server reverse)) (defun gnus-topic-sort-topics-1 (top reverse) (if (cdr top) (let ((subtop (mapcar (gnus-byte-compile `(lambda (top) (gnus-topic-sort-topics-1 top ,reverse))) (sort (cdr top) (lambda (t1 t2) (string-lessp (caar t1) (caar t2))))))) (setcdr top (if reverse (reverse subtop) subtop)))) top) (defun gnus-topic-sort-topics (&optional topic reverse) "Sort topics in TOPIC alphabetically by topic name. If REVERSE, reverse the sorting order." (interactive (list (completing-read "Sort topics in : " gnus-topic-alist nil t (gnus-current-topic)) current-prefix-arg)) (let ((topic-topology (or (and topic (cdr (gnus-topic-find-topology topic))) gnus-topic-topology))) (gnus-topic-sort-topics-1 topic-topology reverse) (gnus-topic-enter-dribble) (gnus-group-list-groups) (gnus-topic-goto-topic topic))) (defun gnus-topic-move (current to) "Move the CURRENT topic to TO." (interactive (list (gnus-group-topic-name) (completing-read "Move to topic: " gnus-topic-alist nil t))) (unless (and current to) (error "Can't find topic")) (let ((current-top (cdr (gnus-topic-find-topology current))) (to-top (cdr (gnus-topic-find-topology to)))) (unless current-top (error "Can't find topic `%s'" current)) (unless to-top (error "Can't find topic `%s'" to)) (if (gnus-topic-find-topology to current-top 0);; Don't care the level (error "Can't move `%s' to its sub-level" current)) (gnus-topic-find-topology current nil nil 'delete) (setcdr (last to-top) (list current-top)) (gnus-topic-enter-dribble) (gnus-group-list-groups) (gnus-topic-goto-topic current))) (defun gnus-subscribe-topics (newsgroup) (catch 'end (let (match gnus-group-change-level-function) (dolist (topic (gnus-topic-list)) (when (and (setq match (cdr (assq 'subscribe (gnus-topic-parameters topic)))) (string-match match newsgroup)) ;; Just subscribe the group. (gnus-subscribe-alphabetically newsgroup) ;; Add the group to the topic. (nconc (assoc topic gnus-topic-alist) (list newsgroup)) ;; if this topic specifies a default level, use it (let ((subscribe-level (cdr (assq 'subscribe-level (gnus-topic-parameters topic))))) (when subscribe-level (gnus-group-change-level newsgroup subscribe-level gnus-level-default-subscribed))) (throw 'end t))) nil))) (provide 'gnus-topic) ;; arch-tag: bf176856-f30c-40f0-ae77-e41529a1134c ;;; gnus-topic.el ends here gnus-5.11+v0.10.dfsg/lisp/gnus-nocem.el0000644000175000017500000003202211004005111017616 0ustar tvainikatvainika;;; gnus-nocem.el --- NoCeM pseudo-cancellation treatment ;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, ;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; Keywords: news ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 3, or (at your option) ;; any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Commentary: ;;; Code: (eval-when-compile (require 'cl)) (require 'gnus) (require 'nnmail) (require 'gnus-art) (require 'gnus-sum) (require 'gnus-range) (defgroup gnus-nocem nil "NoCeM pseudo-cancellation treatment." :group 'gnus-score) (defcustom gnus-nocem-groups '("news.lists.filters" "news.admin.net-abuse.bulletins" "alt.nocem.misc" "news.admin.net-abuse.announce") "*List of groups that will be searched for NoCeM messages." :group 'gnus-nocem :type '(repeat (string :tag "Group"))) (defcustom gnus-nocem-issuers '("AutoMoose-1" ; CancelMoose[tm] "clewis@ferret.ocunix" ; Chris Lewis "cosmo.roadkill" "SpamHippo" "hweede@snafu.de") "*List of NoCeM issuers to pay attention to. This can also be a list of `(ISSUER CONDITION ...)' elements. See for an issuer registry." :group 'gnus-nocem :link '(url-link "http://www.xs4all.nl/~rosalind/nocemreg/nocemreg.html") :type '(repeat (choice string sexp))) (defcustom gnus-nocem-directory (nnheader-concat gnus-article-save-directory "NoCeM/") "*Directory where NoCeM files will be stored." :group 'gnus-nocem :type 'directory) (defcustom gnus-nocem-expiry-wait 15 "*Number of days to keep NoCeM headers in the cache." :group 'gnus-nocem :type 'integer) (defcustom gnus-nocem-verifyer 'pgg-verify "*Function called to verify that the NoCeM message is valid. One likely value is `pgg-verify'. If the function in this variable isn't bound, the message will be used unconditionally." :group 'gnus-nocem :type '(radio (function-item pgg-verify) (function-item mc-verify) (function :tag "other"))) (defcustom gnus-nocem-liberal-fetch nil "*If t try to fetch all messages which have @@NCM in the subject. Otherwise don't fetch messages which have references or whose message-id matches a previously scanned and verified nocem message." :group 'gnus-nocem :type 'boolean) (defcustom gnus-nocem-check-article-limit 500 "*If non-nil, the maximum number of articles to check in any NoCeM group." :group 'gnus-nocem :version "21.1" :type '(choice (const :tag "unlimited" nil) (integer 1000))) (defcustom gnus-nocem-check-from t "Non-nil means check for valid issuers in message bodies. Otherwise don't bother fetching articles unless their author matches a valid issuer, which is much faster if you are selective about the issuers." :group 'gnus-nocem :version "21.1" :type 'boolean) ;;; Internal variables (defvar gnus-nocem-active nil) (defvar gnus-nocem-alist nil) (defvar gnus-nocem-touched-alist nil) (defvar gnus-nocem-hashtb nil) (defvar gnus-nocem-seen-message-ids nil) ;;; Functions (defun gnus-nocem-active-file () (concat (file-name-as-directory gnus-nocem-directory) "active")) (defun gnus-nocem-cache-file () (concat (file-name-as-directory gnus-nocem-directory) "cache")) ;; ;; faster lookups for group names: ;; (defvar gnus-nocem-real-group-hashtb nil "Real-name mappings of subscribed groups.") (defun gnus-fill-real-hashtb () "Fill up a hash table with the real-name mappings from the user's active file." (if (hash-table-p gnus-nocem-real-group-hashtb) (clrhash gnus-nocem-real-group-hashtb) (setq gnus-nocem-real-group-hashtb (make-hash-table :test 'equal))) (mapcar (lambda (group) (setq group (gnus-group-real-name (car group))) (puthash group t gnus-nocem-real-group-hashtb)) gnus-newsrc-alist)) ;;;###autoload (defun gnus-nocem-scan-groups () "Scan all NoCeM groups for new NoCeM messages." (interactive) (let ((groups gnus-nocem-groups) (gnus-inhibit-demon t) group active gactive articles check-headers) (gnus-make-directory gnus-nocem-directory) ;; Load any previous NoCeM headers. (gnus-nocem-load-cache) ;; Get the group name mappings: (gnus-fill-real-hashtb) ;; Read the active file if it hasn't been read yet. (and (file-exists-p (gnus-nocem-active-file)) (not gnus-nocem-active) (ignore-errors (load (gnus-nocem-active-file) t t t))) ;; Go through all groups and see whether new articles have ;; arrived. (while (setq group (pop groups)) (if (not (setq gactive (gnus-activate-group group))) () ; This group doesn't exist. (setq active (nth 1 (assoc group gnus-nocem-active))) (when (and (not (< (cdr gactive) (car gactive))) ; Empty group. (or (not active) (< (cdr active) (cdr gactive)))) ;; Ok, there are new articles in this group, se we fetch the ;; headers. (save-excursion (let ((dependencies (make-vector 10 nil)) headers header) (with-temp-buffer (setq headers (if (eq 'nov (gnus-retrieve-headers (setq articles (gnus-uncompress-range (cons (if active (1+ (cdr active)) (car gactive)) (cdr gactive)))) group)) (gnus-get-newsgroup-headers-xover articles nil dependencies) (gnus-get-newsgroup-headers dependencies))) (while (setq header (pop headers)) ;; We take a closer look on all articles that have ;; "@@NCM" in the subject. Unless we already read ;; this cross posted message. Nocem messages ;; are not allowed to have references, so we can ;; ignore scanning followups. (and (string-match "@@NCM" (mail-header-subject header)) (and gnus-nocem-check-from (let ((case-fold-search t)) (catch 'ok (mapc (lambda (author) (if (consp author) (setq author (car author))) (if (string-match author (mail-header-from header)) (throw 'ok t))) gnus-nocem-issuers) nil))) (or gnus-nocem-liberal-fetch (and (or (string= "" (mail-header-references header)) (null (mail-header-references header))) (not (member (mail-header-message-id header) gnus-nocem-seen-message-ids)))) (push header check-headers))) (setq check-headers (last (nreverse check-headers) gnus-nocem-check-article-limit)) (let ((i 0) (len (length check-headers))) (dolist (h check-headers) (gnus-message 7 "Checking article %d in %s for NoCeM (%d of %d)..." (mail-header-number h) group (incf i) len) (gnus-nocem-check-article group h))))))) (setq gnus-nocem-active (cons (list group gactive) (delq (assoc group gnus-nocem-active) gnus-nocem-active))))) ;; Save the results, if any. (gnus-nocem-save-cache) (gnus-nocem-save-active))) (defun gnus-nocem-check-article (group header) "Check whether the current article is an NCM article and that we want it." ;; Get the article. (let ((date (mail-header-date header)) (gnus-newsgroup-name group) issuer b e type) (when (or (not date) (time-less-p (time-since (date-to-time date)) (days-to-time gnus-nocem-expiry-wait))) (gnus-request-article-this-buffer (mail-header-number header) group) (goto-char (point-min)) (when (re-search-forward "-----BEGIN PGP\\(?: SIGNED\\)? MESSAGE-----" nil t) (delete-region (point-min) (match-beginning 0))) (when (re-search-forward "-----END PGP \\(?:MESSAGE\\|SIGNATURE\\)-----\n?" nil t) (delete-region (match-end 0) (point-max))) (goto-char (point-min)) ;; The article has to have proper NoCeM headers. (when (and (setq b (search-forward "\n@@BEGIN NCM HEADERS\n" nil t)) (setq e (search-forward "\n@@BEGIN NCM BODY\n" nil t))) ;; We get the name of the issuer. (narrow-to-region b e) (setq issuer (mail-fetch-field "issuer") type (mail-fetch-field "type")) (widen) (if (not (gnus-nocem-message-wanted-p issuer type)) (message "invalid NoCeM issuer: %s" issuer) (and (gnus-nocem-verify-issuer issuer) ; She is who she says she is. (gnus-nocem-enter-article) ; We gobble the message. (push (mail-header-message-id header) ; But don't come back for gnus-nocem-seen-message-ids))))))) ; second helpings. (defun gnus-nocem-message-wanted-p (issuer type) (let ((issuers gnus-nocem-issuers) wanted conditions condition) (cond ;; Do the quick check first. ((member issuer issuers) t) ((setq conditions (cdr (assoc issuer issuers))) ;; Check whether we want this type. (while (setq condition (pop conditions)) (cond ((stringp condition) (when (string-match condition type) (setq wanted t))) ((and (consp condition) (eq (car condition) 'not) (stringp (cadr condition))) (when (string-match (cadr condition) type) (setq wanted nil))) (t (error "Invalid NoCeM condition: %S" condition)))) wanted)))) (defun gnus-nocem-verify-issuer (person) "Verify using PGP that the canceler is who she says she is." (if (functionp gnus-nocem-verifyer) (ignore-errors (funcall gnus-nocem-verifyer)) ;; If we don't have Mailcrypt, then we use the message anyway. t)) (defun gnus-nocem-enter-article () "Enter the current article into the NoCeM cache." (goto-char (point-min)) (let ((b (search-forward "\n@@BEGIN NCM BODY\n" nil t)) (e (search-forward "\n@@END NCM BODY\n" nil t)) (buf (current-buffer)) ncm id group) (when (and b e) (narrow-to-region b (1+ (match-beginning 0))) (goto-char (point-min)) (while (search-forward "\t" nil t) (cond ((not (ignore-errors (setq group (gnus-group-real-name (symbol-name (read buf)))) (gethash group gnus-nocem-real-group-hashtb))) ;; An error. ) (t ;; Valid group. (beginning-of-line) (while (eq (char-after) ?\t) (forward-line -1)) (setq id (buffer-substring (point) (1- (search-forward "\t")))) (unless (if (hash-table-p gnus-nocem-hashtb) (gethash id gnus-nocem-hashtb) (setq gnus-nocem-hashtb (make-hash-table :test 'equal)) nil) ;; only store if not already present (puthash id t gnus-nocem-hashtb) (push id ncm)) (forward-line 1) (while (eq (char-after) ?\t) (forward-line 1))))) (when ncm (setq gnus-nocem-touched-alist t) (push (cons (let ((time (current-time))) (setcdr (cdr time) nil) time) ncm) gnus-nocem-alist)) t))) ;;;###autoload (defun gnus-nocem-load-cache () "Load the NoCeM cache." (interactive) (unless gnus-nocem-alist ;; The buffer doesn't exist, so we create it and load the NoCeM ;; cache. (when (file-exists-p (gnus-nocem-cache-file)) (load (gnus-nocem-cache-file) t t t) (gnus-nocem-alist-to-hashtb)))) (defun gnus-nocem-save-cache () "Save the NoCeM cache." (when (and gnus-nocem-alist gnus-nocem-touched-alist) (with-temp-file (gnus-nocem-cache-file) (gnus-prin1 `(setq gnus-nocem-alist ',gnus-nocem-alist))) (setq gnus-nocem-touched-alist nil))) (defun gnus-nocem-save-active () "Save the NoCeM active file." (with-temp-file (gnus-nocem-active-file) (gnus-prin1 `(setq gnus-nocem-active ',gnus-nocem-active)))) (defun gnus-nocem-alist-to-hashtb () "Create a hashtable from the Message-IDs we have." (let* ((alist gnus-nocem-alist) (pprev (cons nil alist)) (prev pprev) (expiry (days-to-time gnus-nocem-expiry-wait)) entry) (if (hash-table-p gnus-nocem-hashtb) (clrhash gnus-nocem-hashtb) (setq gnus-nocem-hashtb (make-hash-table :test 'equal))) (while (setq entry (car alist)) (if (not (time-less-p (time-since (car entry)) expiry)) ;; This entry has expired, so we remove it. (setcdr prev (cdr alist)) (setq prev alist) ;; This is ok, so we enter it into the hashtable. (setq entry (cdr entry)) (while entry (puthash (car entry) t gnus-nocem-hashtb) (setq entry (cdr entry)))) (setq alist (cdr alist))))) (gnus-add-shutdown 'gnus-nocem-close 'gnus) (defun gnus-nocem-close () "Clear internal NoCeM variables." (setq gnus-nocem-alist nil gnus-nocem-hashtb nil gnus-nocem-active nil gnus-nocem-touched-alist nil gnus-nocem-seen-message-ids nil gnus-nocem-real-group-hashtb nil)) (defun gnus-nocem-unwanted-article-p (id) "Say whether article ID in the current group is wanted." (and gnus-nocem-hashtb (gethash id gnus-nocem-hashtb))) (provide 'gnus-nocem) ;; arch-tag: 0e0c74ea-2f8e-4f3e-8fff-09f767c1adef ;;; gnus-nocem.el ends here gnus-5.11+v0.10.dfsg/lisp/sasl-ntlm.el0000644000175000017500000000464211004005110017463 0ustar tvainikatvainika;;; sasl-ntlm.el --- NTLM (NT Lan Manager) module for the SASL client framework ;; Copyright (C) 2000, 2007, 2008 Free Software Foundation, Inc. ;; Author: Taro Kawagishi ;; Keywords: SASL, NTLM ;; Version: 1.00 ;; Created: February 2001 ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 3, or (at your option) ;; any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Commentary: ;; This is a SASL interface layer for NTLM authentication message ;; generation by ntlm.el ;;; Code: (require 'sasl) (require 'ntlm) (defconst sasl-ntlm-steps '(ignore ;nothing to do before making sasl-ntlm-request ;authentication request sasl-ntlm-response) ;response to challenge "A list of functions to be called in sequnece for the NTLM authentication steps. Ther are called by 'sasl-next-step.") (defun sasl-ntlm-request (client step) "SASL step function to generate a NTLM authentication request to the server. Called from 'sasl-next-step. CLIENT is a vector [mechanism user service server sasl-client-properties] STEP is a vector [ ]" (let ((user (sasl-client-name client))) (ntlm-build-auth-request user))) (defun sasl-ntlm-response (client step) "SASL step function to generate a NTLM response against the server challenge stored in the 2nd element of STEP. Called from 'sasl-next-step." (let* ((user (sasl-client-name client)) (passphrase (sasl-read-passphrase (format "NTLM passphrase for %s: " user))) (challenge (sasl-step-data step))) (ntlm-build-auth-response challenge user (ntlm-get-password-hashes passphrase)))) (put 'sasl-ntlm 'sasl-mechanism (sasl-make-mechanism "NTLM" sasl-ntlm-steps)) (provide 'sasl-ntlm) ;; arch-tag: 1d9164c1-1df0-418f-b7ab-360157fd05dc ;;; sasl-ntlm.el ends here gnus-5.11+v0.10.dfsg/lisp/hmac-def.el0000644000175000017500000000575711004005111017226 0ustar tvainikatvainika;;; hmac-def.el --- A macro for defining HMAC functions. ;; Copyright (C) 1999, 2001, 2007, 2008 Free Software Foundation, Inc. ;; Author: Shuhei KOBAYASHI ;; Keywords: HMAC, RFC 2104 ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 3, or (at your option) ;; any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Commentary: ;; This program is implemented from RFC 2104, ;; "HMAC: Keyed-Hashing for Message Authentication". ;;; Code: (defmacro define-hmac-function (name H B L &optional bit) "Define a function NAME(TEXT KEY) which computes HMAC with function H. HMAC function is H(KEY XOR opad, H(KEY XOR ipad, TEXT)): H is a cryptographic hash function, such as SHA1 and MD5, which takes a string and return a digest of it (in binary form). B is a byte-length of a block size of H. (B=64 for both SHA1 and MD5.) L is a byte-length of hash outputs. (L=16 for MD5, L=20 for SHA1.) If BIT is non-nil, truncate output to specified bits." `(defun ,name (text key) ,(concat "Compute " (upcase (symbol-name name)) " over TEXT with KEY.") (let ((key-xor-ipad (make-string ,B ?\x36)) (key-xor-opad (make-string ,B ?\x5C)) (len (length key)) (pos 0)) (unwind-protect (progn ;; if `key' is longer than the block size, apply hash function ;; to `key' and use the result as a real `key'. (if (> len ,B) (setq key (,H key) len ,L)) (while (< pos len) (aset key-xor-ipad pos (logxor (aref key pos) ?\x36)) (aset key-xor-opad pos (logxor (aref key pos) ?\x5C)) (setq pos (1+ pos))) (setq key-xor-ipad (unwind-protect (concat key-xor-ipad text) (fillarray key-xor-ipad 0)) key-xor-ipad (unwind-protect (,H key-xor-ipad) (fillarray key-xor-ipad 0)) key-xor-opad (unwind-protect (concat key-xor-opad key-xor-ipad) (fillarray key-xor-opad 0)) key-xor-opad (unwind-protect (,H key-xor-opad) (fillarray key-xor-opad 0))) ;; now `key-xor-opad' contains ;; H(KEY XOR opad, H(KEY XOR ipad, TEXT)). ,(if (and bit (< (/ bit 8) L)) `(substring key-xor-opad 0 ,(/ bit 8)) ;; return a copy of `key-xor-opad'. `(concat key-xor-opad))) ;; cleanup. (fillarray key-xor-ipad 0) (fillarray key-xor-opad 0))))) (provide 'hmac-def) ;; arch-tag: 645adcef-b835-4900-a10a-11f636c982b9 ;;; hmac-def.el ends here gnus-5.11+v0.10.dfsg/lisp/nnmail.el0000644000175000017500000021456211004005110017033 0ustar tvainikatvainika;;; nnmail.el --- mail support functions for the Gnus mail backends ;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, ;; 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; Keywords: news, mail ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 3, or (at your option) ;; any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Commentary: ;;; Code: ;; For Emacs < 22.2. (eval-and-compile (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) (eval-when-compile (require 'cl)) (require 'gnus) ; for macro gnus-kill-buffer, at least (require 'nnheader) (require 'message) (require 'gnus-util) (require 'mail-source) (require 'mm-util) (require 'gnus-int) (eval-and-compile (autoload 'gnus-add-buffer "gnus") (autoload 'gnus-kill-buffer "gnus")) (defgroup nnmail nil "Reading mail with Gnus." :group 'gnus) (defgroup nnmail-retrieve nil "Retrieving new mail." :group 'nnmail) (defgroup nnmail-prepare nil "Preparing (or mangling) new mail after retrieval." :group 'nnmail) (defgroup nnmail-duplicate nil "Handling of duplicate mail messages." :group 'nnmail) (defgroup nnmail-split nil "Organizing the incoming mail in folders." :group 'nnmail) (defgroup nnmail-files nil "Mail files." :group 'gnus-files :group 'nnmail) (defgroup nnmail-expire nil "Expiring old mail." :group 'nnmail) (defgroup nnmail-procmail nil "Interfacing with procmail and other mail agents." :group 'nnmail) (defgroup nnmail-various nil "Various mail options." :group 'nnmail) (defcustom nnmail-split-methods '(("mail.misc" "")) "*Incoming mail will be split according to this variable. If you'd like, for instance, one mail group for mail from the \"4ad-l\" mailing list, one group for junk mail and one for everything else, you could do something like this: (setq nnmail-split-methods '((\"mail.4ad\" \"From:.*4ad\") (\"mail.junk\" \"From:.*Lars\\\\|Subject:.*buy\") (\"mail.misc\" \"\"))) As you can see, this variable is a list of lists, where the first element in each \"rule\" is the name of the group (which, by the way, does not have to be called anything beginning with \"mail\", \"yonka.zow\" is a fine, fine name), and the second is a regexp that nnmail will try to match on the header to find a fit. The second element can also be a function. In that case, it will be called narrowed to the headers with the first element of the rule as the argument. It should return a non-nil value if it thinks that the mail belongs in that group. The last element should always have \"\" as the regexp. This variable can also have a function as its value." :group 'nnmail-split :type '(choice (repeat :tag "Alist" (group (string :tag "Name") (choice regexp function))) (function-item nnmail-split-fancy) (function :tag "Other"))) ;; Suggested by Erik Selberg . (defcustom nnmail-crosspost t "If non-nil, do crossposting if several split methods match the mail. If nil, the first match found will be used." :group 'nnmail-split :type 'boolean) (defcustom nnmail-split-fancy-with-parent-ignore-groups nil "Regexp that matches group names to be ignored when applying `nnmail-split-fancy-with-parent'. This can also be a list of regexps." :version "22.1" :group 'nnmail-split :type '(choice (const :tag "none" nil) (regexp :value ".*") (repeat :value (".*") regexp))) (defcustom nnmail-cache-ignore-groups nil "Regexp that matches group names to be ignored when inserting message ids into the cache (`nnmail-cache-insert'). This can also be a list of regexps." :version "22.1" :group 'nnmail-split :type '(choice (const :tag "none" nil) (regexp :value ".*") (repeat :value (".*") regexp))) ;; Added by gord@enci.ucalgary.ca (Gordon Matzigkeit). (defcustom nnmail-keep-last-article nil "If non-nil, nnmail will never delete/move a group's last article. It can be marked expirable, so it will be deleted when it is no longer last. You may need to set this variable if other programs are putting new mail into folder numbers that Gnus has marked as expired." :group 'nnmail-procmail :group 'nnmail-various :type 'boolean) (defcustom nnmail-use-long-file-names nil "If non-nil the mail backends will use long file and directory names. If nil, groups like \"mail.misc\" will end up in directories like \"mail/misc/\"." :group 'nnmail-files :type 'boolean) (defcustom nnmail-default-file-modes 384 "Set the mode bits of all new mail files to this integer." :group 'nnmail-files :type 'integer) (defcustom nnmail-expiry-wait 7 "*Expirable articles that are older than this will be expired. This variable can either be a number (which will be interpreted as a number of days) -- this doesn't have to be an integer. This variable can also be `immediate' and `never'." :group 'nnmail-expire :type '(choice (const immediate) (number :tag "days") (const never))) (defcustom nnmail-expiry-wait-function nil "Variable that holds function to specify how old articles should be before they are expired. The function will be called with the name of the group that the expiry is to be performed in, and it should return an integer that says how many days an article can be stored before it is considered \"old\". It can also return the values `never' and `immediate'. Eg.: \(setq nnmail-expiry-wait-function (lambda (newsgroup) (cond ((string-match \"private\" newsgroup) 31) ((string-match \"junk\" newsgroup) 1) ((string-match \"important\" newsgroup) 'never) (t 7))))" :group 'nnmail-expire :type '(choice (const :tag "nnmail-expiry-wait" nil) (function :format "%v" nnmail-))) (defcustom nnmail-expiry-target 'delete "*Variable that says where expired messages should end up. The default value is `delete' (which says to delete the messages), but it can also be a string or a function. If it is a string, expired messages end up in that group. If it is a function, the function is called in a buffer narrowed to the message in question. The function receives one argument, the name of the group the message comes from. The return value should be `delete' or a group name (a string)." :version "21.1" :group 'nnmail-expire :type '(choice (const delete) (function :format "%v" nnmail-) string)) (defcustom nnmail-fancy-expiry-targets nil "Determine expiry target based on articles using fancy techniques. This is a list of (\"HEADER\" \"REGEXP\" \"TARGET\") entries. If `nnmail-expiry-target' is set to the function `nnmail-fancy-expiry-target' and HEADER of the article matches REGEXP, the message will be expired to a group determined by invoking `format-time-string' with TARGET used as the format string and the time extracted from the articles' Date header (if missing the current time is used). In the special cases that HEADER is the symbol `to-from', the regexp will try to match against both the From and the To header. Example: \(setq nnmail-fancy-expiry-targets '((to-from \"boss\" \"nnfolder:Work\") (\"Subject\" \"IMPORTANT\" \"nnfolder:IMPORTANT.%Y.%b\") (\"from\" \".*\" \"nnfolder:Archive-%Y\"))) In this case, articles containing the string \"boss\" in the To or the From header will be expired to the group \"nnfolder:Work\"; articles containing the sting \"IMPORTANT\" in the Subject header will be expired to the group \"nnfolder:IMPORTANT.YYYY.MMM\"; and everything else will be expired to \"nnfolder:Archive-YYYY\"." :version "22.1" :group 'nnmail-expire :type '(repeat (list (choice :tag "Match against" (string :tag "Header") (const to-from)) regexp (string :tag "Target group format string")))) (defcustom nnmail-cache-accepted-message-ids nil "If non-nil, put Message-IDs of Gcc'd articles into the duplicate cache. If non-nil, also update the cache when copy or move articles." :group 'nnmail :type 'boolean) (make-obsolete-variable 'nnmail-spool-file "This option is obsolete in Gnus 5.9. \ Use `mail-sources' instead.") ;; revision 5.29 / p0-85 / Gnus 5.9 ;; Variable removed in No Gnus v0.7 (defcustom nnmail-resplit-incoming nil "*If non-nil, re-split incoming procmail sorted mail." :group 'nnmail-procmail :type 'boolean) (defcustom nnmail-scan-directory-mail-source-once nil "*If non-nil, scan all incoming procmail sorted mails once. It scans low-level sorted spools even when not required." :version "21.1" :group 'nnmail-procmail :type 'boolean) (defcustom nnmail-delete-file-function 'delete-file "Function called to delete files in some mail backends." :group 'nnmail-files :type 'function) (defcustom nnmail-crosspost-link-function (if (string-match "windows-nt\\|emx" (symbol-name system-type)) 'copy-file 'add-name-to-file) "*Function called to create a copy of a file. This is `add-name-to-file' by default, which means that crossposts will use hard links. If your file system doesn't allow hard links, you could set this variable to `copy-file' instead." :group 'nnmail-files :type '(radio (function-item add-name-to-file) (function-item copy-file) (function :tag "Other"))) (defcustom nnmail-read-incoming-hook (if (eq system-type 'windows-nt) '(nnheader-ms-strip-cr) nil) "*Hook that will be run after the incoming mail has been transferred. The incoming mail is moved from the specified spool file (which normally is something like \"/usr/spool/mail/$user\") to the user's home directory. This hook is called after the incoming mail box has been emptied, and can be used to call any mail box programs you have running (\"xwatch\", etc.) Eg. \(add-hook 'nnmail-read-incoming-hook (lambda () (call-process \"/local/bin/mailsend\" nil nil nil \"read\" ;; The incoming mail box file. (expand-file-name (user-login-name) rmail-spool-directory)))) If you have xwatch running, this will alert it that mail has been read. If you use `display-time', you could use something like this: \(add-hook 'nnmail-read-incoming-hook (lambda () ;; Update the displayed time, since that will clear out ;; the flag that says you have mail. (when (eq (process-status \"display-time\") 'run) (display-time-filter display-time-process \"\"))))" :group 'nnmail-prepare :type 'hook) (defcustom nnmail-prepare-incoming-hook nil "Hook called before treating incoming mail. The hook is run in a buffer with all the new, incoming mail." :group 'nnmail-prepare :type 'hook) (defcustom nnmail-prepare-incoming-header-hook nil "Hook called narrowed to the headers of each message. This can be used to remove excessive spaces (and stuff like that) from the headers before splitting and saving the messages." :group 'nnmail-prepare :type 'hook) (defcustom nnmail-prepare-incoming-message-hook nil "Hook called narrowed to each message." :group 'nnmail-prepare :type 'hook) (defcustom nnmail-list-identifiers nil "Regexp that matches list identifiers to be removed. This can also be a list of regexps." :group 'nnmail-prepare :type '(choice (const :tag "none" nil) (regexp :value ".*") (repeat :value (".*") regexp))) (defcustom nnmail-pre-get-new-mail-hook nil "Hook called just before starting to handle new incoming mail." :group 'nnmail-retrieve :type 'hook) (defcustom nnmail-post-get-new-mail-hook nil "Hook called just after finishing handling new incoming mail." :group 'nnmail-retrieve :type 'hook) (defcustom nnmail-split-hook nil "Hook called before deciding where to split an article. The functions in this hook are free to modify the buffer contents in any way they choose -- the buffer contents are discarded after running the split process." :group 'nnmail-split :type 'hook) (defcustom nnmail-spool-hook nil "*A hook called when a new article is spooled." :version "22.1" :group 'nnmail :type 'hook) (defcustom nnmail-large-newsgroup 50 "*The number of articles which indicates a large newsgroup or nil. If the number of articles is greater than the value, verbose messages will be shown to indicate the current status." :group 'nnmail-various :type '(choice (const :tag "infinite" nil) (number :tag "count"))) (define-widget 'nnmail-lazy 'default "Base widget for recursive datastructures. This is copy of the `lazy' widget in Emacs 22.1 provided for compatibility." :format "%{%t%}: %v" :convert-widget 'widget-value-convert-widget :value-create (lambda (widget) (let ((value (widget-get widget :value)) (type (widget-get widget :type))) (widget-put widget :children (list (widget-create-child-value widget (widget-convert type) value))))) :value-delete 'widget-children-value-delete :value-get (lambda (widget) (widget-value (car (widget-get widget :children)))) :value-inline (lambda (widget) (widget-apply (car (widget-get widget :children)) :value-inline)) :default-get (lambda (widget) (widget-default-get (widget-convert (widget-get widget :type)))) :match (lambda (widget value) (widget-apply (widget-convert (widget-get widget :type)) :match value)) :validate (lambda (widget) (widget-apply (car (widget-get widget :children)) :validate))) (define-widget 'nnmail-split-fancy 'nnmail-lazy "Widget for customizing splits in the variable of the same name." :tag "Split" :type '(menu-choice :value (any ".*value.*" "misc") :tag "Type" (string :tag "Destination") (list :tag "Use first match (|)" :value (|) (const :format "" |) (editable-list :inline t nnmail-split-fancy)) (list :tag "Use all matches (&)" :value (&) (const :format "" &) (editable-list :inline t nnmail-split-fancy)) (list :tag "Function with fixed arguments (:)" :value (:) (const :format "" :value :) function (editable-list :inline t (sexp :tag "Arg")) ) (list :tag "Function with split arguments (!)" :value (!) (const :format "" !) function (editable-list :inline t nnmail-split-fancy)) (list :tag "Field match" (choice :tag "Field" regexp symbol) (choice :tag "Match" regexp (symbol :value mail)) (repeat :inline t :tag "Restrictions" (group :inline t (const :format "" -) regexp)) nnmail-split-fancy) (const :tag "Junk (delete mail)" junk))) (defcustom nnmail-split-fancy "mail.misc" "Incoming mail can be split according to this fancy variable. To enable this, set `nnmail-split-methods' to `nnmail-split-fancy'. The format of this variable is SPLIT, where SPLIT can be one of the following: GROUP: Mail will be stored in GROUP (a string). \(FIELD VALUE [- RESTRICT [- RESTRICT [...]]] SPLIT): If the message field FIELD (a regexp) contains VALUE (a regexp), store the messages as specified by SPLIT. If RESTRICT (a regexp) matches some string after FIELD and before the end of the matched VALUE, return nil, otherwise process SPLIT. Multiple RESTRICTs add up, further restricting the possibility of processing SPLIT. \(| SPLIT...): Process each SPLIT expression until one of them matches. A SPLIT expression is said to match if it will cause the mail message to be stored in one or more groups. \(& SPLIT...): Process each SPLIT expression. \(: FUNCTION optional args): Call FUNCTION with the optional args, in the buffer containing the message headers. The return value FUNCTION should be a split, which is then recursively processed. \(! FUNCTION SPLIT): Call FUNCTION with the result of SPLIT. The return value FUNCTION should be a split, which is then recursively processed. junk: Mail will be deleted. Use with care! Do not submerge in water! Example: (setq nnmail-split-fancy '(| (\"Subject\" \"MAKE MONEY FAST\" junk) ...other.rules.omitted...)) FIELD must match a complete field name. VALUE must match a complete word according to the `nnmail-split-fancy-syntax-table' syntax table. You can use \".*\" in the regexps to match partial field names or words. FIELD and VALUE can also be Lisp symbols, in that case they are expanded as specified in `nnmail-split-abbrev-alist'. GROUP can contain \\& and \\N which will substitute from matching \\(\\) patterns in the previous VALUE. Example: \(setq nnmail-split-methods 'nnmail-split-fancy nnmail-split-fancy ;; Messages from the mailer daemon are not crossposted to any of ;; the ordinary groups. Warnings are put in a separate group ;; from real errors. '(| (\"from\" mail (| (\"subject\" \"warn.*\" \"mail.warning\") \"mail.misc\")) ;; Non-error messages are crossposted to all relevant ;; groups, but we don't crosspost between the group for the ;; (ding) list and the group for other (ding) related mail. (& (| (any \"ding@ifi\\\\.uio\\\\.no\" \"ding.list\") (\"subject\" \"ding\" \"ding.misc\")) ;; Other mailing lists... (any \"procmail@informatik\\\\.rwth-aachen\\\\.de\" \"procmail.list\") (any \"SmartList@informatik\\\\.rwth-aachen\\\\.de\" \"SmartList.list\") ;; Both lists below have the same suffix, so prevent ;; cross-posting to mkpkg.list of messages posted only to ;; the bugs- list, but allow cross-posting when the ;; message was really cross-posted. (any \"bugs-mypackage@somewhere\" \"mypkg.bugs\") (any \"mypackage@somewhere\" - \"bugs-mypackage\" \"mypkg.list\") ;; ;; People... (any \"larsi@ifi\\\\.uio\\\\.no\" \"people.Lars Magne Ingebrigtsen\")) ;; Unmatched mail goes to the catch all group. \"misc.misc\"))" :group 'nnmail-split :type 'nnmail-split-fancy) (defcustom nnmail-split-abbrev-alist '((any . "from\\|to\\|cc\\|sender\\|apparently-to\\|resent-from\\|resent-to\\|resent-cc") (mail . "mailer-daemon\\|postmaster\\|uucp") (to . "to\\|cc\\|apparently-to\\|resent-to\\|resent-cc") (from . "from\\|sender\\|resent-from") (nato . "to\\|cc\\|resent-to\\|resent-cc") (naany . "from\\|to\\|cc\\|sender\\|resent-from\\|resent-to\\|resent-cc")) "*Alist of abbreviations allowed in `nnmail-split-fancy'." :group 'nnmail-split :type '(repeat (cons :format "%v" symbol regexp))) (defcustom nnmail-message-id-cache-length 1000 "*The approximate number of Message-IDs nnmail will keep in its cache. If this variable is nil, no checking on duplicate messages will be performed." :group 'nnmail-duplicate :type '(choice (const :tag "disable" nil) (integer :format "%v"))) (defcustom nnmail-message-id-cache-file (nnheader-concat gnus-home-directory ".nnmail-cache") "The file name of the nnmail Message-ID cache." :group 'nnmail-duplicate :group 'nnmail-files :type 'file) (defcustom nnmail-treat-duplicates 'warn "*If non-nil, nnmail keep a cache of Message-IDs to discover mail duplicates. Three values are valid: nil, which means that nnmail is not to keep a Message-ID cache; `warn', which means that nnmail should insert extra headers to warn the user about the duplication (this is the default); and `delete', which means that nnmail will delete duplicated mails. This variable can also be a function. It will be called from a buffer narrowed to the article in question with the Message-ID as a parameter. It should return nil, `warn' or `delete'." :group 'nnmail-duplicate :type '(choice (const :tag "off" nil) (const warn) (const delete))) (defcustom nnmail-extra-headers '(To Newsgroups) "*Extra headers to parse." :version "21.1" :group 'nnmail :type '(repeat symbol)) (defcustom nnmail-split-header-length-limit 2048 "Header lines longer than this limit are excluded from the split function." :version "21.1" :group 'nnmail :type 'integer) (defcustom nnmail-mail-splitting-charset nil "Default charset to be used when splitting incoming mail." :version "22.1" :group 'nnmail :type 'symbol) (defcustom nnmail-mail-splitting-decodes nil "Whether the nnmail splitting functionality should MIME decode headers." :version "22.1" :group 'nnmail :type 'boolean) (defcustom nnmail-split-fancy-match-partial-words nil "Whether to match partial words when fancy splitting. Normally, regexes given in `nnmail-split-fancy' are implicitly surrounded by \"\\=\\<...\\>\". If this variable is true, they are not implicitly\ surrounded by anything." :version "22.1" :group 'nnmail :type 'boolean) (defcustom nnmail-split-lowercase-expanded t "Whether to lowercase expanded entries (i.e. \\N) when splitting mails. This avoids the creation of multiple groups when users send to an address using different case (i.e. mailing-list@domain vs Mailing-List@Domain)." :version "22.1" :group 'nnmail :type 'boolean) ;;; Internal variables. (defvar nnmail-article-buffer " *nnmail incoming*" "The buffer used for splitting incoming mails.") (defvar nnmail-split-history nil "List of group/article elements that say where the previous split put messages.") (defvar nnmail-split-fancy-syntax-table (let ((table (make-syntax-table))) ;; support the %-hack (modify-syntax-entry ?\% "." table) table) "Syntax table used by `nnmail-split-fancy'.") (defvar nnmail-prepare-save-mail-hook nil "Hook called before saving mail.") (defvar nnmail-split-tracing nil) (defvar nnmail-split-trace nil) (defun nnmail-request-post (&optional server) (mail-send-and-exit nil)) (defvar nnmail-file-coding-system 'raw-text "Coding system used in nnmail.") (defvar nnmail-incoming-coding-system mm-text-coding-system "Coding system used in reading inbox") (defvar nnmail-pathname-coding-system nil "*Coding system for file name.") (defun nnmail-find-file (file) "Insert FILE in server buffer safely." (set-buffer nntp-server-buffer) (delete-region (point-min) (point-max)) (let ((format-alist nil) (after-insert-file-functions nil)) (condition-case () (let ((coding-system-for-read nnmail-file-coding-system) (auto-mode-alist (mm-auto-mode-alist)) (file-name-coding-system nnmail-pathname-coding-system)) (insert-file-contents file) t) (file-error nil)))) (defun nnmail-group-pathname (group dir &optional file) "Make file name for GROUP." (concat (let ((dir (file-name-as-directory (expand-file-name dir)))) (setq group (nnheader-replace-duplicate-chars-in-string (nnheader-replace-chars-in-string group ?/ ?_) ?. ?_)) (setq group (nnheader-translate-file-chars group)) ;; If this directory exists, we use it directly. (file-name-as-directory (if (or nnmail-use-long-file-names (file-directory-p (concat dir group))) (expand-file-name group dir) ;; If not, we translate dots into slashes. (expand-file-name (nnheader-replace-chars-in-string group ?. ?/) dir)))) (or file ""))) (defun nnmail-get-active () "Returns an assoc of group names and active ranges. nn*-request-list should have been called before calling this function." ;; Go through all groups from the active list. (save-excursion (set-buffer nntp-server-buffer) (nnmail-parse-active))) (defun nnmail-parse-active () "Parse the active file in the current buffer and return an alist." (goto-char (point-min)) (unless (re-search-forward "[\\\"]" nil t) (goto-char (point-max)) (while (re-search-backward "[][';?()#]" nil t) (insert ?\\))) (goto-char (point-min)) (let ((buffer (current-buffer)) group-assoc group max min) (while (not (eobp)) (condition-case err (progn (narrow-to-region (point) (point-at-eol)) (setq group (read buffer)) (unless (stringp group) (setq group (symbol-name group))) (if (and (numberp (setq max (read buffer))) (numberp (setq min (read buffer)))) (push (list (mm-string-as-unibyte group) (cons min max)) group-assoc))) (error nil)) (widen) (forward-line 1)) group-assoc)) (defvar nnmail-active-file-coding-system 'raw-text "*Coding system for active file.") (defun nnmail-save-active (group-assoc file-name) "Save GROUP-ASSOC in ACTIVE-FILE." (let ((coding-system-for-write nnmail-active-file-coding-system)) (when file-name (with-temp-file file-name (mm-disable-multibyte) (nnmail-generate-active group-assoc))))) (defun nnmail-generate-active (alist) "Generate an active file from group-alist ALIST." (erase-buffer) (let (group) (while (setq group (pop alist)) (insert (format "%S %d %d y\n" (intern (car group)) (cdadr group) (caadr group)))) (goto-char (point-max)) (while (search-backward "\\." nil t) (delete-char 1)))) (defun nnmail-get-split-group (file source) "Find out whether this FILE is to be split into GROUP only. If SOURCE is a directory spec, try to return the group name component." (if (eq (car source) 'directory) (let ((file (file-name-nondirectory file))) (mail-source-bind (directory source) (if (string-match (concat (regexp-quote suffix) "$") file) (substring file 0 (match-beginning 0)) nil))) nil)) (defun nnmail-process-babyl-mail-format (func artnum-func) (let ((case-fold-search t) (count 0) start message-id content-length do-search end) (while (not (eobp)) (goto-char (point-min)) (re-search-forward " \n0, *unseen,+\n\\(\\*\\*\\* EOOH \\*\\*\\*\n\\)?" nil t) (goto-char (match-end 0)) (delete-region (match-beginning 0) (match-end 0)) (narrow-to-region (setq start (point)) (progn ;; Skip all the headers in case there are more "From "s... (or (search-forward "\n\n" nil t) (search-forward-regexp "^[^:]*\\( .*\\|\\)$" nil t) (search-forward " ")) (point))) ;; Unquote the ">From " line, if any. (goto-char (point-min)) (when (looking-at ">From ") (replace-match "X-From-Line: ") ) (run-hooks 'nnmail-prepare-incoming-header-hook) (goto-char (point-max)) ;; Find the Message-ID header. (save-excursion (if (re-search-backward "^Message-ID[ \t]*:[ \n\t]*\\(<[^>]*>\\)" nil t) (setq message-id (buffer-substring (match-beginning 1) (match-end 1))) ;; There is no Message-ID here, so we create one. (save-excursion (when (re-search-backward "^Message-ID[ \t]*:" nil t) (beginning-of-line) (insert "Original-"))) (forward-line -1) (insert "Message-ID: " (setq message-id (nnmail-message-id)) "\n"))) ;; Look for a Content-Length header. (if (not (save-excursion (and (re-search-backward "^Content-Length:[ \t]*\\([0-9]+\\)" start t) (setq content-length (string-to-number (buffer-substring (match-beginning 1) (match-end 1)))) ;; We destroy the header, since none of ;; the backends ever use it, and we do not ;; want to confuse other mailers by having ;; a (possibly) faulty header. (progn (insert "X-") t)))) (setq do-search t) (widen) (if (or (= (+ (point) content-length) (point-max)) (save-excursion (goto-char (+ (point) content-length)) (looking-at ""))) (progn (goto-char (+ (point) content-length)) (setq do-search nil)) (setq do-search t))) (widen) ;; Go to the beginning of the next article - or to the end ;; of the buffer. (when do-search (if (re-search-forward "^" nil t) (goto-char (match-beginning 0)) (goto-char (1- (point-max))))) (delete-char 1) ; delete ^_ (save-excursion (save-restriction (narrow-to-region start (point)) (goto-char (point-min)) (nnmail-check-duplication message-id func artnum-func) (incf count) (setq end (point-max)))) (goto-char end)) count)) (defsubst nnmail-search-unix-mail-delim () "Put point at the beginning of the next Unix mbox message." ;; Algorithm used to find the next article in the ;; brain-dead Unix mbox format: ;; ;; 1) Search for "^From ". ;; 2) If we find it, then see whether the previous ;; line is blank and the next line looks like a header. ;; Then it's possible that this is a mail delim, and we use it. (let ((case-fold-search nil) found) (while (not found) (if (not (re-search-forward "^From " nil t)) (setq found 'no) (save-excursion (beginning-of-line) (when (and (or (bobp) (save-excursion (forward-line -1) (eq (char-after) ?\n))) (save-excursion (forward-line 1) (while (looking-at ">From \\|From ") (forward-line 1)) (looking-at "[^ \n\t:]+[ \n\t]*:"))) (setq found 'yes))))) (beginning-of-line) (eq found 'yes))) (defun nnmail-search-unix-mail-delim-backward () "Put point at the beginning of the current Unix mbox message." ;; Algorithm used to find the next article in the ;; brain-dead Unix mbox format: ;; ;; 1) Search for "^From ". ;; 2) If we find it, then see whether the previous ;; line is blank and the next line looks like a header. ;; Then it's possible that this is a mail delim, and we use it. (let ((case-fold-search nil) found) (while (not found) (if (not (re-search-backward "^From " nil t)) (setq found 'no) (save-excursion (beginning-of-line) (when (and (or (bobp) (save-excursion (forward-line -1) (eq (char-after) ?\n))) (save-excursion (forward-line 1) (while (looking-at ">From \\|From ") (forward-line 1)) (looking-at "[^ \n\t:]+[ \n\t]*:"))) (setq found 'yes))))) (beginning-of-line) (eq found 'yes))) (defun nnmail-process-unix-mail-format (func artnum-func) (let ((case-fold-search t) (count 0) start message-id content-length end skip head-end) (goto-char (point-min)) (if (not (and (re-search-forward "^From " nil t) (goto-char (match-beginning 0)))) ;; Possibly wrong format? (error "Error, unknown mail format! (Possibly corrupted %s `%s'.)" (if (buffer-file-name) "file" "buffer") (or (buffer-file-name) (buffer-name))) ;; Carry on until the bitter end. (while (not (eobp)) (setq start (point) end nil) ;; Find the end of the head. (narrow-to-region start (if (search-forward "\n\n" nil t) (1- (point)) ;; This will never happen, but just to be on the safe side -- ;; if there is no head-body delimiter, we search a bit manually. (while (and (looking-at "From \\|[^ \t]+:") (not (eobp))) (forward-line 1)) (point))) ;; Find the Message-ID header. (goto-char (point-min)) (if (re-search-forward "^Message-ID[ \t]*:[ \n\t]*\\(<[^>]+>\\)" nil t) (setq message-id (match-string 1)) (save-excursion (when (re-search-forward "^Message-ID[ \t]*:" nil t) (beginning-of-line) (insert "Original-"))) ;; There is no Message-ID here, so we create one. (forward-line 1) (insert "Message-ID: " (setq message-id (nnmail-message-id)) "\n")) ;; Look for a Content-Length header. (goto-char (point-min)) (if (not (re-search-forward "^Content-Length:[ \t]*\\([0-9]+\\)" nil t)) (setq content-length nil) (setq content-length (string-to-number (match-string 1))) ;; We destroy the header, since none of the backends ever ;; use it, and we do not want to confuse other mailers by ;; having a (possibly) faulty header. (beginning-of-line) (insert "X-")) (run-hooks 'nnmail-prepare-incoming-header-hook) ;; Find the end of this article. (goto-char (point-max)) (widen) (setq head-end (point)) ;; We try the Content-Length value. The idea: skip over the header ;; separator, then check what happens content-length bytes into the ;; message body. This should be either the end of the buffer, the ;; message separator or a blank line followed by the separator. ;; The blank line should probably be deleted. If neither of the ;; three is met, the content-length header is probably invalid. (when content-length (forward-line 1) (setq skip (+ (point) content-length)) (goto-char skip) (cond ((or (= skip (point-max)) (= (1+ skip) (point-max))) (setq end (point-max))) ((looking-at "From ") (setq end skip)) ((looking-at "[ \t]*\n\\(From \\)") (setq end (match-beginning 1))) (t (setq end nil)))) (if end (goto-char end) ;; No Content-Length, so we find the beginning of the next ;; article or the end of the buffer. (goto-char head-end) (or (nnmail-search-unix-mail-delim) (goto-char (point-max)))) ;; Allow the backend to save the article. (save-excursion (save-restriction (narrow-to-region start (point)) (goto-char (point-min)) (incf count) (nnmail-check-duplication message-id func artnum-func) (setq end (point-max)))) (goto-char end))) count)) (defun nnmail-process-mmdf-mail-format (func artnum-func) (let ((delim "^\^A\^A\^A\^A$") (case-fold-search t) (count 0) start message-id end) (goto-char (point-min)) (if (not (and (re-search-forward delim nil t) (forward-line 1))) ;; Possibly wrong format? (error "Error, unknown mail format! (Possibly corrupted.)") ;; Carry on until the bitter end. (while (not (eobp)) (setq start (point)) ;; Find the end of the head. (narrow-to-region start (if (search-forward "\n\n" nil t) (1- (point)) ;; This will never happen, but just to be on the safe side -- ;; if there is no head-body delimiter, we search a bit manually. (while (and (looking-at "From \\|[^ \t]+:") (not (eobp))) (forward-line 1)) (point))) ;; Find the Message-ID header. (goto-char (point-min)) (if (re-search-forward "^Message-ID[ \t]*:[ \n\t]*\\(<[^>]+>\\)" nil t) (setq message-id (match-string 1)) ;; There is no Message-ID here, so we create one. (save-excursion (when (re-search-backward "^Message-ID[ \t]*:" nil t) (beginning-of-line) (insert "Original-"))) (forward-line 1) (insert "Message-ID: " (setq message-id (nnmail-message-id)) "\n")) (run-hooks 'nnmail-prepare-incoming-header-hook) ;; Find the end of this article. (goto-char (point-max)) (widen) (if (re-search-forward delim nil t) (beginning-of-line) (goto-char (point-max))) ;; Allow the backend to save the article. (save-excursion (save-restriction (narrow-to-region start (point)) (goto-char (point-min)) (incf count) (nnmail-check-duplication message-id func artnum-func) (setq end (point-max)))) (goto-char end) (forward-line 2))) count)) (defun nnmail-process-maildir-mail-format (func artnum-func) ;; In a maildir, every file contains exactly one mail. (let ((case-fold-search t) message-id) (goto-char (point-min)) ;; Find the end of the head. (narrow-to-region (point-min) (if (search-forward "\n\n" nil t) (1- (point)) ;; This will never happen, but just to be on the safe side -- ;; if there is no head-body delimiter, we search a bit manually. (while (and (looking-at "From \\|[^ \t]+:") (not (eobp))) (forward-line 1)) (point))) ;; Find the Message-ID header. (goto-char (point-min)) (if (re-search-forward "^Message-ID:[ \t]*\\(<[^>]+>\\)" nil t) (setq message-id (match-string 1)) ;; There is no Message-ID here, so we create one. (save-excursion (when (re-search-backward "^Message-ID[ \t]*:" nil t) (beginning-of-line) (insert "Original-"))) (forward-line 1) (insert "Message-ID: " (setq message-id (nnmail-message-id)) "\n")) (run-hooks 'nnmail-prepare-incoming-header-hook) ;; Allow the backend to save the article. (widen) (save-excursion (goto-char (point-min)) (nnmail-check-duplication message-id func artnum-func)) 1)) (defvar nnmail-group-names-not-encoded-p nil "Non-nil means group names are not encoded.") (defun nnmail-split-incoming (incoming func &optional exit-func group artnum-func) "Go through the entire INCOMING file and pick out each individual mail. FUNC will be called with the buffer narrowed to each mail." (let ( ;; If this is a group-specific split, we bind the split ;; methods to just this group. (nnmail-split-methods (if (and group (not nnmail-resplit-incoming)) (list (list group "")) nnmail-split-methods)) (nnmail-group-names-not-encoded-p t)) (save-excursion ;; Insert the incoming file. (set-buffer (get-buffer-create nnmail-article-buffer)) (erase-buffer) (let ((coding-system-for-read nnmail-incoming-coding-system)) (mm-insert-file-contents incoming)) (prog1 (if (zerop (buffer-size)) 0 (goto-char (point-min)) (save-excursion (run-hooks 'nnmail-prepare-incoming-hook)) ;; Handle both babyl, MMDF and unix mail formats, since ;; movemail will use the former when fetching from a ;; mailbox, the latter when fetching from a file. (cond ((or (looking-at "\^L") (looking-at "BABYL OPTIONS:")) (nnmail-process-babyl-mail-format func artnum-func)) ((looking-at "\^A\^A\^A\^A") (nnmail-process-mmdf-mail-format func artnum-func)) ((looking-at "Return-Path:") (nnmail-process-maildir-mail-format func artnum-func)) (t (nnmail-process-unix-mail-format func artnum-func)))) (when exit-func (funcall exit-func)) (kill-buffer (current-buffer)))))) (defun nnmail-article-group (func &optional trace) "Look at the headers and return an alist of groups that match. FUNC will be called with the group name to determine the article number." (let ((methods (or nnmail-split-methods '(("bogus" "")))) (obuf (current-buffer)) group-art method grp) (if (and (sequencep methods) (= (length methods) 1)) ;; If there is only just one group to put everything in, we ;; just return a list with just this one method in. (setq group-art (list (cons (caar methods) (funcall func (caar methods))))) ;; We do actual comparison. (save-excursion ;; Copy the article into the work buffer. (set-buffer nntp-server-buffer) (erase-buffer) (insert-buffer-substring obuf) ;; Narrow to headers. (narrow-to-region (goto-char (point-min)) (if (search-forward "\n\n" nil t) (point) (point-max))) (goto-char (point-min)) ;; Decode MIME headers and charsets. (when nnmail-mail-splitting-decodes (let ((mail-parse-charset nnmail-mail-splitting-charset)) (mail-decode-encoded-word-region (point-min) (point-max)))) ;; Fold continuation lines. (goto-char (point-min)) (while (re-search-forward "\\(\r?\n[ \t]+\\)+" nil t) (replace-match " " t t)) ;; Nuke pathologically long headers. Since Gnus applies ;; pathologically complex regexps to the buffer, lines ;; that are looong will take longer than the Universe's ;; existence to process. (goto-char (point-min)) (while (not (eobp)) (unless (< (move-to-column nnmail-split-header-length-limit) nnmail-split-header-length-limit) (delete-region (point) (point-at-eol))) (forward-line 1)) ;; Allow washing. (goto-char (point-min)) (run-hooks 'nnmail-split-hook) (when (setq nnmail-split-tracing trace) (setq nnmail-split-trace nil)) (if (and (symbolp nnmail-split-methods) (fboundp nnmail-split-methods)) (let ((split (condition-case error-info ;; `nnmail-split-methods' is a function, so we ;; just call this function here and use the ;; result. (or (funcall nnmail-split-methods) '("bogus")) (error (nnheader-message 5 "Error in `nnmail-split-methods'; using `bogus' mail group: %S" error-info) (sit-for 1) '("bogus"))))) (setq split (mm-delete-duplicates split)) ;; The article may be "cross-posted" to `junk'. What ;; to do? Just remove the `junk' spec. Don't really ;; see anything else to do... (let (elem) (while (setq elem (car (memq 'junk split))) (setq split (delq elem split)))) (when split (setq group-art (mapcar (lambda (group) (cons group (funcall func group))) split)))) ;; Go through the split methods to find a match. (while (and methods (or nnmail-crosspost (not group-art))) (goto-char (point-max)) (setq method (pop methods) grp (car method)) (if (or methods (not (equal "" (nth 1 method)))) (when (and (ignore-errors (if (stringp (nth 1 method)) (let ((expand (string-match "\\\\[0-9&]" grp)) (pos (re-search-backward (cadr method) nil t))) (and expand (setq grp (nnmail-expand-newtext grp))) pos) ;; Function to say whether this is a match. (funcall (nth 1 method) grp))) ;; Don't enter the article into the same ;; group twice. (not (assoc grp group-art))) (push (cons grp (funcall func grp)) group-art)) ;; This is the final group, which is used as a ;; catch-all. (unless group-art (setq group-art (list (cons (car method) (funcall func (car method)))))))) ;; Fall back on "bogus" if all else fails. (unless group-art (setq group-art (list (cons "bogus" (funcall func "bogus")))))) ;; Produce a trace if non-empty. (when (and trace nnmail-split-trace) (let ((restore (current-buffer))) (nnheader-set-temp-buffer "*Split Trace*") (gnus-add-buffer) (dolist (trace (nreverse nnmail-split-trace)) (prin1 trace (current-buffer)) (insert "\n")) (goto-char (point-min)) (gnus-configure-windows 'split-trace) (set-buffer restore))) (widen) ;; See whether the split methods returned `junk'. (if (equal group-art '(junk)) nil ;; The article may be "cross-posted" to `junk'. What ;; to do? Just remove the `junk' spec. Don't really ;; see anything else to do... (let (elem) (while (setq elem (car (memq 'junk group-art))) (setq group-art (delq elem group-art))) (nreverse group-art))))))) (defun nnmail-insert-lines () "Insert how many lines there are in the body of the mail. Return the number of characters in the body." (let (lines chars) (save-excursion (goto-char (point-min)) (unless (search-forward "\n\n" nil t) (goto-char (point-max)) (insert "\n")) (setq chars (- (point-max) (point))) (setq lines (count-lines (point) (point-max))) (forward-char -1) (save-excursion (when (re-search-backward "^Lines: " nil t) (delete-region (point) (progn (forward-line 1) (point))))) (beginning-of-line) (insert (format "Lines: %d\n" (max lines 0))) chars))) (defun nnmail-insert-xref (group-alist) "Insert an Xref line based on the (group . article) alist." (save-excursion (goto-char (point-min)) (unless (search-forward "\n\n" nil t) (goto-char (point-max)) (insert "\n")) (forward-char -1) (when (re-search-backward "^Xref: " nil t) (delete-region (match-beginning 0) (progn (forward-line 1) (point)))) (insert (format "Xref: %s" (system-name))) (while group-alist (insert (if (mm-multibyte-p) (mm-string-as-multibyte (format " %s:%d" (caar group-alist) (cdar group-alist))) (mm-string-as-unibyte (format " %s:%d" (caar group-alist) (cdar group-alist))))) (setq group-alist (cdr group-alist))) (insert "\n"))) ;;; Message washing functions (defun nnmail-remove-leading-whitespace () "Remove excessive whitespace from all headers." (goto-char (point-min)) (while (re-search-forward "^\\([^ :]+: \\) +" nil t) (replace-match "\\1" t))) (defun nnmail-remove-list-identifiers () "Remove list identifiers from Subject headers." (let ((regexp (if (consp nnmail-list-identifiers) (mapconcat 'identity nnmail-list-identifiers " *\\|") nnmail-list-identifiers))) (when regexp (goto-char (point-min)) (while (re-search-forward (concat "^Subject: +\\(R[Ee]: +\\)*\\(" regexp " *\\)") nil t) (delete-region (match-beginning 2) (match-end 0)) (beginning-of-line)) (when (re-search-forward "^Subject: +\\(\\(R[Ee]: +\\)+\\)R[Ee]: +" nil t) (delete-region (match-beginning 1) (match-end 1)) (beginning-of-line))))) (defun nnmail-remove-tabs () "Translate TAB characters into SPACE characters." (subst-char-in-region (point-min) (point-max) ?\t ? t)) (defcustom nnmail-broken-references-mailers "^X-Mailer:.*\\(Eudora\\|Pegasus\\)" "Header line matching mailer producing bogus References lines. See `nnmail-ignore-broken-references'." :group 'nnmail-prepare :version "23.1" ;; No Gnus :type 'regexp) (defun nnmail-ignore-broken-references () "Ignore the References line and use In-Reply-To Eudora has a broken References line, but an OK In-Reply-To." (goto-char (point-min)) (when (re-search-forward nnmail-broken-references-mailers nil t) (goto-char (point-min)) (when (re-search-forward "^References:" nil t) (beginning-of-line) (insert "X-Gnus-Broken-Eudora-")) (goto-char (point-min)) (when (re-search-forward "^\\(In-Reply-To:[^\n]+\\)\n[ \t]+" nil t) (replace-match "\\1" t)))) (defalias 'nnmail-fix-eudora-headers 'nnmail-ignore-broken-references) (make-obsolete 'nnmail-fix-eudora-headers 'nnmail-ignore-broken-references) (custom-add-option 'nnmail-prepare-incoming-header-hook 'nnmail-ignore-broken-references) ;;; Utility functions (declare-function gnus-activate-group "gnus-start" (group &optional scan dont-check method)) (defun nnmail-do-request-post (accept-func &optional server) "Utility function to directly post a message to an nnmail-derived group. Calls ACCEPT-FUNC (which should be `nnchoke-request-accept-article') to actually put the message in the right group." (let ((success t)) (dolist (mbx (message-unquote-tokens (message-tokenize-header (message-fetch-field "Newsgroups") ", ")) success) (let ((to-newsgroup (gnus-group-prefixed-name mbx gnus-command-method))) (or (gnus-active to-newsgroup) (gnus-activate-group to-newsgroup) (if (gnus-y-or-n-p (format "No such group: %s. Create it? " to-newsgroup)) (or (and (gnus-request-create-group to-newsgroup gnus-command-method) (gnus-activate-group to-newsgroup nil nil gnus-command-method)) (error "Couldn't create group %s" to-newsgroup))) (error "No such group: %s" to-newsgroup)) (unless (funcall accept-func mbx (nth 1 gnus-command-method)) (setq success nil)))))) (defun nnmail-split-fancy () "Fancy splitting method. See the documentation for the variable `nnmail-split-fancy' for details." (with-syntax-table nnmail-split-fancy-syntax-table (nnmail-split-it nnmail-split-fancy))) (defvar nnmail-split-cache nil) ;; Alist of split expressions their equivalent regexps. (defun nnmail-split-it (split) ;; Return a list of groups matching SPLIT. (let (cached-pair) (cond ;; nil split ((null split) nil) ;; A group name. Do the \& and \N subs into the string. ((stringp split) (when nnmail-split-tracing (push split nnmail-split-trace)) (list (nnmail-expand-newtext split))) ;; Junk the message. ((eq split 'junk) (when nnmail-split-tracing (push "junk" nnmail-split-trace)) (list 'junk)) ;; Builtin & operation. ((eq (car split) '&) (apply 'nconc (mapcar 'nnmail-split-it (cdr split)))) ;; Builtin | operation. ((eq (car split) '|) (let (done) (while (and (not done) (cdr split)) (setq split (cdr split) done (nnmail-split-it (car split)))) done)) ;; Builtin : operation. ((eq (car split) ':) (when nnmail-split-tracing (push split nnmail-split-trace)) (nnmail-split-it (save-excursion (eval (cdr split))))) ;; Builtin ! operation. ((eq (car split) '!) (funcall (cadr split) (nnmail-split-it (caddr split)))) ;; Check the cache for the regexp for this split. ((setq cached-pair (assq split nnmail-split-cache)) (let (split-result (end-point (point-max)) (value (nth 1 split))) (if (symbolp value) (setq value (cdr (assq value nnmail-split-abbrev-alist)))) (while (and (goto-char end-point) (re-search-backward (cdr cached-pair) nil t)) (when nnmail-split-tracing (push split nnmail-split-trace)) (let ((split-rest (cddr split)) (end (match-end 0)) ;; The searched regexp is \(\(FIELD\).*\)\(VALUE\). ;; So, start-of-value is the point just before the ;; beginning of the value, whereas after-header-name ;; is the point just after the field name. (start-of-value (match-end 1)) (after-header-name (match-end 2))) ;; Start the next search just before the beginning of the ;; VALUE match. (setq end-point (1- start-of-value)) ;; Handle - RESTRICTs (while (eq (car split-rest) '-) ;; RESTRICT must start after-header-name and ;; end after start-of-value, so that, for ;; (any "foo" - "x-foo" "foo.list") ;; we do not exclude foo.list just because ;; the header is: ``To: x-foo, foo'' (goto-char end) (if (and (re-search-backward (cadr split-rest) after-header-name t) (> (match-end 0) start-of-value)) (setq split-rest nil) (setq split-rest (cddr split-rest)))) (when split-rest (goto-char end) (let ((value (nth 1 split))) (if (symbolp value) (setq value (cdr (assq value nnmail-split-abbrev-alist)))) ;; Someone might want to do a \N sub on this match, so get the ;; correct match positions. (re-search-backward value start-of-value)) (dolist (sp (nnmail-split-it (car split-rest))) (unless (member sp split-result) (push sp split-result)))))) split-result)) ;; Not in cache, compute a regexp for the field/value pair. (t (let ((field (nth 0 split)) (value (nth 1 split)) (split-rest (cddr split)) partial-front partial-rear regexp) (if (symbolp value) (setq value (cdr (assq value nnmail-split-abbrev-alist)))) (if (and (>= (length value) 2) (string= ".*" (substring value 0 2))) (setq value (substring value 2) partial-front "")) ;; Same trick for the rear of the regexp (if (and (>= (length value) 2) (string= ".*" (substring value -2))) (setq value (substring value 0 -2) partial-rear "")) ;; Invert the match-partial-words behavior if the optional ;; last element is specified. (while (eq (car split-rest) '-) (setq split-rest (cddr split-rest))) (when (if (cadr split-rest) (not nnmail-split-fancy-match-partial-words) nnmail-split-fancy-match-partial-words) (setq partial-front "" partial-rear "")) (setq regexp (concat "^\\(\\(" (if (symbolp field) (cdr (assq field nnmail-split-abbrev-alist)) field) "\\):.*\\)" (or partial-front "\\<") "\\(" value "\\)" (or partial-rear "\\>"))) (push (cons split regexp) nnmail-split-cache) ;; Now that it's in the cache, just call nnmail-split-it again ;; on the same split, which will find it immediately in the cache. (nnmail-split-it split)))))) (defun nnmail-expand-newtext (newtext) (let ((len (length newtext)) (pos 0) c expanded beg N did-expand) (while (< pos len) (setq beg pos) (while (and (< pos len) (not (= (aref newtext pos) ?\\))) (setq pos (1+ pos))) (unless (= beg pos) (push (substring newtext beg pos) expanded)) (when (< pos len) ;; We hit a \; expand it. (setq did-expand t pos (1+ pos) c (aref newtext pos)) (if (not (or (= c ?\&) (and (>= c ?1) (<= c ?9)))) ;; \ followed by some character we don't expand. (push (char-to-string c) expanded) ;; \& or \N (if (= c ?\&) (setq N 0) (setq N (- c ?0))) (when (match-beginning N) (push (if nnmail-split-lowercase-expanded (downcase (buffer-substring (match-beginning N) (match-end N))) (buffer-substring (match-beginning N) (match-end N))) expanded)))) (setq pos (1+ pos))) (if did-expand (apply 'concat (nreverse expanded)) newtext))) ;; Activate a backend only if it isn't already activated. ;; If FORCE, re-read the active file even if the backend is ;; already activated. (defun nnmail-activate (backend &optional force) (nnheader-init-server-buffer) (let (file timestamp file-time) (if (or (not (symbol-value (intern (format "%s-group-alist" backend)))) force (and (setq file (ignore-errors (symbol-value (intern (format "%s-active-file" backend))))) (setq file-time (nth 5 (file-attributes file))) (or (not (setq timestamp (condition-case () (symbol-value (intern (format "%s-active-timestamp" backend))) (error 'none)))) (not (consp timestamp)) (equal timestamp '(0 0)) (> (nth 0 file-time) (nth 0 timestamp)) (and (= (nth 0 file-time) (nth 0 timestamp)) (> (nth 1 file-time) (nth 1 timestamp)))))) (save-excursion (or (eq timestamp 'none) (set (intern (format "%s-active-timestamp" backend)) file-time)) (funcall (intern (format "%s-request-list" backend))))) t)) (defun nnmail-message-id () (concat "<" (message-unique-id) "@totally-fudged-out-message-id>")) ;;; ;;; nnmail duplicate handling ;;; (defvar nnmail-cache-buffer nil) (defun nnmail-cache-open () (if (or (not nnmail-treat-duplicates) (and nnmail-cache-buffer (buffer-name nnmail-cache-buffer))) () ; The buffer is open. (save-excursion (set-buffer (setq nnmail-cache-buffer (get-buffer-create " *nnmail message-id cache*"))) (gnus-add-buffer) (when (file-exists-p nnmail-message-id-cache-file) (nnheader-insert-file-contents nnmail-message-id-cache-file)) (set-buffer-modified-p nil) (current-buffer)))) (defun nnmail-cache-close () (when (and nnmail-cache-buffer nnmail-treat-duplicates (buffer-name nnmail-cache-buffer) (buffer-modified-p nnmail-cache-buffer)) (save-excursion (set-buffer nnmail-cache-buffer) ;; Weed out the excess number of Message-IDs. (goto-char (point-max)) (when (search-backward "\n" nil t nnmail-message-id-cache-length) (progn (beginning-of-line) (delete-region (point-min) (point)))) ;; Save the buffer. (or (file-exists-p (file-name-directory nnmail-message-id-cache-file)) (make-directory (file-name-directory nnmail-message-id-cache-file) t)) (nnmail-write-region (point-min) (point-max) nnmail-message-id-cache-file nil 'silent) (set-buffer-modified-p nil) (setq nnmail-cache-buffer nil) (gnus-kill-buffer (current-buffer))))) ;; Compiler directives. (defvar group) (defvar group-art-list) (defvar group-art) (defun nnmail-cache-insert (id grp &optional subject sender) (when (stringp id) ;; this will handle cases like `B r' where the group is nil (let ((grp (or grp gnus-newsgroup-name "UNKNOWN"))) (run-hook-with-args 'nnmail-spool-hook id grp subject sender)) (when nnmail-treat-duplicates ;; Store some information about the group this message is written ;; to. This is passed in as the grp argument -- all locations this ;; has been called from have been checked and the group is available. ;; The only ambiguous case is nnmail-check-duplication which will only ;; pass the first (of possibly >1) group which matches. -Josh (unless (gnus-buffer-live-p nnmail-cache-buffer) (nnmail-cache-open)) (save-excursion (set-buffer nnmail-cache-buffer) (goto-char (point-max)) (if (and grp (not (string= "" grp)) (gnus-methods-equal-p gnus-command-method (nnmail-cache-primary-mail-backend))) (let ((regexp (if (consp nnmail-cache-ignore-groups) (mapconcat 'identity nnmail-cache-ignore-groups "\\|") nnmail-cache-ignore-groups))) (unless (and regexp (string-match regexp grp)) (insert id "\t" grp "\n"))) (insert id "\n")))))) (defun nnmail-cache-primary-mail-backend () (let ((be-list (cons gnus-select-method gnus-secondary-select-methods)) (be nil) (res nil) (get-new-mail nil)) (while (and (null res) be-list) (setq be (car be-list)) (setq be-list (cdr be-list)) (when (and (gnus-method-option-p be 'respool) (setq get-new-mail (intern (format "%s-get-new-mail" (car be)))) (boundp get-new-mail) (symbol-value get-new-mail)) (setq res be))) res)) ;; Fetch the group name corresponding to the message id stored in the ;; cache. (defun nnmail-cache-fetch-group (id) (when (and nnmail-treat-duplicates nnmail-cache-buffer) (save-excursion (set-buffer nnmail-cache-buffer) (goto-char (point-max)) (when (search-backward id nil t) (beginning-of-line) (skip-chars-forward "^\n\r\t") (unless (looking-at "[\r\n]") (forward-char 1) (buffer-substring (point) (point-at-eol))))))) ;; Function for nnmail-split-fancy: look up all references in the ;; cache and if a match is found, return that group. (defun nnmail-split-fancy-with-parent () "Split this message into the same group as its parent. This function can be used as an entry in `nnmail-split-fancy', for example like this: (: nnmail-split-fancy-with-parent) For a message to be split, it looks for the parent message in the References or In-Reply-To header and then looks in the message id cache file (given by the variable `nnmail-message-id-cache-file') to see which group that message was put in. This group is returned. See the Info node `(gnus)Fancy Mail Splitting' for more details." (let* ((refstr (or (message-fetch-field "references") (message-fetch-field "in-reply-to"))) (references nil) (res nil) (regexp (if (consp nnmail-split-fancy-with-parent-ignore-groups) (mapconcat (lambda (x) (format "\\(%s\\)" x)) nnmail-split-fancy-with-parent-ignore-groups "\\|") nnmail-split-fancy-with-parent-ignore-groups))) (when refstr (setq references (nreverse (gnus-split-references refstr))) (unless (gnus-buffer-live-p nnmail-cache-buffer) (nnmail-cache-open)) (dolist (x references) (setq res (or (nnmail-cache-fetch-group x) res)) (when (or (member res '("delayed" "drafts" "queue")) (and regexp res (string-match regexp res))) (setq res nil))) res))) (defun nnmail-cache-id-exists-p (id) (when nnmail-treat-duplicates (save-excursion (set-buffer nnmail-cache-buffer) (goto-char (point-max)) (search-backward id nil t)))) (defun nnmail-fetch-field (header) (save-excursion (save-restriction (message-narrow-to-head) (message-fetch-field header)))) (defun nnmail-check-duplication (message-id func artnum-func) (run-hooks 'nnmail-prepare-incoming-message-hook) ;; If this is a duplicate message, then we do not save it. (let* ((duplication (nnmail-cache-id-exists-p message-id)) (case-fold-search t) (action (when duplication (cond ((memq nnmail-treat-duplicates '(warn delete)) nnmail-treat-duplicates) ((functionp nnmail-treat-duplicates) (funcall nnmail-treat-duplicates message-id)) (t nnmail-treat-duplicates)))) group-art) ;; We insert a line that says what the mail source is. (let ((case-fold-search t)) (goto-char (point-min)) (re-search-forward "^message-id[ \t]*:" nil t) (beginning-of-line) (insert (format "X-Gnus-Mail-Source: %s\n" mail-source-string))) ;; Let the backend save the article (or not). (cond ((not duplication) (funcall func (setq group-art (nreverse (nnmail-article-group artnum-func)))) (nnmail-cache-insert message-id (caar group-art))) ((eq action 'delete) (setq group-art nil)) ((eq action 'warn) ;; We insert a warning. (let ((case-fold-search t)) (goto-char (point-min)) (re-search-forward "^message-id[ \t]*:" nil t) (beginning-of-line) (insert "Gnus-Warning: This is a duplicate of message " message-id "\n") (funcall func (setq group-art (nreverse (nnmail-article-group artnum-func)))))) (t (funcall func (setq group-art (nreverse (nnmail-article-group artnum-func)))))) ;; Add the group-art list to the history list. (if group-art (push group-art nnmail-split-history) (delete-region (point-min) (point-max))))) ;;; Get new mail. (defvar nnmail-fetched-sources nil) (defun nnmail-get-value (&rest args) (let ((sym (intern (apply 'format args)))) (when (boundp sym) (symbol-value sym)))) (defun nnmail-get-new-mail (method exit-func temp &optional group spool-func) "Read new incoming mail." (nnmail-get-new-mail-1 method exit-func temp group nil spool-func)) (defun nnmail-get-new-mail-1 (method exit-func temp group in-group spool-func) (let* ((sources mail-sources) fetching-sources (i 0) (new 0) (total 0) incoming incomings source) (when (and (nnmail-get-value "%s-get-new-mail" method) sources) (while (setq source (pop sources)) ;; Use group's parameter (when (eq (car source) 'group) (let ((mail-sources (list (gnus-group-find-parameter (concat (symbol-name method) ":" group) 'mail-source t)))) (nnmail-get-new-mail-1 method exit-func temp group group spool-func)) (setq source nil)) ;; Hack to only fetch the contents of a single group's spool file. (when (and (eq (car source) 'directory) (null nnmail-scan-directory-mail-source-once) group) (mail-source-bind (directory source) (setq source (append source (list :predicate (gnus-byte-compile `(lambda (file) (string-equal ,(concat group suffix) (file-name-nondirectory file))))))))) (when nnmail-fetched-sources (if (member source nnmail-fetched-sources) (setq source nil) (push source nnmail-fetched-sources) (push source fetching-sources))))) (when fetching-sources ;; We first activate all the groups. (nnmail-activate method) ;; Allow the user to hook. (run-hooks 'nnmail-pre-get-new-mail-hook) ;; Open the message-id cache. (nnmail-cache-open) ;; The we go through all the existing mail source specification ;; and fetch the mail from each. (while (setq source (pop fetching-sources)) (nnheader-message 4 "%s: Reading incoming mail from %s..." method (car source)) (when (setq new (mail-source-fetch source (gnus-byte-compile `(lambda (file orig-file) (nnmail-split-incoming file ',(intern (format "%s-save-mail" method)) ',spool-func (or in-group (if (equal file orig-file) nil (nnmail-get-split-group orig-file ',source))) ',(intern (format "%s-active-number" method))))))) (incf total new) (incf i))) ;; If we did indeed read any incoming spools, we save all info. (if (zerop total) (nnheader-message 4 "%s: Reading incoming mail (no new mail)...done" method (car source)) (nnmail-save-active (nnmail-get-value "%s-group-alist" method) (nnmail-get-value "%s-active-file" method)) (when exit-func (funcall exit-func)) (run-hooks 'nnmail-read-incoming-hook) (nnheader-message 4 "%s: Reading incoming mail (%d new)...done" method total)) ;; Close the message-id cache. (nnmail-cache-close) ;; Allow the user to hook. (run-hooks 'nnmail-post-get-new-mail-hook)))) (defun nnmail-expired-article-p (group time force &optional inhibit) "Say whether an article that is TIME old in GROUP should be expired." (if force t (let ((days (or (and nnmail-expiry-wait-function (funcall nnmail-expiry-wait-function group)) nnmail-expiry-wait))) (cond ((or (eq days 'never) (and (not force) inhibit)) ;; This isn't an expirable group. nil) ((eq days 'immediate) ;; We expire all articles on sight. t) ((equal time '(0 0)) ;; This is an ange-ftp group, and we don't have any dates. nil) ((numberp days) (setq days (days-to-time days)) ;; Compare the time with the current time. (ignore-errors (time-less-p days (time-since time)))))))) (declare-function gnus-group-mark-article-read "gnus-group" (group article)) (defun nnmail-expiry-target-group (target group) ;; Do not invoke this from nntp-server-buffer! At least nnfolder clears ;; that buffer if the nnfolder group isn't selected. (let (nnmail-cache-accepted-message-ids) ;; Don't enter Message-IDs into cache. ;; Let users hack it in TARGET function. (when (functionp target) (setq target (funcall target group))) (unless (eq target 'delete) (when (or (gnus-request-group target) (gnus-request-create-group target)) (let ((group-art (gnus-request-accept-article target nil nil t))) (when (consp group-art) (gnus-group-mark-article-read target (cdr group-art)))))))) (defun nnmail-fancy-expiry-target (group) "Returns a target expiry group determined by `nnmail-fancy-expiry-targets'." (let* (header (case-fold-search nil) (from (or (message-fetch-field "from") "")) (to (or (message-fetch-field "to") "")) (date (message-fetch-field "date")) (target 'delete)) (setq date (if date (condition-case err (date-to-time date) (error (message "%s" (error-message-string err)) (current-time))) (current-time))) (dolist (regexp-target-pair (reverse nnmail-fancy-expiry-targets) target) (setq header (car regexp-target-pair)) (cond ;; If the header is to-from then match against the ;; To or From header ((and (equal header 'to-from) (or (string-match (cadr regexp-target-pair) from) (and (string-match (cadr regexp-target-pair) to) (let ((rmail-dont-reply-to-names (message-dont-reply-to-names))) (equal (rmail-dont-reply-to from) ""))))) (setq target (format-time-string (caddr regexp-target-pair) date))) ((and (not (equal header 'to-from)) (string-match (cadr regexp-target-pair) (or (message-fetch-field header) ""))) (setq target (format-time-string (caddr regexp-target-pair) date))))))) (defun nnmail-check-syntax () "Check (and modify) the syntax of the message in the current buffer." (save-restriction (message-narrow-to-head) (let ((case-fold-search t)) (unless (re-search-forward "^Message-ID[ \t]*:" nil t) (insert "Message-ID: " (nnmail-message-id) "\n"))))) (defun nnmail-write-region (start end filename &optional append visit lockname) "Do a `write-region', and then set the file modes." (let ((coding-system-for-write nnmail-file-coding-system) (file-name-coding-system nnmail-pathname-coding-system)) (write-region start end filename append visit lockname) (set-file-modes filename nnmail-default-file-modes))) ;;; ;;; Status functions ;;; (defun nnmail-replace-status (name value) "Make status NAME and VALUE part of the current status line." (save-restriction (message-narrow-to-head) (let ((status (nnmail-decode-status))) (setq status (delq (member name status) status)) (when value (push (cons name value) status)) (message-remove-header "status") (goto-char (point-max)) (insert "Status: " (nnmail-encode-status status) "\n")))) (defun nnmail-decode-status () "Return a status-value alist from STATUS." (goto-char (point-min)) (when (re-search-forward "^Status: " nil t) (let (name value status) (save-restriction ;; Narrow to the status. (narrow-to-region (point) (if (re-search-forward "^[^ \t]" nil t) (1- (point)) (point-max))) ;; Go through all elements and add them to the list. (goto-char (point-min)) (while (re-search-forward "[^ \t=]+" nil t) (setq name (match-string 0)) (if (not (eq (char-after) ?=)) ;; Implied "yes". (setq value "yes") (forward-char 1) (if (not (eq (char-after) ?\")) (if (not (looking-at "[^ \t]")) ;; Implied "no". (setq value "no") ;; Unquoted value. (setq value (match-string 0)) (goto-char (match-end 0))) ;; Quoted value. (setq value (read (current-buffer))))) (push (cons name value) status))) status))) (defun nnmail-encode-status (status) "Return a status string from STATUS." (mapconcat (lambda (elem) (concat (car elem) "=" (if (string-match "[ \t]" (cdr elem)) (prin1-to-string (cdr elem)) (cdr elem)))) status " ")) (defun nnmail-split-history () "Generate an overview of where the last mail split put articles." (interactive) (unless nnmail-split-history (error "No current split history")) (with-output-to-temp-buffer "*nnmail split history*" (with-current-buffer standard-output (fundamental-mode)) ; for Emacs 20.4+ (dolist (elem nnmail-split-history) (princ (mapconcat (lambda (ga) (concat (car ga) ":" (int-to-string (cdr ga)))) elem ", ")) (princ "\n")))) (defun nnmail-purge-split-history (group) "Remove all instances of GROUP from `nnmail-split-history'." (let ((history nnmail-split-history)) (while history (setcar history (gnus-remove-if (lambda (e) (string= (car e) group)) (car history))) (pop history)) (setq nnmail-split-history (delq nil nnmail-split-history)))) (defun nnmail-new-mail-p (group) "Say whether GROUP has new mail." (let ((his nnmail-split-history) found) (while his (when (assoc group (pop his)) (setq found t his nil))) found)) (defun nnmail-within-headers-p () "Check to see if point is within the headers of a unix mail message. Doesn't change point." (let ((pos (point))) (save-excursion (and (nnmail-search-unix-mail-delim-backward) (not (search-forward "\n\n" pos t)))))) (run-hooks 'nnmail-load-hook) (provide 'nnmail) ;; arch-tag: fe8f671a-50db-428a-bb5d-f00462f72ed7 ;;; nnmail.el ends here gnus-5.11+v0.10.dfsg/lisp/nnultimate.el0000644000175000017500000004002111004005110017720 0ustar tvainikatvainika;;; nnultimate.el --- interfacing with the Ultimate Bulletin Board system ;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, ;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; Keywords: news ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 3, or (at your option) ;; any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Commentary: ;; Note: You need to have `url' and `w3' installed for this ;; backend to work. ;;; Code: (eval-when-compile (require 'cl)) (require 'nnoo) (require 'message) (require 'gnus-util) (require 'gnus) (require 'nnmail) (require 'mm-util) (require 'mm-url) (require 'nnweb) (require 'parse-time) (autoload 'w3-parse-buffer "w3-parse") (nnoo-declare nnultimate) (defvoo nnultimate-directory (nnheader-concat gnus-directory "ultimate/") "Where nnultimate will save its files.") (defvoo nnultimate-address "" "The address of the Ultimate bulletin board.") ;;; Internal variables (defvar nnultimate-groups-alist nil) (defvoo nnultimate-groups nil) (defvoo nnultimate-headers nil) (defvoo nnultimate-articles nil) (defvar nnultimate-table-regexp "postings.*editpost\\|forumdisplay\\|Forum[0-9]+/HTML\\|getbio") ;;; Interface functions (nnoo-define-basics nnultimate) (deffoo nnultimate-retrieve-headers (articles &optional group server fetch-old) (nnultimate-possibly-change-server group server) (unless gnus-nov-is-evil (let* ((last (car (last articles))) (did nil) (start 1) (entry (assoc group nnultimate-groups)) (sid (nth 2 entry)) (topics (nth 4 entry)) (mapping (nth 5 entry)) (old-total (or (nth 6 entry) 1)) (furl "forumdisplay.cgi?action=topics&number=%d&DaysPrune=1000") (furls (list (concat nnultimate-address (format furl sid)))) (nnultimate-table-regexp "postings.*editpost\\|forumdisplay\\|getbio") headers article subject score from date lines parent point contents tinfo fetchers map elem a href garticles topic old-max inc datel table current-page total-contents pages farticles forum-contents parse furl-fetched mmap farticle) (setq map mapping) (while (and (setq article (car articles)) map) ;; Skip past the articles in the map until we reach the ;; article we're looking for. (while (and map (or (> article (caar map)) (< (cadar map) (caar map)))) (pop map)) (when (setq mmap (car map)) (setq farticle -1) (while (and article (<= article (nth 1 mmap))) ;; Do we already have a fetcher for this topic? (if (setq elem (assq (nth 2 mmap) fetchers)) ;; Yes, so we just add the spec to the end. (nconc elem (list (cons article (+ (nth 3 mmap) (incf farticle))))) ;; No, so we add a new one. (push (list (nth 2 mmap) (cons article (+ (nth 3 mmap) (incf farticle)))) fetchers)) (pop articles) (setq article (car articles))))) ;; Now we have the mapping from/to Gnus/nnultimate article numbers, ;; so we start fetching the topics that we need to satisfy the ;; request. (if (not fetchers) (save-excursion (set-buffer nntp-server-buffer) (erase-buffer)) (setq nnultimate-articles nil) (mm-with-unibyte-buffer (dolist (elem fetchers) (setq pages 1 current-page 1 total-contents nil) (while (<= current-page pages) (erase-buffer) (setq subject (nth 2 (assq (car elem) topics))) (setq href (nth 3 (assq (car elem) topics))) (if (= current-page 1) (mm-url-insert href) (string-match "\\.html$" href) (mm-url-insert (concat (substring href 0 (match-beginning 0)) "-" (number-to-string current-page) (match-string 0 href)))) (goto-char (point-min)) (setq contents (ignore-errors (w3-parse-buffer (current-buffer)))) (setq table (nnultimate-find-forum-table contents)) (goto-char (point-min)) (when (re-search-forward "topic is \\([0-9]+\\) pages" nil t) (setq pages (string-to-number (match-string 1)))) (setq contents (cdr (nth 2 (car (nth 2 table))))) (setq total-contents (nconc total-contents contents)) (incf current-page)) (when t (let ((i 0)) (dolist (co total-contents) (push (list (or (nnultimate-topic-article-to-article group (car elem) (incf i)) 1) co subject) nnultimate-articles)))) (when nil (dolist (art (cdr elem)) (when (nth (1- (cdr art)) total-contents) (push (list (car art) (nth (1- (cdr art)) total-contents) subject) nnultimate-articles)))))) (setq nnultimate-articles (sort nnultimate-articles 'car-less-than-car)) ;; Now we have all the articles, conveniently in an alist ;; where the key is the Gnus article number. (dolist (articlef nnultimate-articles) (setq article (nth 0 articlef) contents (nth 1 articlef) subject (nth 2 articlef)) (setq from (mapconcat 'identity (nnweb-text (car (nth 2 contents))) " ") datel (nnweb-text (nth 2 (car (cdr (nth 2 contents)))))) (while datel (when (string-match "Posted" (car datel)) (setq date (substring (car datel) (match-end 0)) datel nil)) (pop datel)) (when date (setq date (delete "" (split-string date "[-, \n\t\r    ]"))) (setq date (if (or (member "AM" date) (member "PM" date)) (format "%s %s %s %s" (nth 1 date) (if (and (>= (length (nth 0 date)) 3) (assoc (downcase (substring (nth 0 date) 0 3)) parse-time-months)) (substring (nth 0 date) 0 3) (car (rassq (string-to-number (nth 0 date)) parse-time-months))) (nth 2 date) (nth 3 date)) (format "%s %s %s %s" (car (rassq (string-to-number (nth 1 date)) parse-time-months)) (nth 0 date) (nth 2 date) (nth 3 date))))) (push (cons article (make-full-mail-header article subject from (or date "") (concat "<" (number-to-string sid) "%" (number-to-string article) "@ultimate." server ">") "" 0 (/ (length (mapconcat 'identity (nnweb-text (cdr (nth 2 (nth 1 (nth 2 contents))))) "")) 70) nil nil)) headers)) (setq nnultimate-headers (sort headers 'car-less-than-car)) (save-excursion (set-buffer nntp-server-buffer) (mm-with-unibyte-current-buffer (erase-buffer) (dolist (header nnultimate-headers) (nnheader-insert-nov (cdr header)))))) 'nov))) (defun nnultimate-topic-article-to-article (group topic article) (catch 'found (dolist (elem (nth 5 (assoc group nnultimate-groups))) (when (and (= topic (nth 2 elem)) (>= article (nth 3 elem)) (< article (+ (- (nth 1 elem) (nth 0 elem)) 1 (nth 3 elem)))) (throw 'found (+ (nth 0 elem) (- article (nth 3 elem)))))))) (deffoo nnultimate-request-group (group &optional server dont-check) (nnultimate-possibly-change-server nil server) (when (not nnultimate-groups) (nnultimate-request-list)) (unless dont-check (nnultimate-create-mapping group)) (let ((elem (assoc group nnultimate-groups))) (cond ((not elem) (nnheader-report 'nnultimate "Group does not exist")) (t (nnheader-report 'nnultimate "Opened group %s" group) (nnheader-insert "211 %d %d %d %s\n" (cadr elem) 1 (cadr elem) (prin1-to-string group)))))) (deffoo nnultimate-request-close () (setq nnultimate-groups-alist nil nnultimate-groups nil)) (deffoo nnultimate-request-article (article &optional group server buffer) (nnultimate-possibly-change-server group server) (let ((contents (cdr (assq article nnultimate-articles)))) (setq contents (cddr (nth 2 (nth 1 (nth 2 (car contents)))))) (when contents (save-excursion (set-buffer (or buffer nntp-server-buffer)) (erase-buffer) (nnweb-insert-html (cons 'p (cons nil (list contents)))) (goto-char (point-min)) (insert "Content-Type: text/html\nMIME-Version: 1.0\n") (let ((header (cdr (assq article nnultimate-headers)))) (mm-with-unibyte-current-buffer (nnheader-insert-header header))) (nnheader-report 'nnultimate "Fetched article %s" article) (cons group article))))) (deffoo nnultimate-request-list (&optional server) (nnultimate-possibly-change-server nil server) (mm-with-unibyte-buffer (mm-url-insert (if (string-match "/$" nnultimate-address) (concat nnultimate-address "Ultimate.cgi") nnultimate-address)) (let ((contents (nth 2 (car (nth 2 (nnultimate-find-forum-table (w3-parse-buffer (current-buffer))))))) sid elem description articles a href group forum a1 a2) (dolist (row contents) (setq row (nth 2 row)) (when (setq a (nnweb-parse-find 'a row)) (setq group (car (last (nnweb-text a))) href (cdr (assq 'href (nth 1 a)))) (setq description (car (last (nnweb-text (nth 1 row))))) (setq a1 (car (last (nnweb-text (nth 2 row))))) (setq a2 (car (last (nnweb-text (nth 3 row))))) (when (string-match "^[0-9]+$" a1) (setq articles (string-to-number a1))) (when (and a2 (string-match "^[0-9]+$" a2)) (setq articles (max articles (string-to-number a2)))) (when href (string-match "number=\\([0-9]+\\)" href) (setq forum (string-to-number (match-string 1 href))) (if (setq elem (assoc group nnultimate-groups)) (setcar (cdr elem) articles) (push (list group articles forum description nil nil nil nil) nnultimate-groups)))))) (nnultimate-write-groups) (nnultimate-generate-active) t)) (deffoo nnultimate-request-newgroups (date &optional server) (nnultimate-possibly-change-server nil server) (nnultimate-generate-active) t) (nnoo-define-skeleton nnultimate) ;;; Internal functions (defun nnultimate-prune-days (group time) "Compute the number of days to fetch info for." (let ((old-time (nth 7 (assoc group nnultimate-groups)))) (if (null old-time) 1000 (- (time-to-days time) (time-to-days old-time))))) (defun nnultimate-create-mapping (group) (let* ((entry (assoc group nnultimate-groups)) (sid (nth 2 entry)) (topics (nth 4 entry)) (mapping (nth 5 entry)) (old-total (or (nth 6 entry) 1)) (current-time (current-time)) (furl (concat "forumdisplay.cgi?action=topics&number=%d&DaysPrune=" (number-to-string (nnultimate-prune-days group current-time)))) (furls (list (concat nnultimate-address (format furl sid)))) contents forum-contents furl-fetched a subject href garticles topic tinfo old-max inc parse) (mm-with-unibyte-buffer (while furls (erase-buffer) (mm-url-insert (pop furls)) (goto-char (point-min)) (setq parse (w3-parse-buffer (current-buffer))) (setq contents (cdr (nth 2 (car (nth 2 (nnultimate-find-forum-table parse)))))) (setq forum-contents (nconc contents forum-contents)) (unless furl-fetched (setq furl-fetched t) ;; On the first time through this loop, we find all the ;; forum URLs. (dolist (a (nnweb-parse-find-all 'a parse)) (let ((href (cdr (assq 'href (nth 1 a))))) (when (and href (string-match "forumdisplay.*startpoint" href)) (push href furls)))) (setq furls (nreverse furls)))) ;; The main idea here is to map Gnus article numbers to ;; nnultimate article numbers. Say there are three topics in ;; this forum, the first with 4 articles, the seconds with 2, ;; and the third with 1. Then this will translate into 7 Gnus ;; article numbers, where 1-4 comes from the first topic, 5-6 ;; from the second and 7 from the third. Now, then next time ;; the group is entered, there's 2 new articles in topic one ;; and 1 in topic three. Then Gnus article number 8-9 be 5-6 ;; in topic one and 10 will be the 2 in topic three. (dolist (row (nreverse forum-contents)) (setq row (nth 2 row)) (when (setq a (nnweb-parse-find 'a row)) (setq subject (car (last (nnweb-text a))) href (cdr (assq 'href (nth 1 a)))) (let ((artlist (nreverse (nnweb-text row))) art) (while (and (not art) artlist) (when (string-match "^[0-9]+$" (car artlist)) (setq art (1+ (string-to-number (car artlist))))) (pop artlist)) (setq garticles art)) (when garticles (string-match "/\\([0-9]+\\).html" href) (setq topic (string-to-number (match-string 1 href))) (if (setq tinfo (assq topic topics)) (progn (setq old-max (cadr tinfo)) (setcar (cdr tinfo) garticles)) (setq old-max 0) (push (list topic garticles subject href) topics) (setcar (nthcdr 4 entry) topics)) (when (not (= old-max garticles)) (setq inc (- garticles old-max)) (setq mapping (nconc mapping (list (list old-total (1- (incf old-total inc)) topic (1+ old-max))))) (incf old-max inc) (setcar (nthcdr 5 entry) mapping) (setcar (nthcdr 6 entry) old-total)))))) (setcar (nthcdr 7 entry) current-time) (setcar (nthcdr 1 entry) (1- old-total)) (nnultimate-write-groups) mapping)) (defun nnultimate-possibly-change-server (&optional group server) (nnultimate-init server) (when (and server (not (nnultimate-server-opened server))) (nnultimate-open-server server)) (unless nnultimate-groups-alist (nnultimate-read-groups) (setq nnultimate-groups (cdr (assoc nnultimate-address nnultimate-groups-alist))))) (deffoo nnultimate-open-server (server &optional defs connectionless) (nnheader-init-server-buffer) (if (nnultimate-server-opened server) t (unless (assq 'nnultimate-address defs) (setq defs (append defs (list (list 'nnultimate-address server))))) (nnoo-change-server 'nnultimate server defs))) (defun nnultimate-read-groups () (setq nnultimate-groups-alist nil) (let ((file (expand-file-name "groups" nnultimate-directory))) (when (file-exists-p file) (mm-with-unibyte-buffer (insert-file-contents file) (goto-char (point-min)) (setq nnultimate-groups-alist (read (current-buffer))))))) (defun nnultimate-write-groups () (setq nnultimate-groups-alist (delq (assoc nnultimate-address nnultimate-groups-alist) nnultimate-groups-alist)) (push (cons nnultimate-address nnultimate-groups) nnultimate-groups-alist) (with-temp-file (expand-file-name "groups" nnultimate-directory) (prin1 nnultimate-groups-alist (current-buffer)))) (defun nnultimate-init (server) "Initialize buffers and such." (unless (file-exists-p nnultimate-directory) (gnus-make-directory nnultimate-directory))) (defun nnultimate-generate-active () (save-excursion (set-buffer nntp-server-buffer) (erase-buffer) (dolist (elem nnultimate-groups) (insert (prin1-to-string (car elem)) " " (number-to-string (cadr elem)) " 1 y\n")))) (defun nnultimate-find-forum-table (contents) (catch 'found (nnultimate-find-forum-table-1 contents))) (defun nnultimate-find-forum-table-1 (contents) (dolist (element contents) (unless (stringp element) (when (and (eq (car element) 'table) (nnultimate-forum-table-p element)) (throw 'found element)) (when (nth 2 element) (nnultimate-find-forum-table-1 (nth 2 element)))))) (defun nnultimate-forum-table-p (parse) (when (not (apply 'gnus-or (mapcar (lambda (p) (nnweb-parse-find 'table p)) (nth 2 parse)))) (let ((href (cdr (assq 'href (nth 1 (nnweb-parse-find 'a parse 20))))) case-fold-search) (when (and href (string-match nnultimate-table-regexp href)) t)))) (provide 'nnultimate) ;; Local Variables: ;; coding: iso-8859-1 ;; End: ;; arch-tag: ab6bfc45-8fe1-4647-9c78-41050eb152b8 ;;; nnultimate.el ends here gnus-5.11+v0.10.dfsg/lisp/deuglify.el0000644000175000017500000004216711004005111017366 0ustar tvainikatvainika;;; deuglify.el --- deuglify broken Outlook (Express) articles ;; Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 ;; Free Software Foundation, Inc. ;; Author: Raymond Scholz ;; Thomas Steffen (unwrapping algorithm, ;; based on an idea of Stefan Monnier) ;; Keywords: mail, news ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 3, or (at your option) ;; any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Commentary: ;; This file enables Gnus to repair broken citations produced by ;; common user agents like MS Outlook (Express). It may repair ;; articles of other user agents too. ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; Outlook sometimes wraps cited lines before sending a message as ;; seen in this example: ;; ;; Example #1 ;; ---------- ;; ;; John Doe wrote: ;; ;; > This sentence no verb. This sentence no verb. This sentence ;; no ;; > verb. This sentence no verb. This sentence no verb. This ;; > sentence no verb. ;; ;; The function `gnus-article-outlook-unwrap-lines' tries to recognize those ;; erroneously wrapped lines and will unwrap them. I.e. putting the ;; wrapped parts ("no" in this example) back where they belong (at the ;; end of the cited line above). ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; Note that some people not only use broken user agents but also ;; practice a bad citation style by omitting blank lines between the ;; cited text and their own text. ;: ;; Example #2 ;; ---------- ;; ;; John Doe wrote: ;; ;; > This sentence no verb. This sentence no verb. This sentence no ;; You forgot in all your sentences. ;; > verb. This sentence no verb. This sentence no verb. This ;; > sentence no verb. ;; ;; Unwrapping "You forgot in all your sentences." would be invalid as ;; this part wasn't intended to be cited text. ;; `gnus-article-outlook-unwrap-lines' will only unwrap lines if the resulting ;; citation line will be of a certain maximum length. You can control ;; this by adjusting `gnus-outlook-deuglify-unwrap-max'. Also ;; unwrapping will only be done if the line above the (possibly) ;; wrapped line has a minimum length of `gnus-outlook-deuglify-unwrap-min'. ;; ;; Furthermore no unwrapping will be undertaken if the last character ;; is one of the chars specified in ;; `gnus-outlook-deuglify-unwrap-stop-chars'. Setting this to ".?!" ;; inhibits unwrapping if the cited line ends with a full stop, ;; question mark or exclamation mark. Note that this variable ;; defaults to `nil', triggering a few false positives but generally ;; giving you better results. ;; ;; Unwrapping works on every level of citation. Thus you will be able ;; repair broken citations of broken user agents citing broken ;; citations of broken user agents citing broken citations... ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; Citations are commonly introduced with an attribution line ;; indicating who wrote the cited text. Outlook adds superfluous ;; information that can be found in the header of the message to this ;; line and often wraps it. ;; ;; If that weren't enough, lots of people write their own text above ;; the cited text and cite the complete original article below. ;; ;; Example #3 ;; ---------- ;; ;; Hey, John. There's no in all your sentences! ;; ;; John Doe wrote in message ;; news:a87usw8$dklsssa$2@some.news.server... ;; > This sentence no verb. This sentence no verb. This sentence ;; no ;; > verb. This sentence no verb. This sentence no verb. This ;; > sentence no verb. ;; > ;; > Bye, John ;; ;; Repairing the attribution line will be done by function ;; `gnus-article-outlook-repair-attribution which calls other function that ;; try to recognize and repair broken attribution lines. See variable ;; `gnus-outlook-deuglify-attrib-cut-regexp' for stuff that should be ;; cut off from the beginning of an attribution line and variable ;; `gnus-outlook-deuglify-attrib-verb-regexp' for the verbs that are ;; required to be found in an attribution line. These function return ;; the point where the repaired attribution line starts. ;; ;; Rearranging the article so that the cited text appears above the ;; new text will be done by function ;; `gnus-article-outlook-rearrange-citation'. This function calls ;; `gnus-article-outlook-repair-attribution to find and repair an attribution ;; line. ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; Well, and that's what the message will look like after applying ;; deuglification: ;; ;; Example #3 (deuglified) ;; ----------------------- ;; ;; John Doe wrote: ;; ;; > This sentence no verb. This sentence no verb. This sentence no ;; > verb. This sentence no verb. This sentence no verb. This ;; > sentence no verb. ;; > ;; > Bye, John ;; ;; Hey, John. There's no in all your sentences! ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; Usage ;; ----- ;; ;; Press `W k' in the Summary Buffer. ;; ;; Non recommended usage :-) ;; --------------------- ;; ;; To automatically invoke deuglification on every article you read, ;; put something like that in your .gnus: ;; ;; (add-hook 'gnus-article-decode-hook 'gnus-article-outlook-unwrap-lines) ;; ;; or _one_ of the following lines: ;; ;; ;; repair broken attribution lines ;; (add-hook 'gnus-article-decode-hook 'gnus-article-outlook-repair-attribution) ;; ;; ;; repair broken attribution lines and citations ;; (add-hook 'gnus-article-decode-hook 'gnus-article-outlook-rearrange-citation) ;; ;; Note that there always may be some false positives, so I suggest ;; using the manual invocation. After deuglification you may want to ;; refill the whole article using `W w'. ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; Limitations ;; ----------- ;; ;; As I said before there may (or will) be a few false positives on ;; unwrapping cited lines with `gnus-article-outlook-unwrap-lines'. ;; ;; `gnus-article-outlook-repair-attribution will only fix the first ;; attribution line found in the article. Furthermore it fixed to ;; certain kinds of attributions. And there may be horribly many ;; false positives, vanishing lines and so on -- so don't trust your ;; eyes. Again I recommend manual invocation. ;; ;; `gnus-article-outlook-rearrange-citation' carries all the limitations of ;; `gnus-article-outlook-repair-attribution. ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; See ChangeLog for other changes. ;; ;; Revision 1.5 2002/01/27 14:39:17 rscholz ;; * New variable `gnus-outlook-deuglify-no-wrap-chars' to inhibit ;; unwrapping if one these chars is first in the possibly wrapped line. ;; * Improved rearranging of the article. ;; * New function `gnus-outlook-repair-attribution-block' for repairing ;; those big "Original Message (following some headers)" attributions. ;; ;; Revision 1.4 2002/01/03 14:05:00 rscholz ;; Renamed `gnus-outlook-deuglify-article' to ;; `gnus-article-outlook-deuglify-article'. ;; Made it easier to deuglify the article while being in Gnus' Article ;; Edit Mode. (suggested by Phil Nitschke) ;; ;; ;; Revision 1.3 2002/01/02 23:35:54 rscholz ;; Fix a bug that caused succeeding long attribution lines to be ;; unwrapped. Minor doc fixes and regular expression tuning. ;; ;; Revision 1.2 2001/12/30 20:14:34 rscholz ;; Clean up source. ;; ;; Revision 1.1 2001/12/30 20:13:32 rscholz ;; Initial revision ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Code: (require 'gnus-art) (require 'gnus-sum) (defconst gnus-outlook-deuglify-version "1.5 Gnus version" "Version of gnus-outlook-deuglify.") ;;; User Customizable Variables: (defgroup gnus-outlook-deuglify nil "Deuglify articles generated by broken user agents like MS Outlook (Express)." :version "22.1" :group 'gnus) (defcustom gnus-outlook-deuglify-unwrap-min 45 "Minimum length of the cited line above the (possibly) wrapped line." :version "22.1" :type 'integer :group 'gnus-outlook-deuglify) (defcustom gnus-outlook-deuglify-unwrap-max 95 "Maximum length of the cited line after unwrapping." :version "22.1" :type 'integer :group 'gnus-outlook-deuglify) (defcustom gnus-outlook-deuglify-cite-marks ">|#%" "Characters that indicate cited lines." :version "22.1" :type 'string :group 'gnus-outlook-deuglify) (defcustom gnus-outlook-deuglify-unwrap-stop-chars nil ;; ".?!" or nil "Characters that inhibit unwrapping if they are the last one on the cited line above the possible wrapped line." :version "22.1" :type '(radio (const :format "None " nil) (string :value ".?!")) :group 'gnus-outlook-deuglify) (defcustom gnus-outlook-deuglify-no-wrap-chars "`" "Characters that inhibit unwrapping if they are the first one in the possibly wrapped line." :version "22.1" :type 'string :group 'gnus-outlook-deuglify) (defcustom gnus-outlook-deuglify-attrib-cut-regexp "\\(On \\|Am \\)?\\(Mon\\|Tue\\|Wed\\|Thu\\|Fri\\|Sat\\|Sun\\),[^,]+, " "Regular expression matching the beginning of an attribution line that should be cut off." :version "22.1" :type 'string :group 'gnus-outlook-deuglify) (defcustom gnus-outlook-deuglify-attrib-verb-regexp "wrote\\|writes\\|says\\|schrieb\\|schreibt\\|meinte\\|skrev\\|a écrit\\|schreef\\|escribió" "Regular expression matching the verb used in an attribution line." :version "22.1" :type 'string :group 'gnus-outlook-deuglify) (defcustom gnus-outlook-deuglify-attrib-end-regexp ": *\\|\\.\\.\\." "Regular expression matching the end of an attribution line." :version "22.1" :type 'string :group 'gnus-outlook-deuglify) (defcustom gnus-outlook-display-hook nil "A hook called after an deuglified article has been prepared. It is run after `gnus-article-prepare-hook'." :version "22.1" :type 'hook :group 'gnus-outlook-deuglify) ;; Functions (defun gnus-outlook-display-article-buffer () "Redisplay current buffer or article buffer." (with-current-buffer (or gnus-article-buffer (current-buffer)) ;; "Emulate" `gnus-article-prepare-display' without calling ;; it. Calling `gnus-article-prepare-display' on an already ;; prepared article removes all MIME parts. I'm unsure whether ;; this is a bug or not. (gnus-article-highlight t) (gnus-treat-article nil) (gnus-run-hooks 'gnus-article-prepare-hook 'gnus-outlook-display-hook))) ;;;###autoload (defun gnus-article-outlook-unwrap-lines (&optional nodisplay) "Unwrap lines that appear to be wrapped citation lines. You can control what lines will be unwrapped by frobbing `gnus-outlook-deuglify-unwrap-min' and `gnus-outlook-deuglify-unwrap-max', indicating the minimum and maximum length of an unwrapped citation line. If NODISPLAY is non-nil, don't redisplay the article buffer." (interactive "P") (let ((case-fold-search nil) (inhibit-read-only t) (cite-marks gnus-outlook-deuglify-cite-marks) (no-wrap gnus-outlook-deuglify-no-wrap-chars) (stop-chars gnus-outlook-deuglify-unwrap-stop-chars)) (gnus-with-article-buffer (article-goto-body) (while (re-search-forward (concat "^\\([ \t" cite-marks "]*\\)" "\\([" cite-marks "].*[^\n " stop-chars "]\\)[ \t]?\n" "\\1\\([^\n " cite-marks no-wrap "]+.*\\)$") nil t) (let ((len12 (- (match-end 2) (match-beginning 1))) (len3 (- (match-end 3) (match-beginning 3)))) (when (and (> len12 gnus-outlook-deuglify-unwrap-min) (< (+ len12 len3) gnus-outlook-deuglify-unwrap-max)) (replace-match "\\1\\2 \\3") (goto-char (match-beginning 0))))))) (unless nodisplay (gnus-outlook-display-article-buffer))) (defun gnus-outlook-rearrange-article (attr-start) "Put the text from ATTR-START to the end of buffer at the top of the article buffer." ;; FIXME: 1. (*) text/plain ( ) text/html (let ((inhibit-read-only t) (cite-marks gnus-outlook-deuglify-cite-marks)) (gnus-with-article-buffer (article-goto-body) ;; article does not start with attribution (unless (= (point) attr-start) (gnus-kill-all-overlays) (let ((cur (point)) ;; before signature or end of buffer (to (if (gnus-article-search-signature) (point) (point-max)))) ;; handle the case where the full quote is below the ;; signature (when (< to attr-start) (setq to (point-max))) (save-excursion (narrow-to-region attr-start to) (goto-char attr-start) (forward-line) (unless (looking-at ">") (message-indent-citation (point) (point-max) 'yank-only) (goto-char (point-max)) (newline) (setq to (point-max))) (widen)) (transpose-regions cur attr-start attr-start to)))))) ;; John Doe wrote in message ;; news:a87usw8$dklsssa$2@some.news.server... (defun gnus-outlook-repair-attribution-outlook () "Repair a broken attribution line (Outlook)." (let ((case-fold-search nil) (inhibit-read-only t) (cite-marks gnus-outlook-deuglify-cite-marks)) (gnus-with-article-buffer (article-goto-body) (when (re-search-forward (concat "^\\([^" cite-marks "].+\\)" "\\(" gnus-outlook-deuglify-attrib-verb-regexp "\\)" "\\(.*\n?[^\n" cite-marks "].*\\)?" "\\(" gnus-outlook-deuglify-attrib-end-regexp "\\)$") nil t) (gnus-kill-all-overlays) (replace-match "\\1\\2\\4") (match-beginning 0))))) ;; ----- Original Message ----- ;; From: "John Doe" ;; To: "Doe Foundation" ;; Sent: Monday, November 19, 2001 12:13 PM ;; Subject: More Doenuts (defun gnus-outlook-repair-attribution-block () "Repair a big broken attribution block." (let ((case-fold-search nil) (inhibit-read-only t) (cite-marks gnus-outlook-deuglify-cite-marks)) (gnus-with-article-buffer (article-goto-body) (when (re-search-forward (concat "^[" cite-marks " \t]*--* ?[^-]+ [^-]+ ?--*\\s *\n" "[^\n:]+:[ \t]*\\([^\n]+\\)\n" "\\([^\n:]+:[ \t]*[^\n]+\n\\)+") nil t) (gnus-kill-all-overlays) (replace-match "\\1 wrote:\n") (match-beginning 0))))) ;; On Wed, 16 Jan 2002 23:23:30 +0100, John Doe wrote: (defun gnus-outlook-repair-attribution-other () "Repair a broken attribution line (other user agents than Outlook)." (let ((case-fold-search nil) (inhibit-read-only t) (cite-marks gnus-outlook-deuglify-cite-marks)) (gnus-with-article-buffer (article-goto-body) (when (re-search-forward (concat "^\\("gnus-outlook-deuglify-attrib-cut-regexp"\\)?" "\\([^" cite-marks "].+\\)\n\\([^\n" cite-marks "].*\\)?" "\\(" gnus-outlook-deuglify-attrib-verb-regexp "\\).*" "\\(" gnus-outlook-deuglify-attrib-end-regexp "\\)$") nil t) (gnus-kill-all-overlays) (replace-match "\\4 \\5\\6\\7") (match-beginning 0))))) ;;;###autoload (defun gnus-article-outlook-repair-attribution (&optional nodisplay) "Repair a broken attribution line. If NODISPLAY is non-nil, don't redisplay the article buffer." (interactive "P") (let ((attrib-start (or (gnus-outlook-repair-attribution-other) (gnus-outlook-repair-attribution-block) (gnus-outlook-repair-attribution-outlook)))) (unless nodisplay (gnus-outlook-display-article-buffer)) attrib-start)) (defun gnus-article-outlook-rearrange-citation (&optional nodisplay) "Repair broken citations. If NODISPLAY is non-nil, don't redisplay the article buffer." (interactive "P") (let ((attrib-start (gnus-article-outlook-repair-attribution 'nodisplay))) ;; rearrange citations if an attribution line has been recognized (if attrib-start (gnus-outlook-rearrange-article attrib-start))) (unless nodisplay (gnus-outlook-display-article-buffer))) ;;;###autoload (defun gnus-outlook-deuglify-article (&optional nodisplay) "Full deuglify of broken Outlook (Express) articles. Treat dumbquotes, unwrap lines, repair attribution and rearrange citation. If NODISPLAY is non-nil, don't redisplay the article buffer." (interactive "P") ;; apply treatment of dumb quotes (gnus-article-treat-dumbquotes) ;; repair wrapped cited lines (gnus-article-outlook-unwrap-lines 'nodisplay) ;; repair attribution line and rearrange citation. (gnus-article-outlook-rearrange-citation 'nodisplay) (unless nodisplay (gnus-outlook-display-article-buffer))) ;;;###autoload (defun gnus-article-outlook-deuglify-article () "Deuglify broken Outlook (Express) articles and redisplay." (interactive) (gnus-outlook-deuglify-article nil)) (provide 'deuglify) ;; Local Variables: ;; coding: iso-8859-1 ;; End: ;; arch-tag: 5f895cc9-51a9-487c-b42e-28844d79eb73 ;;; deuglify.el ends here gnus-5.11+v0.10.dfsg/lisp/gnus-registry.el0000644000175000017500000011737211004622774020425 0ustar tvainikatvainika;;; gnus-registry.el --- article registry for Gnus ;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, ;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc. ;; Author: Ted Zlatanov ;; Keywords: news ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 3, or (at your option) ;; any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Commentary: ;; This is the gnus-registry.el package, which works with all ;; backends, not just nnmail (e.g. NNTP). The major issue is that it ;; doesn't go across backends, so for instance if an article is in ;; nnml:sys and you see a reference to it in nnimap splitting, the ;; article will end up in nnimap:sys ;; gnus-registry.el intercepts article respooling, moving, deleting, ;; and copying for all backends. If it doesn't work correctly for ;; you, submit a bug report and I'll be glad to fix it. It needs ;; documentation in the manual (also on my to-do list). ;; Put this in your startup file (~/.gnus.el for instance) ;; (setq gnus-registry-max-entries 2500 ;; gnus-registry-use-long-group-names t) ;; (gnus-registry-initialize) ;; Then use this in your fancy-split: ;; (: gnus-registry-split-fancy-with-parent) ;; TODO: ;; - get the correct group on spool actions ;; - articles that are spooled to a different backend should be handled ;;; Code: (eval-when-compile (require 'cl)) (require 'gnus) (require 'gnus-int) (require 'gnus-sum) (require 'gnus-util) (require 'nnmail) (defvar gnus-adaptive-word-syntax-table) (defvar gnus-registry-dirty t "Boolean set to t when the registry is modified") (defgroup gnus-registry nil "The Gnus registry." :version "22.1" :group 'gnus) (defvar gnus-registry-hashtb (make-hash-table :size 256 :test 'equal) "*The article registry by Message ID.") (defcustom gnus-registry-marks '((Important :char ?i :image "summary_important") (Work :char ?w :image "summary_work") (Personal :char ?p :image "summary_personal") (To-Do :char ?t :image "summary_todo") (Later :char ?l :image "summary_later")) "List of registry marks and their options. `gnus-registry-mark-article' will offer symbols from this list for completion. Each entry must have a character to be useful for summary mode line display and for keyboard shortcuts. Each entry must have an image string to be useful for visual display." :group 'gnus-registry :type '(repeat :tag "Registry Marks" (cons :tag "Mark" (symbol :tag "Name") (checklist :tag "Options" :greedy t (group :inline t (const :format "" :value :char) (character :tag "Character code")) (group :inline t (const :format "" :value :image) (string :tag "Image")))))) (defcustom gnus-registry-default-mark 'To-Do "The default mark. Should be a valid key for `gnus-registry-marks'." :group 'gnus-registry :type 'symbol) (defcustom gnus-registry-unfollowed-groups '("delayed$" "drafts$" "queue$" "INBOX$") "List of groups that gnus-registry-split-fancy-with-parent won't return. The group names are matched, they don't have to be fully qualified. This parameter tells the Registry 'never split a message into a group that matches one of these, regardless of references.'" :group 'gnus-registry :type '(repeat regexp)) (defcustom gnus-registry-install 'ask "Whether the registry should be installed." :group 'gnus-registry :type '(choice (const :tag "Never Install" nil) (const :tag "Always Install" t) (const :tag "Ask Me" ask))) (defcustom gnus-registry-clean-empty t "Whether the empty registry entries should be deleted. Registry entries are considered empty when they have no groups and no extra data." :group 'gnus-registry :type 'boolean) (defcustom gnus-registry-use-long-group-names nil "Whether the registry should use long group names (BUGGY)." :group 'gnus-registry :type 'boolean) (defcustom gnus-registry-track-extra nil "Whether the registry should track extra data about a message. The Subject and Sender (From:) headers are currently tracked this way." :group 'gnus-registry :type '(set :tag "Tracking choices" (const :tag "Track by subject (Subject: header)" subject) (const :tag "Track by sender (From: header)" sender))) (defcustom gnus-registry-split-strategy nil "Whether the registry should track extra data about a message. The Subject and Sender (From:) headers are currently tracked this way." :group 'gnus-registry :type '(choice :tag "Tracking choices" (const :tag "Only use single choices, discard multiple matches" nil) (const :tag "Majority of matches wins" majority) (const :tag "First found wins" first))) (defcustom gnus-registry-entry-caching t "Whether the registry should cache extra information." :group 'gnus-registry :type 'boolean) (defcustom gnus-registry-minimum-subject-length 5 "The minimum length of a subject before it's considered trackable." :group 'gnus-registry :type 'integer) (defcustom gnus-registry-trim-articles-without-groups t "Whether the registry should clean out message IDs without groups." :group 'gnus-registry :type 'boolean) (defcustom gnus-registry-extra-entries-precious '(marks) "What extra entries are precious, meaning they won't get trimmed. When you save the Gnus registry, it's trimmed to be no longer than `gnus-registry-max-entries' (which is nil by default, so no trimming happens). Any entries with extra data in this list (by default, marks are included, so articles with marks are considered precious) will not be trimmed." :group 'gnus-registry :type '(repeat symbol)) (defcustom gnus-registry-cache-file (nnheader-concat (or gnus-dribble-directory gnus-home-directory "~/") ".gnus.registry.eld") "File where the Gnus registry will be stored." :group 'gnus-registry :type 'file) (defcustom gnus-registry-max-entries nil "Maximum number of entries in the registry, nil for unlimited." :group 'gnus-registry :type '(radio (const :format "Unlimited " nil) (integer :format "Maximum number: %v"))) (defun gnus-registry-track-subject-p () (memq 'subject gnus-registry-track-extra)) (defun gnus-registry-track-sender-p () (memq 'sender gnus-registry-track-extra)) (defun gnus-registry-cache-read () "Read the registry cache file." (interactive) (let ((file gnus-registry-cache-file)) (when (file-exists-p file) (gnus-message 5 "Reading %s..." file) (gnus-load file) (gnus-message 5 "Reading %s...done" file)))) ;; FIXME: Get rid of duplicated code, cf. `gnus-save-newsrc-file' in ;; `gnus-start.el'. --rsteib (defun gnus-registry-cache-save () "Save the registry cache file." (interactive) (let ((file gnus-registry-cache-file)) (save-excursion (set-buffer (gnus-get-buffer-create " *Gnus-registry-cache*")) (make-local-variable 'version-control) (setq version-control gnus-backup-startup-file) (setq buffer-file-name file) (setq default-directory (file-name-directory buffer-file-name)) (buffer-disable-undo) (erase-buffer) (gnus-message 5 "Saving %s..." file) (if gnus-save-startup-file-via-temp-buffer (let ((coding-system-for-write gnus-ding-file-coding-system) (standard-output (current-buffer))) (gnus-gnus-to-quick-newsrc-format t "gnus registry startup file" 'gnus-registry-alist) (gnus-registry-cache-whitespace file) (save-buffer)) (let ((coding-system-for-write gnus-ding-file-coding-system) (version-control gnus-backup-startup-file) (startup-file file) (working-dir (file-name-directory file)) working-file (i -1)) ;; Generate the name of a non-existent file. (while (progn (setq working-file (format (if (and (eq system-type 'ms-dos) (not (gnus-long-file-names))) "%s#%d.tm#" ; MSDOS limits files to 8+3 (if (memq system-type '(vax-vms axp-vms)) "%s$tmp$%d" "%s#tmp#%d")) working-dir (setq i (1+ i)))) (file-exists-p working-file))) (unwind-protect (progn (gnus-with-output-to-file working-file (gnus-gnus-to-quick-newsrc-format t "gnus registry startup file" 'gnus-registry-alist)) ;; These bindings will mislead the current buffer ;; into thinking that it is visiting the startup ;; file. (let ((buffer-backed-up nil) (buffer-file-name startup-file) (file-precious-flag t) (setmodes (file-modes startup-file))) ;; Backup the current version of the startup file. (backup-buffer) ;; Replace the existing startup file with the temp file. (rename-file working-file startup-file t) (gnus-set-file-modes startup-file setmodes))) (condition-case nil (delete-file working-file) (file-error nil))))) (gnus-kill-buffer (current-buffer)) (gnus-message 5 "Saving %s...done" file)))) ;; Idea from Dan Christensen ;; Save the gnus-registry file with extra line breaks. (defun gnus-registry-cache-whitespace (filename) (gnus-message 7 "Adding whitespace to %s" filename) (save-excursion (goto-char (point-min)) (while (re-search-forward "^(\\|(\\\"" nil t) (replace-match "\n\\&" t)) (goto-char (point-min)) (while (re-search-forward " $" nil t) (replace-match "" t t)))) (defun gnus-registry-save (&optional force) (when (or gnus-registry-dirty force) (let ((caching gnus-registry-entry-caching)) ;; turn off entry caching, so mtime doesn't get recorded (setq gnus-registry-entry-caching nil) ;; remove entry caches (maphash (lambda (key value) (if (hash-table-p value) (remhash key gnus-registry-hashtb))) gnus-registry-hashtb) ;; remove empty entries (when gnus-registry-clean-empty (gnus-registry-clean-empty-function)) ;; now trim and clean text properties from the registry appropriately (setq gnus-registry-alist (gnus-registry-remove-alist-text-properties (gnus-registry-trim (gnus-hashtable-to-alist gnus-registry-hashtb)))) ;; really save (gnus-registry-cache-save) (setq gnus-registry-entry-caching caching) (setq gnus-registry-dirty nil)))) (defun gnus-registry-clean-empty-function () "Remove all empty entries from the registry. Returns count thereof." (let ((count 0)) (maphash (lambda (key value) (when (stringp key) (dolist (group (gnus-registry-fetch-groups key)) (when (gnus-parameter-registry-ignore group) (gnus-message 10 "gnus-registry: deleted ignored group %s from key %s" group key) (gnus-registry-delete-group key group))) (unless (gnus-registry-group-count key) (gnus-registry-delete-id key)) (unless (or (gnus-registry-fetch-group key) ;; TODO: look for specific extra data here! ;; in this example, we look for 'label (gnus-registry-fetch-extra key 'label)) (incf count) (gnus-registry-delete-id key)) (unless (stringp key) (gnus-message 10 "gnus-registry key %s was not a string, removing" key) (gnus-registry-delete-id key)))) gnus-registry-hashtb) count)) (defun gnus-registry-read () (gnus-registry-cache-read) (setq gnus-registry-hashtb (gnus-alist-to-hashtable gnus-registry-alist)) (setq gnus-registry-dirty nil)) (defun gnus-registry-remove-alist-text-properties (v) "Remove text properties from all strings in alist." (if (stringp v) (gnus-string-remove-all-properties v) (if (and (listp v) (listp (cdr v))) (mapcar 'gnus-registry-remove-alist-text-properties v) (if (and (listp v) (stringp (cdr v))) (cons (gnus-registry-remove-alist-text-properties (car v)) (gnus-registry-remove-alist-text-properties (cdr v))) v)))) (defun gnus-registry-trim (alist) "Trim alist to size, using gnus-registry-max-entries. Any entries with extra data (marks, currently) are left alone." (if (null gnus-registry-max-entries) alist ; just return the alist ;; else, when given max-entries, trim the alist (let* ((timehash (make-hash-table :size 20000 :test 'equal)) (precious (make-hash-table :size 20000 :test 'equal)) (trim-length (- (length alist) gnus-registry-max-entries)) (trim-length (if (natnump trim-length) trim-length 0)) precious-list junk-list) (maphash (lambda (key value) (let ((extra (gnus-registry-fetch-extra key))) (dolist (item gnus-registry-extra-entries-precious) (dolist (e extra) (when (equal (nth 0 e) item) (puthash key t precious) (return)))) (puthash key (gnus-registry-fetch-extra key 'mtime) timehash))) gnus-registry-hashtb) (dolist (item alist) (let ((key (nth 0 item))) (if (gethash key precious) (push item precious-list) (push item junk-list)))) (sort junk-list (lambda (a b) (let ((t1 (or (cdr (gethash (car a) timehash)) '(0 0 0))) (t2 (or (cdr (gethash (car b) timehash)) '(0 0 0)))) (time-less-p t1 t2)))) ;; we use the return value of this setq, which is the trimmed alist (setq alist (append precious-list (nthcdr trim-length junk-list)))))) (defun gnus-registry-action (action data-header from &optional to method) (let* ((id (mail-header-id data-header)) (subject (gnus-string-remove-all-properties (gnus-registry-simplify-subject (mail-header-subject data-header)))) (sender (gnus-string-remove-all-properties (mail-header-from data-header))) (from (gnus-group-guess-full-name-from-command-method from)) (to (if to (gnus-group-guess-full-name-from-command-method to) nil)) (to-name (if to to "the Bit Bucket")) (old-entry (gethash id gnus-registry-hashtb))) (gnus-message 7 "Registry: article %s %s from %s to %s" id (if method "respooling" "going") from to) ;; All except copy will need a delete (gnus-registry-delete-group id from) (when (equal 'copy action) (gnus-registry-add-group id from subject sender)) ; undo the delete (gnus-registry-add-group id to subject sender))) (defun gnus-registry-spool-action (id group &optional subject sender) (let ((group (gnus-group-guess-full-name-from-command-method group))) (when (and (stringp id) (string-match "\r$" id)) (setq id (substring id 0 -1))) (gnus-message 7 "Registry: article %s spooled to %s" id group) (gnus-registry-add-group id group subject sender))) ;; Function for nn{mail|imap}-split-fancy: look up all references in ;; the cache and if a match is found, return that group. (defun gnus-registry-split-fancy-with-parent () "Split this message into the same group as its parent. The parent is obtained from the registry. This function can be used as an entry in `nnmail-split-fancy' or `nnimap-split-fancy', for example like this: (: gnus-registry-split-fancy-with-parent) This function tracks ALL backends, unlike `nnmail-split-fancy-with-parent' which tracks only nnmail messages. For a message to be split, it looks for the parent message in the References or In-Reply-To header and then looks in the registry to see which group that message was put in. This group is returned, unless `gnus-registry-follow-group-p' return nil for that group. See the Info node `(gnus)Fancy Mail Splitting' for more details." (let* ((refstr (or (message-fetch-field "references") "")) ; guaranteed (reply-to (message-fetch-field "in-reply-to")) ; may be nil ;; now, if reply-to is valid, append it to the References (refstr (if reply-to (concat refstr " " reply-to) refstr)) ;; these may not be used, but the code is cleaner having them up here (sender (gnus-string-remove-all-properties (message-fetch-field "from"))) (subject (gnus-string-remove-all-properties (gnus-registry-simplify-subject (message-fetch-field "subject")))) (nnmail-split-fancy-with-parent-ignore-groups (if (listp nnmail-split-fancy-with-parent-ignore-groups) nnmail-split-fancy-with-parent-ignore-groups (list nnmail-split-fancy-with-parent-ignore-groups))) (log-agent "gnus-registry-split-fancy-with-parent") found found-full) ;; this is a big if-else statement. it uses ;; gnus-registry-post-process-groups to filter the results after ;; every step. (cond ;; the references string must be valid and parse to valid references ((and refstr (gnus-extract-references refstr)) (dolist (reference (nreverse (gnus-extract-references refstr))) (gnus-message 9 "%s is looking for matches for reference %s from [%s]" log-agent reference refstr) (dolist (group (gnus-registry-fetch-groups reference)) (when (and group (gnus-registry-follow-group-p group)) (gnus-message 7 "%s traced the reference %s from [%s] to group %s" log-agent reference refstr group) (push group found)))) ;; filter the found groups and return them ;; the found groups are the full groups (setq found (gnus-registry-post-process-groups "references" refstr found found))) ;; else: there were no matches, now try the extra tracking by sender ((and (gnus-registry-track-sender-p) sender (not (equal sender user-mail-address))) (maphash (lambda (key value) (let ((this-sender (cdr (gnus-registry-fetch-extra key 'sender))) matches) (when (and this-sender (equal sender this-sender)) (let ((groups (gnus-registry-fetch-groups key))) (dolist (group groups) (push group found-full) (setq found (append (list group) (delete group found))))) (push key matches) (gnus-message ;; raise level of messaging if gnus-registry-track-extra (if gnus-registry-track-extra 7 9) "%s (extra tracking) traced sender %s to groups %s (keys %s)" log-agent sender found matches)))) gnus-registry-hashtb) ;; filter the found groups and return them ;; the found groups are NOT the full groups (setq found (gnus-registry-post-process-groups "sender" sender found found-full))) ;; else: there were no matches, now try the extra tracking by subject ((and (gnus-registry-track-subject-p) subject (< gnus-registry-minimum-subject-length (length subject))) (maphash (lambda (key value) (let ((this-subject (cdr (gnus-registry-fetch-extra key 'subject))) matches) (when (and this-subject (equal subject this-subject)) (let ((groups (gnus-registry-fetch-groups key))) (dolist (group groups) (push group found-full) (setq found (append (list group) (delete group found))))) (push key matches) (gnus-message ;; raise level of messaging if gnus-registry-track-extra (if gnus-registry-track-extra 7 9) "%s (extra tracking) traced subject %s to groups %s (keys %s)" log-agent subject found matches)))) gnus-registry-hashtb) ;; filter the found groups and return them ;; the found groups are NOT the full groups (setq found (gnus-registry-post-process-groups "subject" subject found found-full)))) ;; after the (cond) we extract the actual value safely (car-safe found))) (defun gnus-registry-post-process-groups (mode key groups groups-full) "Modifies GROUPS found by MODE for KEY to determine which ones to follow. MODE can be 'subject' or 'sender' for example. The KEY is the value by which MODE was searched. Transforms each group name to the equivalent short name. Checks if the current Gnus method (from `gnus-command-method' or from `gnus-newsgroup-name') is the same as the group's method. This is not possible if gnus-registry-use-long-group-names is false. Foreign methods are not supported so they are rejected. Reduces the list to a single group, or complains if that's not possible. Uses `gnus-registry-split-strategy' and GROUPS-FULL if necessary." (let ((log-agent "gnus-registry-post-process-group") out) ;; the strategy can be 'first, 'majority, or nil (when (eq gnus-registry-split-strategy 'first) (when groups (setq groups (list (car-safe groups))))) (when (eq gnus-registry-split-strategy 'majority) (let ((freq (make-hash-table :size 256 :test 'equal))) (mapc (lambda(x) (puthash x (1+ (gethash x freq 0)) freq)) groups-full) (setq groups (list (car-safe (sort groups (lambda (a b) (> (gethash a freq 0) (gethash b freq 0))))))))) (if gnus-registry-use-long-group-names (dolist (group groups) (let ((m1 (gnus-find-method-for-group group)) (m2 (or gnus-command-method (gnus-find-method-for-group gnus-newsgroup-name))) (short-name (gnus-group-short-name group))) (if (gnus-methods-equal-p m1 m2) (progn ;; this is REALLY just for debugging (gnus-message 10 "%s stripped group %s to %s" log-agent group short-name) (unless (member short-name out) (push short-name out))) ;; else... (gnus-message 7 "%s ignored foreign group %s" log-agent group)))) (setq out groups)) (when (cdr-safe out) (gnus-message 5 "%s: too many extra matches (%s) for %s %s. Returning none." log-agent out mode key) (setq out nil)) out)) (defun gnus-registry-follow-group-p (group) "Determines if a group name should be followed. Consults `gnus-registry-unfollowed-groups' and `nnmail-split-fancy-with-parent-ignore-groups'." (not (or (gnus-registry-grep-in-list group gnus-registry-unfollowed-groups) (gnus-registry-grep-in-list group nnmail-split-fancy-with-parent-ignore-groups)))) (defun gnus-registry-wash-for-keywords (&optional force) (interactive) (let ((id (gnus-registry-fetch-message-id-fast gnus-current-article)) word words) (if (or (not (gnus-registry-fetch-extra id 'keywords)) force) (save-excursion (set-buffer gnus-article-buffer) (article-goto-body) (save-window-excursion (save-restriction (narrow-to-region (point) (point-max)) (with-syntax-table gnus-adaptive-word-syntax-table (while (re-search-forward "\\b\\w+\\b" nil t) (setq word (gnus-registry-remove-alist-text-properties (downcase (buffer-substring (match-beginning 0) (match-end 0))))) (if (> (length word) 3) (push word words)))))) (gnus-registry-store-extra-entry id 'keywords words))))) (defun gnus-registry-find-keywords (keyword) (interactive "skeyword: ") (let (articles) (maphash (lambda (key value) (when (gnus-registry-grep-in-list keyword (cdr (gnus-registry-fetch-extra key 'keywords))) (push key articles))) gnus-registry-hashtb) articles)) (defun gnus-registry-register-message-ids () "Register the Message-ID of every article in the group" (unless (gnus-parameter-registry-ignore gnus-newsgroup-name) (dolist (article gnus-newsgroup-articles) (let ((id (gnus-registry-fetch-message-id-fast article))) (unless (member gnus-newsgroup-name (gnus-registry-fetch-groups id)) (gnus-message 9 "Registry: Registering article %d with group %s" article gnus-newsgroup-name) (gnus-registry-add-group id gnus-newsgroup-name (gnus-registry-fetch-simplified-message-subject-fast article) (gnus-registry-fetch-sender-fast article))))))) (defun gnus-registry-fetch-message-id-fast (article) "Fetch the Message-ID quickly, using the internal gnus-data-list function" (if (and (numberp article) (assoc article (gnus-data-list nil))) (mail-header-id (gnus-data-header (assoc article (gnus-data-list nil)))) nil)) (defun gnus-registry-simplify-subject (subject) (if (stringp subject) (gnus-simplify-subject subject) nil)) (defun gnus-registry-fetch-simplified-message-subject-fast (article) "Fetch the Subject quickly, using the internal gnus-data-list function" (if (and (numberp article) (assoc article (gnus-data-list nil))) (gnus-string-remove-all-properties (gnus-registry-simplify-subject (mail-header-subject (gnus-data-header (assoc article (gnus-data-list nil)))))) nil)) (defun gnus-registry-fetch-sender-fast (article) "Fetch the Sender quickly, using the internal gnus-data-list function" (if (and (numberp article) (assoc article (gnus-data-list nil))) (gnus-string-remove-all-properties (mail-header-from (gnus-data-header (assoc article (gnus-data-list nil))))) nil)) ;;; this should be redone with catch/throw (defun gnus-registry-grep-in-list (word list) (when word (memq nil (mapcar 'not (mapcar (lambda (x) (string-match word x)) list))))) (defun gnus-registry-do-marks (type function) "For each known mark, call FUNCTION for each cell of type TYPE. FUNCTION should take two parameters, a mark symbol and the cell value." (dolist (mark-info gnus-registry-marks) (let* ((mark (car-safe mark-info)) (data (cdr-safe mark-info)) (cell-data (plist-get data type))) (when cell-data (funcall function mark cell-data))))) ;;; this is ugly code, but I don't know how to do it better (defun gnus-registry-install-shortcuts () "Install the keyboard shortcuts and menus for the registry. Uses `gnus-registry-marks' to find what shortcuts to install." (let (keys-plist) (gnus-registry-do-marks :char (lambda (mark data) (let ((function-format (format "gnus-registry-%%s-article-%s-mark" mark))) ;;; The following generates these functions: ;;; (defun gnus-registry-set-article-Important-mark (&rest articles) ;;; "Apply the Important mark to process-marked ARTICLES." ;;; (interactive (gnus-summary-work-articles current-prefix-arg)) ;;; (gnus-registry-set-article-mark-internal 'Important articles nil t)) ;;; (defun gnus-registry-remove-article-Important-mark (&rest articles) ;;; "Apply the Important mark to process-marked ARTICLES." ;;; (interactive (gnus-summary-work-articles current-prefix-arg)) ;;; (gnus-registry-set-article-mark-internal 'Important articles t t)) (dolist (remove '(t nil)) (let* ((variant-name (if remove "remove" "set")) (function-name (format function-format variant-name)) (shortcut (format "%c" data)) (shortcut (if remove (upcase shortcut) shortcut))) (unintern function-name) (eval `(defun ;; function name ,(intern function-name) ;; parameter definition (&rest articles) ;; documentation ,(format "%s the %s mark over process-marked ARTICLES." (upcase-initials variant-name) mark) ;; interactive definition (interactive (gnus-summary-work-articles current-prefix-arg)) ;; actual code ;; if this is called and the user doesn't want the ;; registry enabled, we'll ask anyhow (when (eq gnus-registry-install nil) (setq gnus-registry-install 'ask)) ;; now the user is asked if gnus-registry-install is 'ask (when (gnus-registry-install-p) (gnus-registry-set-article-mark-internal ;; all this just to get the mark, I must be doing it wrong (intern ,(symbol-name mark)) articles ,remove t) (dolist (article articles) (gnus-summary-update-article article (assoc article (gnus-data-list nil))))))) (push (intern function-name) keys-plist) (push shortcut keys-plist) (gnus-message 9 "Defined mark handling function %s" function-name)))))) (gnus-define-keys-1 '(gnus-registry-mark-map "M" gnus-summary-mark-map) keys-plist))) ;;; use like this: ;;; (defalias 'gnus-user-format-function-M ;;; 'gnus-registry-user-format-function-M) (defun gnus-registry-user-format-function-M (headers) (let* ((id (mail-header-message-id headers)) (marks (when id (gnus-registry-fetch-extra-marks id)))) (apply 'concat (mapcar (lambda(mark) (let ((c (plist-get (cdr-safe (assoc mark gnus-registry-marks)) :char))) (if c (list c) nil))) marks)))) (defun gnus-registry-read-mark () "Read a mark name from the user with completion." (let ((mark (gnus-completing-read-with-default (symbol-name gnus-registry-default-mark) "Label" (mapcar (lambda (x) ; completion list (cons (symbol-name (car-safe x)) (car-safe x))) gnus-registry-marks)))) (when (stringp mark) (intern mark)))) (defun gnus-registry-set-article-mark (&rest articles) "Apply a mark to process-marked ARTICLES." (interactive (gnus-summary-work-articles current-prefix-arg)) (gnus-registry-set-article-mark-internal (gnus-registry-read-mark) articles nil t)) (defun gnus-registry-remove-article-mark (&rest articles) "Remove a mark from process-marked ARTICLES." (interactive (gnus-summary-work-articles current-prefix-arg)) (gnus-registry-set-article-mark-internal (gnus-registry-read-mark) articles t t)) (defun gnus-registry-set-article-mark-internal (mark articles &optional remove show-message) "Apply a mark to a list of ARTICLES." (let ((article-id-list (mapcar 'gnus-registry-fetch-message-id-fast articles))) (dolist (id article-id-list) (let* ( ;; all the marks for this article without the mark of ;; interest (marks (delq mark (gnus-registry-fetch-extra-marks id))) ;; the new marks we want to use (new-marks (if remove marks (cons mark marks)))) (when show-message (gnus-message 1 "%s mark %s with message ID %s, resulting in %S" (if remove "Removing" "Adding") mark id new-marks)) (apply 'gnus-registry-store-extra-marks ; set the extra marks id ; for the message ID new-marks))))) (defun gnus-registry-get-article-marks (&rest articles) "Get the Gnus registry marks for ARTICLES and show them if interactive. Uses process/prefix conventions. For multiple articles, only the last one's marks are returned." (interactive (gnus-summary-work-articles 1)) (let (marks) (dolist (article articles) (let ((article-id (gnus-registry-fetch-message-id-fast article))) (setq marks (gnus-registry-fetch-extra-marks article-id)))) (when (interactive-p) (gnus-message 1 "Marks are %S" marks)) marks)) ;;; if this extends to more than 'marks, it should be improved to be more generic. (defun gnus-registry-fetch-extra-marks (id) "Get the marks of a message, based on the message ID. Returns a list of symbol marks or nil." (car-safe (cdr (gnus-registry-fetch-extra id 'marks)))) (defun gnus-registry-has-extra-mark (id mark) "Checks if a message has `mark', based on the message ID `id'." (memq mark (gnus-registry-fetch-extra-marks id))) (defun gnus-registry-store-extra-marks (id &rest mark-list) "Set the marks of a message, based on the message ID. The `mark-list' can be nil, in which case no marks are left." (gnus-registry-store-extra-entry id 'marks (list mark-list))) (defun gnus-registry-delete-extra-marks (id &rest mark-delete-list) "Delete the message marks in `mark-delete-list', based on the message ID." (let ((marks (gnus-registry-fetch-extra-marks id))) (when marks (dolist (mark mark-delete-list) (setq marks (delq mark marks)))) (gnus-registry-store-extra-marks id (car marks)))) (defun gnus-registry-delete-all-extra-marks (id) "Delete all the marks for a message ID." (gnus-registry-store-extra-marks id nil)) (defun gnus-registry-fetch-extra (id &optional entry) "Get the extra data of a message, based on the message ID. Returns the first place where the trail finds a nonstring." (let ((entry-cache (gethash entry gnus-registry-hashtb))) (if (and entry (hash-table-p entry-cache) (gethash id entry-cache)) (gethash id entry-cache) ;; else, if there is no caching possible... (let ((trail (gethash id gnus-registry-hashtb))) (when (listp trail) (dolist (crumb trail) (unless (stringp crumb) (return (gnus-registry-fetch-extra-entry crumb entry id))))))))) (defun gnus-registry-fetch-extra-entry (alist &optional entry id) "Get the extra data of a message, or a specific entry in it. Update the entry cache if needed." (if (and entry id) (let ((entry-cache (gethash entry gnus-registry-hashtb)) entree) (when gnus-registry-entry-caching ;; create the hash table (unless (hash-table-p entry-cache) (setq entry-cache (make-hash-table :size 4096 :test 'equal)) (puthash entry entry-cache gnus-registry-hashtb)) ;; get the entree from the hash table or from the alist (setq entree (gethash id entry-cache))) (unless entree (setq entree (assq entry alist)) (when gnus-registry-entry-caching (puthash id entree entry-cache))) entree) alist)) (defun gnus-registry-store-extra (id extra) "Store the extra data of a message, based on the message ID. The message must have at least one group name." (when (gnus-registry-group-count id) ;; we now know the trail has at least 1 group name, so it's not empty (let ((trail (gethash id gnus-registry-hashtb)) (old-extra (gnus-registry-fetch-extra id)) entry-cache) (dolist (crumb trail) (unless (stringp crumb) (dolist (entry crumb) (setq entry-cache (gethash (car entry) gnus-registry-hashtb)) (when entry-cache (remhash id entry-cache)))) (puthash id (cons extra (delete old-extra trail)) gnus-registry-hashtb) (setq gnus-registry-dirty t))))) (defun gnus-registry-delete-extra-entry (id key) "Delete a specific entry in the extras field of the registry entry for id." (gnus-registry-store-extra-entry id key nil)) (defun gnus-registry-store-extra-entry (id key value) "Put a specific entry in the extras field of the registry entry for id." (let* ((extra (gnus-registry-fetch-extra id)) ;; all the entries except the one for `key' (the-rest (gnus-assq-delete-all key (gnus-registry-fetch-extra id))) (alist (if value (gnus-registry-remove-alist-text-properties (cons (cons key value) the-rest)) the-rest))) (gnus-registry-store-extra id alist))) (defun gnus-registry-fetch-group (id) "Get the group of a message, based on the message ID. Returns the first place where the trail finds a group name." (when (gnus-registry-group-count id) ;; we now know the trail has at least 1 group name (let ((trail (gethash id gnus-registry-hashtb))) (dolist (crumb trail) (when (stringp crumb) (return (if gnus-registry-use-long-group-names crumb (gnus-group-short-name crumb)))))))) (defun gnus-registry-fetch-groups (id) "Get the groups of a message, based on the message ID." (let ((trail (gethash id gnus-registry-hashtb)) groups) (dolist (crumb trail) (when (stringp crumb) ;; push the group name into the list (setq groups (cons (if (or (not (stringp crumb)) gnus-registry-use-long-group-names) crumb (gnus-group-short-name crumb)) groups)))) ;; return the list of groups groups)) (defun gnus-registry-group-count (id) "Get the number of groups of a message, based on the message ID." (let ((trail (gethash id gnus-registry-hashtb))) (if (and trail (listp trail)) (apply '+ (mapcar (lambda (x) (if (stringp x) 1 0)) trail)) 0))) (defun gnus-registry-delete-group (id group) "Delete a group for a message, based on the message ID." (when (and group id) (let ((trail (gethash id gnus-registry-hashtb)) (short-group (gnus-group-short-name group))) (puthash id (if trail (delete short-group (delete group trail)) nil) gnus-registry-hashtb)) ;; now, clear the entry if there are no more groups (when gnus-registry-trim-articles-without-groups (unless (gnus-registry-group-count id) (gnus-registry-delete-id id))) ;; is this ID still in the registry? (when (gethash id gnus-registry-hashtb) (gnus-registry-store-extra-entry id 'mtime (current-time))))) (defun gnus-registry-delete-id (id) "Delete a message ID from the registry." (when (stringp id) (remhash id gnus-registry-hashtb) (maphash (lambda (key value) (when (hash-table-p value) (remhash id value))) gnus-registry-hashtb))) (defun gnus-registry-add-group (id group &optional subject sender) "Add a group for a message, based on the message ID." (when group (when (and id (not (string-match "totally-fudged-out-message-id" id))) (let ((full-group group) (group (if gnus-registry-use-long-group-names group (gnus-group-short-name group)))) (gnus-registry-delete-group id group) (unless gnus-registry-use-long-group-names ;; unnecessary in this case (gnus-registry-delete-group id full-group)) (let ((trail (gethash id gnus-registry-hashtb))) (puthash id (if trail (cons group trail) (list group)) gnus-registry-hashtb) (when (and (gnus-registry-track-subject-p) subject) (gnus-registry-store-extra-entry id 'subject (gnus-registry-simplify-subject subject))) (when (and (gnus-registry-track-sender-p) sender) (gnus-registry-store-extra-entry id 'sender sender)) (gnus-registry-store-extra-entry id 'mtime (current-time))))))) (defun gnus-registry-clear () "Clear the Gnus registry." (interactive) (setq gnus-registry-alist nil) (setq gnus-registry-hashtb (gnus-alist-to-hashtable gnus-registry-alist)) (setq gnus-registry-dirty t)) ;;;###autoload (defun gnus-registry-initialize () "Initialize the Gnus registry." (interactive) (gnus-message 5 "Initializing the registry") (setq gnus-registry-install t) ; in case it was 'ask or nil (gnus-registry-install-hooks) (gnus-registry-install-shortcuts) (gnus-registry-read)) ;;;###autoload (defun gnus-registry-install-hooks () "Install the registry hooks." (interactive) (add-hook 'gnus-summary-article-move-hook 'gnus-registry-action) (add-hook 'gnus-summary-article-delete-hook 'gnus-registry-action) (add-hook 'gnus-summary-article-expire-hook 'gnus-registry-action) (add-hook 'nnmail-spool-hook 'gnus-registry-spool-action) (add-hook 'gnus-save-newsrc-hook 'gnus-registry-save) (add-hook 'gnus-read-newsrc-el-hook 'gnus-registry-read) (add-hook 'gnus-summary-prepare-hook 'gnus-registry-register-message-ids)) (defun gnus-registry-unload-hook () "Uninstall the registry hooks." (interactive) (remove-hook 'gnus-summary-article-move-hook 'gnus-registry-action) (remove-hook 'gnus-summary-article-delete-hook 'gnus-registry-action) (remove-hook 'gnus-summary-article-expire-hook 'gnus-registry-action) (remove-hook 'nnmail-spool-hook 'gnus-registry-spool-action) (remove-hook 'gnus-save-newsrc-hook 'gnus-registry-save) (remove-hook 'gnus-read-newsrc-el-hook 'gnus-registry-read) (remove-hook 'gnus-summary-prepare-hook 'gnus-registry-register-message-ids)) (add-hook 'gnus-registry-unload-hook 'gnus-registry-unload-hook) (defun gnus-registry-install-p () (interactive) (when (eq gnus-registry-install 'ask) (setq gnus-registry-install (gnus-y-or-n-p (concat "Enable the Gnus registry? " "See the variable `gnus-registry-install' " "to get rid of this query permanently. "))) (when gnus-registry-install ;; we just set gnus-registry-install to t, so initialize the registry! (gnus-registry-initialize))) ;;; we could call it here: (customize-variable 'gnus-registry-install) gnus-registry-install) (when (or (eq gnus-registry-install t) (gnus-registry-install-p)) (gnus-registry-initialize)) ;; TODO: a few things (provide 'gnus-registry) ;; arch-tag: 5cba0a32-718a-4a97-8c91-0a15af21da94 ;;; gnus-registry.el ends here gnus-5.11+v0.10.dfsg/lisp/gnus-bcklg.el0000644000175000017500000001246511004005110017607 0ustar tvainikatvainika;;; gnus-bcklg.el --- backlog functions for Gnus ;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, ;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; Keywords: news ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 3, or (at your option) ;; any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Commentary: ;;; Code: (eval-when-compile (require 'cl)) (require 'gnus) ;;; ;;; Buffering of read articles. ;;; (defvar gnus-backlog-buffer " *Gnus Backlog*") (defvar gnus-backlog-articles nil) (defvar gnus-backlog-hashtb nil) (defun gnus-backlog-buffer () "Return the backlog buffer." (or (get-buffer gnus-backlog-buffer) (save-excursion (set-buffer (gnus-get-buffer-create gnus-backlog-buffer)) (buffer-disable-undo) (setq buffer-read-only t) (get-buffer gnus-backlog-buffer)))) (defun gnus-backlog-setup () "Initialize backlog variables." (unless gnus-backlog-hashtb (setq gnus-backlog-hashtb (gnus-make-hashtable 1024)))) (gnus-add-shutdown 'gnus-backlog-shutdown 'gnus) (defun gnus-backlog-shutdown () "Clear all backlog variables and buffers." (interactive) (when (get-buffer gnus-backlog-buffer) (gnus-kill-buffer gnus-backlog-buffer)) (setq gnus-backlog-hashtb nil gnus-backlog-articles nil)) (defun gnus-backlog-enter-article (group number buffer) (when (and (numberp number) (not (string-match "^nnvirtual" group))) (gnus-backlog-setup) (let ((ident (intern (concat group ":" (int-to-string number)) gnus-backlog-hashtb)) b) (if (memq ident gnus-backlog-articles) () ; It's already kept. ;; Remove the oldest article, if necessary. (and (numberp gnus-keep-backlog) (>= (length gnus-backlog-articles) gnus-keep-backlog) (gnus-backlog-remove-oldest-article)) (push ident gnus-backlog-articles) ;; Insert the new article. (save-excursion (set-buffer (gnus-backlog-buffer)) (let (buffer-read-only) (goto-char (point-max)) (unless (bolp) (insert "\n")) (setq b (point)) (insert-buffer-substring buffer) ;; Tag the beginning of the article with the ident. (if (> (point-max) b) (gnus-put-text-property b (1+ b) 'gnus-backlog ident) (gnus-error 3 "Article %d is blank" number)))))))) (defun gnus-backlog-remove-oldest-article () (save-excursion (set-buffer (gnus-backlog-buffer)) (goto-char (point-min)) (if (zerop (buffer-size)) () ; The buffer is empty. (let ((ident (get-text-property (point) 'gnus-backlog)) buffer-read-only) ;; Remove the ident from the list of articles. (when ident (setq gnus-backlog-articles (delq ident gnus-backlog-articles))) ;; Delete the article itself. (delete-region (point) (next-single-property-change (1+ (point)) 'gnus-backlog nil (point-max))))))) (defun gnus-backlog-remove-article (group number) "Remove article NUMBER in GROUP from the backlog." (when (numberp number) (gnus-backlog-setup) (let ((ident (intern (concat group ":" (int-to-string number)) gnus-backlog-hashtb)) beg end) (when (memq ident gnus-backlog-articles) ;; It was in the backlog. (save-excursion (set-buffer (gnus-backlog-buffer)) (let (buffer-read-only) (when (setq beg (text-property-any (point-min) (point-max) 'gnus-backlog ident)) ;; Find the end (i. e., the beginning of the next article). (setq end (next-single-property-change (1+ beg) 'gnus-backlog (current-buffer) (point-max))) (delete-region beg end) ;; Return success. t)) (setq gnus-backlog-articles (delq ident gnus-backlog-articles))))))) (defun gnus-backlog-request-article (group number &optional buffer) (when (and (numberp number) (not (string-match "^nnvirtual" group))) (gnus-backlog-setup) (let ((ident (intern (concat group ":" (int-to-string number)) gnus-backlog-hashtb)) beg end) (when (memq ident gnus-backlog-articles) ;; It was in the backlog. (save-excursion (set-buffer (gnus-backlog-buffer)) (if (not (setq beg (text-property-any (point-min) (point-max) 'gnus-backlog ident))) ;; It wasn't in the backlog after all. (ignore (setq gnus-backlog-articles (delq ident gnus-backlog-articles))) ;; Find the end (i. e., the beginning of the next article). (setq end (next-single-property-change (1+ beg) 'gnus-backlog (current-buffer) (point-max))))) (save-excursion (and buffer (set-buffer buffer)) (let ((buffer-read-only nil)) (erase-buffer) (insert-buffer-substring gnus-backlog-buffer beg end))) t)))) (provide 'gnus-bcklg) ;; arch-tag: 66259e56-505a-4bba-8a0d-3552c5b94e39 ;;; gnus-bcklg.el ends here gnus-5.11+v0.10.dfsg/lisp/nnheader.el0000644000175000017500000010531011004005111017330 0ustar tvainikatvainika;;; nnheader.el --- header access macros for Gnus and its backends ;; Copyright (C) 1987, 1988, 1989, 1990, 1993, 1994, ;; 1995, 1996, 1997, 1998, 2000, 2001, 2002, 2003, ;; 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc. ;; Author: Masanobu UMEDA ;; Lars Magne Ingebrigtsen ;; Keywords: news ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 3, or (at your option) ;; any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Commentary: ;;; Code: (eval-when-compile (require 'cl)) (defvar nnmail-extra-headers) (defvar gnus-newsgroup-name) (defvar nnheader-file-coding-system) (defvar jka-compr-compression-info-list) ;; Requiring `gnus-util' at compile time creates a circular ;; dependency between nnheader.el and gnus-util.el. ;;(eval-when-compile (require 'gnus-util)) (require 'mail-utils) (require 'mm-util) (require 'gnus-util) (eval-and-compile (autoload 'gnus-sorted-intersection "gnus-range") (autoload 'gnus-intersection "gnus-range") (autoload 'gnus-sorted-complement "gnus-range") (autoload 'gnus-sorted-difference "gnus-range")) (defcustom gnus-verbose-backends 7 "Integer that says how verbose the Gnus backends should be. The higher the number, the more messages the Gnus backends will flash to say what it's doing. At zero, the Gnus backends will be totally mute; at five, they will display most important messages; and at ten, they will keep on jabbering all the time." :group 'gnus-start :type 'integer) (defcustom gnus-nov-is-evil nil "If non-nil, Gnus backends will never output headers in the NOV format." :group 'gnus-server :type 'boolean) (defvar nnheader-max-head-length 8192 "*Max length of the head of articles. Value is an integer, nil, or t. nil means read in chunks of a file indefinitely until a complete head is found\; t means always read the entire file immediately, disregarding `nnheader-head-chop-length'. Integer values will in effect be rounded up to the nearest multiple of `nnheader-head-chop-length'.") (defvar nnheader-head-chop-length 2048 "*Length of each read operation when trying to fetch HEAD headers.") (defvar nnheader-read-timeout (if (string-match "windows-nt\\|os/2\\|emx\\|cygwin" (symbol-name system-type)) ;; http://thread.gmane.org/v9655t3pjo.fsf@marauder.physik.uni-ulm.de ;; ;; IIRC, values lower than 1.0 didn't/don't work on Windows/DOS. ;; ;; There should probably be a runtime test to determine the timing ;; resolution, or a primitive to report it. I don't know off-hand ;; what's possible. Perhaps better, maybe the Windows/DOS primitive ;; could round up non-zero timeouts to a minimum of 1.0? 1.0 0.1) "How long nntp should wait between checking for the end of output. Shorter values mean quicker response, but are more CPU intensive.") (defvar nnheader-file-name-translation-alist (let ((case-fold-search t)) (cond ((string-match "windows-nt\\|os/2\\|emx\\|cygwin" (symbol-name system-type)) (append (mapcar (lambda (c) (cons c ?_)) '(?: ?* ?\" ?< ?> ??)) (if (string-match "windows-nt\\|cygwin" (symbol-name system-type)) nil '((?+ . ?-))))) (t nil))) "*Alist that says how to translate characters in file names. For instance, if \":\" is invalid as a file character in file names on your system, you could say something like: \(setq nnheader-file-name-translation-alist '((?: . ?_)))") (defvar nnheader-directory-separator-character (string-to-char (substring (file-name-as-directory ".") -1)) "*A character used to a directory separator.") (eval-and-compile (autoload 'nnmail-message-id "nnmail") (autoload 'mail-position-on-field "sendmail") (autoload 'message-remove-header "message") (autoload 'gnus-buffer-live-p "gnus-util")) ;;; Header access macros. ;; These macros may look very much like the ones in GNUS 4.1. They ;; are, in a way, but you should note that the indices they use have ;; been changed from the internal GNUS format to the NOV format. The ;; makes it possible to read headers from XOVER much faster. ;; ;; The format of a header is now: ;; [number subject from date id references chars lines xref extra] ;; ;; (That next-to-last entry is defined as "misc" in the NOV format, ;; but Gnus uses it for xrefs.) (defmacro mail-header-number (header) "Return article number in HEADER." `(aref ,header 0)) (defmacro mail-header-set-number (header number) "Set article number of HEADER to NUMBER." `(aset ,header 0 ,number)) (defmacro mail-header-subject (header) "Return subject string in HEADER." `(aref ,header 1)) (defmacro mail-header-set-subject (header subject) "Set article subject of HEADER to SUBJECT." `(aset ,header 1 ,subject)) (defmacro mail-header-from (header) "Return author string in HEADER." `(aref ,header 2)) (defmacro mail-header-set-from (header from) "Set article author of HEADER to FROM." `(aset ,header 2 ,from)) (defmacro mail-header-date (header) "Return date in HEADER." `(aref ,header 3)) (defmacro mail-header-set-date (header date) "Set article date of HEADER to DATE." `(aset ,header 3 ,date)) (defalias 'mail-header-message-id 'mail-header-id) (defmacro mail-header-id (header) "Return Id in HEADER." `(aref ,header 4)) (defalias 'mail-header-set-message-id 'mail-header-set-id) (defmacro mail-header-set-id (header id) "Set article Id of HEADER to ID." `(aset ,header 4 ,id)) (defmacro mail-header-references (header) "Return references in HEADER." `(aref ,header 5)) (defmacro mail-header-set-references (header ref) "Set article references of HEADER to REF." `(aset ,header 5 ,ref)) (defmacro mail-header-chars (header) "Return number of chars of article in HEADER." `(aref ,header 6)) (defmacro mail-header-set-chars (header chars) "Set number of chars in article of HEADER to CHARS." `(aset ,header 6 ,chars)) (defmacro mail-header-lines (header) "Return lines in HEADER." `(aref ,header 7)) (defmacro mail-header-set-lines (header lines) "Set article lines of HEADER to LINES." `(aset ,header 7 ,lines)) (defmacro mail-header-xref (header) "Return xref string in HEADER." `(aref ,header 8)) (defmacro mail-header-set-xref (header xref) "Set article XREF of HEADER to xref." `(aset ,header 8 ,xref)) (defmacro mail-header-extra (header) "Return the extra headers in HEADER." `(aref ,header 9)) (defun mail-header-set-extra (header extra) "Set the extra headers in HEADER to EXTRA." (aset header 9 extra)) (defsubst make-mail-header (&optional init) "Create a new mail header structure initialized with INIT." (make-vector 10 init)) (defsubst make-full-mail-header (&optional number subject from date id references chars lines xref extra) "Create a new mail header structure initialized with the parameters given." (vector number subject from date id references chars lines xref extra)) ;; fake message-ids: generation and detection (defvar nnheader-fake-message-id 1) (defsubst nnheader-generate-fake-message-id (&optional number) (if (numberp number) (format "fake+none+%s+%d" gnus-newsgroup-name number) (format "fake+none+%s+%s" gnus-newsgroup-name (int-to-string (incf nnheader-fake-message-id))))) (defsubst nnheader-fake-message-id-p (id) (save-match-data ; regular message-id's are <.*> (string-match "\\`fake\\+none\\+.*\\+[0-9]+\\'" id))) ;; Parsing headers and NOV lines. (defsubst nnheader-remove-cr-followed-by-lf () (goto-char (point-max)) (while (search-backward "\r\n" nil t) (delete-char 1))) (defsubst nnheader-header-value () (skip-chars-forward " \t") (buffer-substring (point) (point-at-eol))) (autoload 'ietf-drums-unfold-fws "ietf-drums") (defun nnheader-parse-naked-head (&optional number) ;; This function unfolds continuation lines in this buffer ;; destructively. When this side effect is unwanted, use ;; `nnheader-parse-head' instead of this function. (let ((case-fold-search t) (buffer-read-only nil) (cur (current-buffer)) (p (point-min)) in-reply-to lines ref) (nnheader-remove-cr-followed-by-lf) (ietf-drums-unfold-fws) (subst-char-in-region (point-min) (point-max) ?\t ? ) (goto-char p) (insert "\n") (prog1 ;; This implementation of this function, with nine ;; search-forwards instead of the one re-search-forward and a ;; case (which basically was the old function) is actually ;; about twice as fast, even though it looks messier. You ;; can't have everything, I guess. Speed and elegance don't ;; always go hand in hand. (vector ;; Number. (or number 0) ;; Subject. (progn (goto-char p) (if (search-forward "\nsubject:" nil t) (nnheader-header-value) "(none)")) ;; From. (progn (goto-char p) (if (search-forward "\nfrom:" nil t) (nnheader-header-value) "(nobody)")) ;; Date. (progn (goto-char p) (if (search-forward "\ndate:" nil t) (nnheader-header-value) "")) ;; Message-ID. (progn (goto-char p) (if (search-forward "\nmessage-id:" nil t) (buffer-substring (1- (or (search-forward "<" (point-at-eol) t) (point))) (or (search-forward ">" (point-at-eol) t) (point))) ;; If there was no message-id, we just fake one to make ;; subsequent routines simpler. (nnheader-generate-fake-message-id number))) ;; References. (progn (goto-char p) (if (search-forward "\nreferences:" nil t) (nnheader-header-value) ;; Get the references from the in-reply-to header if ;; there were no references and the in-reply-to header ;; looks promising. (if (and (search-forward "\nin-reply-to:" nil t) (setq in-reply-to (nnheader-header-value)) (string-match "<[^\n>]+>" in-reply-to)) (let (ref2) (setq ref (substring in-reply-to (match-beginning 0) (match-end 0))) (while (string-match "<[^\n>]+>" in-reply-to (match-end 0)) (setq ref2 (substring in-reply-to (match-beginning 0) (match-end 0))) (when (> (length ref2) (length ref)) (setq ref ref2))) ref) nil))) ;; Chars. 0 ;; Lines. (progn (goto-char p) (if (search-forward "\nlines: " nil t) (if (numberp (setq lines (read cur))) lines 0) 0)) ;; Xref. (progn (goto-char p) (and (search-forward "\nxref:" nil t) (nnheader-header-value))) ;; Extra. (when nnmail-extra-headers (let ((extra nnmail-extra-headers) out) (while extra (goto-char p) (when (search-forward (concat "\n" (symbol-name (car extra)) ":") nil t) (push (cons (car extra) (nnheader-header-value)) out)) (pop extra)) out))) (goto-char p) (delete-char 1)))) (defun nnheader-parse-head (&optional naked) (let ((cur (current-buffer)) num beg end) (when (if naked (setq num 0 beg (point-min) end (point-max)) (goto-char (point-min)) ;; Search to the beginning of the next header. Error ;; messages do not begin with 2 or 3. (when (re-search-forward "^[23][0-9]+ " nil t) (end-of-line) (setq num (read cur) beg (point) end (if (search-forward "\n.\n" nil t) (- (point) 2) (point))))) (with-temp-buffer (insert-buffer-substring cur beg end) (nnheader-parse-naked-head num))))) (defmacro nnheader-nov-skip-field () '(search-forward "\t" eol 'move)) (defmacro nnheader-nov-field () '(buffer-substring (point) (if (nnheader-nov-skip-field) (1- (point)) eol))) (defmacro nnheader-nov-read-integer () '(prog1 (if (eq (char-after) ?\t) 0 (let ((num (condition-case nil (read (current-buffer)) (error nil)))) (if (numberp num) num 0))) (or (eobp) (forward-char 1)))) (defmacro nnheader-nov-parse-extra () '(let (out string) (while (not (memq (char-after) '(?\n nil))) (setq string (nnheader-nov-field)) (when (string-match "^\\([^ :]+\\): " string) (push (cons (intern (match-string 1 string)) (substring string (match-end 0))) out))) out)) (eval-and-compile (defvar nnheader-uniquify-message-id nil)) (defmacro nnheader-nov-read-message-id (&optional number) `(let ((id (nnheader-nov-field))) (if (string-match "^<[^>]+>$" id) ,(if nnheader-uniquify-message-id `(if (string-match "__[^@]+@" id) (concat (substring id 0 (match-beginning 0)) (substring id (1- (match-end 0)))) id) 'id) (nnheader-generate-fake-message-id ,number)))) (defun nnheader-parse-nov () (let ((eol (point-at-eol)) (number (nnheader-nov-read-integer))) (vector number ; number (nnheader-nov-field) ; subject (nnheader-nov-field) ; from (nnheader-nov-field) ; date (nnheader-nov-read-message-id number) ; id (nnheader-nov-field) ; refs (nnheader-nov-read-integer) ; chars (nnheader-nov-read-integer) ; lines (if (eq (char-after) ?\n) nil (if (looking-at "Xref: ") (goto-char (match-end 0))) (nnheader-nov-field)) ; Xref (nnheader-nov-parse-extra)))) ; extra (defun nnheader-insert-nov (header) (princ (mail-header-number header) (current-buffer)) (let ((p (point))) (insert "\t" (or (mail-header-subject header) "(none)") "\t" (or (mail-header-from header) "(nobody)") "\t" (or (mail-header-date header) "") "\t" (or (mail-header-id header) (nnmail-message-id)) "\t" (or (mail-header-references header) "") "\t") (princ (or (mail-header-chars header) 0) (current-buffer)) (insert "\t") (princ (or (mail-header-lines header) 0) (current-buffer)) (insert "\t") (when (mail-header-xref header) (insert "Xref: " (mail-header-xref header))) (when (or (mail-header-xref header) (mail-header-extra header)) (insert "\t")) (when (mail-header-extra header) (let ((extra (mail-header-extra header))) (while extra (insert (symbol-name (caar extra)) ": " (cdar extra) "\t") (pop extra)))) (insert "\n") (backward-char 1) (while (search-backward "\n" p t) (delete-char 1)) (forward-line 1))) (defun nnheader-parse-overview-file (file) "Parse FILE and return a list of headers." (mm-with-unibyte-buffer (nnheader-insert-file-contents file) (goto-char (point-min)) (let (headers) (while (not (eobp)) (push (nnheader-parse-nov) headers) (forward-line 1)) (nreverse headers)))) (defun nnheader-write-overview-file (file headers) "Write HEADERS to FILE." (with-temp-file file (mapcar 'nnheader-insert-nov headers))) (defun nnheader-insert-header (header) (insert "Subject: " (or (mail-header-subject header) "(none)") "\n" "From: " (or (mail-header-from header) "(nobody)") "\n" "Date: " (or (mail-header-date header) "") "\n" "Message-ID: " (or (mail-header-id header) (nnmail-message-id)) "\n" "References: " (or (mail-header-references header) "") "\n" "Lines: ") (princ (or (mail-header-lines header) 0) (current-buffer)) (insert "\n\n")) (defun nnheader-insert-article-line (article) (goto-char (point-min)) (insert "220 ") (princ article (current-buffer)) (insert " Article retrieved.\n") (search-forward "\n\n" nil 'move) (delete-region (point) (point-max)) (forward-char -1) (insert ".")) (defun nnheader-nov-delete-outside-range (beg end) "Delete all NOV lines that lie outside the BEG to END range." ;; First we find the first wanted line. (nnheader-find-nov-line beg) (delete-region (point-min) (point)) ;; Then we find the last wanted line. (when (nnheader-find-nov-line end) (forward-line 1)) (delete-region (point) (point-max))) (defun nnheader-find-nov-line (article) "Put point at the NOV line that start with ARTICLE. If ARTICLE doesn't exist, put point where that line would have been. The function will return non-nil if the line could be found." ;; This function basically does a binary search. (let ((max (point-max)) (min (goto-char (point-min))) (cur (current-buffer)) (prev (point-min)) num found) (while (not found) (goto-char (+ min (/ (- max min) 2))) (beginning-of-line) (if (or (= (point) prev) (eobp)) (setq found t) (setq prev (point)) (while (and (not (numberp (setq num (read cur)))) (not (eobp))) (gnus-delete-line)) (cond ((> num article) (setq max (point))) ((< num article) (setq min (point))) (t (setq found 'yes))))) ;; We may be at the first line. (when (and (not num) (not (eobp))) (setq num (read cur))) ;; Now we may have found the article we're looking for, or we ;; may be somewhere near it. (when (and (not (eq found 'yes)) (not (eq num article))) (setq found (point)) (while (and (< (point) max) (or (not (numberp num)) (< num article))) (forward-line 1) (setq found (point)) (or (eobp) (= (setq num (read cur)) article))) (unless (eq num article) (goto-char found))) (beginning-of-line) (eq num article))) ;; Various cruft the backends and Gnus need to communicate. (defvar nntp-server-buffer nil) (defvar nntp-process-response nil) (defvar news-reply-yank-from nil) (defvar news-reply-yank-message-id nil) (defvar nnheader-callback-function nil) (defun nnheader-init-server-buffer () "Initialize the Gnus-backend communication buffer." (unless (gnus-buffer-live-p nntp-server-buffer) (setq nntp-server-buffer (get-buffer-create " *nntpd*"))) (with-current-buffer nntp-server-buffer (erase-buffer) (mm-enable-multibyte) (kill-all-local-variables) (setq case-fold-search t) ;Should ignore case. (set (make-local-variable 'nntp-process-response) nil) t)) ;;; Various functions the backends use. (defun nnheader-file-error (file) "Return a string that says what is wrong with FILE." (format (cond ((not (file-exists-p file)) "%s does not exist") ((file-directory-p file) "%s is a directory") ((not (file-readable-p file)) "%s is not readable")) file)) (defun nnheader-insert-head (file) "Insert the head of the article." (when (file-exists-p file) (if (eq nnheader-max-head-length t) ;; Just read the entire file. (nnheader-insert-file-contents file) ;; Read blocks of the size specified by `nnheader-head-chop-length' ;; until we find a separator. (let ((beg 0) (start (point)) ;; Use `binary' to prevent the contents from being decoded, ;; or it will change the number of characters that ;; `insert-file-contents' returns. (coding-system-for-read 'binary)) (while (and (eq nnheader-head-chop-length (nth 1 (mm-insert-file-contents file nil beg (incf beg nnheader-head-chop-length)))) ;; CRLF or CR might be used for the line-break code. (prog1 (not (re-search-forward "\n\r?\n\\|\r\r" nil t)) (goto-char (point-max))) (or (null nnheader-max-head-length) (< beg nnheader-max-head-length)))) ;; Finally decode the contents. (when (mm-coding-system-p nnheader-file-coding-system) (mm-decode-coding-region start (point-max) nnheader-file-coding-system)))) t)) (defun nnheader-article-p () "Say whether the current buffer looks like an article." (goto-char (point-min)) (if (not (search-forward "\n\n" nil t)) nil (narrow-to-region (point-min) (1- (point))) (goto-char (point-min)) (while (looking-at "[a-zA-Z][^ \t]+:.*\n\\([ \t].*\n\\)*\\|From .*\n") (goto-char (match-end 0))) (prog1 (eobp) (widen)))) (defun nnheader-insert-references (references message-id) "Insert a References header based on REFERENCES and MESSAGE-ID." (if (and (not references) (not message-id)) ;; This is invalid, but not all articles have Message-IDs. () (mail-position-on-field "References") (let ((begin (point-at-bol)) (fill-column 78) (fill-prefix "\t")) (when references (insert references)) (when (and references message-id) (insert " ")) (when message-id (insert message-id)) ;; Fold long References lines to conform to RFC1036 (sort of). ;; The region must end with a newline to fill the region ;; without inserting extra newline. (fill-region-as-paragraph begin (1+ (point)))))) (defun nnheader-replace-header (header new-value) "Remove HEADER and insert the NEW-VALUE." (save-excursion (save-restriction (nnheader-narrow-to-headers) (prog1 (message-remove-header header) (goto-char (point-max)) (insert header ": " new-value "\n"))))) (defun nnheader-narrow-to-headers () "Narrow to the head of an article." (widen) (narrow-to-region (goto-char (point-min)) (if (search-forward "\n\n" nil t) (1- (point)) (point-max))) (goto-char (point-min))) (defun nnheader-get-lines-and-char () "Return the number of lines and chars in the article body." (goto-char (point-min)) (if (not (re-search-forward "\n\r?\n" nil t)) (list 0 0) (list (count-lines (point) (point-max)) (- (point-max) (point))))) (defun nnheader-remove-body () "Remove the body from an article in this current buffer." (goto-char (point-min)) (when (re-search-forward "\n\r?\n" nil t) (delete-region (point) (point-max)))) (defun nnheader-set-temp-buffer (name &optional noerase) "Set-buffer to an empty (possibly new) buffer called NAME with undo disabled." (set-buffer (get-buffer-create name)) (buffer-disable-undo) (unless noerase (erase-buffer)) (current-buffer)) (defvar nnheader-numerical-files (if (boundp 'jka-compr-compression-info-list) (concat "\\([0-9]+\\)\\(" (mapconcat (lambda (i) (aref i 0)) jka-compr-compression-info-list "\\|") "\\)?") "[0-9]+$") "Regexp that match numerical files.") (defvar nnheader-numerical-short-files (concat "^" nnheader-numerical-files) "Regexp that matches numerical file names.") (defvar nnheader-numerical-full-files (concat "/" nnheader-numerical-files) "Regexp that matches numerical full file names.") (defsubst nnheader-file-to-number (file) "Take a FILE name and return the article number." (if (string= nnheader-numerical-short-files "^[0-9]+$") (string-to-number file) (string-match nnheader-numerical-short-files file) (string-to-number (match-string 0 file)))) (defvar nnheader-directory-files-is-safe (or (eq system-type 'windows-nt) (not (featurep 'xemacs))) "If non-nil, Gnus believes `directory-files' is safe. It has been reported numerous times that `directory-files' fails with an alarming frequency on NFS mounted file systems. If it is nil, `nnheader-directory-files-safe' is used.") (defun nnheader-directory-files-safe (&rest args) "Execute `directory-files' twice and returns the longer result." (let ((first (apply 'directory-files args)) (second (apply 'directory-files args))) (if (> (length first) (length second)) first second))) (defun nnheader-directory-articles (dir) "Return a list of all article files in directory DIR." (mapcar 'nnheader-file-to-number (if nnheader-directory-files-is-safe (directory-files dir nil nnheader-numerical-short-files t) (nnheader-directory-files-safe dir nil nnheader-numerical-short-files t)))) (defun nnheader-article-to-file-alist (dir) "Return an alist of article/file pairs in DIR." (mapcar (lambda (file) (cons (nnheader-file-to-number file) file)) (if nnheader-directory-files-is-safe (directory-files dir nil nnheader-numerical-short-files t) (nnheader-directory-files-safe dir nil nnheader-numerical-short-files t)))) (defun nnheader-fold-continuation-lines () "Fold continuation lines in the current buffer." (nnheader-replace-regexp "\\(\r?\n[ \t]+\\)+" " ")) (defun nnheader-translate-file-chars (file &optional full) "Translate FILE into something that can be a file name. If FULL, translate everything." (if (null nnheader-file-name-translation-alist) ;; No translation is necessary. file (let* ((i 0) trans leaf path len) (if full ;; Do complete translation. (setq leaf (copy-sequence file) path "" i (if (and (< 1 (length leaf)) (eq ?: (aref leaf 1))) 2 0)) ;; We translate -- but only the file name. We leave the directory ;; alone. (if (and (featurep 'xemacs) (memq system-type '(cygwin32 win32 w32 mswindows windows-nt cygwin))) ;; This is needed on NT and stuff, because ;; file-name-nondirectory is not enough to split ;; file names, containing ':', e.g. ;; "d:\\Work\\News\\nntp+news.fido7.ru:fido7.ru.gnu.SCORE" ;; ;; we are trying to correctly split such names: ;; "d:file.name" -> "a:" "file.name" ;; "aaa:bbb.ccc" -> "" "aaa:bbb.ccc" ;; "d:aaa\\bbb:ccc" -> "d:aaa\\" "bbb:ccc" ;; etc. ;; to translate then only the file name part. (progn (setq leaf file path "") (if (string-match "\\(^\\w:\\|[/\\]\\)\\([^/\\]+\\)$" file) (setq leaf (substring file (match-beginning 2)) path (substring file 0 (match-beginning 2))))) ;; Emacs DTRT, says andrewi. (setq leaf (file-name-nondirectory file) path (file-name-directory file)))) (setq len (length leaf)) (while (< i len) (when (setq trans (cdr (assq (aref leaf i) nnheader-file-name-translation-alist))) (aset leaf i trans)) (incf i)) (concat path leaf)))) (defun nnheader-report (backend &rest args) "Report an error from the BACKEND. The first string in ARGS can be a format string." (set (intern (format "%s-status-string" backend)) (if (< (length args) 2) (car args) (apply 'format args))) nil) (defun nnheader-get-report (backend) "Get the most recent report from BACKEND." (condition-case () (nnheader-message 5 "%s" (symbol-value (intern (format "%s-status-string" backend)))) (error (nnheader-message 5 "")))) (defun nnheader-insert (format &rest args) "Clear the communication buffer and insert FORMAT and ARGS into the buffer. If FORMAT isn't a format string, it and all ARGS will be inserted without formatting." (save-excursion (set-buffer nntp-server-buffer) (erase-buffer) (if (string-match "%" format) (insert (apply 'format format args)) (apply 'insert format args)) t)) (defsubst nnheader-replace-chars-in-string (string from to) (mm-subst-char-in-string from to string)) (defun nnheader-replace-duplicate-chars-in-string (string from to) "Replace characters in STRING from FROM to TO." (let ((string (substring string 0)) ;Copy string. (len (length string)) (idx 0) prev i) ;; Replace all occurrences of FROM with TO. (while (< idx len) (setq i (aref string idx)) (when (and (eq prev from) (= i from)) (aset string (1- idx) to) (aset string idx to)) (setq prev i) (setq idx (1+ idx))) string)) (defun nnheader-file-to-group (file &optional top) "Return a group name based on FILE and TOP." (nnheader-replace-chars-in-string (if (not top) file (condition-case () (substring (expand-file-name file) (length (expand-file-name (file-name-as-directory top)))) (error ""))) nnheader-directory-separator-character ?.)) (defun nnheader-message (level &rest args) "Message if the Gnus backends are talkative." (if (or (not (numberp gnus-verbose-backends)) (<= level gnus-verbose-backends)) (if gnus-add-timestamp-to-message (apply 'gnus-message-with-timestamp args) (apply 'message args)) (apply 'format args))) (defun nnheader-be-verbose (level) "Return whether the backends should be verbose on LEVEL." (or (not (numberp gnus-verbose-backends)) (<= level gnus-verbose-backends))) (defvar nnheader-pathname-coding-system 'iso-8859-1 "*Coding system for file name.") (defun nnheader-group-pathname (group dir &optional file) "Make file name for GROUP." (concat (let ((dir (file-name-as-directory (expand-file-name dir)))) ;; If this directory exists, we use it directly. (file-name-as-directory (if (file-directory-p (concat dir group)) (expand-file-name group dir) ;; If not, we translate dots into slashes. (expand-file-name (mm-encode-coding-string (nnheader-replace-chars-in-string group ?. ?/) nnheader-pathname-coding-system) dir)))) (cond ((null file) "") ((numberp file) (int-to-string file)) (t file)))) (defun nnheader-concat (dir &rest files) "Concat DIR as directory to FILES." (apply 'concat (file-name-as-directory dir) files)) (defun nnheader-ms-strip-cr () "Strip ^M from the end of all lines." (save-excursion (nnheader-remove-cr-followed-by-lf))) (defun nnheader-file-size (file) "Return the file size of FILE or 0." (or (nth 7 (file-attributes file)) 0)) (defun nnheader-find-etc-directory (package &optional file first) "Go through `load-path' and find the \"../etc/PACKAGE\" directory. This function will look in the parent directory of each `load-path' entry, and look for the \"etc\" directory there. If FILE, find the \".../etc/PACKAGE\" file instead. If FIRST is non-nil, return the directory or the file found at the first. Otherwise, find the newest one, though it may take a time." (let ((path load-path) dir results) ;; We try to find the dir by looking at the load path, ;; stripping away the last component and adding "etc/". (while path (if (and (car path) (file-exists-p (setq dir (concat (file-name-directory (directory-file-name (car path))) "etc/" package (if file "" "/")))) (or file (file-directory-p dir))) (progn (or (member dir results) (push dir results)) (setq path (if first nil (cdr path)))) (setq path (cdr path)))) (if (or first (not (cdr results))) (car results) (car (sort results 'file-newer-than-file-p))))) (defvar ange-ftp-path-format) (defvar efs-path-regexp) (defun nnheader-re-read-dir (path) "Re-read directory PATH if PATH is on a remote system." (if (and (fboundp 'efs-re-read-dir) (boundp 'efs-path-regexp)) (when (string-match efs-path-regexp path) (efs-re-read-dir path)) (when (and (fboundp 'ange-ftp-re-read-dir) (boundp 'ange-ftp-path-format)) (when (string-match (car ange-ftp-path-format) path) (ange-ftp-re-read-dir path))))) (defvar nnheader-file-coding-system 'raw-text "Coding system used in file backends of Gnus.") (defun nnheader-insert-file-contents (filename &optional visit beg end replace) "Like `insert-file-contents', q.v., but only reads in the file. A buffer may be modified in several ways after reading into the buffer due to advanced Emacs features, such as file-name-handlers, format decoding, find-file-hooks, etc. This function ensures that none of these modifications will take place." (let ((coding-system-for-read nnheader-file-coding-system)) (mm-insert-file-contents filename visit beg end replace))) (defun nnheader-insert-nov-file (file first) (let ((size (nth 7 (file-attributes file))) (cutoff (* 32 1024))) (when size (if (< size cutoff) ;; If the file is small, we just load it. (nnheader-insert-file-contents file) ;; We start on the assumption that FIRST is pretty recent. If ;; not, we just insert the rest of the file as well. (let (current) (nnheader-insert-file-contents file nil (- size cutoff) size) (goto-char (point-min)) (delete-region (point) (or (search-forward "\n" nil 'move) (point))) (setq current (ignore-errors (read (current-buffer)))) (if (and (numberp current) (< current first)) t (delete-region (point-min) (point-max)) (nnheader-insert-file-contents file))))))) (defun nnheader-find-file-noselect (&rest args) "Open a file with some variables bound. See `find-file-noselect' for the arguments." (let* ((format-alist nil) (auto-mode-alist (mm-auto-mode-alist)) (default-major-mode 'fundamental-mode) (enable-local-variables nil) (after-insert-file-functions nil) (enable-local-eval nil) (coding-system-for-read nnheader-file-coding-system) (version-control 'never) (ffh (if (boundp 'find-file-hook) 'find-file-hook 'find-file-hooks)) (val (symbol-value ffh))) (set ffh nil) (unwind-protect (apply 'find-file-noselect args) (set ffh val)))) (defun nnheader-directory-regular-files (dir) "Return a list of all regular files in DIR." (let ((files (directory-files dir t)) out) (while files (when (file-regular-p (car files)) (push (car files) out)) (pop files)) (nreverse out))) (defun nnheader-directory-files (&rest args) "Same as `directory-files', but prune \".\" and \"..\"." (let ((files (apply 'directory-files args)) out) (while files (unless (member (file-name-nondirectory (car files)) '("." "..")) (push (car files) out)) (pop files)) (nreverse out))) (defmacro nnheader-skeleton-replace (from &optional to regexp) `(let ((new (generate-new-buffer " *nnheader replace*")) (cur (current-buffer)) (start (point-min))) (set-buffer cur) (goto-char (point-min)) (while (,(if regexp 're-search-forward 'search-forward) ,from nil t) (insert-buffer-substring cur start (prog1 (match-beginning 0) (set-buffer new))) (goto-char (point-max)) ,(when to `(insert ,to)) (set-buffer cur) (setq start (point))) (insert-buffer-substring cur start (prog1 (point-max) (set-buffer new))) (copy-to-buffer cur (point-min) (point-max)) (kill-buffer (current-buffer)) (set-buffer cur))) (defun nnheader-replace-string (from to) "Do a fast replacement of FROM to TO from point to `point-max'." (nnheader-skeleton-replace from to)) (defun nnheader-replace-regexp (from to) "Do a fast regexp replacement of FROM to TO from point to `point-max'." (nnheader-skeleton-replace from to t)) (defun nnheader-strip-cr () "Strip all \r's from the current buffer." (nnheader-skeleton-replace "\r")) (defalias 'nnheader-cancel-timer 'cancel-timer) (defalias 'nnheader-cancel-function-timers 'cancel-function-timers) (defun nnheader-accept-process-output (process) (accept-process-output process (truncate nnheader-read-timeout) (truncate (* (- nnheader-read-timeout (truncate nnheader-read-timeout)) 1000)))) (when (featurep 'xemacs) (require 'nnheaderxm)) (run-hooks 'nnheader-load-hook) (provide 'nnheader) ;; arch-tag: a9c4b7d9-52ae-4ec9-b196-dfd93124d202 ;;; nnheader.el ends here gnus-5.11+v0.10.dfsg/lisp/hmac-md5.el0000644000175000017500000000562211004005111017144 0ustar tvainikatvainika;;; hmac-md5.el --- Compute HMAC-MD5. ;; Copyright (C) 1999, 2001, 2007, 2008 Free Software Foundation, Inc. ;; Author: Shuhei KOBAYASHI ;; Keywords: HMAC, RFC 2104, HMAC-MD5, MD5, KEYED-MD5, CRAM-MD5 ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 3, or (at your option) ;; any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Commentary: ;; Test cases from RFC 2202, "Test Cases for HMAC-MD5 and HMAC-SHA-1". ;; ;; (encode-hex-string (hmac-md5 "Hi There" (make-string 16 ?\x0b))) ;; => "9294727a3638bb1c13f48ef8158bfc9d" ;; ;; (encode-hex-string (hmac-md5 "what do ya want for nothing?" "Jefe")) ;; => "750c783e6ab0b503eaa86e310a5db738" ;; ;; (encode-hex-string (hmac-md5 (make-string 50 ?\xdd) (make-string 16 ?\xaa))) ;; => "56be34521d144c88dbb8c733f0e8b3f6" ;; ;; (encode-hex-string ;; (hmac-md5 ;; (make-string 50 ?\xcd) ;; (decode-hex-string "0102030405060708090a0b0c0d0e0f10111213141516171819"))) ;; => "697eaf0aca3a3aea3a75164746ffaa79" ;; ;; (encode-hex-string ;; (hmac-md5 "Test With Truncation" (make-string 16 ?\x0c))) ;; => "56461ef2342edc00f9bab995690efd4c" ;; ;; (encode-hex-string ;; (hmac-md5-96 "Test With Truncation" (make-string 16 ?\x0c))) ;; => "56461ef2342edc00f9bab995" ;; ;; (encode-hex-string ;; (hmac-md5 ;; "Test Using Larger Than Block-Size Key - Hash Key First" ;; (make-string 80 ?\xaa))) ;; => "6b1ab7fe4bd7bf8f0b62e6ce61b9d0cd" ;; ;; (encode-hex-string ;; (hmac-md5 ;; "Test Using Larger Than Block-Size Key and Larger Than One Block-Size Data" ;; (make-string 80 ?\xaa))) ;; => "6f630fad67cda0ee1fb1f562db3aa53e" ;;; Code: (eval-when-compile (require 'hmac-def)) (require 'hex-util) ; (decode-hex-string STRING) (require 'md5) ; expects (md5 STRING) (defun md5-binary (string) "Return the MD5 of STRING in binary form." (if (condition-case nil ;; `md5' of v21 takes 4th arg CODING (and 5th arg NOERROR). (md5 "" nil nil 'binary) ; => "d41d8cd98f00b204e9800998ecf8427e" (wrong-number-of-arguments nil)) (decode-hex-string (md5 string nil nil 'binary)) (decode-hex-string (md5 string)))) (define-hmac-function hmac-md5 md5-binary 64 16) ; => (hmac-md5 TEXT KEY) (define-hmac-function hmac-md5-96 md5-binary 64 16 96) (provide 'hmac-md5) ;; arch-tag: 0ab3f4f6-3d4b-4167-a9fa-635b7fed7f27 ;;; hmac-md5.el ends here gnus-5.11+v0.10.dfsg/lisp/message.el0000644000175000017500000105310111004005110017170 0ustar tvainikatvainika;;; message.el --- composing mail and news messages ;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, ;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; Keywords: mail, news ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 3, or (at your option) ;; any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Commentary: ;; This mode provides mail-sending facilities from within Emacs. It ;; consists mainly of large chunks of code from the sendmail.el, ;; gnus-msg.el and rnewspost.el files. ;;; Code: (eval-and-compile (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) (eval-when-compile (require 'cl)) (require 'hashcash) (require 'canlock) (require 'mailheader) (require 'gmm-utils) (require 'nnheader) ;; This is apparently necessary even though things are autoloaded. ;; Because we dynamically bind mail-abbrev-mode-regexp, we'd better ;; require mailabbrev here. (if (featurep 'xemacs) (require 'mail-abbrevs) (require 'mailabbrev)) (require 'mail-parse) (require 'mml) (require 'rfc822) (require 'ecomplete) (autoload 'mailclient-send-it "mailclient") ;; Emacs 22 or contrib/ (defvar gnus-message-group-art) (defvar gnus-list-identifiers) ; gnus-sum is required where necessary (defvar rmail-enable-mime-composing) (defgroup message '((user-mail-address custom-variable) (user-full-name custom-variable)) "Mail and news message composing." :link '(custom-manual "(message)Top") :group 'mail :group 'news) (put 'user-mail-address 'custom-type 'string) (put 'user-full-name 'custom-type 'string) (defgroup message-various nil "Various Message Variables." :link '(custom-manual "(message)Various Message Variables") :group 'message) (defgroup message-buffers nil "Message Buffers." :link '(custom-manual "(message)Message Buffers") :group 'message) (defgroup message-sending nil "Message Sending." :link '(custom-manual "(message)Sending Variables") :group 'message) (defgroup message-interface nil "Message Interface." :link '(custom-manual "(message)Interface") :group 'message) (defgroup message-forwarding nil "Message Forwarding." :link '(custom-manual "(message)Forwarding") :group 'message-interface) (defgroup message-insertion nil "Message Insertion." :link '(custom-manual "(message)Insertion") :group 'message) (defgroup message-headers nil "Message Headers." :link '(custom-manual "(message)Message Headers") :group 'message) (defgroup message-news nil "Composing News Messages." :group 'message) (defgroup message-mail nil "Composing Mail Messages." :group 'message) (defgroup message-faces nil "Faces used for message composing." :group 'message :group 'faces) (defcustom message-directory "~/Mail/" "*Directory from which all other mail file variables are derived." :group 'message-various :type 'directory) (defcustom message-max-buffers 10 "*How many buffers to keep before starting to kill them off." :group 'message-buffers :type 'integer) (defcustom message-send-rename-function nil "Function called to rename the buffer after sending it." :group 'message-buffers :type '(choice function (const nil))) (defcustom message-fcc-handler-function 'message-output "*A function called to save outgoing articles. This function will be called with the name of the file to store the article in. The default function is `message-output' which saves in Unix mailbox format." :type '(radio (function-item message-output) (function :tag "Other")) :group 'message-sending) (defcustom message-fcc-externalize-attachments nil "If non-nil, attachments are included as external parts in Fcc copies." :version "22.1" :type 'boolean :group 'message-sending) (defcustom message-courtesy-message "The following message is a courtesy copy of an article\nthat has been posted to %s as well.\n\n" "*This is inserted at the start of a mailed copy of a posted message. If the string contains the format spec \"%s\", the Newsgroups the article has been posted to will be inserted there. If this variable is nil, no such courtesy message will be added." :group 'message-sending :type '(radio string (const nil))) (defcustom message-ignored-bounced-headers "^\\(Received\\|Return-Path\\|Delivered-To\\):" "*Regexp that matches headers to be removed in resent bounced mail." :group 'message-interface :type 'regexp) (defcustom message-from-style 'default "*Specifies how \"From\" headers look. If nil, they contain just the return address like: king@grassland.com If `parens', they look like: king@grassland.com (Elvis Parsley) If `angles', they look like: Elvis Parsley Otherwise, most addresses look like `angles', but they look like `parens' if `angles' would need quoting and `parens' would not." :type '(choice (const :tag "simple" nil) (const parens) (const angles) (const default)) :group 'message-headers) (defcustom message-insert-canlock t "Whether to insert a Cancel-Lock header in news postings." :version "22.1" :group 'message-headers :type 'boolean) (defcustom message-syntax-checks (if message-insert-canlock '((sender . disabled)) nil) ;; Guess this one shouldn't be easy to customize... "*Controls what syntax checks should not be performed on outgoing posts. To disable checking of long signatures, for instance, add `(signature . disabled)' to this list. Don't touch this variable unless you really know what you're doing. Checks include `approved', `bogus-recipient', `continuation-headers', `control-chars', `empty', `existing-newsgroups', `from', `illegible-text', `invisible-text', `long-header-lines', `long-lines', `message-id', `multiple-headers', `new-text', `newsgroups', `quoting-style', `repeated-newsgroups', `reply-to', `sender', `sendsys', `shoot', `shorten-followup-to', `signature', `size', `subject', `subject-cmsg' and `valid-newsgroups'." :group 'message-news :type '(repeat sexp)) ; Fixme: improve this (defcustom message-required-headers '((optional . References) From) "*Headers to be generated or prompted for when sending a message. Also see `message-required-news-headers' and `message-required-mail-headers'." :version "22.1" :group 'message-news :group 'message-headers :link '(custom-manual "(message)Message Headers") :type '(repeat sexp)) (defcustom message-draft-headers '(References From Date) "*Headers to be generated when saving a draft message." :version "22.1" :group 'message-news :group 'message-headers :link '(custom-manual "(message)Message Headers") :type '(repeat sexp)) (defcustom message-required-news-headers '(From Newsgroups Subject Date Message-ID (optional . Organization) (optional . User-Agent)) "*Headers to be generated or prompted for when posting an article. RFC977 and RFC1036 require From, Date, Newsgroups, Subject, Message-ID. Organization, Lines, In-Reply-To, Expires, and User-Agent are optional. If you don't want message to insert some header, remove it from this list." :group 'message-news :group 'message-headers :link '(custom-manual "(message)Message Headers") :type '(repeat sexp)) (defcustom message-required-mail-headers '(From Subject Date (optional . In-Reply-To) Message-ID (optional . User-Agent)) "*Headers to be generated or prompted for when mailing a message. It is recommended that From, Date, To, Subject and Message-ID be included. Organization and User-Agent are optional." :group 'message-mail :group 'message-headers :link '(custom-manual "(message)Message Headers") :type '(repeat sexp)) (defcustom message-deletable-headers '(Message-ID Date Lines) "Headers to be deleted if they already exist and were generated by message previously." :group 'message-headers :link '(custom-manual "(message)Message Headers") :type 'sexp) (defcustom message-ignored-news-headers "^NNTP-Posting-Host:\\|^Xref:\\|^[BGF]cc:\\|^Resent-Fcc:\\|^X-Draft-From:\\|^X-Gnus-Agent-Meta-Information:" "*Regexp of headers to be removed unconditionally before posting." :group 'message-news :group 'message-headers :link '(custom-manual "(message)Message Headers") :type '(repeat :value-to-internal (lambda (widget value) (custom-split-regexp-maybe value)) :match (lambda (widget value) (or (stringp value) (widget-editable-list-match widget value))) regexp)) (defcustom message-ignored-mail-headers "^[GF]cc:\\|^Resent-Fcc:\\|^Xref:\\|^X-Draft-From:\\|^X-Gnus-Agent-Meta-Information:" "*Regexp of headers to be removed unconditionally before mailing." :group 'message-mail :group 'message-headers :link '(custom-manual "(message)Mail Headers") :type 'regexp) (defcustom message-ignored-supersedes-headers "^Path:\\|^Date\\|^NNTP-Posting-Host:\\|^Xref:\\|^Lines:\\|^Received:\\|^X-From-Line:\\|^X-Trace:\\|^X-ID:\\|^X-Complaints-To:\\|Return-Path:\\|^Supersedes:\\|^NNTP-Posting-Date:\\|^X-Trace:\\|^X-Complaints-To:\\|^Cancel-Lock:\\|^Cancel-Key:\\|^X-Hashcash:\\|^X-Payment:\\|^Approved:" "*Header lines matching this regexp will be deleted before posting. It's best to delete old Path and Date headers before posting to avoid any confusion." :group 'message-interface :link '(custom-manual "(message)Superseding") :type '(repeat :value-to-internal (lambda (widget value) (custom-split-regexp-maybe value)) :match (lambda (widget value) (or (stringp value) (widget-editable-list-match widget value))) regexp)) (defcustom message-subject-re-regexp "^[ \t]*\\([Rr][Ee]\\(\\[[0-9]*\\]\\)*:[ \t]*\\)*[ \t]*" "*Regexp matching \"Re: \" in the subject line." :group 'message-various :link '(custom-manual "(message)Message Headers") :type 'regexp) ;;; Start of variables adopted from `message-utils.el'. (defcustom message-subject-trailing-was-query 'ask "*What to do with trailing \"(was: )\" in subject lines. If nil, leave the subject unchanged. If it is the symbol `ask', query the user what do do. In this case, the subject is matched against `message-subject-trailing-was-ask-regexp'. If `message-subject-trailing-was-query' is t, always strip the trailing old subject. In this case, `message-subject-trailing-was-regexp' is used." :version "22.1" :type '(choice (const :tag "never" nil) (const :tag "always strip" t) (const ask)) :link '(custom-manual "(message)Message Headers") :group 'message-various) (defcustom message-subject-trailing-was-ask-regexp "[ \t]*\\([[(]+[Ww][Aa][Ss][ \t]*.*[\])]+\\)" "*Regexp matching \"(was: )\" in the subject line. The function `message-strip-subject-trailing-was' uses this regexp if `message-subject-trailing-was-query' is set to the symbol `ask'. If the variable is t instead of `ask', use `message-subject-trailing-was-regexp' instead. It is okay to create some false positives here, as the user is asked." :version "22.1" :group 'message-various :link '(custom-manual "(message)Message Headers") :type 'regexp) (defcustom message-subject-trailing-was-regexp "[ \t]*\\((*[Ww][Aa][Ss]:[ \t]*.*)\\)" "*Regexp matching \"(was: )\" in the subject line. If `message-subject-trailing-was-query' is set to t, the subject is matched against `message-subject-trailing-was-regexp' in `message-strip-subject-trailing-was'. You should use a regexp creating very few false positives here." :version "22.1" :group 'message-various :link '(custom-manual "(message)Message Headers") :type 'regexp) ;;; marking inserted text (defcustom message-mark-insert-begin "--8<---------------cut here---------------start------------->8---\n" "How to mark the beginning of some inserted text." :version "22.1" :type 'string :link '(custom-manual "(message)Insertion Variables") :group 'message-various) (defcustom message-mark-insert-end "--8<---------------cut here---------------end--------------->8---\n" "How to mark the end of some inserted text." :version "22.1" :type 'string :link '(custom-manual "(message)Insertion Variables") :group 'message-various) (defcustom message-archive-header "X-No-Archive: Yes\n" "Header to insert when you don't want your article to be archived. Archives \(such as groups.google.com\) respect this header." :version "22.1" :type 'string :link '(custom-manual "(message)Header Commands") :group 'message-various) (defcustom message-archive-note "X-No-Archive: Yes - save http://groups.google.com/" "Note to insert why you wouldn't want this posting archived. If nil, don't insert any text in the body." :version "22.1" :type '(radio string (const nil)) :link '(custom-manual "(message)Header Commands") :group 'message-various) ;;; Crossposts and Followups ;; inspired by JoH-followup-to by Jochem Huhman ;; new suggestions by R. Weikusat (defvar message-cross-post-old-target nil "Old target for cross-posts or follow-ups.") (make-variable-buffer-local 'message-cross-post-old-target) (defcustom message-cross-post-default t "When non-nil `message-cross-post-followup-to' will perform a crosspost. If nil, `message-cross-post-followup-to' will only do a followup. Note that you can explicitly override this setting by calling `message-cross-post-followup-to' with a prefix." :version "22.1" :type 'boolean :group 'message-various) (defcustom message-cross-post-note "Crosspost & Followup-To: " "Note to insert before signature to notify of cross-post and follow-up." :version "22.1" :type 'string :group 'message-various) (defcustom message-followup-to-note "Followup-To: " "Note to insert before signature to notify of follow-up only." :version "22.1" :type 'string :group 'message-various) (defcustom message-cross-post-note-function 'message-cross-post-insert-note "Function to use to insert note about Crosspost or Followup-To. The function will be called with four arguments. The function should not only insert a note, but also ensure old notes are deleted. See the documentation for `message-cross-post-insert-note'." :version "22.1" :type 'function :group 'message-various) ;;; End of variables adopted from `message-utils.el'. (defcustom message-signature-separator "^-- $" "Regexp matching the signature separator. This variable is used to strip off the signature from quoted text when `message-cite-function' is `message-cite-original-without-signature'. Most useful values are \"^-- $\" (strict) and \"^-- *$\" (loose; allow missing whitespace)." :type '(choice (const :tag "strict" "^-- $") (const :tag "loose" "^-- *$") regexp) :version "22.3" ;; Gnus 5.10.12 (changed default) :link '(custom-manual "(message)Various Message Variables") :group 'message-various) (defcustom message-elide-ellipsis "\n[...]\n\n" "*The string which is inserted for elided text." :type 'string :link '(custom-manual "(message)Various Commands") :group 'message-various) (defcustom message-interactive t "Non-nil means when sending a message wait for and display errors. nil means let mailer mail back a message to report errors." :group 'message-sending :group 'message-mail :link '(custom-manual "(message)Sending Variables") :type 'boolean) (defcustom message-generate-new-buffers 'unique "*Say whether to create a new message buffer to compose a message. Valid values include: nil Generate the buffer name in the Message way (e.g., *mail*, *news*, *mail to whom*, *news on group*, etc.) and continue editing in the existing buffer of that name. If there is no such buffer, it will be newly created. `unique' or t Create the new buffer with the name generated in the Message way. `unsent' Similar to `unique' but the buffer name begins with \"*unsent \". `standard' Similar to nil but the buffer name is simpler like *mail message*. function If this is a function, call that function with three parameters: The type, the To address and the group name (any of these may be nil). The function should return the new buffer name." :group 'message-buffers :link '(custom-manual "(message)Message Buffers") :type '(choice (const nil) (sexp :tag "unique" :format "unique\n" :value unique :match (lambda (widget value) (memq value '(unique t)))) (const unsent) (const standard) (function :format "\n %{%t%}: %v"))) (defcustom message-kill-buffer-on-exit nil "*Non-nil means that the message buffer will be killed after sending a message." :group 'message-buffers :link '(custom-manual "(message)Message Buffers") :type 'boolean) (defcustom message-kill-buffer-query t "*Non-nil means that killing a modified message buffer has to be confirmed. This is used by `message-kill-buffer'." :version "23.1" ;; No Gnus :group 'message-buffers :type 'boolean) (defvar gnus-local-organization) (defcustom message-user-organization (or (and (boundp 'gnus-local-organization) (stringp gnus-local-organization) gnus-local-organization) (getenv "ORGANIZATION") t) "*String to be used as an Organization header. If t, use `message-user-organization-file'." :group 'message-headers :type '(choice string (const :tag "consult file" t))) (defcustom message-user-organization-file (let (orgfile) (dolist (f (list "/etc/organization" "/etc/news/organization" "/usr/lib/news/organization")) (when (file-readable-p f) (setq orgfile f))) orgfile) "*Local news organization file." :type 'file :link '(custom-manual "(message)News Headers") :group 'message-headers) (defcustom message-make-forward-subject-function #'message-forward-subject-name-subject "*List of functions called to generate subject headers for forwarded messages. The subject generated by the previous function is passed into each successive function. The provided functions are: * `message-forward-subject-author-subject' Source of article (author or newsgroup), in brackets followed by the subject * `message-forward-subject-name-subject' Source of article (name of author or newsgroup), in brackets followed by the subject * `message-forward-subject-fwd' Subject of article with 'Fwd:' prepended to it." :group 'message-forwarding :link '(custom-manual "(message)Forwarding") :type '(radio (function-item message-forward-subject-author-subject) (function-item message-forward-subject-fwd) (function-item message-forward-subject-name-subject) (repeat :tag "List of functions" function))) (defcustom message-forward-as-mime t "*Non-nil means forward messages as an inline/rfc822 MIME section. Otherwise, directly inline the old message in the forwarded message." :version "21.1" :group 'message-forwarding :link '(custom-manual "(message)Forwarding") :type 'boolean) (defcustom message-forward-show-mml 'best "*Non-nil means show forwarded messages as MML (decoded from MIME). Otherwise, forwarded messages are unchanged. Can also be the symbol `best' to indicate that MML should be used, except when it is a bad idea to use MML. One example where it is a bad idea is when forwarding a signed or encrypted message, because converting MIME to MML would invalidate the digital signature." :version "21.1" :group 'message-forwarding :type '(choice (const :tag "use MML" t) (const :tag "don't use MML " nil) (const :tag "use MML when appropriate" best))) (defcustom message-forward-before-signature t "*Non-nil means put forwarded message before signature, else after." :group 'message-forwarding :type 'boolean) (defcustom message-wash-forwarded-subjects nil "*Non-nil means try to remove as much cruft as possible from the subject. Done before generating the new subject of a forward." :group 'message-forwarding :link '(custom-manual "(message)Forwarding") :type 'boolean) (defcustom message-ignored-resent-headers ;; `Delivered-To' needs to be removed because some mailers use it to ;; detect loops, so if you resend a message to an address that ultimately ;; comes back to you (e.g. a mailing-list to which you subscribe, in which ;; case you may be removed from the list on the grounds that mail to you ;; bounced with a "mailing loop" error). "^Return-receipt\\|^X-Gnus\\|^Gnus-Warning:\\|^>?From \\|^Delivered-To:" "*All headers that match this regexp will be deleted when resending a message." :group 'message-interface :link '(custom-manual "(message)Resending") :type '(repeat :value-to-internal (lambda (widget value) (custom-split-regexp-maybe value)) :match (lambda (widget value) (or (stringp value) (widget-editable-list-match widget value))) regexp)) (defcustom message-forward-ignored-headers "^Content-Transfer-Encoding:\\|^X-Gnus" "*All headers that match this regexp will be deleted when forwarding a message." :version "21.1" :group 'message-forwarding :type '(repeat :value-to-internal (lambda (widget value) (custom-split-regexp-maybe value)) :match (lambda (widget value) (or (stringp value) (widget-editable-list-match widget value))) regexp)) (defcustom message-ignored-cited-headers "." "*Delete these headers from the messages you yank." :group 'message-insertion :link '(custom-manual "(message)Insertion Variables") :type 'regexp) (defcustom message-cite-prefix-regexp (if (string-match "[[:digit:]]" "1") ;; Support POSIX? XEmacs 21.5.27 doesn't. "\\([ \t]*[_.[:word:]]+>+\\|[ \t]*[]>|}]\\)+" ;; ?-, ?_ or ?. MUST NOT be in syntax entry w. (let (non-word-constituents) (with-syntax-table text-mode-syntax-table (setq non-word-constituents (concat (if (string-match "\\w" "_") "" "_") (if (string-match "\\w" ".") "" ".")))) (if (equal non-word-constituents "") "\\([ \t]*\\(\\w\\)+>+\\|[ \t]*[]>|}]\\)+" (concat "\\([ \t]*\\(\\w\\|[" non-word-constituents "]\\)+>+\\|[ \t]*[]>|}]\\)+")))) "*Regexp matching the longest possible citation prefix on a line." :version "22.1" :group 'message-insertion :link '(custom-manual "(message)Insertion Variables") :type 'regexp :set (lambda (symbol value) (prog1 (custom-set-default symbol value) (if (boundp 'gnus-message-cite-prefix-regexp) (setq gnus-message-cite-prefix-regexp (concat "^\\(?:" value "\\)")))))) (defcustom message-cancel-message "I am canceling my own article.\n" "Message to be inserted in the cancel message." :group 'message-interface :link '(custom-manual "(message)Canceling News") :type 'string) (defvar smtpmail-default-smtp-server) (defun message-send-mail-function () "Return suitable value for the variable `message-send-mail-function'." (cond ((and (require 'sendmail) (boundp 'sendmail-program) sendmail-program (executable-find sendmail-program)) 'message-send-mail-with-sendmail) ((and (locate-library "smtpmail") (require 'smtpmail) smtpmail-default-smtp-server) 'message-smtpmail-send-it) ((locate-library "mailclient") 'message-send-mail-with-mailclient) (t (lambda () (error "Don't know how to send mail. Please customize `message-send-mail-function'"))))) ;; Useful to set in site-init.el (defcustom message-send-mail-function (message-send-mail-function) "Function to call to send the current buffer as mail. The headers should be delimited by a line whose contents match the variable `mail-header-separator'. Valid values include `message-send-mail-with-sendmail' `message-send-mail-with-mh', `message-send-mail-with-qmail', `message-smtpmail-send-it', `smtpmail-send-it', `feedmail-send-it' and `message-send-mail-with-mailclient'. The default is system dependent and determined by the function `message-send-mail-function'. See also `send-mail-function'." :type '(radio (function-item message-send-mail-with-sendmail) (function-item message-send-mail-with-mh) (function-item message-send-mail-with-qmail) (function-item message-smtpmail-send-it) (function-item smtpmail-send-it) (function-item feedmail-send-it) (function-item message-send-mail-with-mailclient :tag "Use Mailclient package") (function :tag "Other")) :group 'message-sending :version "23.1" ;; No Gnus :initialize 'custom-initialize-default :link '(custom-manual "(message)Mail Variables") :group 'message-mail) (defcustom message-send-news-function 'message-send-news "Function to call to send the current buffer as news. The headers should be delimited by a line whose contents match the variable `mail-header-separator'." :group 'message-sending :group 'message-news :link '(custom-manual "(message)News Variables") :type 'function) (defcustom message-reply-to-function nil "If non-nil, function that should return a list of headers. This function should pick out addresses from the To, Cc, and From headers and respond with new To and Cc headers." :group 'message-interface :link '(custom-manual "(message)Reply") :type '(choice function (const nil))) (defcustom message-wide-reply-to-function nil "If non-nil, function that should return a list of headers. This function should pick out addresses from the To, Cc, and From headers and respond with new To and Cc headers." :group 'message-interface :link '(custom-manual "(message)Wide Reply") :type '(choice function (const nil))) (defcustom message-followup-to-function nil "If non-nil, function that should return a list of headers. This function should pick out addresses from the To, Cc, and From headers and respond with new To and Cc headers." :group 'message-interface :link '(custom-manual "(message)Followup") :type '(choice function (const nil))) (defcustom message-extra-wide-headers nil "If non-nil, a list of additional address headers. These are used when composing a wide reply." :group 'message-sending :type '(repeat string)) (defcustom message-use-followup-to 'ask "*Specifies what to do with Followup-To header. If nil, always ignore the header. If it is t, use its value, but query before using the \"poster\" value. If it is the symbol `ask', always query the user whether to use the value. If it is the symbol `use', always use the value." :group 'message-interface :link '(custom-manual "(message)Followup") :type '(choice (const :tag "ignore" nil) (const :tag "use & query" t) (const use) (const ask))) (defcustom message-use-mail-followup-to 'use "*Specifies what to do with Mail-Followup-To header. If nil, always ignore the header. If it is the symbol `ask', always query the user whether to use the value. If it is the symbol `use', always use the value." :version "22.1" :group 'message-interface :link '(custom-manual "(message)Mailing Lists") :type '(choice (const :tag "ignore" nil) (const use) (const ask))) (defcustom message-subscribed-address-functions nil "*Specifies functions for determining list subscription. If nil, do not attempt to determine list subscription with functions. If non-nil, this variable contains a list of functions which return regular expressions to match lists. These functions can be used in conjunction with `message-subscribed-regexps' and `message-subscribed-addresses'." :version "22.1" :group 'message-interface :link '(custom-manual "(message)Mailing Lists") :type '(repeat sexp)) (defcustom message-subscribed-address-file nil "*A file containing addresses the user is subscribed to. If nil, do not look at any files to determine list subscriptions. If non-nil, each line of this file should be a mailing list address." :version "22.1" :group 'message-interface :link '(custom-manual "(message)Mailing Lists") :type '(radio file (const nil))) (defcustom message-subscribed-addresses nil "*Specifies a list of addresses the user is subscribed to. If nil, do not use any predefined list subscriptions. This list of addresses can be used in conjunction with `message-subscribed-address-functions' and `message-subscribed-regexps'." :version "22.1" :group 'message-interface :link '(custom-manual "(message)Mailing Lists") :type '(repeat string)) (defcustom message-subscribed-regexps nil "*Specifies a list of addresses the user is subscribed to. If nil, do not use any predefined list subscriptions. This list of regular expressions can be used in conjunction with `message-subscribed-address-functions' and `message-subscribed-addresses'." :version "22.1" :group 'message-interface :link '(custom-manual "(message)Mailing Lists") :type '(repeat regexp)) (defcustom message-allow-no-recipients 'ask "Specifies what to do when there are no recipients other than Gcc/Fcc. If it is the symbol `always', the posting is allowed. If it is the symbol `never', the posting is not allowed. If it is the symbol `ask', you are prompted." :version "22.1" :group 'message-interface :link '(custom-manual "(message)Message Headers") :type '(choice (const always) (const never) (const ask))) (defcustom message-sendmail-f-is-evil nil "*Non-nil means don't add \"-f username\" to the sendmail command line. Doing so would be even more evil than leaving it out." :group 'message-sending :link '(custom-manual "(message)Mail Variables") :type 'boolean) (defcustom message-sendmail-envelope-from nil "*Envelope-from when sending mail with sendmail. If this is nil, use `user-mail-address'. If it is the symbol `header', use the From: header of the message." :version "22.1" :type '(choice (string :tag "From name") (const :tag "Use From: header from message" header) (const :tag "Use `user-mail-address'" nil)) :link '(custom-manual "(message)Mail Variables") :group 'message-sending) (defcustom message-sendmail-extra-arguments nil "Additional arguments to `sendmail-program'." ;; E.g. '("-a" "account") for msmtp :version "23.1" ;; No Gnus :type '(repeat string) ;; :link '(custom-manual "(message)Mail Variables") :group 'message-sending) ;; qmail-related stuff (defcustom message-qmail-inject-program "/var/qmail/bin/qmail-inject" "Location of the qmail-inject program." :group 'message-sending :link '(custom-manual "(message)Mail Variables") :type 'file) (defcustom message-qmail-inject-args nil "Arguments passed to qmail-inject programs. This should be a list of strings, one string for each argument. It may also be a function. For e.g., if you wish to set the envelope sender address so that bounces go to the right place or to deal with listserv's usage of that address, you might set this variable to '(\"-f\" \"you@some.where\")." :group 'message-sending :link '(custom-manual "(message)Mail Variables") :type '(choice (function) (repeat string))) (defvar gnus-post-method) (defvar gnus-select-method) (defcustom message-post-method (cond ((and (boundp 'gnus-post-method) (listp gnus-post-method) gnus-post-method) gnus-post-method) ((boundp 'gnus-select-method) gnus-select-method) (t '(nnspool ""))) "*Method used to post news. Note that when posting from inside Gnus, for instance, this variable isn't used." :group 'message-news :group 'message-sending ;; This should be the `gnus-select-method' widget, but that might ;; create a dependence to `gnus.el'. :type 'sexp) ;; FIXME: This should be a temporary workaround until someone implements a ;; proper solution. If a crash happens while replying, the auto-save file ;; will *not* have a `References:' header if `message-generate-headers-first' ;; is nil. See: http://article.gmane.org/gmane.emacs.gnus.general/51138 (defcustom message-generate-headers-first '(references) "Which headers should be generated before starting to compose a message. If t, generate all required headers. This can also be a list of headers to generate. The variables `message-required-news-headers' and `message-required-mail-headers' specify which headers to generate. Note that the variable `message-deletable-headers' specifies headers which are to be deleted and then re-generated before sending, so this variable will not have a visible effect for those headers." :group 'message-headers :link '(custom-manual "(message)Message Headers") :type '(choice (const :tag "None" nil) (const :tag "References" '(references)) (const :tag "All" t) (repeat (sexp :tag "Header")))) (defcustom message-fill-column 72 "Column beyond which automatic line-wrapping should happen. Local value for message buffers. If non-nil, also turn on auto-fill in message buffers." :group 'message-various ;; :link '(custom-manual "(message)Message Headers") :type '(choice (const :tag "Don't turn on auto fill" nil) (integer))) (defcustom message-setup-hook nil "Normal hook, run each time a new outgoing message is initialized. The function `message-setup' runs this hook." :group 'message-various :link '(custom-manual "(message)Various Message Variables") :type 'hook) (defcustom message-cancel-hook nil "Hook run when cancelling articles." :group 'message-various :link '(custom-manual "(message)Various Message Variables") :type 'hook) (defcustom message-signature-setup-hook nil "Normal hook, run each time a new outgoing message is initialized. It is run after the headers have been inserted and before the signature is inserted." :group 'message-various :link '(custom-manual "(message)Various Message Variables") :type 'hook) (defcustom message-mode-hook nil "Hook run in message mode buffers." :group 'message-various :type 'hook) (defcustom message-header-hook nil "Hook run in a message mode buffer narrowed to the headers." :group 'message-various :type 'hook) (defcustom message-header-setup-hook nil "Hook called narrowed to the headers when setting up a message buffer." :group 'message-various :link '(custom-manual "(message)Various Message Variables") :type 'hook) (defcustom message-minibuffer-local-map (let ((map (make-sparse-keymap 'message-minibuffer-local-map))) (set-keymap-parent map minibuffer-local-map) map) "Keymap for `message-read-from-minibuffer'." :version "22.1" :group 'message-various) (defcustom message-citation-line-function 'message-insert-citation-line "*Function called to insert the \"Whomever writes:\" line. Predefined functions include `message-insert-citation-line' and `message-insert-formatted-citation-line' (see the variable `message-citation-line-format'). Note that Gnus provides a feature where the reader can click on `writes:' to hide the cited text. If you change this line too much, people who read your message will have to change their Gnus configuration. See the variable `gnus-cite-attribution-suffix'." :type '(choice (function-item :tag "plain" message-insert-citation-line) (function-item :tag "formatted" message-insert-formatted-citation-line) (function :tag "Other")) :link '(custom-manual "(message)Insertion Variables") :group 'message-insertion) (defcustom message-citation-line-format "On %a, %b %d %Y, %N wrote:\n" "Format of the \"Whomever writes:\" line. The string is formatted using `format-spec'. The following constructs are replaced: %f The full From, e.g. \"John Doe \". %n The mail address, e.g. \"john.doe@example.invalid\". %N The real name if present, e.g.: \"John Doe\", else fall back to the mail address. %F The first name if present, e.g.: \"John\". %L The last name if present, e.g.: \"Doe\". All other format specifiers are passed to `format-time-string' which is called using the date from the article your replying to. Extracting the first (%F) and last name (%L) is done heuristically, so you should always check it yourself. Please also read the note in the documentation of `message-citation-line-function'." :type '(choice (const :tag "Plain" "%f writes:") (const :tag "Include date" "On %a, %b %d %Y, %n wrote:") string) :link '(custom-manual "(message)Insertion Variables") :version "23.1" ;; No Gnus :group 'message-insertion) (defcustom message-yank-prefix "> " "*Prefix inserted on the lines of yanked messages. Fix `message-cite-prefix-regexp' if it is set to an abnormal value. See also `message-yank-cited-prefix' and `message-yank-empty-prefix'." :type 'string :link '(custom-manual "(message)Insertion Variables") :group 'message-insertion) (defcustom message-yank-cited-prefix ">" "*Prefix inserted on cited lines of yanked messages. Fix `message-cite-prefix-regexp' if it is set to an abnormal value. See also `message-yank-prefix' and `message-yank-empty-prefix'." :version "22.1" :type 'string :link '(custom-manual "(message)Insertion Variables") :group 'message-insertion) (defcustom message-yank-empty-prefix ">" "*Prefix inserted on empty lines of yanked messages. See also `message-yank-prefix' and `message-yank-cited-prefix'." :version "22.1" :type 'string :link '(custom-manual "(message)Insertion Variables") :group 'message-insertion) (defcustom message-indentation-spaces 3 "*Number of spaces to insert at the beginning of each cited line. Used by `message-yank-original' via `message-yank-cite'." :group 'message-insertion :link '(custom-manual "(message)Insertion Variables") :type 'integer) ;;;###autoload (defcustom message-cite-function 'message-cite-original-without-signature "*Function for citing an original message. Predefined functions include `message-cite-original' and `message-cite-original-without-signature'. Note that these functions use `mail-citation-hook' if that is non-nil." :type '(radio (function-item message-cite-original) (function-item message-cite-original-without-signature) (function-item sc-cite-original) (function :tag "Other")) :link '(custom-manual "(message)Insertion Variables") :version "22.3" ;; Gnus 5.10.12 (changed default) :group 'message-insertion) (defcustom message-indent-citation-function 'message-indent-citation "*Function for modifying a citation just inserted in the mail buffer. This can also be a list of functions. Each function can find the citation between (point) and (mark t). And each function should leave point and mark around the citation text as modified." :type 'function :link '(custom-manual "(message)Insertion Variables") :group 'message-insertion) (defcustom message-signature t "*String to be inserted at the end of the message buffer. If t, the `message-signature-file' file will be inserted instead. If a function, the result from the function will be used instead. If a form, the result from the form will be used instead." :type 'sexp :link '(custom-manual "(message)Insertion Variables") :group 'message-insertion) (defcustom message-signature-file "~/.signature" "*Name of file containing the text inserted at end of message buffer. Ignored if the named file doesn't exist. If nil, don't insert a signature. If a path is specified, the value of `message-signature-directory' is ignored, even if set." :type '(choice file (const :tags "None" nil)) :link '(custom-manual "(message)Insertion Variables") :group 'message-insertion) (defcustom message-signature-directory nil "*Name of directory containing signature files. Comes in handy if you have many such files, handled via posting styles for instance. If nil, `message-signature-file' is expected to specify the directory if needed." :type '(choice string (const :tags "None" nil)) :link '(custom-manual "(message)Insertion Variables") :group 'message-insertion) (defcustom message-signature-insert-empty-line t "*If non-nil, insert an empty line before the signature separator." :version "22.1" :type 'boolean :link '(custom-manual "(message)Insertion Variables") :group 'message-insertion) (defcustom message-distribution-function nil "*Function called to return a Distribution header." :group 'message-news :group 'message-headers :link '(custom-manual "(message)News Headers") :type '(choice function (const nil))) (defcustom message-expires 14 "Number of days before your article expires." :group 'message-news :group 'message-headers :link '(custom-manual "(message)News Headers") :type 'integer) (defcustom message-user-path nil "If nil, use the NNTP server name in the Path header. If stringp, use this; if non-nil, use no host name (user name only)." :group 'message-news :group 'message-headers :link '(custom-manual "(message)News Headers") :type '(choice (const :tag "nntp" nil) (string :tag "name") (sexp :tag "none" :format "%t" t))) (defvar message-reply-buffer nil) (defvar message-reply-headers nil "The headers of the current replied article. It is a vector of the following headers: \[number subject from date id references chars lines xref extra].") (defvar message-newsreader nil) (defvar message-mailer nil) (defvar message-sent-message-via nil) (defvar message-checksum nil) (defvar message-send-actions nil "A list of actions to be performed upon successful sending of a message.") (defvar message-exit-actions nil "A list of actions to be performed upon exiting after sending a message.") (defvar message-kill-actions nil "A list of actions to be performed before killing a message buffer.") (defvar message-postpone-actions nil "A list of actions to be performed after postponing a message.") (define-widget 'message-header-lines 'text "All header lines must be LFD terminated." :format "%{%t%}:%n%v" :valid-regexp "^\\'" :error "All header lines must be newline terminated") (defcustom message-default-headers "" "*A string containing header lines to be inserted in outgoing messages. It is inserted before you edit the message, so you can edit or delete these lines." :group 'message-headers :link '(custom-manual "(message)Message Headers") :type 'message-header-lines) (defcustom message-default-mail-headers "" "*A string of header lines to be inserted in outgoing mails." :group 'message-headers :group 'message-mail :link '(custom-manual "(message)Mail Headers") :type 'message-header-lines) (defcustom message-default-news-headers "" "*A string of header lines to be inserted in outgoing news articles." :group 'message-headers :group 'message-news :link '(custom-manual "(message)News Headers") :type 'message-header-lines) ;; Note: could use /usr/ucb/mail instead of sendmail; ;; options -t, and -v if not interactive. (defcustom message-mailer-swallows-blank-line (if (and (string-match "sparc-sun-sunos\\(\\'\\|[^5]\\)" system-configuration) (file-readable-p "/etc/sendmail.cf") (let ((buffer (get-buffer-create " *temp*"))) (unwind-protect (with-current-buffer buffer (insert-file-contents "/etc/sendmail.cf") (goto-char (point-min)) (let ((case-fold-search nil)) (re-search-forward "^OR\\>" nil t))) (kill-buffer buffer)))) ;; According to RFC822, "The field-name must be composed of printable ;; ASCII characters (i. e., characters that have decimal values between ;; 33 and 126, except colon)", i. e., any chars except ctl chars, ;; space, or colon. '(looking-at "[ \t]\\|[][!\"#$%&'()*+,-./0-9;<=>?@A-Z\\\\^_`a-z{|}~]+:")) "*Set this non-nil if the system's mailer runs the header and body together. \(This problem exists on Sunos 4 when sendmail is run in remote mode.) The value should be an expression to test whether the problem will actually occur." :group 'message-sending :link '(custom-manual "(message)Mail Variables") :type 'sexp) ;;;###autoload (define-mail-user-agent 'message-user-agent 'message-mail 'message-send-and-exit 'message-kill-buffer 'message-send-hook) (defvar message-mh-deletable-headers '(Message-ID Date Lines Sender) "If non-nil, delete the deletable headers before feeding to mh.") (defvar message-send-method-alist '((news message-news-p message-send-via-news) (mail message-mail-p message-send-via-mail)) "Alist of ways to send outgoing messages. Each element has the form \(TYPE PREDICATE FUNCTION) where TYPE is a symbol that names the method; PREDICATE is a function called without any parameters to determine whether the message is a message of type TYPE; and FUNCTION is a function to be called if PREDICATE returns non-nil. FUNCTION is called with one parameter -- the prefix.") (defcustom message-mail-alias-type 'abbrev "*What alias expansion type to use in Message buffers. The default is `abbrev', which uses mailabbrev. `ecomplete' uses an electric completion mode. nil switches mail aliases off. This can also be a list of values." :group 'message :link '(custom-manual "(message)Mail Aliases") :type '(choice (const :tag "Use Mailabbrev" abbrev) (const :tag "Use ecomplete" ecomplete) (const :tag "No expansion" nil))) (defcustom message-self-insert-commands '(self-insert-command) "List of `self-insert-command's used to trigger ecomplete. When one of those commands is invoked to enter a character in To or Cc header, ecomplete will suggest the candidates of recipients (see also `message-mail-alias-type'). If you use some tool to enter non-ASCII text and it replaces `self-insert-command' with the other command, e.g. `egg-self-insert-command', you may want to add it to this list." :group 'message-various :type '(repeat function)) (defcustom message-auto-save-directory (file-name-as-directory (nnheader-concat message-directory "drafts")) "*Directory where Message auto-saves buffers if Gnus isn't running. If nil, Message won't auto-save." :group 'message-buffers :link '(custom-manual "(message)Various Message Variables") :type '(choice directory (const :tag "Don't auto-save" nil))) (defcustom message-default-charset (and (not (mm-multibyte-p)) 'iso-8859-1) "Default charset used in non-MULE Emacsen. If nil, you might be asked to input the charset." :version "21.1" :group 'message :link '(custom-manual "(message)Various Message Variables") :type 'symbol) (defcustom message-dont-reply-to-names (and (boundp 'rmail-dont-reply-to-names) rmail-dont-reply-to-names) "*Addresses to prune when doing wide replies. This can be a regexp or a list of regexps. Also, a value of nil means exclude your own user name only." :version "21.1" :group 'message :link '(custom-manual "(message)Wide Reply") :type '(choice (const :tag "Yourself" nil) regexp (repeat :tag "Regexp List" regexp))) (defsubst message-dont-reply-to-names () (gmm-regexp-concat message-dont-reply-to-names)) (defvar message-shoot-gnksa-feet nil "*A list of GNKSA feet you are allowed to shoot. Gnus gives you all the opportunity you could possibly want for shooting yourself in the foot. Also, Gnus allows you to shoot the feet of Good Net-Keeping Seal of Approval. The following are foot candidates: `empty-article' Allow you to post an empty article; `quoted-text-only' Allow you to post quoted text only; `multiple-copies' Allow you to post multiple copies; `cancel-messages' Allow you to cancel or supersede messages from your other email addresses.") (defsubst message-gnksa-enable-p (feature) (or (not (listp message-shoot-gnksa-feet)) (memq feature message-shoot-gnksa-feet))) (defcustom message-hidden-headers '("^References:" "^Face:" "^X-Face:" "^X-Draft-From:") "Regexp of headers to be hidden when composing new messages. This can also be a list of regexps to match headers. Or a list starting with `not' and followed by regexps." :version "22.1" :group 'message :link '(custom-manual "(message)Message Headers") :type '(choice :format "%{%t%}: %[Value Type%] %v" (regexp :menu-tag "regexp" :format "regexp\n%t: %v") (repeat :menu-tag "(regexp ...)" :format "(regexp ...)\n%v%i" (regexp :format "%t: %v")) (cons :menu-tag "(not regexp ...)" :format "(not regexp ...)\n%v" (const not) (repeat :format "%v%i" (regexp :format "%t: %v"))))) (defcustom message-cite-articles-with-x-no-archive t "If non-nil, cite text from articles that has X-No-Archive set." :group 'message :type 'boolean) ;;; Internal variables. ;;; Well, not really internal. (defvar message-mode-syntax-table (let ((table (copy-syntax-table text-mode-syntax-table))) (modify-syntax-entry ?% ". " table) (modify-syntax-entry ?> ". " table) (modify-syntax-entry ?< ". " table) table) "Syntax table used while in Message mode.") (defface message-header-to '((((class color) (background dark)) (:foreground "DarkOliveGreen1" :bold t)) (((class color) (background light)) (:foreground "MidnightBlue" :bold t)) (t (:bold t :italic t))) "Face used for displaying From headers." :group 'message-faces) ;; backward-compatibility alias (put 'message-header-to-face 'face-alias 'message-header-to) (defface message-header-cc '((((class color) (background dark)) (:foreground "chartreuse1" :bold t)) (((class color) (background light)) (:foreground "MidnightBlue")) (t (:bold t))) "Face used for displaying Cc headers." :group 'message-faces) ;; backward-compatibility alias (put 'message-header-cc-face 'face-alias 'message-header-cc) (defface message-header-subject '((((class color) (background dark)) (:foreground "OliveDrab1")) (((class color) (background light)) (:foreground "navy blue" :bold t)) (t (:bold t))) "Face used for displaying subject headers." :group 'message-faces) ;; backward-compatibility alias (put 'message-header-subject-face 'face-alias 'message-header-subject) (defface message-header-newsgroups '((((class color) (background dark)) (:foreground "yellow" :bold t :italic t)) (((class color) (background light)) (:foreground "blue4" :bold t :italic t)) (t (:bold t :italic t))) "Face used for displaying newsgroups headers." :group 'message-faces) ;; backward-compatibility alias (put 'message-header-newsgroups-face 'face-alias 'message-header-newsgroups) (defface message-header-other '((((class color) (background dark)) (:foreground "VioletRed1")) (((class color) (background light)) (:foreground "steel blue")) (t (:bold t :italic t))) "Face used for displaying newsgroups headers." :group 'message-faces) ;; backward-compatibility alias (put 'message-header-other-face 'face-alias 'message-header-other) (defface message-header-name '((((class color) (background dark)) (:foreground "green")) (((class color) (background light)) (:foreground "cornflower blue")) (t (:bold t))) "Face used for displaying header names." :group 'message-faces) ;; backward-compatibility alias (put 'message-header-name-face 'face-alias 'message-header-name) (defface message-header-xheader '((((class color) (background dark)) (:foreground "DeepSkyBlue1")) (((class color) (background light)) (:foreground "blue")) (t (:bold t))) "Face used for displaying X-Header headers." :group 'message-faces) ;; backward-compatibility alias (put 'message-header-xheader-face 'face-alias 'message-header-xheader) (defface message-separator '((((class color) (background dark)) (:foreground "LightSkyBlue1")) (((class color) (background light)) (:foreground "brown")) (t (:bold t))) "Face used for displaying the separator." :group 'message-faces) ;; backward-compatibility alias (put 'message-separator-face 'face-alias 'message-separator) (defface message-cited-text '((((class color) (background dark)) (:foreground "LightPink1")) (((class color) (background light)) (:foreground "red")) (t (:bold t))) "Face used for displaying cited text names." :group 'message-faces) ;; backward-compatibility alias (put 'message-cited-text-face 'face-alias 'message-cited-text) (defface message-mml '((((class color) (background dark)) (:foreground "MediumSpringGreen")) (((class color) (background light)) (:foreground "ForestGreen")) (t (:bold t))) "Face used for displaying MML." :group 'message-faces) ;; backward-compatibility alias (put 'message-mml-face 'face-alias 'message-mml) (defun message-font-lock-make-header-matcher (regexp) (let ((form `(lambda (limit) (let ((start (point))) (save-restriction (widen) (goto-char (point-min)) (if (re-search-forward (concat "^" (regexp-quote mail-header-separator) "$") nil t) (setq limit (min limit (match-beginning 0)))) (goto-char start)) (and (< start limit) (re-search-forward ,regexp limit t)))))) (if (featurep 'bytecomp) (byte-compile form) form))) (defvar message-font-lock-keywords (let ((content "[ \t]*\\(.+\\(\n[ \t].*\\)*\\)\n?")) `((,(message-font-lock-make-header-matcher (concat "^\\([Tt]o:\\)" content)) (1 'message-header-name) (2 'message-header-to nil t)) (,(message-font-lock-make-header-matcher (concat "^\\(^[GBF]?[Cc][Cc]:\\|^[Rr]eply-[Tt]o:\\)" content)) (1 'message-header-name) (2 'message-header-cc nil t)) (,(message-font-lock-make-header-matcher (concat "^\\([Ss]ubject:\\)" content)) (1 'message-header-name) (2 'message-header-subject nil t)) (,(message-font-lock-make-header-matcher (concat "^\\([Nn]ewsgroups:\\|Followup-[Tt]o:\\)" content)) (1 'message-header-name) (2 'message-header-newsgroups nil t)) (,(message-font-lock-make-header-matcher (concat "^\\(X-[A-Za-z0-9-]+:\\|In-Reply-To:\\)" content)) (1 'message-header-name) (2 'message-header-xheader)) (,(message-font-lock-make-header-matcher (concat "^\\([A-Z][^: \n\t]+:\\)" content)) (1 'message-header-name) (2 'message-header-other nil t)) ,@(if (and mail-header-separator (not (equal mail-header-separator ""))) `((,(concat "^\\(" (regexp-quote mail-header-separator) "\\)$") 1 'message-separator)) nil) ((lambda (limit) (re-search-forward (concat "^\\(" message-cite-prefix-regexp "\\).*") limit t)) (0 'message-cited-text)) ("<#/?\\(multipart\\|part\\|external\\|mml\\|secure\\)[^>]*>" (0 'message-mml)))) "Additional expressions to highlight in Message mode.") ;; XEmacs does it like this. For Emacs, we have to set the ;; `font-lock-defaults' buffer-local variable. (put 'message-mode 'font-lock-defaults '(message-font-lock-keywords t)) (defvar message-face-alist '((bold . message-bold-region) (underline . underline-region) (default . (lambda (b e) (message-unbold-region b e) (ununderline-region b e)))) "Alist of mail and news faces for facemenu. The cdr of each entry is a function for applying the face to a region.") (defcustom message-send-hook nil "Hook run before sending messages. This hook is run quite early when sending." :group 'message-various :options '(ispell-message) :link '(custom-manual "(message)Various Message Variables") :type 'hook) (defcustom message-send-mail-hook nil "Hook run before sending mail messages. This hook is run very late -- just before the message is sent as mail." :group 'message-various :link '(custom-manual "(message)Various Message Variables") :type 'hook) (defcustom message-send-news-hook nil "Hook run before sending news messages. This hook is run very late -- just before the message is sent as news." :group 'message-various :link '(custom-manual "(message)Various Message Variables") :type 'hook) (defcustom message-sent-hook nil "Hook run after sending messages." :group 'message-various :type 'hook) (defvar message-send-coding-system 'binary "Coding system to encode outgoing mail.") (defvar message-draft-coding-system mm-auto-save-coding-system "*Coding system to compose mail. If you'd like to make it possible to share draft files between XEmacs and Emacs, you may use `iso-2022-7bit' for this value at your own risk. Note that the coding-system `iso-2022-7bit' isn't suitable to all data.") (defcustom message-send-mail-partially-limit 1000000 "The limitation of messages sent as message/partial. The lower bound of message size in characters, beyond which the message should be sent in several parts. If it is nil, the size is unlimited." :version "21.1" :group 'message-buffers :link '(custom-manual "(message)Mail Variables") :type '(choice (const :tag "unlimited" nil) (integer 1000000))) (defcustom message-alternative-emails nil "*Regexp matching alternative email addresses. The first address in the To, Cc or From headers of the original article matching this variable is used as the From field of outgoing messages. This variable has precedence over posting styles and anything that runs off `message-setup-hook'." :group 'message-headers :link '(custom-manual "(message)Message Headers") :type '(choice (const :tag "Always use primary" nil) regexp)) (defcustom message-hierarchical-addresses nil "A list of hierarchical mail address definitions. Inside each entry, the first address is the \"top\" address, and subsequent addresses are subaddresses; this is used to indicate that mail sent to the first address will automatically be delivered to the subaddresses. So if the first address appears in the recipient list for a message, the subaddresses will be removed (if present) before the mail is sent. All addresses in this structure should be downcased." :version "22.1" :group 'message-headers :type '(repeat (repeat string))) (defcustom message-mail-user-agent nil "Like `mail-user-agent'. Except if it is nil, use Gnus native MUA; if it is t, use `mail-user-agent'." :version "22.1" :type '(radio (const :tag "Gnus native" :format "%t\n" nil) (const :tag "`mail-user-agent'" :format "%t\n" t) (function-item :tag "Default Emacs mail" :format "%t\n" sendmail-user-agent) (function-item :tag "Emacs interface to MH" :format "%t\n" mh-e-user-agent) (function :tag "Other")) :version "21.1" :group 'message) (defcustom message-wide-reply-confirm-recipients nil "Whether to confirm a wide reply to multiple email recipients. If this variable is nil, don't ask whether to reply to all recipients. If this variable is non-nil, pose the question \"Reply to all recipients?\" before a wide reply to multiple recipients. If the user answers yes, reply to all recipients as usual. If the user answers no, only reply back to the author." :version "22.1" :group 'message-headers :link '(custom-manual "(message)Wide Reply") :type 'boolean) (defcustom message-user-fqdn nil "*Domain part of Message-Ids." :version "22.1" :group 'message-headers :link '(custom-manual "(message)News Headers") :type '(radio (const :format "%v " nil) (string :format "FQDN: %v"))) (defcustom message-use-idna (and (condition-case nil (require 'idna) (file-error)) (mm-coding-system-p 'utf-8) (executable-find idna-program) (string= (idna-to-ascii "räksmörgås") "xn--rksmrgs-5wao1o") t) "Whether to encode non-ASCII in domain names into ASCII according to IDNA. GNU Libidn, and in particular the elisp package \"idna.el\" and the external program \"idn\", must be installed for this functionality to work." :version "22.1" :group 'message-headers :link '(custom-manual "(message)IDNA") :type '(choice (const :tag "Ask" ask) (const :tag "Never" nil) (const :tag "Always" t))) (defcustom message-generate-hashcash (if (executable-find "hashcash") t) "*Whether to generate X-Hashcash: headers. If t, always generate hashcash headers. If `opportunistic', only generate hashcash headers if it can be done without the user waiting (i.e., only asynchronously). You must have the \"hashcash\" binary installed, see `hashcash-path'." :group 'message-headers :link '(custom-manual "(message)Mail Headers") :type '(choice (const :tag "Always" t) (const :tag "Never" nil) (const :tag "Opportunistic" opportunistic))) ;;; Internal variables. (defvar message-sending-message "Sending...") (defvar message-buffer-list nil) (defvar message-this-is-news nil) (defvar message-this-is-mail nil) (defvar message-draft-article nil) (defvar message-mime-part nil) (defvar message-posting-charset nil) (defvar message-inserted-headers nil) ;; Byte-compiler warning (defvar gnus-active-hashtb) (defvar gnus-read-active-file) ;;; Regexp matching the delimiter of messages in UNIX mail format ;;; (UNIX From lines), minus the initial ^. It should be a copy ;;; of rmail.el's rmail-unix-mail-delimiter. (defvar message-unix-mail-delimiter (let ((time-zone-regexp (concat "\\([A-Z]?[A-Z]?[A-Z][A-Z]\\( DST\\)?" "\\|[-+]?[0-9][0-9][0-9][0-9]" "\\|" "\\) *"))) (concat "From " ;; Many things can happen to an RFC 822 mailbox before it is put into ;; a `From' line. The leading phrase can be stripped, e.g. ;; `Joe <@w.x:joe@y.z>' -> `<@w.x:joe@y.z>'. The <> can be stripped, e.g. ;; `<@x.y:joe@y.z>' -> `@x.y:joe@y.z'. Everything starting with a CRLF ;; can be removed, e.g. ;; From: joe@y.z (Joe K ;; User) ;; can yield `From joe@y.z (Joe K Fri Mar 22 08:11:15 1996', and ;; From: Joe User ;; ;; can yield `From Joe User Fri Mar 22 08:11:15 1996'. ;; The mailbox can be removed or be replaced by white space, e.g. ;; From: "Joe User"{space}{tab} ;; ;; can yield `From {space}{tab} Fri Mar 22 08:11:15 1996', ;; where {space} and {tab} represent the Ascii space and tab characters. ;; We want to match the results of any of these manglings. ;; The following regexp rejects names whose first characters are ;; obviously bogus, but after that anything goes. "\\([^\0-\b\n-\r\^?].*\\)?" ;; The time the message was sent. "\\([^\0-\r \^?]+\\) +" ; day of the week "\\([^\0-\r \^?]+\\) +" ; month "\\([0-3]?[0-9]\\) +" ; day of month "\\([0-2][0-9]:[0-5][0-9]\\(:[0-6][0-9]\\)?\\) *" ; time of day ;; Perhaps a time zone, specified by an abbreviation, or by a ;; numeric offset. time-zone-regexp ;; The year. " \\([0-9][0-9]+\\) *" ;; On some systems the time zone can appear after the year, too. time-zone-regexp ;; Old uucp cruft. "\\(remote from .*\\)?" "\n")) "Regexp matching the delimiter of messages in UNIX mail format.") (defvar message-unsent-separator (concat "^ *---+ +Unsent message follows +---+ *$\\|" "^ *---+ +Returned message +---+ *$\\|" "^Start of returned message$\\|" "^ *---+ +Original message +---+ *$\\|" "^ *--+ +begin message +--+ *$\\|" "^ *---+ +Original message follows +---+ *$\\|" "^ *---+ +Undelivered message follows +---+ *$\\|" "^------ This is a copy of the message, including all the headers. ------ *$\\|" "^|? *---+ +Message text follows: +---+ *|?$") "A regexp that matches the separator before the text of a failed message.") (defvar message-field-fillers '((To message-fill-field-address) (Cc message-fill-field-address) (From message-fill-field-address)) "Alist of header names/filler functions.") (defvar message-header-format-alist `((From) (Newsgroups) (To) (Cc) (Subject) (In-Reply-To) (Fcc) (Bcc) (Date) (Organization) (Distribution) (Lines) (Expires) (Message-ID) (References . message-shorten-references) (User-Agent)) "Alist used for formatting headers.") (defvar message-options nil "Some saved answers when sending message.") (defvar message-send-mail-real-function nil "Internal send mail function.") (defvar message-bogus-system-names "^localhost\\.\\|\\.local$" "The regexp of bogus system names.") (defcustom message-valid-fqdn-regexp (concat "[a-z0-9][-.a-z0-9]+\\." ;; [hostname.subdomain.]domain. ;; valid TLDs: "\\([a-z][a-z]\\|" ;; two letter country TDLs "aero\\|arpa\\|bitnet\\|biz\\|bofh\\|" "cat\\|com\\|coop\\|edu\\|gov\\|" "info\\|int\\|jobs\\|" "mil\\|mobi\\|museum\\|name\\|net\\|" "org\\|pro\\|travel\\|uucp\\)") ;; http://en.wikipedia.org/wiki/List_of_Internet_top-level_domains ;; http://en.wikipedia.org/wiki/GTLD ;; `in the process of being approved': .asia .post .tel .sex ;; "dead" nato bitnet uucp "Regular expression that matches a valid FQDN." ;; see also: gnus-button-valid-fqdn-regexp :version "22.1" :group 'message-headers :type 'regexp) (eval-and-compile (autoload 'gnus-alive-p "gnus-util") (autoload 'gnus-delay-article "gnus-delay") (autoload 'gnus-extract-address-components "gnus-util") (autoload 'gnus-find-method-for-group "gnus") (autoload 'gnus-group-decoded-name "gnus-group") (autoload 'gnus-group-name-charset "gnus-group") (autoload 'gnus-group-name-decode "gnus-group") (autoload 'gnus-groups-from-server "gnus") (autoload 'gnus-make-local-hook "gnus-util") (autoload 'gnus-open-server "gnus-int") (autoload 'gnus-output-to-mail "gnus-util") (autoload 'gnus-output-to-rmail "gnus-util") (autoload 'gnus-request-post "gnus-int") (autoload 'gnus-select-frame-set-input-focus "gnus-util") (autoload 'gnus-server-string "gnus") (autoload 'idna-to-ascii "idna") (autoload 'message-setup-toolbar "messagexmas") (autoload 'mh-new-draft-name "mh-comp") (autoload 'mh-send-letter "mh-comp") (autoload 'nndraft-request-associate-buffer "nndraft") (autoload 'nndraft-request-expire-articles "nndraft") (autoload 'nnvirtual-find-group-art "nnvirtual") (autoload 'rmail-dont-reply-to "mail-utils") (autoload 'rmail-msg-is-pruned "rmail") (autoload 'rmail-msg-restore-non-pruned-header "rmail") (autoload 'rmail-output "rmailout")) ;;; ;;; Utility functions. ;;; (defmacro message-y-or-n-p (question show &rest text) "Ask QUESTION, displaying remaining args in a temporary buffer if SHOW." `(message-talkative-question 'y-or-n-p ,question ,show ,@text)) (defmacro message-delete-line (&optional n) "Delete the current line (and the next N lines)." `(delete-region (progn (beginning-of-line) (point)) (progn (forward-line ,(or n 1)) (point)))) (defun message-mark-active-p () "Non-nil means the mark and region are currently active in this buffer." mark-active) (defun message-unquote-tokens (elems) "Remove double quotes (\") from strings in list ELEMS." (mapcar (lambda (item) (while (string-match "^\\(.*\\)\"\\(.*\\)$" item) (setq item (concat (match-string 1 item) (match-string 2 item)))) item) elems)) (defun message-tokenize-header (header &optional separator) "Split HEADER into a list of header elements. SEPARATOR is a string of characters to be used as separators. \",\" is used by default." (if (not header) nil (let ((regexp (format "[%s]+" (or separator ","))) (first t) beg quoted elems paren) (with-temp-buffer (mm-enable-multibyte) (setq beg (point-min)) (insert header) (goto-char (point-min)) (while (not (eobp)) (if first (setq first nil) (forward-char 1)) (cond ((and (> (point) beg) (or (eobp) (and (looking-at regexp) (not quoted) (not paren)))) (push (buffer-substring beg (point)) elems) (setq beg (match-end 0))) ((eq (char-after) ?\") (setq quoted (not quoted))) ((and (eq (char-after) ?\() (not quoted)) (setq paren t)) ((and (eq (char-after) ?\)) (not quoted)) (setq paren nil)))) (nreverse elems))))) (defun message-mail-file-mbox-p (file) "Say whether FILE looks like a Unix mbox file." (when (and (file-exists-p file) (file-readable-p file) (file-regular-p file)) (with-temp-buffer (nnheader-insert-file-contents file) (goto-char (point-min)) (looking-at message-unix-mail-delimiter)))) (defun message-fetch-field (header &optional not-all) "The same as `mail-fetch-field', only remove all newlines. The buffer is expected to be narrowed to just the header of the message; see `message-narrow-to-headers-or-head'." (let* ((inhibit-point-motion-hooks t) (value (mail-fetch-field header nil (not not-all)))) (when value (while (string-match "\n[\t ]+" value) (setq value (replace-match " " t t value))) value))) (defun message-field-value (header &optional not-all) "The same as `message-fetch-field', only narrow to the headers first." (save-excursion (save-restriction (message-narrow-to-headers-or-head) (message-fetch-field header not-all)))) (defun message-narrow-to-field () "Narrow the buffer to the header on the current line." (beginning-of-line) (while (looking-at "[ \t]") (forward-line -1)) (narrow-to-region (point) (progn (forward-line 1) (if (re-search-forward "^[^ \n\t]" nil t) (point-at-bol) (point-max)))) (goto-char (point-min))) (defun message-add-header (&rest headers) "Add the HEADERS to the message header, skipping those already present." (while headers (let (hclean) (unless (string-match "^\\([^:]+\\):[ \t]*[^ \t]" (car headers)) (error "Invalid header `%s'" (car headers))) (setq hclean (match-string 1 (car headers))) (save-restriction (message-narrow-to-headers) (unless (re-search-forward (concat "^" (regexp-quote hclean) ":") nil t) (goto-char (point-max)) (if (string-match "\n$" (car headers)) (insert (car headers)) (insert (car headers) ?\n))))) (setq headers (cdr headers)))) (defmacro message-with-reply-buffer (&rest forms) "Evaluate FORMS in the reply buffer, if it exists." `(when (and message-reply-buffer (buffer-name message-reply-buffer)) (with-current-buffer message-reply-buffer ,@forms))) (put 'message-with-reply-buffer 'lisp-indent-function 0) (put 'message-with-reply-buffer 'edebug-form-spec '(body)) (defun message-fetch-reply-field (header) "Fetch field HEADER from the message we're replying to." (message-with-reply-buffer (save-restriction (mail-narrow-to-head) (message-fetch-field header)))) (defun message-strip-list-identifiers (subject) "Remove list identifiers in `gnus-list-identifiers' from string SUBJECT." (require 'gnus-sum) ; for gnus-list-identifiers (let ((regexp (if (stringp gnus-list-identifiers) gnus-list-identifiers (mapconcat 'identity gnus-list-identifiers " *\\|")))) (if (string-match (concat "\\(\\(\\(Re: +\\)?\\(" regexp " *\\)\\)+\\(Re: +\\)?\\)") subject) (concat (substring subject 0 (match-beginning 1)) (or (match-string 3 subject) (match-string 5 subject)) (substring subject (match-end 1))) subject))) (defun message-strip-subject-re (subject) "Remove \"Re:\" from subject lines in string SUBJECT." (if (string-match message-subject-re-regexp subject) (substring subject (match-end 0)) subject)) (defcustom message-replacement-char "." "Replacement character used instead of unprintable or not decodable chars." :group 'message-various :version "22.1" ;; Gnus 5.10.9 :type '(choice string (const ".") (const "?"))) ;; FIXME: We also should call `message-strip-subject-encoded-words' ;; when forwarding. Probably in `message-make-forward-subject' and ;; `message-forward-make-body'. (defun message-strip-subject-encoded-words (subject) "Fix non-decodable words in SUBJECT." ;; Cf. `gnus-simplify-subject-fully'. (let* ((case-fold-search t) (replacement-chars (format "[%s%s%s]" message-replacement-char message-replacement-char message-replacement-char)) (enc-word-re "=\\?\\([^?]+\\)\\?\\([QB]\\)\\?\\([^?]+\\)\\(\\?=\\)") cs-string (have-marker (with-temp-buffer (insert subject) (goto-char (point-min)) (when (re-search-forward enc-word-re nil t) (setq cs-string (match-string 1))))) cs-coding q-or-b word-beg word-end) (if (or (not have-marker) ;; No encoded word found... ;; ... or double encoding was correct: (and (stringp cs-string) (setq cs-string (downcase cs-string)) (mm-coding-system-p (intern cs-string)) (not (prog1 (y-or-n-p (format "\ Decoded Subject \"%s\" contains a valid encoded word. Decode again? " subject)) (setq cs-coding (intern cs-string)))))) subject (with-temp-buffer (insert subject) (goto-char (point-min)) (while (re-search-forward enc-word-re nil t) (setq cs-string (downcase (match-string 1)) q-or-b (match-string 2) word-beg (match-beginning 0) word-end (match-end 0)) (setq cs-coding (if (mm-coding-system-p (intern cs-string)) (setq cs-coding (intern cs-string)) nil)) ;; No double encoded subject? => bogus charset. (unless cs-coding (setq cs-coding (mm-read-coding-system (format "\ Decoded Subject \"%s\" contains an encoded word. The charset `%s' is unknown or invalid. Hit RET to replace non-decodable characters with \"%s\" or enter replacement charset: " subject cs-string message-replacement-char))) (if cs-coding (replace-match (concat "=?" (symbol-name cs-coding) "?\\2?\\3\\4\\5")) (save-excursion (goto-char word-beg) (re-search-forward "=\\?\\([^?]+\\)\\?\\([QB]\\)\\?" word-end t) (replace-match "") ;; QP or base64 (if (string-match "\\`Q\\'" q-or-b) ;; QP (progn (message "Replacing non-decodable characters with \"%s\"." message-replacement-char) (while (re-search-forward "\\(=[A-F0-9][A-F0-9]\\)+" word-end t) (replace-match message-replacement-char))) ;; base64 (message "Replacing non-decodable characters with \"%s\"." replacement-chars) (re-search-forward "[^?]+" word-end t) (replace-match replacement-chars)) (re-search-forward "\\?=") (replace-match ""))))) (rfc2047-decode-region (point-min) (point-max)) (buffer-string))))) ;;; Start of functions adopted from `message-utils.el'. (defun message-strip-subject-trailing-was (subject) "Remove trailing \"(was: )\" from SUBJECT lines. Leading \"Re: \" is not stripped by this function. Use the function `message-strip-subject-re' for this." (let* ((query message-subject-trailing-was-query) (new) (found)) (setq found (string-match (if (eq query 'ask) message-subject-trailing-was-ask-regexp message-subject-trailing-was-regexp) subject)) (if found (setq new (substring subject 0 (match-beginning 0)))) (if (or (not found) (eq query nil)) subject (if (eq query 'ask) (if (message-y-or-n-p "Strip `(was: )' in subject? " t (concat "Strip `(was: )' in subject " "and use the new one instead?\n\n" "Current subject is: \"" subject "\"\n\n" "New subject would be: \"" new "\"\n\n" "See the variable `message-subject-trailing-was-query' " "to get rid of this query." )) new subject) new)))) ;;; Suggested by Jonas Steverud @ www.dtek.chalmers.se/~d4jonas/ (defun message-change-subject (new-subject) "Ask for NEW-SUBJECT header, append (was: )." ;; (interactive (list (read-from-minibuffer "New subject: "))) (cond ((and (not (or (null new-subject) ; new subject not empty (zerop (string-width new-subject)) (string-match "^[ \t]*$" new-subject)))) (save-excursion (let ((old-subject (save-restriction (message-narrow-to-headers) (message-fetch-field "Subject")))) (cond ((not old-subject) (error "No current subject")) ((not (string-match (concat "^[ \t]*" (regexp-quote new-subject) " \t]*$") old-subject)) ; yes, it really is a new subject ;; delete eventual Re: prefix (setq old-subject (message-strip-subject-re old-subject)) (message-goto-subject) (message-delete-line) (insert (concat "Subject: " new-subject " (was: " old-subject ")\n"))))))))) (defun message-mark-inserted-region (beg end &optional verbatim) "Mark some region in the current article with enclosing tags. See `message-mark-insert-begin' and `message-mark-insert-end'. If VERBATIM, use slrn style verbatim marks (\"#v+\" and \"#v-\")." (interactive "r\nP") (save-excursion ;; add to the end of the region first, otherwise end would be invalid (goto-char end) (insert (if verbatim "#v-\n" message-mark-insert-end)) (goto-char beg) (insert (if verbatim "#v+\n" message-mark-insert-begin)))) (defun message-mark-insert-file (file &optional verbatim) "Insert FILE at point, marking it with enclosing tags. See `message-mark-insert-begin' and `message-mark-insert-end'. If VERBATIM, use slrn style verbatim marks (\"#v+\" and \"#v-\")." (interactive "fFile to insert: \nP") ;; reverse insertion to get correct result. (let ((p (point))) (insert (if verbatim "#v-\n" message-mark-insert-end)) (goto-char p) (insert-file-contents file) (goto-char p) (insert (if verbatim "#v+\n" message-mark-insert-begin)))) (defun message-add-archive-header () "Insert \"X-No-Archive: Yes\" in the header and a note in the body. The note can be customized using `message-archive-note'. When called with a prefix argument, ask for a text to insert. If you don't want the note in the body, set `message-archive-note' to nil." (interactive) (if current-prefix-arg (setq message-archive-note (read-from-minibuffer "Reason for No-Archive: " (cons message-archive-note 0)))) (save-excursion (if (message-goto-signature) (re-search-backward message-signature-separator)) (when message-archive-note (insert message-archive-note) (newline)) (message-add-header message-archive-header) (message-sort-headers))) (defun message-cross-post-followup-to-header (target-group) "Mangles FollowUp-To and Newsgroups header to point to TARGET-GROUP. With prefix-argument just set Follow-Up, don't cross-post." (interactive (list ; Completion based on Gnus (completing-read "Followup To: " (if (boundp 'gnus-newsrc-alist) gnus-newsrc-alist) nil nil '("poster" . 0) (if (boundp 'gnus-group-history) 'gnus-group-history)))) (message-remove-header "Follow[Uu]p-[Tt]o" t) (message-goto-newsgroups) (beginning-of-line) ;; if we already did a crosspost before, kill old target (if (and message-cross-post-old-target (re-search-forward (regexp-quote (concat "," message-cross-post-old-target)) nil t)) (replace-match "")) ;; unless (followup is to poster or user explicitly asked not ;; to cross-post, or target-group is already in Newsgroups) ;; add target-group to Newsgroups line. (cond ((and (or ;; def: cross-post, req:no (and message-cross-post-default (not current-prefix-arg)) ;; def: no-cross-post, req:yes (and (not message-cross-post-default) current-prefix-arg)) (not (string-match "poster" target-group)) (not (string-match (regexp-quote target-group) (message-fetch-field "Newsgroups")))) (end-of-line) (insert (concat "," target-group)))) (end-of-line) ; ensure Followup: comes after Newsgroups: ;; unless new followup would be identical to Newsgroups line ;; make a new Followup-To line (if (not (string-match (concat "^[ \t]*" target-group "[ \t]*$") (message-fetch-field "Newsgroups"))) (insert (concat "\nFollowup-To: " target-group))) (setq message-cross-post-old-target target-group)) (defun message-cross-post-insert-note (target-group cross-post in-old old-groups) "Insert a in message body note about a set Followup or Crosspost. If there have been previous notes, delete them. TARGET-GROUP specifies the group to Followup-To. When CROSS-POST is t, insert note about crossposting. IN-OLD specifies whether TARGET-GROUP is a member of OLD-GROUPS. OLD-GROUPS lists the old-groups the posting would have been made to before the user asked for a Crosspost." ;; start scanning body for previous uses (message-goto-signature) (let ((head (re-search-backward (concat "^" mail-header-separator) nil t))) ; just search in body (message-goto-signature) (while (re-search-backward (concat "^" (regexp-quote message-cross-post-note) ".*") head t) (message-delete-line)) (message-goto-signature) (while (re-search-backward (concat "^" (regexp-quote message-followup-to-note) ".*") head t) (message-delete-line)) ;; insert new note (if (message-goto-signature) (re-search-backward message-signature-separator)) (if (or in-old (not cross-post) (string-match "^[ \t]*poster[ \t]*$" target-group)) (insert (concat message-followup-to-note target-group "\n")) (insert (concat message-cross-post-note target-group "\n"))))) (defun message-cross-post-followup-to (target-group) "Crossposts message and set Followup-To to TARGET-GROUP. With prefix-argument just set Follow-Up, don't cross-post." (interactive (list ; Completion based on Gnus (completing-read "Followup To: " (if (boundp 'gnus-newsrc-alist) gnus-newsrc-alist) nil nil '("poster" . 0) (if (boundp 'gnus-group-history) 'gnus-group-history)))) (cond ((not (or (null target-group) ; new subject not empty (zerop (string-width target-group)) (string-match "^[ \t]*$" target-group))) (save-excursion (let* ((old-groups (message-fetch-field "Newsgroups")) (in-old (string-match (regexp-quote target-group) (or old-groups "")))) ;; check whether target exactly matches old Newsgroups (cond ((not old-groups) (error "No current newsgroup")) ((or (not in-old) (not (string-match (concat "^[ \t]*" (regexp-quote target-group) "[ \t]*$") old-groups))) ;; yes, Newsgroups line must change (message-cross-post-followup-to-header target-group) ;; insert note whether we do cross-post or followup-to (funcall message-cross-post-note-function target-group (if (or (and message-cross-post-default (not current-prefix-arg)) (and (not message-cross-post-default) current-prefix-arg)) t) in-old old-groups)))))))) ;;; Reduce To: to Cc: or Bcc: header (defun message-reduce-to-to-cc () "Replace contents of To: header with contents of Cc: or Bcc: header." (interactive) (let ((cc-content (save-restriction (message-narrow-to-headers) (message-fetch-field "cc"))) (bcc nil)) (if (and (not cc-content) (setq cc-content (save-restriction (message-narrow-to-headers) (message-fetch-field "bcc")))) (setq bcc t)) (cond (cc-content (save-excursion (message-goto-to) (message-delete-line) (insert (concat "To: " cc-content "\n")) (save-restriction (message-narrow-to-headers) (message-remove-header (if bcc "bcc" "cc")))))))) ;;; End of functions adopted from `message-utils.el'. (defun message-remove-header (header &optional is-regexp first reverse) "Remove HEADER in the narrowed buffer. If IS-REGEXP, HEADER is a regular expression. If FIRST, only remove the first instance of the header. Return the number of headers removed." (goto-char (point-min)) (let ((regexp (if is-regexp header (concat "^" (regexp-quote header) ":"))) (number 0) (case-fold-search t) last) (while (and (not (eobp)) (not last)) (if (if reverse (not (looking-at regexp)) (looking-at regexp)) (progn (incf number) (when first (setq last t)) (delete-region (point) ;; There might be a continuation header, so we have to search ;; until we find a new non-continuation line. (progn (forward-line 1) (if (re-search-forward "^[^ \t]" nil t) (goto-char (match-beginning 0)) (point-max))))) (forward-line 1) (if (re-search-forward "^[^ \t]" nil t) (goto-char (match-beginning 0)) (goto-char (point-max))))) number)) (defun message-remove-first-header (header) "Remove the first instance of HEADER if there is more than one." (let ((count 0) (regexp (concat "^" (regexp-quote header) ":"))) (save-excursion (goto-char (point-min)) (while (re-search-forward regexp nil t) (incf count))) (while (> count 1) (message-remove-header header nil t) (decf count)))) (defun message-narrow-to-headers () "Narrow the buffer to the head of the message." (widen) (narrow-to-region (goto-char (point-min)) (if (re-search-forward (concat "^" (regexp-quote mail-header-separator) "\n") nil t) (match-beginning 0) (point-max))) (goto-char (point-min))) (defun message-narrow-to-head-1 () "Like `message-narrow-to-head'. Don't widen." (narrow-to-region (goto-char (point-min)) (if (search-forward "\n\n" nil 1) (1- (point)) (point-max))) (goto-char (point-min))) (defun message-narrow-to-head () "Narrow the buffer to the head of the message. Point is left at the beginning of the narrowed-to region." (widen) (message-narrow-to-head-1)) (defun message-narrow-to-headers-or-head () "Narrow the buffer to the head of the message." (widen) (narrow-to-region (goto-char (point-min)) (if (re-search-forward (concat "\\(\n\\)\n\\|^\\(" (regexp-quote mail-header-separator) "\n\\)") nil t) (or (match-end 1) (match-beginning 2)) (point-max))) (goto-char (point-min))) (defun message-news-p () "Say whether the current buffer contains a news message." (and (not message-this-is-mail) (or message-this-is-news (save-excursion (save-restriction (message-narrow-to-headers) (and (message-fetch-field "newsgroups") (not (message-fetch-field "posted-to")))))))) (defun message-mail-p () "Say whether the current buffer contains a mail message." (and (not message-this-is-news) (or message-this-is-mail (save-excursion (save-restriction (message-narrow-to-headers) (or (message-fetch-field "to") (message-fetch-field "cc") (message-fetch-field "bcc"))))))) (defun message-subscribed-p () "Say whether we need to insert a MFT header." (or message-subscribed-regexps message-subscribed-addresses message-subscribed-address-file message-subscribed-address-functions)) (defun message-next-header () "Go to the beginning of the next header." (beginning-of-line) (or (eobp) (forward-char 1)) (not (if (re-search-forward "^[^ \t]" nil t) (beginning-of-line) (goto-char (point-max))))) (defun message-sort-headers-1 () "Sort the buffer as headers using `message-rank' text props." (goto-char (point-min)) (require 'sort) (sort-subr nil 'message-next-header (lambda () (message-next-header) (unless (bobp) (forward-char -1))) (lambda () (or (get-text-property (point) 'message-rank) 10000)))) (defun message-sort-headers () "Sort the headers of the current message according to `message-header-format-alist'." (interactive) (save-excursion (save-restriction (let ((max (1+ (length message-header-format-alist))) rank) (message-narrow-to-headers) (while (re-search-forward "^[^ \n]+:" nil t) (put-text-property (match-beginning 0) (1+ (match-beginning 0)) 'message-rank (if (setq rank (length (memq (assq (intern (buffer-substring (match-beginning 0) (1- (match-end 0)))) message-header-format-alist) message-header-format-alist))) (- max rank) (1+ max))))) (message-sort-headers-1)))) (defun message-kill-address () "Kill the address under point." (interactive) (let ((start (point))) (message-skip-to-next-address) (kill-region start (point)))) (autoload 'Info-goto-node "info") (defvar mml2015-use) (defun message-info (&optional arg) "Display the Message manual. Prefixed with one \\[universal-argument], display the Emacs MIME manual. With two \\[universal-argument]'s, display the EasyPG or PGG manual, depending on the value of `mml2015-use'." (interactive "p") ;; Why not `info', which is in loaddefs.el? (Info-goto-node (format "(%s)Top" (cond ((eq arg 16) (require 'mml2015) mml2015-use) ((eq arg 4) 'emacs-mime) ;; `booleanp' only available in Emacs 22+ ((and (not (memq arg '(nil t))) (symbolp arg)) arg) (t 'message))))) ;;; ;;; Message mode ;;; ;;; Set up keymap. (defvar message-mode-map nil) (unless message-mode-map (setq message-mode-map (make-keymap)) (set-keymap-parent message-mode-map text-mode-map) (define-key message-mode-map "\C-c?" 'describe-mode) (define-key message-mode-map "\C-c\C-f\C-t" 'message-goto-to) (define-key message-mode-map "\C-c\C-f\C-o" 'message-goto-from) (define-key message-mode-map "\C-c\C-f\C-b" 'message-goto-bcc) (define-key message-mode-map "\C-c\C-f\C-w" 'message-goto-fcc) (define-key message-mode-map "\C-c\C-f\C-c" 'message-goto-cc) (define-key message-mode-map "\C-c\C-f\C-s" 'message-goto-subject) (define-key message-mode-map "\C-c\C-f\C-r" 'message-goto-reply-to) (define-key message-mode-map "\C-c\C-f\C-n" 'message-goto-newsgroups) (define-key message-mode-map "\C-c\C-f\C-d" 'message-goto-distribution) (define-key message-mode-map "\C-c\C-f\C-f" 'message-goto-followup-to) (define-key message-mode-map "\C-c\C-f\C-m" 'message-goto-mail-followup-to) (define-key message-mode-map "\C-c\C-f\C-k" 'message-goto-keywords) (define-key message-mode-map "\C-c\C-f\C-u" 'message-goto-summary) (define-key message-mode-map "\C-c\C-f\C-i" 'message-insert-or-toggle-importance) (define-key message-mode-map "\C-c\C-f\C-a" 'message-generate-unsubscribed-mail-followup-to) ;; modify headers (and insert notes in body) (define-key message-mode-map "\C-c\C-fs" 'message-change-subject) ;; (define-key message-mode-map "\C-c\C-fx" 'message-cross-post-followup-to) ;; prefix+message-cross-post-followup-to = same w/o cross-post (define-key message-mode-map "\C-c\C-ft" 'message-reduce-to-to-cc) (define-key message-mode-map "\C-c\C-fa" 'message-add-archive-header) ;; mark inserted text (define-key message-mode-map "\C-c\M-m" 'message-mark-inserted-region) (define-key message-mode-map "\C-c\M-f" 'message-mark-insert-file) (define-key message-mode-map "\C-c\C-b" 'message-goto-body) (define-key message-mode-map "\C-c\C-i" 'message-goto-signature) (define-key message-mode-map "\C-c\C-t" 'message-insert-to) (define-key message-mode-map "\C-c\C-fw" 'message-insert-wide-reply) (define-key message-mode-map "\C-c\C-n" 'message-insert-newsgroups) (define-key message-mode-map "\C-c\C-l" 'message-to-list-only) (define-key message-mode-map "\C-c\C-f\C-e" 'message-insert-expires) (define-key message-mode-map "\C-c\C-u" 'message-insert-or-toggle-importance) (define-key message-mode-map "\C-c\M-n" 'message-insert-disposition-notification-to) (define-key message-mode-map "\C-c\C-y" 'message-yank-original) (define-key message-mode-map "\C-c\M-\C-y" 'message-yank-buffer) (define-key message-mode-map "\C-c\C-q" 'message-fill-yanked-message) (define-key message-mode-map "\C-c\C-w" 'message-insert-signature) (define-key message-mode-map "\C-c\M-h" 'message-insert-headers) (define-key message-mode-map "\C-c\C-r" 'message-caesar-buffer-body) (define-key message-mode-map "\C-c\C-o" 'message-sort-headers) (define-key message-mode-map "\C-c\M-r" 'message-rename-buffer) (define-key message-mode-map "\C-c\C-c" 'message-send-and-exit) (define-key message-mode-map "\C-c\C-s" 'message-send) (define-key message-mode-map "\C-c\C-k" 'message-kill-buffer) (define-key message-mode-map "\C-c\C-d" 'message-dont-send) (define-key message-mode-map "\C-c\n" 'gnus-delay-article) (define-key message-mode-map "\C-c\M-k" 'message-kill-address) (define-key message-mode-map "\C-c\C-e" 'message-elide-region) (define-key message-mode-map "\C-c\C-v" 'message-delete-not-region) (define-key message-mode-map "\C-c\C-z" 'message-kill-to-signature) (define-key message-mode-map "\M-\r" 'message-newline-and-reformat) (define-key message-mode-map [remap split-line] 'message-split-line) (define-key message-mode-map "\C-c\C-a" 'mml-attach-file) (define-key message-mode-map "\C-a" 'message-beginning-of-line) (define-key message-mode-map "\t" 'message-tab) (define-key message-mode-map "\M-;" 'comment-region) (define-key message-mode-map "\M-n" 'message-display-abbrev)) (easy-menu-define message-mode-menu message-mode-map "Message Menu." `("Message" ["Yank Original" message-yank-original message-reply-buffer] ["Fill Yanked Message" message-fill-yanked-message t] ["Insert Signature" message-insert-signature t] ["Caesar (rot13) Message" message-caesar-buffer-body t] ["Caesar (rot13) Region" message-caesar-region (message-mark-active-p)] ["Elide Region" message-elide-region :active (message-mark-active-p) ,@(if (featurep 'xemacs) nil '(:help "Replace text in region with an ellipsis"))] ["Delete Outside Region" message-delete-not-region :active (message-mark-active-p) ,@(if (featurep 'xemacs) nil '(:help "Delete all quoted text outside region"))] ["Kill To Signature" message-kill-to-signature t] ["Newline and Reformat" message-newline-and-reformat t] ["Rename buffer" message-rename-buffer t] ["Spellcheck" ispell-message ,@(if (featurep 'xemacs) '(t) '(:help "Spellcheck this message"))] "----" ["Insert Region Marked" message-mark-inserted-region :active (message-mark-active-p) ,@(if (featurep 'xemacs) nil '(:help "Mark region with enclosing tags"))] ["Insert File Marked..." message-mark-insert-file ,@(if (featurep 'xemacs) '(t) '(:help "Insert file at point marked with enclosing tags"))] "----" ["Send Message" message-send-and-exit ,@(if (featurep 'xemacs) '(t) '(:help "Send this message"))] ["Postpone Message" message-dont-send ,@(if (featurep 'xemacs) '(t) '(:help "File this draft message and exit"))] ["Send at Specific Time..." gnus-delay-article ,@(if (featurep 'xemacs) '(t) '(:help "Ask, then arrange to send message at that time"))] ["Kill Message" message-kill-buffer ,@(if (featurep 'xemacs) '(t) '(:help "Delete this message without sending"))] "----" ["Message manual" message-info ,@(if (featurep 'xemacs) '(t) '(:help "Display the Message manual"))])) (easy-menu-define message-mode-field-menu message-mode-map "" `("Field" ["To" message-goto-to t] ["From" message-goto-from t] ["Subject" message-goto-subject t] ["Change subject..." message-change-subject t] ["Cc" message-goto-cc t] ["Bcc" message-goto-bcc t] ["Fcc" message-goto-fcc t] ["Reply-To" message-goto-reply-to t] ["Flag As Important" message-insert-importance-high ,@(if (featurep 'xemacs) '(t) '(:help "Mark this message as important"))] ["Flag As Unimportant" message-insert-importance-low ,@(if (featurep 'xemacs) '(t) '(:help "Mark this message as unimportant"))] ["Request Receipt" message-insert-disposition-notification-to ,@(if (featurep 'xemacs) '(t) '(:help "Request a receipt notification"))] "----" ;; (typical) news stuff ["Summary" message-goto-summary t] ["Keywords" message-goto-keywords t] ["Newsgroups" message-goto-newsgroups t] ["Fetch Newsgroups" message-insert-newsgroups t] ["Followup-To" message-goto-followup-to t] ;; ["Followup-To (with note in body)" message-cross-post-followup-to t] ["Crosspost / Followup-To..." message-cross-post-followup-to t] ["Distribution" message-goto-distribution t] ["Expires" message-insert-expires t ] ["X-No-Archive" message-add-archive-header t ] "----" ;; (typical) mailing-lists stuff ["Fetch To" message-insert-to ,@(if (featurep 'xemacs) '(t) '(:help "Insert a To header that points to the author."))] ["Fetch To and Cc" message-insert-wide-reply ,@(if (featurep 'xemacs) '(t) '(:help "Insert To and Cc headers as if you were doing a wide reply."))] "----" ["Send to list only" message-to-list-only t] ["Mail-Followup-To" message-goto-mail-followup-to t] ["Unsubscribed list post" message-generate-unsubscribed-mail-followup-to ,@(if (featurep 'xemacs) '(t) '(:help "Insert a reasonable `Mail-Followup-To:' header."))] ["Reduce To: to Cc:" message-reduce-to-to-cc t] "----" ["Sort Headers" message-sort-headers t] ["Encode non-ASCII domain names" message-idna-to-ascii-rhs t] ;; We hide `message-hidden-headers' by narrowing the buffer. ["Show Hidden Headers" widen t] ["Goto Body" message-goto-body t] ["Goto Signature" message-goto-signature t])) (defvar message-tool-bar-map nil) (defvar facemenu-add-face-function) (defvar facemenu-remove-face-function) ;;; Forbidden properties ;; ;; We use `after-change-functions' to keep special text properties ;; that interfer with the normal function of message mode out of the ;; buffer. (defcustom message-strip-special-text-properties t "Strip special properties from the message buffer. Emacs has a number of special text properties which can break message composing in various ways. If this option is set, message will strip these properties from the message composition buffer. However, some packages requires these properties to be present in order to work. If you use one of these packages, turn this option off, and hope the message composition doesn't break too bad." :version "22.1" :group 'message-various :link '(custom-manual "(message)Various Message Variables") :type 'boolean) (defconst message-forbidden-properties ;; No reason this should be clutter up customize. We make it a ;; property list (rather than a list of property symbols), to be ;; directly useful for `remove-text-properties'. '(field nil read-only nil invisible nil intangible nil mouse-face nil modification-hooks nil insert-in-front-hooks nil insert-behind-hooks nil point-entered nil point-left nil) ;; Other special properties: ;; category, face, display: probably doesn't do any harm. ;; fontified: is used by font-lock. ;; syntax-table, local-map: I dunno. ;; We need to add XEmacs names to the list. "Property list of with properties forbidden in message buffers. The values of the properties are ignored, only the property names are used.") (defun message-tamago-not-in-use-p (pos) "Return t when tamago version 4 is not in use at the cursor position. Tamago version 4 is a popular input method for writing Japanese text. It uses the properties `intangible', `invisible', `modification-hooks' and `read-only' when translating ascii or kana text to kanji text. These properties are essential to work, so we should never strip them." (not (and (boundp 'egg-modefull-mode) (symbol-value 'egg-modefull-mode) (or (memq (get-text-property pos 'intangible) '(its-part-1 its-part-2)) (get-text-property pos 'egg-end) (get-text-property pos 'egg-lang) (get-text-property pos 'egg-start))))) (defsubst message-mail-alias-type-p (type) (if (atom message-mail-alias-type) (eq message-mail-alias-type type) (memq type message-mail-alias-type))) (defun message-strip-forbidden-properties (begin end &optional old-length) "Strip forbidden properties between BEGIN and END, ignoring the third arg. This function is intended to be called from `after-change-functions'. See also `message-forbidden-properties'." (when (and (message-mail-alias-type-p 'ecomplete) (memq this-command message-self-insert-commands)) (message-display-abbrev)) (when (and message-strip-special-text-properties (message-tamago-not-in-use-p begin)) (let ((buffer-read-only nil) (inhibit-read-only t)) (remove-text-properties begin end message-forbidden-properties)))) ;;;###autoload (define-derived-mode message-mode text-mode "Message" "Major mode for editing mail and news to be sent. Like Text Mode but with these additional commands:\\ C-c C-s `message-send' (send the message) C-c C-c `message-send-and-exit' C-c C-d Postpone sending the message C-c C-k Kill the message C-c C-f move to a header field (and create it if there isn't): C-c C-f C-t move to To C-c C-f C-s move to Subject C-c C-f C-c move to Cc C-c C-f C-b move to Bcc C-c C-f C-w move to Fcc C-c C-f C-r move to Reply-To C-c C-f C-u move to Summary C-c C-f C-n move to Newsgroups C-c C-f C-k move to Keywords C-c C-f C-d move to Distribution C-c C-f C-o move to From (\"Originator\") C-c C-f C-f move to Followup-To C-c C-f C-m move to Mail-Followup-To C-c C-f C-e move to Expires C-c C-f C-i cycle through Importance values C-c C-f s change subject and append \"(was: )\" C-c C-f x crossposting with FollowUp-To header and note in body C-c C-f t replace To: header with contents of Cc: or Bcc: C-c C-f a Insert X-No-Archive: header and a note in the body C-c C-t `message-insert-to' (add a To header to a news followup) C-c C-l `message-to-list-only' (removes all but list address in to/cc) C-c C-n `message-insert-newsgroups' (add a Newsgroup header to a news reply) C-c C-b `message-goto-body' (move to beginning of message text). C-c C-i `message-goto-signature' (move to the beginning of the signature). C-c C-w `message-insert-signature' (insert `message-signature-file' file). C-c C-y `message-yank-original' (insert current message, if any). C-c C-q `message-fill-yanked-message' (fill what was yanked). C-c C-e `message-elide-region' (elide the text between point and mark). C-c C-v `message-delete-not-region' (remove the text outside the region). C-c C-z `message-kill-to-signature' (kill the text up to the signature). C-c C-r `message-caesar-buffer-body' (rot13 the message body). C-c C-a `mml-attach-file' (attach a file as MIME). C-c C-u `message-insert-or-toggle-importance' (insert or cycle importance). C-c M-n `message-insert-disposition-notification-to' (request receipt). C-c M-m `message-mark-inserted-region' (mark region with enclosing tags). C-c M-f `message-mark-insert-file' (insert file marked with enclosing tags). M-RET `message-newline-and-reformat' (break the line and reformat)." (setq local-abbrev-table text-mode-abbrev-table) (set (make-local-variable 'message-reply-buffer) nil) (set (make-local-variable 'message-inserted-headers) nil) (set (make-local-variable 'message-send-actions) nil) (set (make-local-variable 'message-exit-actions) nil) (set (make-local-variable 'message-kill-actions) nil) (set (make-local-variable 'message-postpone-actions) nil) (set (make-local-variable 'message-draft-article) nil) (setq buffer-offer-save t) (set (make-local-variable 'facemenu-add-face-function) (lambda (face end) (let ((face-fun (cdr (assq face message-face-alist)))) (if face-fun (funcall face-fun (point) end) (error "Face %s not configured for %s mode" face mode-name))) "")) (set (make-local-variable 'facemenu-remove-face-function) t) (set (make-local-variable 'message-reply-headers) nil) (make-local-variable 'message-newsreader) (make-local-variable 'message-mailer) (make-local-variable 'message-post-method) (set (make-local-variable 'message-sent-message-via) nil) (set (make-local-variable 'message-checksum) nil) (set (make-local-variable 'message-mime-part) 0) (message-setup-fill-variables) (when message-fill-column (setq fill-column message-fill-column) (turn-on-auto-fill)) ;; Allow using comment commands to add/remove quoting. ;; (set (make-local-variable 'comment-start) message-yank-prefix) (when message-yank-prefix (set (make-local-variable 'comment-start) message-yank-prefix) (set (make-local-variable 'comment-start-skip) (concat "^" (regexp-quote message-yank-prefix) "[ \t]*"))) (if (featurep 'xemacs) (message-setup-toolbar) (set (make-local-variable 'font-lock-defaults) '(message-font-lock-keywords t)) (if (boundp 'tool-bar-map) (set (make-local-variable 'tool-bar-map) (message-make-tool-bar)))) (easy-menu-add message-mode-menu message-mode-map) (easy-menu-add message-mode-field-menu message-mode-map) (gnus-make-local-hook 'after-change-functions) ;; Mmmm... Forbidden properties... (add-hook 'after-change-functions 'message-strip-forbidden-properties nil 'local) ;; Allow mail alias things. (cond ((message-mail-alias-type-p 'abbrev) (if (fboundp 'mail-abbrevs-setup) (mail-abbrevs-setup) (if (fboundp 'mail-aliases-setup) ; warning avoidance (mail-aliases-setup)))) ((message-mail-alias-type-p 'ecomplete) (ecomplete-setup))) (unless buffer-file-name (message-set-auto-save-file-name)) (unless (buffer-base-buffer) ;; Don't enable multibyte on an indirect buffer. Maybe enabling ;; multibyte is not necessary at all. -- zsh (mm-enable-multibyte)) (set (make-local-variable 'indent-tabs-mode) nil) ;No tabs for indentation. (mml-mode)) (defun message-setup-fill-variables () "Setup message fill variables." (set (make-local-variable 'fill-paragraph-function) 'message-fill-paragraph) (make-local-variable 'paragraph-separate) (make-local-variable 'paragraph-start) (make-local-variable 'adaptive-fill-regexp) (unless (boundp 'adaptive-fill-first-line-regexp) (setq adaptive-fill-first-line-regexp nil)) (make-local-variable 'adaptive-fill-first-line-regexp) (let ((quote-prefix-regexp ;; User should change message-cite-prefix-regexp if ;; message-yank-prefix is set to an abnormal value. (concat "\\(" message-cite-prefix-regexp "\\)[ \t]*"))) (setq paragraph-start (concat (regexp-quote mail-header-separator) "$\\|" "[ \t]*$\\|" ; blank lines "-- $\\|" ; signature delimiter "---+$\\|" ; delimiters for forwarded messages page-delimiter "$\\|" ; spoiler warnings ".*wrote:$\\|" ; attribution lines quote-prefix-regexp "$\\|" ; empty lines in quoted text ; mml tags "<#!*/?\\(multipart\\|part\\|external\\|mml\\|secure\\)")) (setq paragraph-separate paragraph-start) (setq adaptive-fill-regexp (concat quote-prefix-regexp "\\|" adaptive-fill-regexp)) (setq adaptive-fill-first-line-regexp (concat quote-prefix-regexp "\\|" adaptive-fill-first-line-regexp))) (make-local-variable 'auto-fill-inhibit-regexp) ;;(setq auto-fill-inhibit-regexp "^[A-Z][^: \n\t]+:") (setq auto-fill-inhibit-regexp nil) (make-local-variable 'normal-auto-fill-function) (setq normal-auto-fill-function 'message-do-auto-fill) ;; KLUDGE: auto fill might already be turned on in `text-mode-hook'. ;; In that case, ensure that it uses the right function. The real ;; solution would be not to use `define-derived-mode', and run ;; `text-mode-hook' ourself at the end of the mode. ;; -- Per Abrahamsen Date: 2001-10-19. ;; This kludge is unneeded in Emacs>=21 since define-derived-mode is ;; now careful to run parent hooks after the body. --Stef (when auto-fill-function (setq auto-fill-function normal-auto-fill-function))) ;;; ;;; Message mode commands ;;; ;;; Movement commands (defun message-goto-to () "Move point to the To header." (interactive) (message-position-on-field "To")) (defun message-goto-from () "Move point to the From header." (interactive) (message-position-on-field "From")) (defun message-goto-subject () "Move point to the Subject header." (interactive) (message-position-on-field "Subject")) (defun message-goto-cc () "Move point to the Cc header." (interactive) (message-position-on-field "Cc" "To")) (defun message-goto-bcc () "Move point to the Bcc header." (interactive) (message-position-on-field "Bcc" "Cc" "To")) (defun message-goto-fcc () "Move point to the Fcc header." (interactive) (message-position-on-field "Fcc" "To" "Newsgroups")) (defun message-goto-reply-to () "Move point to the Reply-To header." (interactive) (message-position-on-field "Reply-To" "Subject")) (defun message-goto-newsgroups () "Move point to the Newsgroups header." (interactive) (message-position-on-field "Newsgroups")) (defun message-goto-distribution () "Move point to the Distribution header." (interactive) (message-position-on-field "Distribution")) (defun message-goto-followup-to () "Move point to the Followup-To header." (interactive) (message-position-on-field "Followup-To" "Newsgroups")) (defun message-goto-mail-followup-to () "Move point to the Mail-Followup-To header." (interactive) (message-position-on-field "Mail-Followup-To" "To")) (defun message-goto-keywords () "Move point to the Keywords header." (interactive) (message-position-on-field "Keywords" "Subject")) (defun message-goto-summary () "Move point to the Summary header." (interactive) (message-position-on-field "Summary" "Subject")) (defun message-goto-body (&optional interactivep) "Move point to the beginning of the message body." (interactive (list t)) (when (and interactivep (looking-at "[ \t]*\n")) (expand-abbrev)) (goto-char (point-min)) (or (search-forward (concat "\n" mail-header-separator "\n") nil t) (search-forward-regexp "[^:]+:\\([^\n]\\|\n[ \t]\\)+\n\n" nil t))) (defun message-in-body-p () "Return t if point is in the message body." (let ((body (save-excursion (message-goto-body) (point)))) (>= (point) body))) (defun message-goto-eoh () "Move point to the end of the headers." (interactive) (message-goto-body) (forward-line -1)) (defun message-goto-signature () "Move point to the beginning of the message signature. If there is no signature in the article, go to the end and return nil." (interactive) (goto-char (point-min)) (if (re-search-forward message-signature-separator nil t) (forward-line 1) (goto-char (point-max)) nil)) (defun message-generate-unsubscribed-mail-followup-to (&optional include-cc) "Insert a reasonable MFT header in a post to an unsubscribed list. When making original posts to a mailing list you are not subscribed to, you have to type in a MFT header by hand. The contents, usually, are the addresses of the list and your own address. This function inserts such a header automatically. It fetches the contents of the To: header in the current mail buffer, and appends the current `user-mail-address'. If the optional argument INCLUDE-CC is non-nil, the addresses in the Cc: header are also put into the MFT." (interactive "P") (let* (cc tos) (save-restriction (message-narrow-to-headers) (message-remove-header "Mail-Followup-To") (setq cc (and include-cc (message-fetch-field "Cc"))) (setq tos (if cc (concat (message-fetch-field "To") "," cc) (message-fetch-field "To")))) (message-goto-mail-followup-to) (insert (concat tos ", " user-mail-address)))) (defun message-insert-to (&optional force) "Insert a To header that points to the author of the article being replied to. If the original author requested not to be sent mail, don't insert unless the prefix FORCE is given." (interactive "P") (let* ((mct (message-fetch-reply-field "mail-copies-to")) (dont (and mct (or (equal (downcase mct) "never") (equal (downcase mct) "nobody")))) (to (or (message-fetch-reply-field "mail-reply-to") (message-fetch-reply-field "reply-to") (message-fetch-reply-field "from")))) (when (and dont to) (message (if force "Ignoring the user request not to have copies sent via mail" "Complying with the user request not to have copies sent via mail"))) (when (and force (not to)) (error "No mail address in the article")) (when (and to (or force (not dont))) (message-carefully-insert-headers (list (cons 'To to)))))) (defun message-insert-wide-reply () "Insert To and Cc headers as if you were doing a wide reply." (interactive) (let ((headers (message-with-reply-buffer (message-get-reply-headers t)))) (message-carefully-insert-headers headers))) (defcustom message-header-synonyms '((To Cc Bcc) (Original-To)) "List of lists of header synonyms. E.g., if this list contains a member list with elements `Cc' and `To', then `message-carefully-insert-headers' will not insert a `To' header when the message is already `Cc'ed to the recipient." :version "22.1" :group 'message-headers :link '(custom-manual "(message)Message Headers") :type '(repeat sexp)) (defun message-carefully-insert-headers (headers) "Insert the HEADERS, an alist, into the message buffer. Does not insert the headers when they are already present there or in the synonym headers, defined by `message-header-synonyms'." ;; FIXME: Should compare only the address and not the full name. Comparison ;; should be done case-folded (and with `string=' rather than ;; `string-match'). ;; (mail-strip-quoted-names "Foo Bar , bla@fasel (Bla Fasel)") (dolist (header headers) (let* ((header-name (symbol-name (car header))) (new-header (cdr header)) (synonyms (loop for synonym in message-header-synonyms when (memq (car header) synonym) return synonym)) (old-header (loop for synonym in synonyms for old-header = (mail-fetch-field (symbol-name synonym)) when (and old-header (string-match new-header old-header)) return synonym))) (if old-header (message "already have `%s' in `%s'" new-header old-header) (when (and (message-position-on-field header-name) (setq old-header (mail-fetch-field header-name)) (not (string-match "\\` *\\'" old-header))) (insert ", ")) (insert new-header))))) (defun message-widen-reply () "Widen the reply to include maximum recipients." (interactive) (let ((follow-to (and message-reply-buffer (buffer-name message-reply-buffer) (with-current-buffer message-reply-buffer (message-get-reply-headers t))))) (save-excursion (save-restriction (message-narrow-to-headers) (dolist (elem follow-to) (message-remove-header (symbol-name (car elem))) (goto-char (point-min)) (insert (symbol-name (car elem)) ": " (cdr elem) "\n")))))) (defun message-insert-newsgroups () "Insert the Newsgroups header from the article being replied to." (interactive) (when (and (message-position-on-field "Newsgroups") (mail-fetch-field "newsgroups") (not (string-match "\\` *\\'" (mail-fetch-field "newsgroups")))) (insert ",")) (insert (or (message-fetch-reply-field "newsgroups") ""))) ;;; Various commands (defun message-delete-not-region (beg end) "Delete everything in the body of the current message outside of the region." (interactive "r") (let (citeprefix) (save-excursion (goto-char beg) ;; snarf citation prefix, if appropriate (unless (eq (point) (progn (beginning-of-line) (point))) (when (looking-at message-cite-prefix-regexp) (setq citeprefix (match-string 0)))) (goto-char end) (delete-region (point) (if (not (message-goto-signature)) (point) (forward-line -2) (point))) (insert "\n") (goto-char beg) (delete-region beg (progn (message-goto-body) (forward-line 2) (point))) (when citeprefix (insert citeprefix)))) (when (message-goto-signature) (forward-line -2))) (defun message-kill-to-signature (&optional arg) "Kill all text up to the signature. If a numberic argument or prefix arg is given, leave that number of lines before the signature intact." (interactive "P") (save-excursion (save-restriction (let ((point (point))) (narrow-to-region point (point-max)) (message-goto-signature) (unless (eobp) (if (and arg (numberp arg)) (forward-line (- -1 arg)) (end-of-line -1))) (unless (= point (point)) (kill-region point (point)) (unless (bolp) (insert "\n"))))))) (defun message-newline-and-reformat (&optional arg not-break) "Insert four newlines, and then reformat if inside quoted text. Prefix arg means justify as well." (interactive (list (if current-prefix-arg 'full))) (let (quoted point beg end leading-space bolp fill-paragraph-function) (setq point (point)) (beginning-of-line) (setq beg (point)) (setq bolp (= beg point)) ;; Find first line of the paragraph. (if not-break (while (and (not (eobp)) (not (looking-at message-cite-prefix-regexp)) (looking-at paragraph-start)) (forward-line 1))) ;; Find the prefix (when (looking-at message-cite-prefix-regexp) (setq quoted (match-string 0)) (goto-char (match-end 0)) (looking-at "[ \t]*") (setq leading-space (match-string 0))) (if (and quoted (not not-break) (not bolp) (< (- point beg) (length quoted))) ;; break inside the cite prefix. (setq quoted nil end nil)) (if quoted (progn (forward-line 1) (while (and (not (eobp)) (not (looking-at paragraph-separate)) (looking-at message-cite-prefix-regexp) (equal quoted (match-string 0))) (goto-char (match-end 0)) (looking-at "[ \t]*") (if (> (length leading-space) (length (match-string 0))) (setq leading-space (match-string 0))) (forward-line 1)) (setq end (point)) (goto-char beg) (while (and (if (bobp) nil (forward-line -1) t) (not (looking-at paragraph-start)) (looking-at message-cite-prefix-regexp) (equal quoted (match-string 0))) (setq beg (point)) (goto-char (match-end 0)) (looking-at "[ \t]*") (if (> (length leading-space) (length (match-string 0))) (setq leading-space (match-string 0))))) (while (and (not (eobp)) (not (looking-at paragraph-separate)) (not (looking-at message-cite-prefix-regexp))) (forward-line 1)) (setq end (point)) (goto-char beg) (while (and (if (bobp) nil (forward-line -1) t) (not (looking-at paragraph-start)) (not (looking-at message-cite-prefix-regexp))) (setq beg (point)))) (goto-char point) (save-restriction (narrow-to-region beg end) (if not-break (setq point nil) (if bolp (newline) (newline) (newline)) (setq point (point)) ;; (newline 2) doesn't mark both newline's as hard, so call ;; newline twice. -jas (newline) (newline) (delete-region (point) (re-search-forward "[ \t]*")) (when (and quoted (not bolp)) (insert quoted leading-space))) (undo-boundary) (if quoted (let* ((adaptive-fill-regexp (regexp-quote (concat quoted leading-space))) (adaptive-fill-first-line-regexp adaptive-fill-regexp )) (fill-paragraph arg)) (fill-paragraph arg)) (if point (goto-char point))))) (defun message-fill-paragraph (&optional arg) "Message specific function to fill a paragraph. This function is used as the value of `fill-paragraph-function' in Message buffers and is not meant to be called directly." (interactive (list (if current-prefix-arg 'full))) (if (if (boundp 'filladapt-mode) filladapt-mode) nil (if (message-point-in-header-p) (message-fill-field) (message-newline-and-reformat arg t)) t)) (defun message-point-in-header-p () "Return t if point is in the header." (save-excursion (not (re-search-backward (concat "^" (regexp-quote mail-header-separator) "\n") nil t)))) (defun message-do-auto-fill () "Like `do-auto-fill', but don't fill in message header." (unless (message-point-in-header-p) (do-auto-fill))) (defun message-insert-signature (&optional force) "Insert a signature. See documentation for variable `message-signature'." (interactive (list 0)) (let* ((signature (cond ((and (null message-signature) (eq force 0)) (save-excursion (goto-char (point-max)) (not (re-search-backward message-signature-separator nil t)))) ((and (null message-signature) force) t) ((functionp message-signature) (funcall message-signature)) ((listp message-signature) (eval message-signature)) (t message-signature))) signature-file) (setq signature (cond ((stringp signature) signature) ((and (eq t signature) message-signature-file) (setq signature-file (if (and message-signature-directory ;; don't actually use the signature directory ;; if message-signature-file contains a path. (not (file-name-directory message-signature-file))) (nnheader-concat message-signature-directory message-signature-file) message-signature-file)) (file-exists-p signature-file)))) (when signature (goto-char (point-max)) ;; Insert the signature. (unless (bolp) (insert "\n")) (when message-signature-insert-empty-line (insert "\n")) (insert "-- \n") (if (eq signature t) (insert-file-contents signature-file) (insert signature)) (goto-char (point-max)) (or (bolp) (insert "\n"))))) (defun message-insert-importance-high () "Insert header to mark message as important." (interactive) (save-excursion (save-restriction (message-narrow-to-headers) (message-remove-header "Importance")) (message-goto-eoh) (insert "Importance: high\n"))) (defun message-insert-importance-low () "Insert header to mark message as unimportant." (interactive) (save-excursion (save-restriction (message-narrow-to-headers) (message-remove-header "Importance")) (message-goto-eoh) (insert "Importance: low\n"))) (defun message-insert-or-toggle-importance () "Insert a \"Importance: high\" header, or cycle through the header values. The three allowed values according to RFC 1327 are `high', `normal' and `low'." (interactive) (save-excursion (let ((new "high") cur) (save-restriction (message-narrow-to-headers) (when (setq cur (message-fetch-field "Importance")) (message-remove-header "Importance") (setq new (cond ((string= cur "high") "low") ((string= cur "low") "normal") (t "high"))))) (message-goto-eoh) (insert (format "Importance: %s\n" new))))) (defun message-insert-disposition-notification-to () "Request a disposition notification (return receipt) to this message. Note that this should not be used in newsgroups." (interactive) (save-excursion (save-restriction (message-narrow-to-headers) (message-remove-header "Disposition-Notification-To")) (message-goto-eoh) (insert (format "Disposition-Notification-To: %s\n" (or (message-field-value "Reply-to") (message-field-value "From") (message-make-from)))))) (defun message-elide-region (b e) "Elide the text in the region. An ellipsis (from `message-elide-ellipsis') will be inserted where the text was killed." (interactive "r") (kill-region b e) (insert message-elide-ellipsis)) (defvar message-caesar-translation-table nil) (defun message-caesar-region (b e &optional n) "Caesar rotate region B to E by N, default 13, for decrypting netnews." (interactive (list (min (point) (or (mark t) (point))) (max (point) (or (mark t) (point))) (when current-prefix-arg (prefix-numeric-value current-prefix-arg)))) (setq n (if (numberp n) (mod n 26) 13)) ;canonize N (unless (or (zerop n) ; no action needed for a rot of 0 (= b e)) ; no region to rotate ;; We build the table, if necessary. (when (or (not message-caesar-translation-table) (/= (aref message-caesar-translation-table ?a) (+ ?a n))) (setq message-caesar-translation-table (message-make-caesar-translation-table n))) (translate-region b e message-caesar-translation-table))) (defun message-make-caesar-translation-table (n) "Create a rot table with offset N." (let ((i -1) (table (make-string 256 0))) (while (< (incf i) 256) (aset table i i)) (concat (substring table 0 ?A) (substring table (+ ?A n) (+ ?A n (- 26 n))) (substring table ?A (+ ?A n)) (substring table (+ ?A 26) ?a) (substring table (+ ?a n) (+ ?a n (- 26 n))) (substring table ?a (+ ?a n)) (substring table (+ ?a 26) 255)))) (defun message-caesar-buffer-body (&optional rotnum wide) "Caesar rotate all letters in the current buffer by 13 places. Used to encode/decode possibly offensive messages (commonly in rec.humor). With prefix arg, specifies the number of places to rotate each letter forward. Mail and USENET news headers are not rotated unless WIDE is non-nil." (interactive (if current-prefix-arg (list (prefix-numeric-value current-prefix-arg)) (list nil))) (save-excursion (save-restriction (when (and (not wide) (message-goto-body)) (narrow-to-region (point) (point-max))) (message-caesar-region (point-min) (point-max) rotnum)))) (defun message-pipe-buffer-body (program) "Pipe the message body in the current buffer through PROGRAM." (save-excursion (save-restriction (when (message-goto-body) (narrow-to-region (point) (point-max))) (shell-command-on-region (point-min) (point-max) program nil t)))) (defun message-rename-buffer (&optional enter-string) "Rename the *message* buffer to \"*message* RECIPIENT\". If the function is run with a prefix, it will ask for a new buffer name, rather than giving an automatic name." (interactive "Pbuffer name: ") (save-excursion (save-restriction (goto-char (point-min)) (narrow-to-region (point) (search-forward mail-header-separator nil 'end)) (let* ((mail-to (or (if (message-news-p) (message-fetch-field "Newsgroups") (message-fetch-field "To")) "")) (mail-trimmed-to (if (string-match "," mail-to) (concat (substring mail-to 0 (match-beginning 0)) ", ...") mail-to)) (name-default (concat "*message* " mail-trimmed-to)) (name (if enter-string (read-string "New buffer name: " name-default) name-default))) (rename-buffer name t))))) (defun message-fill-yanked-message (&optional justifyp) "Fill the paragraphs of a message yanked into this one. Numeric argument means justify as well." (interactive "P") (save-excursion (goto-char (point-min)) (search-forward (concat "\n" mail-header-separator "\n") nil t) (let ((fill-prefix message-yank-prefix)) (fill-individual-paragraphs (point) (point-max) justifyp)))) (defun message-indent-citation (&optional start end yank-only) "Modify text just inserted from a message to be cited. The inserted text should be the region. When this function returns, the region is again around the modified text. Normally, indent each nonblank line `message-indentation-spaces' spaces. However, if `message-yank-prefix' is non-nil, insert that prefix on each line." (unless start (setq start (point))) (unless yank-only ;; Remove unwanted headers. (when message-ignored-cited-headers (let (all-removed) (save-restriction (narrow-to-region (goto-char start) (if (search-forward "\n\n" nil t) (1- (point)) (point))) (message-remove-header message-ignored-cited-headers t) (when (= (point-min) (point-max)) (setq all-removed t)) (goto-char (point-max))) (if all-removed (goto-char start) (forward-line 1)))) ;; Delete blank lines at the start of the buffer. (while (and (point-min) (eolp) (not (eobp))) (message-delete-line)) ;; Delete blank lines at the end of the buffer. (goto-char (point-max)) (unless (eolp) (insert "\n")) (while (and (zerop (forward-line -1)) (looking-at "$")) (message-delete-line))) ;; Do the indentation. (if (null message-yank-prefix) (indent-rigidly start (or end (mark t)) message-indentation-spaces) (save-excursion (goto-char start) (while (< (point) (or end (mark t))) (cond ((looking-at ">") (insert message-yank-cited-prefix)) ((looking-at "^$") (insert message-yank-empty-prefix)) (t (insert message-yank-prefix))) (forward-line 1)))) (goto-char start)) (defun message-remove-blank-cited-lines (&optional remove) "Remove cited lines containing only blanks. If REMOVE is non-nil, remove newlines, too. To use this automatically, you may add this function to `gnus-message-setup-hook'." (interactive "P") (let ((citexp (concat "^\\(" (when (boundp 'message-yank-cited-prefix) (concat message-yank-cited-prefix "\\|")) message-yank-prefix "\\)+ *\n" ))) (gnus-message 8 "removing `%s'" citexp) (save-excursion (message-goto-body) (while (re-search-forward citexp nil t) (replace-match (if remove "" "\n")))))) (defvar message-cite-reply-above nil "If non-nil, start own text above the quote. Note: Top posting is bad netiquette. Don't use it unless you really must. You probably want to set variable only for specific groups, e.g. using `gnus-posting-styles': (eval (set (make-local-variable 'message-cite-reply-above) t)) This variable has no effect in news postings.") (defun message-yank-original (&optional arg) "Insert the message being replied to, if any. Puts point before the text and mark after. Normally indents each nonblank line ARG spaces (default 3). However, if `message-yank-prefix' is non-nil, insert that prefix on each line. This function uses `message-cite-function' to do the actual citing. Just \\[universal-argument] as argument means don't indent, insert no prefix, and don't delete any headers." (interactive "P") (let ((modified (buffer-modified-p)) body-text) (when (and message-reply-buffer message-cite-function) (when message-cite-reply-above (if (and (not (message-news-p)) (or (eq message-cite-reply-above 'is-evil) (y-or-n-p "\ Top posting is bad netiquette. Please don't top post unless you really must. Really top post? "))) (save-excursion (setq body-text (buffer-substring (message-goto-body) (point-max))) (delete-region (message-goto-body) (point-max))) (set (make-local-variable 'message-cite-reply-above) nil))) (delete-windows-on message-reply-buffer t) (push-mark (save-excursion (insert-buffer-substring message-reply-buffer) (unless (bolp) (insert ?\n)) (point))) (unless arg (funcall message-cite-function) (unless (eq (char-before (mark t)) ?\n) (let ((pt (point))) (goto-char (mark t)) (insert-before-markers ?\n) (goto-char pt)))) (when message-cite-reply-above (message-goto-body) (insert body-text) (insert (if (bolp) "\n" "\n\n")) (message-goto-body)) ;; Add a `message-setup-very-last-hook' here? ;; Add `gnus-article-highlight-citation' here? (unless modified (setq message-checksum (message-checksum)))))) (defun message-yank-buffer (buffer) "Insert BUFFER into the current buffer and quote it." (interactive "bYank buffer: ") (let ((message-reply-buffer (get-buffer buffer))) (save-window-excursion (message-yank-original)))) (defun message-buffers () "Return a list of active message buffers." (let (buffers) (save-current-buffer (dolist (buffer (buffer-list t)) (set-buffer buffer) (when (and (eq major-mode 'message-mode) (null message-sent-message-via)) (push (buffer-name buffer) buffers)))) (nreverse buffers))) (defun message-cite-original-1 (strip-signature) "Cite an original message. If STRIP-SIGNATURE is non-nil, strips off the signature from the original message. This function uses `mail-citation-hook' if that is non-nil." (if (and (boundp 'mail-citation-hook) mail-citation-hook) (run-hooks 'mail-citation-hook) (let* ((start (point)) (end (mark t)) (x-no-archive nil) (functions (when message-indent-citation-function (if (listp message-indent-citation-function) message-indent-citation-function (list message-indent-citation-function)))) ;; This function may be called by `gnus-summary-yank-message' and ;; may insert a different article from the original. So, we will ;; modify the value of `message-reply-headers' with that article. (message-reply-headers (save-restriction (narrow-to-region start end) (message-narrow-to-head-1) (setq x-no-archive (message-fetch-field "x-no-archive")) (vector 0 (or (message-fetch-field "subject") "none") (or (message-fetch-field "from") "nobody") (message-fetch-field "date") (message-fetch-field "message-id" t) (message-fetch-field "references") 0 0 "")))) (mml-quote-region start end) (when strip-signature ;; Allow undoing. (undo-boundary) (goto-char end) (when (re-search-backward message-signature-separator start t) ;; Also peel off any blank lines before the signature. (forward-line -1) (while (looking-at "^[ \t]*$") (forward-line -1)) (forward-line 1) (delete-region (point) end) (unless (search-backward "\n\n" start t) ;; Insert a blank line if it is peeled off. (insert "\n")))) (goto-char start) (mapc 'funcall functions) (when message-citation-line-function (unless (bolp) (insert "\n")) (funcall message-citation-line-function)) (when (and x-no-archive (not message-cite-articles-with-x-no-archive) (string-match "yes" x-no-archive)) (undo-boundary) (delete-region (point) (mark t)) (insert "> [Quoted text removed due to X-No-Archive]\n") (push-mark) (forward-line -1))))) (defun message-cite-original () "Cite function in the standard Message manner." (message-cite-original-1 nil)) (defvar gnus-extract-address-components) (autoload 'format-spec "format-spec") (defun message-insert-formatted-citation-line (&optional from date) "Function that inserts a formatted citation line. See `message-citation-line-format'." ;; The optional args are for testing/debugging. They will disappear later. ;; Example: ;; (with-temp-buffer ;; (message-insert-formatted-citation-line ;; "John Doe " ;; (current-time)) ;; (buffer-string)) (when (or message-reply-headers (and from date)) (unless from (setq from (mail-header-from message-reply-headers))) (let* ((data (condition-case () (funcall (if (boundp gnus-extract-address-components) gnus-extract-address-components 'mail-extract-address-components) from) (error nil))) (name (car data)) (fname name) (lname name) (net (car (cdr data))) (name-or-net (or (car data) (car (cdr data)) from)) (replydate (or date ;; We need Gnus functionality if the user wants date or time from ;; the original article: (when (string-match "%[^fnNFL]" message-citation-line-format) (autoload 'gnus-date-get-time "gnus-util") (gnus-date-get-time (mail-header-date message-reply-headers))))) (flist (let ((i ?A) lst) (when (stringp name) ;; Guess first name and last name: (cond ((string-match "\\`\\(\\w\\|[-.]\\)+ \\(\\w\\|[-.]\\)+\\'" name) (setq fname (nth 0 (split-string name "[ \t]+")) lname (nth 1 (split-string name "[ \t]+")))) ((string-match "\\`\\(\\w\\|[-.]\\)+, \\(\\w\\|[-.]\\)+\\'" name) (setq fname (nth 1 (split-string name "[ \t,]+")) lname (nth 0 (split-string name "[ \t,]+")))) ((string-match "\\`\\(\\w\\|[-.]\\)+\\'" name) (setq fname name lname "")))) ;; The following letters are not used in `format-time-string': (push ?E lst) (push "" lst) (push ?F lst) (push fname lst) ;; We might want to use "" instead of "" later. (push ?J lst) (push "" lst) (push ?K lst) (push "" lst) (push ?L lst) (push lname lst) (push ?N lst) (push name-or-net lst) (push ?O lst) (push "" lst) (push ?P lst) (push "

    " lst) (push ?Q lst) (push "" lst) (push ?f lst) (push from lst) (push ?i lst) (push "" lst) (push ?n lst) (push net lst) (push ?o lst) (push "" lst) (push ?q lst) (push "" lst) (push ?t lst) (push "" lst) (push ?v lst) (push "" lst) ;; Delegate the rest to `format-time-string': (while (<= i ?z) (when (and (not (memq i lst)) ;; Skip (Z,a) (or (<= i ?Z) (>= i ?a))) (push i lst) (push (condition-case nil (progn (format-time-string (format "%%%c" i) replydate)) (format ">%c<" i)) lst)) (setq i (1+ i))) (reverse lst))) (spec (apply 'format-spec-make flist))) (insert (format-spec message-citation-line-format spec))) (newline))) (defun message-cite-original-without-signature () "Cite function in the standard Message manner. This function strips off the signature from the original message." (message-cite-original-1 t)) (defun message-insert-citation-line () "Insert a simple citation line." (when message-reply-headers (insert (mail-header-from message-reply-headers) " writes:") (newline) (newline))) (defun message-position-on-field (header &rest afters) (let ((case-fold-search t)) (save-restriction (narrow-to-region (goto-char (point-min)) (progn (re-search-forward (concat "^" (regexp-quote mail-header-separator) "$")) (match-beginning 0))) (goto-char (point-min)) (if (re-search-forward (concat "^" (regexp-quote header) ":") nil t) (progn (re-search-forward "^[^ \t]" nil 'move) (beginning-of-line) (skip-chars-backward "\n") t) (while (and afters (not (re-search-forward (concat "^" (regexp-quote (car afters)) ":") nil t))) (pop afters)) (when afters (re-search-forward "^[^ \t]" nil 'move) (beginning-of-line)) (insert header ": \n") (forward-char -1) nil)))) (defun message-remove-signature () "Remove the signature from the text between point and mark. The text will also be indented the normal way." (save-excursion (let ((start (point)) mark) (if (not (re-search-forward message-signature-separator (mark t) t)) ;; No signature here, so we just indent the cited text. (message-indent-citation) ;; Find the last non-empty line. (forward-line -1) (while (looking-at "[ \t]*$") (forward-line -1)) (forward-line 1) (setq mark (set-marker (make-marker) (point))) (goto-char start) (message-indent-citation) ;; Enable undoing the deletion. (undo-boundary) (delete-region mark (mark t)) (set-marker mark nil))))) ;;; ;;; Sending messages ;;; (defun message-send-and-exit (&optional arg) "Send message like `message-send', then, if no errors, exit from mail buffer." (interactive "P") (let ((buf (current-buffer)) (actions message-exit-actions)) (when (and (message-send arg) (buffer-name buf)) (if message-kill-buffer-on-exit (kill-buffer buf) (bury-buffer buf) (when (eq buf (current-buffer)) (message-bury buf))) (message-do-actions actions) t))) (defun message-dont-send () "Don't send the message you have been editing. Instead, just auto-save the buffer and then bury it." (interactive) (set-buffer-modified-p t) (save-buffer) (let ((actions message-postpone-actions)) (message-bury (current-buffer)) (message-do-actions actions))) (defun message-kill-buffer () "Kill the current buffer." (interactive) (when (or (not (buffer-modified-p)) (not message-kill-buffer-query) (yes-or-no-p "Message modified; kill anyway? ")) (let ((actions message-kill-actions) (draft-article message-draft-article) (auto-save-file-name buffer-auto-save-file-name) (file-name buffer-file-name) (modified (buffer-modified-p))) (setq buffer-file-name nil) (kill-buffer (current-buffer)) (when (and (or (and auto-save-file-name (file-exists-p auto-save-file-name)) (and file-name (file-exists-p file-name))) (progn ;; If the message buffer has lived in a dedicated window, ;; `kill-buffer' has killed the frame. Thus the ;; `yes-or-no-p' may show up in a lowered frame. Make sure ;; that the user can see the question by raising the ;; current frame: (raise-frame) (yes-or-no-p (format "Remove the backup file%s? " (if modified " too" ""))))) (ignore-errors (delete-file auto-save-file-name)) (let ((message-draft-article draft-article)) (message-disassociate-draft))) (message-do-actions actions)))) (defun message-bury (buffer) "Bury this mail BUFFER." (let ((newbuf (other-buffer buffer))) (bury-buffer buffer) (if (and (window-dedicated-p (selected-window)) (not (null (delq (selected-frame) (visible-frame-list))))) (delete-frame (selected-frame)) (switch-to-buffer newbuf)))) (defun message-send (&optional arg) "Send the message in the current buffer. If `message-interactive' is non-nil, wait for success indication or error messages, and inform user. Otherwise any failure is reported in a message back to the user from the mailer. The usage of ARG is defined by the instance that called Message. It should typically alter the sending method in some way or other." (interactive "P") ;; Make it possible to undo the coming changes. (undo-boundary) (let ((inhibit-read-only t)) (put-text-property (point-min) (point-max) 'read-only nil)) (message-fix-before-sending) (run-hooks 'message-send-hook) (message message-sending-message) (let ((alist message-send-method-alist) (success t) elem sent dont-barf-on-no-method (message-options message-options)) (message-options-set-recipient) (while (and success (setq elem (pop alist))) (when (funcall (cadr elem)) (when (and (or (not (memq (car elem) message-sent-message-via)) (message-fetch-field "supersedes") (if (or (message-gnksa-enable-p 'multiple-copies) (not (eq (car elem) 'news))) (y-or-n-p (format "Already sent message via %s; resend? " (car elem))) (error "Denied posting -- multiple copies"))) (setq success (funcall (caddr elem) arg))) (setq sent t)))) (unless (or sent (not success) (let ((fcc (message-fetch-field "Fcc")) (gcc (message-fetch-field "Gcc"))) (when (or fcc gcc) (or (eq message-allow-no-recipients 'always) (and (not (eq message-allow-no-recipients 'never)) (setq dont-barf-on-no-method (gnus-y-or-n-p (format "No receiver, perform %s anyway? " (cond ((and fcc gcc) "Fcc and Gcc") (fcc "Fcc") (t "Gcc")))))))))) (error "No methods specified to send by")) (when (or dont-barf-on-no-method (and success sent)) (message-do-fcc) (save-excursion (run-hooks 'message-sent-hook)) (message "Sending...done") ;; Do ecomplete address snarfing. (when (message-mail-alias-type-p 'ecomplete) (message-put-addresses-in-ecomplete)) ;; Mark the buffer as unmodified and delete auto-save. (set-buffer-modified-p nil) (delete-auto-save-file-if-necessary t) (message-disassociate-draft) ;; Delete other mail buffers and stuff. (message-do-send-housekeeping) (message-do-actions message-send-actions) ;; Return success. t))) (defun message-send-via-mail (arg) "Send the current message via mail." (message-send-mail arg)) (defun message-send-via-news (arg) "Send the current message via news." (funcall message-send-news-function arg)) (defmacro message-check (type &rest forms) "Eval FORMS if TYPE is to be checked." `(or (message-check-element ,type) (save-excursion ,@forms))) (put 'message-check 'lisp-indent-function 1) (put 'message-check 'edebug-form-spec '(form body)) (defun message-text-with-property (prop &optional start end reverse) "Return a list of start and end positions where the text has PROP. START and END bound the search, they default to `point-min' and `point-max' respectively. If REVERSE is non-nil, find text which does not have PROP." (unless start (setq start (point-min))) (unless end (setq end (point-max))) (let (next regions) (if reverse (while (and start (setq start (text-property-any start end prop nil))) (setq next (next-single-property-change start prop nil end)) (push (cons start (or next end)) regions) (setq start next)) (while (and start (or (get-text-property start prop) (and (setq start (next-single-property-change start prop nil end)) (get-text-property start prop)))) (setq next (text-property-any start end prop nil)) (push (cons start (or next end)) regions) (setq start next))) (nreverse regions))) (defcustom message-bogus-address-regexp nil ;; "noreply\\|nospam\\|invalid" "Regexp of potentially bogus mail addresses." :version "23.1" ;; No Gnus :group 'message-headers :type 'regexp) (defun message-fix-before-sending () "Do various things to make the message nice before sending it." ;; Make sure there's a newline at the end of the message. (goto-char (point-max)) (unless (bolp) (insert "\n")) ;; Make the hidden headers visible. (widen) ;; Sort headers before sending the message. (message-sort-headers) ;; Make invisible text visible. ;; It doesn't seem as if this is useful, since the invisible property ;; is clobbered by an after-change hook anyhow. (message-check 'invisible-text (let ((regions (message-text-with-property 'invisible)) from to) (when regions (while regions (setq from (caar regions) to (cdar regions) regions (cdr regions)) (put-text-property from to 'invisible nil) (message-overlay-put (message-make-overlay from to) 'face 'highlight)) (unless (yes-or-no-p "Invisible text found and made visible; continue sending? ") (error "Invisible text found and made visible"))))) (message-check 'illegible-text (let (char found choice) (message-goto-body) (while (progn (skip-chars-forward mm-7bit-chars) (when (get-text-property (point) 'no-illegible-text) ;; There is a signed or encrypted raw message part ;; that is considered to be safe. (goto-char (or (next-single-property-change (point) 'no-illegible-text) (point-max)))) (setq char (char-after))) (when (or (< (mm-char-int char) 128) (and (mm-multibyte-p) (memq (char-charset char) '(eight-bit-control eight-bit-graphic control-1)) (not (get-text-property (point) 'untranslated-utf-8)))) (message-overlay-put (message-make-overlay (point) (1+ (point))) 'face 'highlight) (setq found t)) (forward-char)) (when found (setq choice (gnus-multiple-choice "Non-printable characters found. Continue sending?" `((?d "Remove non-printable characters and send") (?r ,(format "Replace non-printable characters with \"%s\" and send" message-replacement-char)) (?i "Ignore non-printable characters and send") (?e "Continue editing")))) (if (eq choice ?e) (error "Non-printable characters")) (message-goto-body) (skip-chars-forward mm-7bit-chars) (while (not (eobp)) (when (let ((char (char-after))) (or (< (mm-char-int char) 128) (and (mm-multibyte-p) ;; FIXME: Wrong for Emacs 23 (unicode) and for ;; things like undecable utf-8. Should at least ;; use find-coding-systems-region. (memq (char-charset char) '(eight-bit-control eight-bit-graphic control-1)) (not (get-text-property (point) 'untranslated-utf-8))))) (if (eq choice ?i) (message-kill-all-overlays) (delete-char 1) (when (eq choice ?r) (insert message-replacement-char)))) (forward-char) (skip-chars-forward mm-7bit-chars))))) (message-check 'bogus-recipient ;; Warn before composing or sending a mail to an invalid address. (message-check-recipients))) (defun message-bogus-recipient-p (recipients) "Check if a mail address in RECIPIENTS looks bogus. RECIPIENTS is a mail header. Return a list of potentially bogus addresses. If none is found, return nil. An addresses might be bogus if the domain part is not fully qualified, see `message-valid-fqdn-regexp', or if it matches `message-bogus-address-regexp'." ;; FIXME: How about "foo@subdomain", when the MTA adds ".domain.tld"? (let (found) (mapc (lambda (address) (setq address (cadr address)) (when (or (not (or (not (string-match "@" address)) (string-match (concat ".@.*\\(" message-valid-fqdn-regexp "\\)\\'") address))) (and (stringp message-bogus-address-regexp) (string-match message-bogus-address-regexp address))) (push address found))) ;; (mail-extract-address-components recipients t)) found)) (defun message-check-recipients () "Warn before composing or sending a mail to an invalid address. This function could be useful in `message-setup-hook'." (interactive) (save-restriction (message-narrow-to-headers) (dolist (hdr '("To" "Cc" "Bcc")) (let ((addr (message-fetch-field hdr))) (when (stringp addr) (dolist (bog (message-bogus-recipient-p addr)) (and bog (not (y-or-n-p (format "Address `%s' might be bogus. Continue? " bog))) (error "Bogus address.")))))))) (defun message-add-action (action &rest types) "Add ACTION to be performed when doing an exit of type TYPES." (while types (add-to-list (intern (format "message-%s-actions" (pop types))) action))) (defun message-delete-action (action &rest types) "Delete ACTION from lists of actions performed when doing an exit of type TYPES." (let (var) (while types (set (setq var (intern (format "message-%s-actions" (pop types)))) (delq action (symbol-value var)))))) (defun message-do-actions (actions) "Perform all actions in ACTIONS." ;; Now perform actions on successful sending. (dolist (action actions) (ignore-errors (cond ;; A simple function. ((functionp action) (funcall action)) ;; Something to be evaled. (t (eval action)))))) (defun message-send-mail-partially () "Send mail as message/partial." ;; replace the header delimiter with a blank line (goto-char (point-min)) (re-search-forward (concat "^" (regexp-quote mail-header-separator) "\n")) (replace-match "\n") (run-hooks 'message-send-mail-hook) (let ((p (goto-char (point-min))) (tembuf (message-generate-new-buffer-clone-locals " message temp")) (curbuf (current-buffer)) (id (message-make-message-id)) (n 1) plist total header required-mail-headers) (while (not (eobp)) (if (< (point-max) (+ p message-send-mail-partially-limit)) (goto-char (point-max)) (goto-char (+ p message-send-mail-partially-limit)) (beginning-of-line) (if (<= (point) p) (forward-line 1))) ;; In case of bad message. (push p plist) (setq p (point))) (setq total (length plist)) (push (point-max) plist) (setq plist (nreverse plist)) (unwind-protect (save-excursion (setq p (pop plist)) (while plist (set-buffer curbuf) (copy-to-buffer tembuf p (car plist)) (set-buffer tembuf) (goto-char (point-min)) (if header (progn (goto-char (point-min)) (narrow-to-region (point) (point)) (insert header)) (message-goto-eoh) (setq header (buffer-substring (point-min) (point))) (goto-char (point-min)) (narrow-to-region (point) (point)) (insert header) (message-remove-header "Mime-Version") (message-remove-header "Content-Type") (message-remove-header "Content-Transfer-Encoding") (message-remove-header "Message-ID") (message-remove-header "Lines") (goto-char (point-max)) (insert "Mime-Version: 1.0\n") (setq header (buffer-string))) (goto-char (point-max)) (insert (format "Content-Type: message/partial; id=\"%s\"; number=%d; total=%d\n\n" id n total)) (forward-char -1) (let ((mail-header-separator "")) (when (memq 'Message-ID message-required-mail-headers) (insert "Message-ID: " (message-make-message-id) "\n")) (when (memq 'Lines message-required-mail-headers) (insert "Lines: " (message-make-lines) "\n")) (message-goto-subject) (end-of-line) (insert (format " (%d/%d)" n total)) (widen) (mm-with-unibyte-current-buffer (funcall (or message-send-mail-real-function message-send-mail-function)))) (setq n (+ n 1)) (setq p (pop plist)) (erase-buffer))) (kill-buffer tembuf)))) (defun message-send-mail (&optional arg) (require 'mail-utils) (let* ((tembuf (message-generate-new-buffer-clone-locals " message temp")) (case-fold-search nil) (news (message-news-p)) (mailbuf (current-buffer)) (message-this-is-mail t) (message-posting-charset (if (fboundp 'gnus-setup-posting-charset) (gnus-setup-posting-charset nil) message-posting-charset)) (headers message-required-mail-headers)) (when (and message-generate-hashcash (not (eq message-generate-hashcash 'opportunistic))) (message "Generating hashcash...") ;; Wait for calculations already started to finish... (hashcash-wait-async) ;; ...and do calculations not already done. mail-add-payment ;; will leave existing X-Hashcash headers alone. (mail-add-payment) (message "Generating hashcash...done")) (save-restriction (message-narrow-to-headers) ;; Generate the Mail-Followup-To header if the header is not there... (if (and (message-subscribed-p) (not (mail-fetch-field "mail-followup-to"))) (setq headers (cons (cons "Mail-Followup-To" (message-make-mail-followup-to)) message-required-mail-headers)) ;; otherwise, delete the MFT header if the field is empty (when (equal "" (mail-fetch-field "mail-followup-to")) (message-remove-header "^Mail-Followup-To:"))) ;; Insert some headers. (let ((message-deletable-headers (if news nil message-deletable-headers))) (message-generate-headers headers)) ;; Check continuation headers. (message-check 'continuation-headers (goto-char (point-min)) (while (re-search-forward "^[^ \t\n][^ \t\n:]*[ \t\n]" nil t) (goto-char (match-beginning 0)) (if (y-or-n-p "Fix continuation lines? ") (insert " ") (forward-line 1) (unless (y-or-n-p "Send anyway? ") (error "Failed to send the message"))))) ;; Let the user do all of the above. (run-hooks 'message-header-hook)) (unwind-protect (with-current-buffer tembuf (erase-buffer) ;; Avoid copying text props (except hard newlines). (insert (with-current-buffer mailbuf (mml-buffer-substring-no-properties-except-hard-newlines (point-min) (point-max)))) ;; Remove some headers. (message-encode-message-body) (save-restriction (message-narrow-to-headers) ;; We (re)generate the Lines header. (when (memq 'Lines message-required-mail-headers) (message-generate-headers '(Lines))) ;; Remove some headers. (message-remove-header message-ignored-mail-headers t) (let ((mail-parse-charset message-default-charset)) (mail-encode-encoded-word-buffer))) (goto-char (point-max)) ;; require one newline at the end. (or (= (preceding-char) ?\n) (insert ?\n)) (message-cleanup-headers) ;; FIXME: we're inserting the courtesy copy after encoding. ;; This is wrong if the courtesy copy string contains ;; non-ASCII characters. -- jh (when (save-restriction (message-narrow-to-headers) (and news (or (message-fetch-field "cc") (message-fetch-field "bcc") (message-fetch-field "to")) (let ((content-type (message-fetch-field "content-type"))) (and (or (not content-type) (string= "text/plain" (car (mail-header-parse-content-type content-type)))) (not (string= "base64" (message-fetch-field "content-transfer-encoding"))))))) (message-insert-courtesy-copy)) (if (or (not message-send-mail-partially-limit) (< (buffer-size) message-send-mail-partially-limit) (not (message-y-or-n-p "The message size is too large, split? " t "\ The message size, " (/ (buffer-size) 1000) "KB, is too large. Some mail gateways (MTA's) bounce large messages. To avoid the problem, answer `y', and the message will be split into several smaller pieces, the size of each is about " (/ message-send-mail-partially-limit 1000) "KB except the last one. However, some mail readers (MUA's) can't read split messages, i.e., mails in message/partially format. Answer `n', and the message will be sent in one piece. The size limit is controlled by `message-send-mail-partially-limit'. If you always want Gnus to send messages in one piece, set `message-send-mail-partially-limit' to nil. "))) (mm-with-unibyte-current-buffer (message "Sending via mail...") (funcall (or message-send-mail-real-function message-send-mail-function))) (message-send-mail-partially))) (kill-buffer tembuf)) (set-buffer mailbuf) (push 'mail message-sent-message-via))) (defun message-send-mail-with-sendmail () "Send off the prepared buffer with sendmail." (let ((errbuf (if message-interactive (message-generate-new-buffer-clone-locals " sendmail errors") 0)) resend-to-addresses delimline) (unwind-protect (progn (let ((case-fold-search t)) (save-restriction (message-narrow-to-headers) (setq resend-to-addresses (message-fetch-field "resent-to"))) ;; Change header-delimiter to be what sendmail expects. (goto-char (point-min)) (re-search-forward (concat "^" (regexp-quote mail-header-separator) "\n")) (replace-match "\n") (backward-char 1) (setq delimline (point-marker)) (run-hooks 'message-send-mail-hook) ;; Insert an extra newline if we need it to work around ;; Sun's bug that swallows newlines. (goto-char (1+ delimline)) (when (eval message-mailer-swallows-blank-line) (newline)) (when message-interactive (with-current-buffer errbuf (erase-buffer)))) (let* ((default-directory "/") (coding-system-for-write message-send-coding-system) (cpr (apply 'call-process-region (append (list (point-min) (point-max) (cond ((boundp 'sendmail-program) sendmail-program) ((file-exists-p "/usr/sbin/sendmail") "/usr/sbin/sendmail") ((file-exists-p "/usr/lib/sendmail") "/usr/lib/sendmail") ((file-exists-p "/usr/ucblib/sendmail") "/usr/ucblib/sendmail") (t "fakemail")) nil errbuf nil "-oi") message-sendmail-extra-arguments ;; Always specify who from, ;; since some systems have broken sendmails. ;; But some systems are more broken with -f, so ;; we'll let users override this. (if (null message-sendmail-f-is-evil) (list "-f" (message-sendmail-envelope-from))) ;; These mean "report errors by mail" ;; and "deliver in background". (if (null message-interactive) '("-oem" "-odb")) ;; Get the addresses from the message ;; unless this is a resend. ;; We must not do that for a resend ;; because we would find the original addresses. ;; For a resend, include the specific addresses. (if resend-to-addresses (list resend-to-addresses) '("-t")))))) (unless (or (null cpr) (and (numberp cpr) (zerop cpr))) (error "Sending...failed with exit value %d" cpr))) (when message-interactive (with-current-buffer errbuf (goto-char (point-min)) (while (re-search-forward "\n+ *" nil t) (replace-match "; ")) (if (not (zerop (buffer-size))) (error "Sending...failed to %s" (buffer-string)))))) (when (bufferp errbuf) (kill-buffer errbuf))))) (defun message-send-mail-with-qmail () "Pass the prepared message buffer to qmail-inject. Refer to the documentation for the variable `message-send-mail-function' to find out how to use this." ;; replace the header delimiter with a blank line (goto-char (point-min)) (re-search-forward (concat "^" (regexp-quote mail-header-separator) "\n")) (replace-match "\n") (run-hooks 'message-send-mail-hook) ;; send the message (case (let ((coding-system-for-write message-send-coding-system)) (apply 'call-process-region (point-min) (point-max) message-qmail-inject-program nil nil nil ;; qmail-inject's default behaviour is to look for addresses on the ;; command line; if there're none, it scans the headers. ;; yes, it does The Right Thing w.r.t. Resent-To and it's kin. ;; ;; in general, ALL of qmail-inject's defaults are perfect for simply ;; reading a formatted (i. e., at least a To: or Resent-To header) ;; message from stdin. ;; ;; qmail also has the advantage of not having been raped by ;; various vendors, so we don't have to allow for that, either -- ;; compare this with message-send-mail-with-sendmail and weep ;; for sendmail's lost innocence. ;; ;; all this is way cool coz it lets us keep the arguments entirely ;; free for -inject-arguments -- a big win for the user and for us ;; since we don't have to play that double-guessing game and the user ;; gets full control (no gestapo'ish -f's, for instance). --sj (if (functionp message-qmail-inject-args) (funcall message-qmail-inject-args) message-qmail-inject-args))) ;; qmail-inject doesn't say anything on it's stdout/stderr, ;; we have to look at the retval instead (0 nil) (100 (error "qmail-inject reported permanent failure")) (111 (error "qmail-inject reported transient failure")) ;; should never happen (t (error "qmail-inject reported unknown failure")))) (defun message-send-mail-with-mh () "Send the prepared message buffer with mh." (let ((mh-previous-window-config nil) (name (mh-new-draft-name))) (setq buffer-file-name name) ;; MH wants to generate these headers itself. (when message-mh-deletable-headers (let ((headers message-mh-deletable-headers)) (while headers (goto-char (point-min)) (and (re-search-forward (concat "^" (symbol-name (car headers)) ": *") nil t) (message-delete-line)) (pop headers)))) (run-hooks 'message-send-mail-hook) ;; Pass it on to mh. (mh-send-letter))) (defun message-smtpmail-send-it () "Send the prepared message buffer with `smtpmail-send-it'. This only differs from `smtpmail-send-it' that this command evaluates `message-send-mail-hook' just before sending a message. It is useful if your ISP requires the POP-before-SMTP authentication. See the Gnus manual for details." (run-hooks 'message-send-mail-hook) (smtpmail-send-it)) (defun message-send-mail-with-mailclient () "Send the prepared message buffer with `mailclient-send-it'. This only differs from `smtpmail-send-it' that this command evaluates `message-send-mail-hook' just before sending a message." (run-hooks 'message-send-mail-hook) (mailclient-send-it)) (defun message-canlock-generate () "Return a string that is non-trivial to guess. Do not use this for anything important, it is cryptographically weak." (require 'sha1) (let (sha1-maximum-internal-length) (sha1 (concat (message-unique-id) (format "%x%x%x" (random) (random t) (random)) (prin1-to-string (recent-keys)) (prin1-to-string (garbage-collect)))))) (defun message-canlock-password () "The password used by message for cancel locks. This is the value of `canlock-password', if that option is non-nil. Otherwise, generate and save a value for `canlock-password' first." (unless canlock-password (customize-save-variable 'canlock-password (message-canlock-generate)) (setq canlock-password-for-verify canlock-password)) canlock-password) (defun message-insert-canlock () (when message-insert-canlock (message-canlock-password) (canlock-insert-header))) (defun message-send-news (&optional arg) (let* ((tembuf (message-generate-new-buffer-clone-locals " *message temp*")) (case-fold-search nil) (method (if (functionp message-post-method) (funcall message-post-method arg) message-post-method)) (newsgroups-field (save-restriction (message-narrow-to-headers-or-head) (message-fetch-field "Newsgroups"))) (followup-field (save-restriction (message-narrow-to-headers-or-head) (message-fetch-field "Followup-To"))) ;; BUG: We really need to get the charset for each name in the ;; Newsgroups and Followup-To lines to allow crossposting ;; between group namess with incompatible character sets. ;; -- Per Abrahamsen 2001-10-08. (group-field-charset (gnus-group-name-charset method newsgroups-field)) (followup-field-charset (gnus-group-name-charset method (or followup-field ""))) (rfc2047-header-encoding-alist (append (when group-field-charset (list (cons "Newsgroups" group-field-charset))) (when followup-field-charset (list (cons "Followup-To" followup-field-charset))) rfc2047-header-encoding-alist)) (messbuf (current-buffer)) (message-syntax-checks (if (and arg (listp message-syntax-checks)) (cons '(existing-newsgroups . disabled) message-syntax-checks) message-syntax-checks)) (message-this-is-news t) (message-posting-charset (gnus-setup-posting-charset newsgroups-field)) result) (if (not (message-check-news-body-syntax)) nil (save-restriction (message-narrow-to-headers) ;; Insert some headers. (message-generate-headers message-required-news-headers) (message-insert-canlock) ;; Let the user do all of the above. (run-hooks 'message-header-hook)) ;; Note: This check will be disabled by the ".*" default value for ;; gnus-group-name-charset-group-alist. -- Pa 2001-10-07. (when (and group-field-charset (listp message-syntax-checks)) (setq message-syntax-checks (cons '(valid-newsgroups . disabled) message-syntax-checks))) (message-cleanup-headers) (if (not (let ((message-post-method method)) (message-check-news-syntax))) nil (unwind-protect (with-current-buffer tembuf (buffer-disable-undo) (erase-buffer) ;; Avoid copying text props (except hard newlines). (insert (with-current-buffer messbuf (mml-buffer-substring-no-properties-except-hard-newlines (point-min) (point-max)))) (message-encode-message-body) ;; Remove some headers. (save-restriction (message-narrow-to-headers) ;; We (re)generate the Lines header. (when (memq 'Lines message-required-mail-headers) (message-generate-headers '(Lines))) ;; Remove some headers. (message-remove-header message-ignored-news-headers t) (let ((mail-parse-charset message-default-charset)) (mail-encode-encoded-word-buffer))) (goto-char (point-max)) ;; require one newline at the end. (or (= (preceding-char) ?\n) (insert ?\n)) (let ((case-fold-search t)) ;; Remove the delimiter. (goto-char (point-min)) (re-search-forward (concat "^" (regexp-quote mail-header-separator) "\n")) (replace-match "\n") (backward-char 1)) (run-hooks 'message-send-news-hook) (gnus-open-server method) (message "Sending news via %s..." (gnus-server-string method)) (setq result (let ((mail-header-separator "")) (gnus-request-post method)))) (kill-buffer tembuf)) (set-buffer messbuf) (if result (push 'news message-sent-message-via) (message "Couldn't send message via news: %s" (nnheader-get-report (car method))) nil))))) ;;; ;;; Header generation & syntax checking. ;;; (defun message-check-element (type) "Return non-nil if this TYPE is not to be checked." (if (eq message-syntax-checks 'dont-check-for-anything-just-trust-me) t (let ((able (assq type message-syntax-checks))) (and (consp able) (eq (cdr able) 'disabled))))) (defun message-check-news-syntax () "Check the syntax of the message." (save-excursion (save-restriction (widen) ;; We narrow to the headers and check them first. (save-excursion (save-restriction (message-narrow-to-headers) (message-check-news-header-syntax)))))) (defun message-check-news-header-syntax () (and ;; Check Newsgroups header. (message-check 'newsgroups (let ((group (message-fetch-field "newsgroups"))) (or (and group (not (string-match "\\`[ \t]*\\'" group))) (ignore (message "The newsgroups field is empty or missing. Posting is denied."))))) ;; Check the Subject header. (message-check 'subject (let* ((case-fold-search t) (subject (message-fetch-field "subject"))) (or (and subject (not (string-match "\\`[ \t]*\\'" subject))) (ignore (message "The subject field is empty or missing. Posting is denied."))))) ;; Check for commands in Subject. (message-check 'subject-cmsg (if (string-match "^cmsg " (message-fetch-field "subject")) (y-or-n-p "The control code \"cmsg\" is in the subject. Really post? ") t)) ;; Check long header lines. (message-check 'long-header-lines (let ((start (point)) (header nil) (length 0) found) (while (and (not found) (re-search-forward "^\\([^ \t:]+\\): " nil t)) (if (> (- (point) (match-beginning 0)) 998) (setq found t length (- (point) (match-beginning 0))) (setq header (match-string-no-properties 1))) (setq start (match-beginning 0)) (forward-line 1)) (if found (y-or-n-p (format "Your %s header is too long (%d). Really post? " header length)) t))) ;; Check for multiple identical headers. (message-check 'multiple-headers (let (found) (while (and (not found) (re-search-forward "^[^ \t:]+: " nil t)) (save-excursion (or (re-search-forward (concat "^" (regexp-quote (setq found (buffer-substring (match-beginning 0) (- (match-end 0) 2)))) ":") nil t) (setq found nil)))) (if found (y-or-n-p (format "Multiple %s headers. Really post? " found)) t))) ;; Check for Version and Sendsys. (message-check 'sendsys (if (re-search-forward "^Sendsys:\\|^Version:" nil t) (y-or-n-p (format "The article contains a %s command. Really post? " (buffer-substring (match-beginning 0) (1- (match-end 0))))) t)) ;; See whether we can shorten Followup-To. (message-check 'shorten-followup-to (let ((newsgroups (message-fetch-field "newsgroups")) (followup-to (message-fetch-field "followup-to")) to) (when (and newsgroups (string-match "," newsgroups) (not followup-to) (not (zerop (length (setq to (completing-read "Followups to (default no Followup-To header): " (mapcar #'list (cons "poster" (message-tokenize-header newsgroups))))))))) (goto-char (point-min)) (insert "Followup-To: " to "\n")) t)) ;; Check "Shoot me". (message-check 'shoot (if (re-search-forward "Message-ID.*.i-did-not-set--mail-host-address--so-tickle-me" nil t) (y-or-n-p "You appear to have a misconfigured system. Really post? ") t)) ;; Check for Approved. (message-check 'approved (if (re-search-forward "^Approved:" nil t) (y-or-n-p "The article contains an Approved header. Really post? ") t)) ;; Check the Message-ID header. (message-check 'message-id (let* ((case-fold-search t) (message-id (message-fetch-field "message-id" t))) (or (not message-id) ;; Is there an @ in the ID? (and (string-match "@" message-id) ;; Is there a dot in the ID? (string-match "@[^.]*\\." message-id) ;; Does the ID end with a dot? (not (string-match "\\.>" message-id))) (y-or-n-p (format "The Message-ID looks strange: \"%s\". Really post? " message-id))))) ;; Check the Newsgroups & Followup-To headers. (message-check 'existing-newsgroups (let* ((case-fold-search t) (newsgroups (message-fetch-field "newsgroups")) (followup-to (message-fetch-field "followup-to")) (groups (message-tokenize-header (if followup-to (concat newsgroups "," followup-to) newsgroups))) (post-method (if (functionp message-post-method) (funcall message-post-method) message-post-method)) ;; KLUDGE to handle nnvirtual groups. Doing this right ;; would probably involve a new nnoo function. ;; -- Per Abrahamsen , 2001-10-17. (method (if (and (consp post-method) (eq (car post-method) 'nnvirtual) gnus-message-group-art) (let ((group (car (nnvirtual-find-group-art (car gnus-message-group-art) (cdr gnus-message-group-art))))) (gnus-find-method-for-group group)) post-method)) (known-groups (mapcar (lambda (n) (gnus-group-name-decode (gnus-group-real-name n) (gnus-group-name-charset method n))) (gnus-groups-from-server method))) errors) (while groups (when (and (not (equal (car groups) "poster")) (not (member (car groups) known-groups)) (not (member (car groups) errors))) (push (car groups) errors)) (pop groups)) (cond ;; Gnus is not running. ((or (not (and (boundp 'gnus-active-hashtb) gnus-active-hashtb)) (not (boundp 'gnus-read-active-file))) t) ;; We don't have all the group names. ((and (or (not gnus-read-active-file) (eq gnus-read-active-file 'some)) errors) (y-or-n-p (format "Really use %s possibly unknown group%s: %s? " (if (= (length errors) 1) "this" "these") (if (= (length errors) 1) "" "s") (mapconcat 'identity errors ", ")))) ;; There were no errors. ((not errors) t) ;; There are unknown groups. (t (y-or-n-p (format "Really post to %s unknown group%s: %s? " (if (= (length errors) 1) "this" "these") (if (= (length errors) 1) "" "s") (mapconcat 'identity errors ", "))))))) ;; Check continuation headers. (message-check 'continuation-headers (goto-char (point-min)) (let ((do-posting t)) (while (re-search-forward "^[^ \t\n][^ \t\n:]*[ \t\n]" nil t) (goto-char (match-beginning 0)) (if (y-or-n-p "Fix continuation lines? ") (insert " ") (forward-line 1) (unless (y-or-n-p "Send anyway? ") (setq do-posting nil)))) do-posting)) ;; Check the Newsgroups & Followup-To headers for syntax errors. (message-check 'valid-newsgroups (let ((case-fold-search t) (headers '("Newsgroups" "Followup-To")) header error) (while (and headers (not error)) (when (setq header (mail-fetch-field (car headers))) (if (or (not (string-match "\\`\\([-+_&.a-zA-Z0-9]+\\)?\\(,[-+_&.a-zA-Z0-9]+\\)*\\'" header)) (memq nil (mapcar (lambda (g) (not (string-match "\\.\\'\\|\\.\\." g))) (message-tokenize-header header ",")))) (setq error t))) (unless error (pop headers))) (if (not error) t (y-or-n-p (format "The %s header looks odd: \"%s\". Really post? " (car headers) header))))) (message-check 'repeated-newsgroups (let ((case-fold-search t) (headers '("Newsgroups" "Followup-To")) header error groups group) (while (and headers (not error)) (when (setq header (mail-fetch-field (pop headers))) (setq groups (message-tokenize-header header ",")) (while (setq group (pop groups)) (when (member group groups) (setq error group groups nil))))) (if (not error) t (y-or-n-p (format "Group %s is repeated in headers. Really post? " error))))) ;; Check the From header. (message-check 'from (let* ((case-fold-search t) (from (message-fetch-field "from")) ad) (cond ((not from) (message "There is no From line. Posting is denied.") nil) ((or (not (string-match "@[^\\.]*\\." (setq ad (nth 1 (mail-extract-address-components from))))) ;larsi@ifi (string-match "\\.\\." ad) ;larsi@ifi..uio (string-match "@\\." ad) ;larsi@.ifi.uio (string-match "\\.$" ad) ;larsi@ifi.uio. (not (string-match "^[^@]+@[^@]+$" ad)) ;larsi.ifi.uio (string-match "(.*).*(.*)" from)) ;(lars) (lars) (message "Denied posting -- the From looks strange: \"%s\"." from) nil) ((let ((addresses (rfc822-addresses from))) (while (and addresses (not (eq (string-to-char (car addresses)) ?\())) (setq addresses (cdr addresses))) addresses) (message "Denied posting -- bad From address: \"%s\"." from) nil) (t t)))) ;; Check the Reply-To header. (message-check 'reply-to (let* ((case-fold-search t) (reply-to (message-fetch-field "reply-to")) ad) (cond ((not reply-to) t) ((string-match "," reply-to) (y-or-n-p (format "Multiple Reply-To addresses: \"%s\". Really post? " reply-to))) ((or (not (string-match "@[^\\.]*\\." (setq ad (nth 1 (mail-extract-address-components reply-to))))) ;larsi@ifi (string-match "\\.\\." ad) ;larsi@ifi..uio (string-match "@\\." ad) ;larsi@.ifi.uio (string-match "\\.$" ad) ;larsi@ifi.uio. (not (string-match "^[^@]+@[^@]+$" ad)) ;larsi.ifi.uio (string-match "(.*).*(.*)" reply-to)) ;(lars) (lars) (y-or-n-p (format "The Reply-To looks strange: \"%s\". Really post? " reply-to))) (t t)))))) (defun message-check-news-body-syntax () (and ;; Check for long lines. (message-check 'long-lines (goto-char (point-min)) (re-search-forward (concat "^" (regexp-quote mail-header-separator) "$")) (forward-line 1) (while (and (or (looking-at "<#\\(/\\)?\\(multipart\\|part\\|external\\|mml\\)") (let ((p (point))) (end-of-line) (< (- (point) p) 80))) (zerop (forward-line 1)))) (or (bolp) (eobp) (y-or-n-p "You have lines longer than 79 characters. Really post? "))) ;; Check whether the article is empty. (message-check 'empty (goto-char (point-min)) (re-search-forward (concat "^" (regexp-quote mail-header-separator) "$")) (forward-line 1) (let ((b (point))) (goto-char (point-max)) (re-search-backward message-signature-separator nil t) (beginning-of-line) (or (re-search-backward "[^ \n\t]" b t) (if (message-gnksa-enable-p 'empty-article) (y-or-n-p "Empty article. Really post? ") (message "Denied posting -- Empty article.") nil)))) ;; Check for control characters. (message-check 'control-chars (if (re-search-forward (mm-string-to-multibyte "[\000-\007\013\015-\032\034-\037\200-\237]") nil t) (y-or-n-p "The article contains control characters. Really post? ") t)) ;; Check excessive size. (message-check 'size (if (> (buffer-size) 60000) (y-or-n-p (format "The article is %d octets long. Really post? " (buffer-size))) t)) ;; Check whether any new text has been added. (message-check 'new-text (or (not message-checksum) (not (eq (message-checksum) message-checksum)) (if (message-gnksa-enable-p 'quoted-text-only) (y-or-n-p "It looks like no new text has been added. Really post? ") (message "Denied posting -- no new text has been added.") nil))) ;; Check the length of the signature. (message-check 'signature (goto-char (point-max)) (if (not (re-search-backward message-signature-separator nil t)) t (if (>= (count-lines (1+ (point-at-eol)) (point-max)) 5) (if (message-gnksa-enable-p 'signature) (y-or-n-p (format "Signature is excessively long (%d lines). Really post? " (count-lines (1+ (point-at-eol)) (point-max)))) (message "Denied posting -- Excessive signature.") nil) t))) ;; Ensure that text follows last quoted portion. (message-check 'quoting-style (goto-char (point-max)) (let ((no-problem t)) (when (search-backward-regexp "^>[^\n]*\n" nil t) (setq no-problem (search-forward-regexp "^[ \t]*[^>\n]" nil t))) (if no-problem t (if (message-gnksa-enable-p 'quoted-text-only) (y-or-n-p "Your text should follow quoted text. Really post? ") ;; Ensure that (goto-char (point-min)) (re-search-forward (concat "^" (regexp-quote mail-header-separator) "$")) (if (search-forward-regexp "^[ \t]*[^>\n]" nil t) (y-or-n-p "Your text should follow quoted text. Really post? ") (message "Denied posting -- only quoted text.") nil))))))) (defun message-checksum () "Return a \"checksum\" for the current buffer." (let ((sum 0)) (save-excursion (goto-char (point-min)) (re-search-forward (concat "^" (regexp-quote mail-header-separator) "$")) (while (not (eobp)) (when (not (looking-at "[ \t\n]")) (setq sum (logxor (ash sum 1) (if (natnump sum) 0 1) (char-after)))) (forward-char 1))) sum)) (defun message-do-fcc () "Process Fcc headers in the current buffer." (let ((case-fold-search t) (buf (current-buffer)) list file (mml-externalize-attachments message-fcc-externalize-attachments)) (save-excursion (save-restriction (message-narrow-to-headers) (setq file (message-fetch-field "fcc" t))) (when file (set-buffer (get-buffer-create " *message temp*")) (erase-buffer) (insert-buffer-substring buf) (message-encode-message-body) (save-restriction (message-narrow-to-headers) (while (setq file (message-fetch-field "fcc" t)) (push file list) (message-remove-header "fcc" nil t)) (let ((mail-parse-charset message-default-charset) (rfc2047-header-encoding-alist (cons '("Newsgroups" . default) rfc2047-header-encoding-alist))) (mail-encode-encoded-word-buffer))) (goto-char (point-min)) (when (re-search-forward (concat "^" (regexp-quote mail-header-separator) "$") nil t) (replace-match "" t t )) ;; Process FCC operations. (while list (setq file (pop list)) (if (string-match "^[ \t]*|[ \t]*\\(.*\\)[ \t]*$" file) ;; Pipe the article to the program in question. (call-process-region (point-min) (point-max) shell-file-name nil nil nil shell-command-switch (match-string 1 file)) ;; Save the article. (setq file (expand-file-name file)) (unless (file-exists-p (file-name-directory file)) (make-directory (file-name-directory file) t)) (if (and message-fcc-handler-function (not (eq message-fcc-handler-function 'rmail-output))) (funcall message-fcc-handler-function file) (if (and (file-readable-p file) (mail-file-babyl-p file)) (rmail-output file 1 nil t) (let ((mail-use-rfc822 t)) (rmail-output file 1 t t)))))) (kill-buffer (current-buffer)))))) (defun message-output (filename) "Append this article to Unix/babyl mail file FILENAME." (if (and (file-readable-p filename) (mail-file-babyl-p filename)) (gnus-output-to-rmail filename t) (gnus-output-to-mail filename t))) (defun message-cleanup-headers () "Do various automatic cleanups of the headers." ;; Remove empty lines in the header. (save-restriction (message-narrow-to-headers) ;; Remove blank lines. (while (re-search-forward "^[ \t]*\n" nil t) (replace-match "" t t)) ;; Correct Newsgroups and Followup-To headers: Change sequence of ;; spaces to comma and eliminate spaces around commas. Eliminate ;; embedded line breaks. (goto-char (point-min)) (while (re-search-forward "^\\(Newsgroups\\|Followup-To\\): +" nil t) (save-restriction (narrow-to-region (point) (if (re-search-forward "^[^ \t]" nil t) (match-beginning 0) (forward-line 1) (point))) (goto-char (point-min)) (while (re-search-forward "\n[ \t]+" nil t) (replace-match " " t t)) ;No line breaks (too confusing) (goto-char (point-min)) (while (re-search-forward "[ \t\n]*,[ \t\n]*\\|[ \t]+" nil t) (replace-match "," t t)) (goto-char (point-min)) ;; Remove trailing commas. (when (re-search-forward ",+$" nil t) (replace-match "" t t)))))) (defun message-make-date (&optional now) "Make a valid data header. If NOW, use that time instead." (let ((system-time-locale "C")) (format-time-string "%a, %d %b %Y %T %z" now))) (defun message-insert-expires (days) "Insert the Expires header. Expiry in DAYS days." (interactive "NExpire article in how many days? ") (save-excursion (message-position-on-field "Expires" "X-Draft-From") (insert (message-make-expires-date days)))) (defun message-make-expires-date (days) "Make date string for the Expires header. Expiry in DAYS days. In posting styles use `(\"Expires\" (make-expires-date 30))'." (let* ((cur (decode-time (current-time))) (nday (+ days (nth 3 cur)))) (setf (nth 3 cur) nday) (message-make-date (apply 'encode-time cur)))) (defun message-make-message-id () "Make a unique Message-ID." (concat "<" (message-unique-id) (let ((psubject (save-excursion (message-fetch-field "subject"))) (psupersedes (save-excursion (message-fetch-field "supersedes")))) (if (or (and message-reply-headers (mail-header-references message-reply-headers) (mail-header-subject message-reply-headers) psubject (not (string= (message-strip-subject-re (mail-header-subject message-reply-headers)) (message-strip-subject-re psubject)))) (and psupersedes (string-match "_-_@" psupersedes))) "_-_" "")) "@" (message-make-fqdn) ">")) (defvar message-unique-id-char nil) ;; If you ever change this function, make sure the new version ;; cannot generate IDs that the old version could. ;; You might for example insert a "." somewhere (not next to another dot ;; or string boundary), or modify the "fsf" string. (defun message-unique-id () ;; Don't use microseconds from (current-time), they may be unsupported. ;; Instead we use this randomly inited counter. (setq message-unique-id-char (% (1+ (or message-unique-id-char (logand (random t) (1- (lsh 1 20))))) ;; (current-time) returns 16-bit ints, ;; and 2^16*25 just fits into 4 digits i base 36. (* 25 25))) (let ((tm (current-time))) (concat (if (or (memq system-type '(ms-dos emx vax-vms)) ;; message-number-base36 doesn't handle bigints. (floatp (user-uid))) (let ((user (downcase (user-login-name)))) (while (string-match "[^a-z0-9_]" user) (aset user (match-beginning 0) ?_)) user) (message-number-base36 (user-uid) -1)) (message-number-base36 (+ (car tm) (lsh (% message-unique-id-char 25) 16)) 4) (message-number-base36 (+ (nth 1 tm) (lsh (/ message-unique-id-char 25) 16)) 4) ;; Append a given name, because while the generated ID is unique ;; to this newsreader, other newsreaders might otherwise generate ;; the same ID via another algorithm. ".fsf"))) (defun message-number-base36 (num len) (if (if (< len 0) (<= num 0) (= len 0)) "" (concat (message-number-base36 (/ num 36) (1- len)) (char-to-string (aref "zyxwvutsrqponmlkjihgfedcba9876543210" (% num 36)))))) (defun message-make-organization () "Make an Organization header." (let* ((organization (when message-user-organization (if (functionp message-user-organization) (funcall message-user-organization) message-user-organization)))) (with-temp-buffer (mm-enable-multibyte) (cond ((stringp organization) (insert organization)) ((and (eq t organization) message-user-organization-file (file-exists-p message-user-organization-file)) (insert-file-contents message-user-organization-file))) (goto-char (point-min)) (while (re-search-forward "[\t\n]+" nil t) (replace-match "" t t)) (unless (zerop (buffer-size)) (buffer-string))))) (defun message-make-lines () "Count the number of lines and return numeric string." (save-excursion (save-restriction (widen) (message-goto-body) (int-to-string (count-lines (point) (point-max)))))) (defun message-make-references () "Return the References header for this message." (when message-reply-headers (let ((message-id (mail-header-message-id message-reply-headers)) (references (mail-header-references message-reply-headers))) (if (or references message-id) (concat (or references "") (and references " ") (or message-id "")) nil)))) (defun message-make-in-reply-to () "Return the In-Reply-To header for this message." (when message-reply-headers (let ((from (mail-header-from message-reply-headers)) (date (mail-header-date message-reply-headers)) (msg-id (mail-header-message-id message-reply-headers))) (when from (let ((name (mail-extract-address-components from))) (concat msg-id (if msg-id " (") (if (car name) (if (string-match "[^\000-\177]" (car name)) ;; Quote a string containing non-ASCII characters. ;; It will make the RFC2047 encoder cause an error ;; if there are special characters. (mm-with-multibyte-buffer (insert (car name)) (goto-char (point-min)) (while (search-forward "\"" nil t) (when (prog2 (backward-char) (zerop (% (skip-chars-backward "\\\\") 2)) (goto-char (match-beginning 0))) (insert "\\")) (forward-char)) ;; Those quotes will be removed by the RFC2047 encoder. (concat "\"" (buffer-string) "\"")) (car name)) (nth 1 name)) "'s message of \"" (if (or (not date) (string= date "")) "(unknown date)" date) "\"" (if msg-id ")"))))))) (defun message-make-distribution () "Make a Distribution header." (let ((orig-distribution (message-fetch-reply-field "distribution"))) (cond ((functionp message-distribution-function) (funcall message-distribution-function)) (t orig-distribution)))) (defun message-make-expires () "Return an Expires header based on `message-expires'." (let ((current (current-time)) (future (* 1.0 message-expires 60 60 24))) ;; Add the future to current. (setcar current (+ (car current) (round (/ future (expt 2 16))))) (setcar (cdr current) (+ (nth 1 current) (% (round future) (expt 2 16)))) (message-make-date current))) (defun message-make-path () "Return uucp path." (let ((login-name (user-login-name))) (cond ((null message-user-path) (concat (system-name) "!" login-name)) ((stringp message-user-path) ;; Support GENERICPATH. Suggested by vixie@decwrl.dec.com. (concat message-user-path "!" login-name)) (t login-name)))) (defun message-make-from (&optional name address) "Make a From header." (let* ((style message-from-style) (login (or address (message-make-address))) (fullname (or name (and (boundp 'user-full-name) user-full-name) (user-full-name)))) (when (string= fullname "&") (setq fullname (user-login-name))) (with-temp-buffer (mm-enable-multibyte) (cond ((or (null style) (equal fullname "")) (insert login)) ((or (eq style 'angles) (and (not (eq style 'parens)) ;; Use angles if no quoting is needed, or if parens would ;; need quoting too. (or (not (string-match "[^- !#-'*+/-9=?A-Z^-~]" fullname)) (let ((tmp (concat fullname nil))) (while (string-match "([^()]*)" tmp) (aset tmp (match-beginning 0) ?-) (aset tmp (1- (match-end 0)) ?-)) (string-match "[\\()]" tmp))))) (insert fullname) (goto-char (point-min)) ;; Look for a character that cannot appear unquoted ;; according to RFC 822. (when (re-search-forward "[^- !#-'*+/-9=?A-Z^-~]" nil 1) ;; Quote fullname, escaping specials. (goto-char (point-min)) (insert "\"") (while (re-search-forward "[\"\\]" nil 1) (replace-match "\\\\\\&" t)) (insert "\"")) (insert " <" login ">")) (t ; 'parens or default (insert login " (") (let ((fullname-start (point))) (insert fullname) (goto-char fullname-start) ;; RFC 822 says \ and nonmatching parentheses ;; must be escaped in comments. ;; Escape every instance of ()\ ... (while (re-search-forward "[()\\]" nil 1) (replace-match "\\\\\\&" t)) ;; ... then undo escaping of matching parentheses, ;; including matching nested parentheses. (goto-char fullname-start) (while (re-search-forward "\\(\\=\\|[^\\]\\(\\\\\\\\\\)*\\)\\\\(\\(\\([^\\]\\|\\\\\\\\\\)*\\)\\\\)" nil 1) (replace-match "\\1(\\3)" t) (goto-char fullname-start))) (insert ")"))) (buffer-string)))) (defun message-make-sender () "Return the \"real\" user address. This function tries to ignore all user modifications, and give as trustworthy answer as possible." (concat (user-login-name) "@" (system-name))) (defun message-make-address () "Make the address of the user." (or (message-user-mail-address) (concat (user-login-name) "@" (message-make-domain)))) (defun message-user-mail-address () "Return the pertinent part of `user-mail-address'." (when (and user-mail-address (string-match "@.*\\." user-mail-address)) (if (string-match " " user-mail-address) (nth 1 (mail-extract-address-components user-mail-address)) user-mail-address))) (defun message-sendmail-envelope-from () "Return the envelope from." (cond ((eq message-sendmail-envelope-from 'header) (nth 1 (mail-extract-address-components (message-fetch-field "from")))) ((stringp message-sendmail-envelope-from) message-sendmail-envelope-from) (t (message-make-address)))) (defun message-make-fqdn () "Return user's fully qualified domain name." (let* ((system-name (system-name)) (user-mail (message-user-mail-address)) (user-domain (if (and user-mail (string-match "@\\(.*\\)\\'" user-mail)) (match-string 1 user-mail))) (case-fold-search t)) (cond ((and message-user-fqdn (stringp message-user-fqdn) (string-match message-valid-fqdn-regexp message-user-fqdn) (not (string-match message-bogus-system-names message-user-fqdn))) ;; `message-user-fqdn' seems to be valid message-user-fqdn) ((and (string-match message-valid-fqdn-regexp system-name) (not (string-match message-bogus-system-names system-name))) ;; `system-name' returned the right result. system-name) ;; Try `mail-host-address'. ((and (boundp 'mail-host-address) (stringp mail-host-address) (string-match message-valid-fqdn-regexp mail-host-address) (not (string-match message-bogus-system-names mail-host-address))) mail-host-address) ;; We try `user-mail-address' as a backup. ((and user-domain (stringp user-domain) (string-match message-valid-fqdn-regexp user-domain) (not (string-match message-bogus-system-names user-domain))) user-domain) ;; Default to this bogus thing. (t (concat system-name ".i-did-not-set--mail-host-address--so-tickle-me"))))) (defun message-make-host-name () "Return the name of the host." (let ((fqdn (message-make-fqdn))) (string-match "^[^.]+\\." fqdn) (substring fqdn 0 (1- (match-end 0))))) (defun message-make-domain () "Return the domain name." (or mail-host-address (message-make-fqdn))) (defun message-to-list-only () "Send a message to the list only. Remove all addresses but the list address from To and Cc headers." (interactive) (let ((listaddr (message-make-mail-followup-to t))) (when listaddr (save-excursion (message-remove-header "to") (message-remove-header "cc") (message-position-on-field "To" "X-Draft-From") (insert listaddr))))) (defun message-make-mail-followup-to (&optional only-show-subscribed) "Return the Mail-Followup-To header. If passed the optional argument ONLY-SHOW-SUBSCRIBED only return the subscribed address (and not the additional To and Cc header contents)." (let* ((case-fold-search t) (to (message-fetch-field "To")) (cc (message-fetch-field "cc")) (msg-recipients (concat to (and to cc ", ") cc)) (recipients (mapcar 'mail-strip-quoted-names (message-tokenize-header msg-recipients))) (file-regexps (if message-subscribed-address-file (let (begin end item re) (save-excursion (with-temp-buffer (insert-file-contents message-subscribed-address-file) (while (not (eobp)) (setq begin (point)) (forward-line 1) (setq end (point)) (if (bolp) (setq end (1- end))) (setq item (regexp-quote (buffer-substring begin end))) (if re (setq re (concat re "\\|" item)) (setq re (concat "\\`\\(" item)))) (and re (list (concat re "\\)\\'")))))))) (mft-regexps (apply 'append message-subscribed-regexps (mapcar 'regexp-quote message-subscribed-addresses) file-regexps (mapcar 'funcall message-subscribed-address-functions)))) (save-match-data (let ((list (loop for recipient in recipients when (loop for regexp in mft-regexps when (string-match regexp recipient) return t) return recipient))) (when list (if only-show-subscribed list msg-recipients)))))) (defun message-idna-to-ascii-rhs-1 (header) "Interactively potentially IDNA encode domain names in HEADER." (let ((field (message-fetch-field header)) rhs ace address) (when field (dolist (rhs (mm-delete-duplicates (mapcar (lambda (rhs) (or (cadr (split-string rhs "@")) "")) (mapcar 'downcase (mapcar 'car (mail-header-parse-addresses field)))))) (setq ace (if (string-match "\\`[[:ascii:]]+\\'" rhs) rhs (downcase (idna-to-ascii rhs)))) (when (and (not (equal rhs ace)) (or (not (eq message-use-idna 'ask)) (y-or-n-p (format "Replace %s with %s in %s:? " rhs ace header)))) (goto-char (point-min)) (while (re-search-forward (concat "^" header ":") nil t) (message-narrow-to-field) (while (search-forward (concat "@" rhs) nil t) (replace-match (concat "@" ace) t t)) (goto-char (point-max)) (widen))))))) (defun message-idna-to-ascii-rhs () "Possibly IDNA encode non-ASCII domain names in From:, To: and Cc: headers. See `message-idna-encode'." (interactive) (when message-use-idna (save-excursion (save-restriction (message-narrow-to-head) (message-idna-to-ascii-rhs-1 "From") (message-idna-to-ascii-rhs-1 "To") (message-idna-to-ascii-rhs-1 "Reply-To") (message-idna-to-ascii-rhs-1 "Mail-Reply-To") (message-idna-to-ascii-rhs-1 "Mail-Followup-To") (message-idna-to-ascii-rhs-1 "Cc"))))) (defun message-generate-headers (headers) "Prepare article HEADERS. Headers already prepared in the buffer are not modified." (setq headers (append headers message-required-headers)) (save-restriction (message-narrow-to-headers) (let* ((Date (message-make-date)) (Message-ID (message-make-message-id)) (Organization (message-make-organization)) (From (message-make-from)) (Path (message-make-path)) (Subject nil) (Newsgroups nil) (In-Reply-To (message-make-in-reply-to)) (References (message-make-references)) (To nil) (Distribution (message-make-distribution)) (Lines (message-make-lines)) (User-Agent message-newsreader) (Expires (message-make-expires)) (case-fold-search t) (optionalp nil) header value elem header-string) ;; First we remove any old generated headers. (let ((headers message-deletable-headers)) (unless (buffer-modified-p) (setq headers (delq 'Message-ID (copy-sequence headers)))) (while headers (goto-char (point-min)) (and (re-search-forward (concat "^" (symbol-name (car headers)) ": *") nil t) (get-text-property (1+ (match-beginning 0)) 'message-deletable) (message-delete-line)) (pop headers))) ;; Go through all the required headers and see if they are in the ;; articles already. If they are not, or are empty, they are ;; inserted automatically - except for Subject, Newsgroups and ;; Distribution. (while headers (goto-char (point-min)) (setq elem (pop headers)) (if (consp elem) (if (eq (car elem) 'optional) (setq header (cdr elem) optionalp t) (setq header (car elem))) (setq header elem)) (setq header-string (if (stringp header) header (symbol-name header))) (when (or (not (re-search-forward (concat "^" (regexp-quote (downcase header-string)) ":") nil t)) (progn ;; The header was found. We insert a space after the ;; colon, if there is none. (if (/= (char-after) ? ) (insert " ") (forward-char 1)) ;; Find out whether the header is empty. (looking-at "[ \t]*\n[^ \t]"))) ;; So we find out what value we should insert. (setq value (cond ((and (consp elem) (eq (car elem) 'optional) (not (member header-string message-inserted-headers))) ;; This is an optional header. If the cdr of this ;; is something that is nil, then we do not insert ;; this header. (setq header (cdr elem)) (or (and (functionp (cdr elem)) (funcall (cdr elem))) (and (boundp (cdr elem)) (symbol-value (cdr elem))))) ((consp elem) ;; The element is a cons. Either the cdr is a ;; string to be inserted verbatim, or it is a ;; function, and we insert the value returned from ;; this function. (or (and (stringp (cdr elem)) (cdr elem)) (and (functionp (cdr elem)) (funcall (cdr elem))))) ((and (boundp header) (symbol-value header)) ;; The element is a symbol. We insert the value ;; of this symbol, if any. (symbol-value header)) ((not (message-check-element (intern (downcase (symbol-name header))))) ;; We couldn't generate a value for this header, ;; so we just ask the user. (read-from-minibuffer (format "Empty header for %s; enter value: " header))))) ;; Finally insert the header. (when (and value (not (equal value ""))) (save-excursion (if (bolp) (progn ;; This header didn't exist, so we insert it. (goto-char (point-max)) (let ((formatter (cdr (assq header message-header-format-alist)))) (if formatter (funcall formatter header value) (insert header-string ": " value)) (goto-char (message-fill-field)) ;; We check whether the value was ended by a ;; newline. If not, we insert one. (unless (bolp) (insert "\n")) (forward-line -1))) ;; The value of this header was empty, so we clear ;; totally and insert the new value. (delete-region (point) (point-at-eol)) ;; If the header is optional, and the header was ;; empty, we can't insert it anyway. (unless optionalp (push header-string message-inserted-headers) (insert value) (message-fill-field))) ;; Add the deletable property to the headers that require it. (and (memq header message-deletable-headers) (progn (beginning-of-line) (looking-at "[^:]+: ")) (add-text-properties (point) (match-end 0) '(message-deletable t face italic) (current-buffer))))))) ;; Insert new Sender if the From is strange. (let ((from (message-fetch-field "from")) (sender (message-fetch-field "sender")) (secure-sender (message-make-sender))) (when (and from (not (message-check-element 'sender)) (not (string= (downcase (cadr (mail-extract-address-components from))) (downcase secure-sender))) (or (null sender) (not (string= (downcase (cadr (mail-extract-address-components sender))) (downcase secure-sender))))) (goto-char (point-min)) ;; Rename any old Sender headers to Original-Sender. (when (re-search-forward "^\\(Original-\\)*Sender:" nil t) (beginning-of-line) (insert "Original-") (beginning-of-line)) (when (or (message-news-p) (string-match "@.+\\.." secure-sender)) (insert "Sender: " secure-sender "\n")))) ;; Check for IDNA (message-idna-to-ascii-rhs)))) (defun message-insert-courtesy-copy () "Insert a courtesy message in mail copies of combined messages." (let (newsgroups) (save-excursion (save-restriction (message-narrow-to-headers) (when (setq newsgroups (message-fetch-field "newsgroups")) (goto-char (point-max)) (insert "Posted-To: " newsgroups "\n"))) (forward-line 1) (when message-courtesy-message (cond ((string-match "%s" message-courtesy-message) (insert (format message-courtesy-message newsgroups))) (t (insert message-courtesy-message))))))) ;;; ;;; Setting up a message buffer ;;; (defun message-skip-to-next-address () (let ((end (save-excursion (message-next-header) (point))) quoted char) (when (looking-at ",") (forward-char 1)) (while (and (not (= (point) end)) (or (not (eq char ?,)) quoted)) (skip-chars-forward "^,\"" (point-max)) (when (eq (setq char (following-char)) ?\") (setq quoted (not quoted))) (unless (= (point) end) (forward-char 1))) (skip-chars-forward " \t\n"))) (defun message-fill-address (header value) (insert (capitalize (symbol-name header)) ": " (if (consp value) (car value) value) "\n") (message-fill-field-address)) (defun message-split-line () "Split current line, moving portion beyond point vertically down. If the current line has `message-yank-prefix', insert it on the new line." (interactive "*") (condition-case nil (split-line message-yank-prefix) ;; Emacs 22.1+ supports arg. (error (split-line)))) (defun message-insert-header (header value) (insert (capitalize (symbol-name header)) ": " (if (consp value) (car value) value))) (defun message-field-name () (save-excursion (goto-char (point-min)) (when (looking-at "\\([^:]+\\):") (intern (capitalize (match-string 1)))))) (defun message-fill-field () (save-excursion (save-restriction (message-narrow-to-field) (let ((field-name (message-field-name))) (funcall (or (cadr (assq field-name message-field-fillers)) 'message-fill-field-general))) (point-max)))) (defun message-fill-field-address () (while (not (eobp)) (message-skip-to-next-address) (let (last) (if (and (> (current-column) 78) last) (progn (save-excursion (goto-char last) (insert "\n\t")) (setq last (1+ (point)))) (setq last (1+ (point))))))) (defun message-fill-field-general () (let ((begin (point)) (fill-column 78) (fill-prefix "\t")) (while (and (search-forward "\n" nil t) (not (eobp))) (replace-match " " t t)) (fill-region-as-paragraph begin (point-max)) ;; Tapdance around looong Message-IDs. (forward-line -1) (when (looking-at "[ \t]*$") (message-delete-line)) (goto-char begin) (search-forward ":" nil t) (when (looking-at "\n[ \t]+") (replace-match " " t t)) (goto-char (point-max)))) (defun message-shorten-1 (list cut surplus) "Cut SURPLUS elements out of LIST, beginning with CUTth one." (setcdr (nthcdr (- cut 2) list) (nthcdr (+ (- cut 2) surplus 1) list))) (defun message-shorten-references (header references) "Trim REFERENCES to be 21 Message-ID long or less, and fold them. When sending via news, also check that the REFERENCES are less than 988 characters long, and if they are not, trim them until they are." (let ((maxcount 21) (count 0) (cut 2) refs) (with-temp-buffer (insert references) (goto-char (point-min)) ;; Cons a list of valid references. GNKSA says we must not include MIDs ;; with whitespace or missing brackets (7.a "Does not propagate broken ;; Message-IDs in original References"). (while (re-search-forward "<[^ <]+@[^ <]+>" nil t) (push (match-string 0) refs)) (setq refs (nreverse refs) count (length refs))) ;; If the list has more than MAXCOUNT elements, trim it by ;; removing the CUTth element and the required number of ;; elements that follow. (when (> count maxcount) (let ((surplus (- count maxcount))) (message-shorten-1 refs cut surplus) (decf count surplus))) ;; When sending via news, make sure the total folded length will ;; be less than 998 characters. This is to cater to broken INN ;; 2.3 which counts the total number of characters in a header ;; rather than the physical line length of each line, as it should. ;; ;; This hack should be removed when it's believed than INN 2.3 is ;; no longer widely used. ;; ;; At this point the headers have not been generated, thus we use ;; message-this-is-news directly. (when message-this-is-news (while (< 998 (with-temp-buffer (message-insert-header header (mapconcat #'identity refs " ")) (buffer-size))) (message-shorten-1 refs cut 1))) ;; Finally, collect the references back into a string and insert ;; it into the buffer. (message-insert-header header (mapconcat #'identity refs " ")))) (defun message-position-point () "Move point to where the user probably wants to find it." (message-narrow-to-headers) (cond ((re-search-forward "^[^:]+:[ \t]*$" nil t) (search-backward ":" ) (widen) (forward-char 1) (if (eq (char-after) ? ) (forward-char 1) (insert " "))) (t (goto-char (point-max)) (widen) (forward-line 1) (unless (looking-at "$") (forward-line 2))) (sit-for 0))) (defcustom message-beginning-of-line t "Whether \\\\[message-beginning-of-line]\ goes to beginning of header values." :version "22.1" :group 'message-buffers :link '(custom-manual "(message)Movement") :type 'boolean) (defun message-beginning-of-line (&optional n) "Move point to beginning of header value or to beginning of line. The prefix argument N is passed directly to `beginning-of-line'. This command is identical to `beginning-of-line' if point is outside the message header or if the option `message-beginning-of-line' is nil. If point is in the message header and on a (non-continued) header line, move point to the beginning of the header value or the beginning of line, whichever is closer. If point is already at beginning of line, move point to beginning of header value. Therefore, repeated calls will toggle point between beginning of field and beginning of line." (interactive "p") (let ((zrs 'zmacs-region-stays)) (when (and (featurep 'xemacs) (interactive-p) (boundp zrs)) (set zrs t))) (if (and message-beginning-of-line (message-point-in-header-p)) (let* ((here (point)) (bol (progn (beginning-of-line n) (point))) (eol (point-at-eol)) (eoh (re-search-forward ": *" eol t))) (goto-char (if (and eoh (or (< eoh here) (= bol here))) eoh bol))) (beginning-of-line n))) (defun message-buffer-name (type &optional to group) "Return a new (unique) buffer name based on TYPE and TO." (cond ;; Generate a new buffer name The Message Way. ((memq message-generate-new-buffers '(unique t)) (generate-new-buffer-name (concat "*" type (if to (concat " to " (or (car (mail-extract-address-components to)) to) "") "") (if (and group (not (string= group ""))) (concat " on " group) "") "*"))) ;; Check whether `message-generate-new-buffers' is a function, ;; and if so, call it. ((functionp message-generate-new-buffers) (funcall message-generate-new-buffers type to group)) ((eq message-generate-new-buffers 'unsent) (generate-new-buffer-name (concat "*unsent " type (if to (concat " to " (or (car (mail-extract-address-components to)) to) "") "") (if (and group (not (string= group ""))) (concat " on " group) "") "*"))) ;; Search for the existing message buffer with the specified name. (t (let* ((new (if (eq message-generate-new-buffers 'standard) (generate-new-buffer-name (concat "*" type " message*")) (let ((message-generate-new-buffers 'unique)) (message-buffer-name type to group)))) (regexp (concat "\\`" (regexp-quote (if (string-match "<[0-9]+>\\'" new) (substring new 0 (match-beginning 0)) new)) "\\(?:<\\([0-9]+\\)>\\)?\\'")) (case-fold-search nil)) (or (cdar (last (sort (delq nil (mapcar (lambda (b) (when (and (string-match regexp (setq b (buffer-name b))) (eq (with-current-buffer b major-mode) 'message-mode)) (cons (string-to-number (or (match-string 1 b) "1")) b))) (buffer-list))) 'car-less-than-car))) new))))) (defun message-pop-to-buffer (name &optional switch-function) "Pop to buffer NAME, and warn if it already exists and is modified." (let ((buffer (get-buffer name))) (if (and buffer (buffer-name buffer)) (let ((window (get-buffer-window buffer 0))) (if window ;; Raise the frame already displaying the message buffer. (progn (gnus-select-frame-set-input-focus (window-frame window)) (select-window window)) (funcall (or switch-function 'pop-to-buffer) buffer) (set-buffer buffer)) (when (and (buffer-modified-p) (not (prog1 (y-or-n-p "Message already being composed; erase? ") (message nil)))) (error "Message being composed"))) (funcall (or switch-function 'pop-to-buffer) name) (set-buffer name)) (erase-buffer) (message-mode))) (defun message-do-send-housekeeping () "Kill old message buffers." ;; We might have sent this buffer already. Delete it from the ;; list of buffers. (setq message-buffer-list (delq (current-buffer) message-buffer-list)) (while (and message-max-buffers message-buffer-list (>= (length message-buffer-list) message-max-buffers)) ;; Kill the oldest buffer -- unless it has been changed. (let ((buffer (pop message-buffer-list))) (when (and (buffer-name buffer) (not (buffer-modified-p buffer))) (kill-buffer buffer)))) ;; Rename the buffer. (if message-send-rename-function (funcall message-send-rename-function) ;; Note: mail-abbrevs of XEmacs renames buffer name behind Gnus. (when (string-match "\\`\\*\\(sent \\|unsent \\)?\\(.+\\)\\*[^\\*]*\\|\\`mail to " (buffer-name)) (let ((name (match-string 2 (buffer-name))) to group) (if (not (or (null name) (string-equal name "mail") (string-equal name "posting"))) (setq name (concat "*sent " name "*")) (message-narrow-to-headers) (setq to (message-fetch-field "to")) (setq group (message-fetch-field "newsgroups")) (widen) (setq name (cond (to (concat "*sent mail to " (or (car (mail-extract-address-components to)) to) "*")) ((and group (not (string= group ""))) (concat "*sent posting on " group "*")) (t "*sent mail*")))) (unless (string-equal name (buffer-name)) (rename-buffer name t))))) ;; Push the current buffer onto the list. (when message-max-buffers (setq message-buffer-list (nconc message-buffer-list (list (current-buffer)))))) (defun message-mail-user-agent () (let ((mua (cond ((not message-mail-user-agent) nil) ((eq message-mail-user-agent t) mail-user-agent) (t message-mail-user-agent)))) (if (memq mua '(message-user-agent gnus-user-agent)) nil mua))) (defun message-setup (headers &optional replybuffer actions continue switch-function) (let ((mua (message-mail-user-agent)) subject to field yank-action) (if (not (and message-this-is-mail mua)) (message-setup-1 headers replybuffer actions) (if replybuffer (setq yank-action (list 'insert-buffer replybuffer))) (setq headers (copy-sequence headers)) (setq field (assq 'Subject headers)) (when field (setq subject (cdr field)) (setq headers (delq field headers))) (setq field (assq 'To headers)) (when field (setq to (cdr field)) (setq headers (delq field headers))) (let ((mail-user-agent mua)) (compose-mail to subject (mapcar (lambda (item) (cons (format "%s" (car item)) (cdr item))) headers) continue switch-function yank-action actions))))) (defun message-headers-to-generate (headers included-headers excluded-headers) "Return a list that includes all headers from HEADERS. If INCLUDED-HEADERS is a list, just include those headers. If it is t, include all headers. In any case, headers from EXCLUDED-HEADERS are not included." (let ((result nil) header-name) (dolist (header headers) (setq header-name (cond ((and (consp header) (eq (car header) 'optional)) ;; On the form (optional . Header) (cdr header)) ((consp header) ;; On the form (Header . function) (car header)) (t ;; Just a Header. header))) (when (and (not (memq header-name excluded-headers)) (or (eq included-headers t) (memq header-name included-headers))) (push header result))) (nreverse result))) (defun message-setup-1 (headers &optional replybuffer actions) (dolist (action actions) (condition-case nil (add-to-list 'message-send-actions `(apply ',(car action) ',(cdr action))))) (setq message-reply-buffer replybuffer) (goto-char (point-min)) ;; Insert all the headers. (mail-header-format (let ((h headers) (alist message-header-format-alist)) (while h (unless (assq (caar h) message-header-format-alist) (push (list (caar h)) alist)) (pop h)) alist) headers) (delete-region (point) (progn (forward-line -1) (point))) (when message-default-headers (insert message-default-headers) (or (bolp) (insert ?\n))) (insert mail-header-separator "\n") (forward-line -1) (when (message-news-p) (when message-default-news-headers (insert message-default-news-headers) (or (bolp) (insert ?\n))) (when message-generate-headers-first (message-generate-headers (message-headers-to-generate (append message-required-news-headers message-required-headers) message-generate-headers-first '(Lines Subject))))) (when (message-mail-p) (when message-default-mail-headers (insert message-default-mail-headers) (or (bolp) (insert ?\n))) (when message-generate-headers-first (message-generate-headers (message-headers-to-generate (append message-required-mail-headers message-required-headers) message-generate-headers-first '(Lines Subject))))) (run-hooks 'message-signature-setup-hook) (message-insert-signature) (save-restriction (message-narrow-to-headers) (run-hooks 'message-header-setup-hook)) (setq buffer-undo-list nil) (when message-generate-hashcash ;; Generate hashcash headers for recipients already known (mail-add-payment-async)) ;; Gnus posting styles are applied via buffer-local `message-setup-hook' ;; values. (run-hooks 'message-setup-hook) ;; Do this last to give it precedence over posting styles, etc. (when (message-mail-p) (save-restriction (message-narrow-to-headers) (if message-alternative-emails (message-use-alternative-email-as-from)))) (message-position-point) ;; Allow correct handling of `message-checksum' in `message-yank-original': (set-buffer-modified-p nil) (undo-boundary)) (defun message-set-auto-save-file-name () "Associate the message buffer with a file in the drafts directory." (when message-auto-save-directory (unless (file-directory-p (directory-file-name message-auto-save-directory)) (make-directory message-auto-save-directory t)) (if (gnus-alive-p) (setq message-draft-article (nndraft-request-associate-buffer "drafts")) (setq buffer-file-name (expand-file-name (if (memq system-type '(ms-dos ms-windows windows-nt cygwin cygwin32 win32 w32 mswindows)) "message" "*message*") message-auto-save-directory)) (setq buffer-auto-save-file-name (make-auto-save-file-name))) (clear-visited-file-modtime) (setq buffer-file-coding-system message-draft-coding-system))) (defun message-disassociate-draft () "Disassociate the message buffer from the drafts directory." (when message-draft-article (nndraft-request-expire-articles (list message-draft-article) "nndraft:drafts" nil t))) (defun message-insert-headers () "Generate the headers for the article." (interactive) (save-excursion (save-restriction (message-narrow-to-headers) (when (message-news-p) (message-generate-headers (delq 'Lines (delq 'Subject (copy-sequence message-required-news-headers))))) (when (message-mail-p) (message-generate-headers (delq 'Lines (delq 'Subject (copy-sequence message-required-mail-headers)))))))) ;;; ;;; Commands for interfacing with message ;;; ;;;###autoload (defun message-mail (&optional to subject other-headers continue switch-function yank-action send-actions) "Start editing a mail message to be sent. OTHER-HEADERS is an alist of header/value pairs. CONTINUE says whether to continue editing a message already being composed. SWITCH-FUNCTION is a function used to switch to and display the mail buffer." (interactive) (let ((message-this-is-mail t) replybuffer) (unless (message-mail-user-agent) (message-pop-to-buffer ;; Search for the existing message buffer if `continue' is non-nil. (let ((message-generate-new-buffers (when (or (not continue) (eq message-generate-new-buffers 'standard) (functionp message-generate-new-buffers)) message-generate-new-buffers))) (message-buffer-name "mail" to)) switch-function)) ;; FIXME: message-mail should do something if YANK-ACTION is not ;; insert-buffer. (and (consp yank-action) (eq (car yank-action) 'insert-buffer) (setq replybuffer (nth 1 yank-action))) (message-setup (nconc `((To . ,(or to "")) (Subject . ,(or subject ""))) (when other-headers other-headers)) replybuffer send-actions continue switch-function) ;; FIXME: Should return nil if failure. t)) ;;;###autoload (defun message-news (&optional newsgroups subject) "Start editing a news article to be sent." (interactive) (let ((message-this-is-news t)) (message-pop-to-buffer (message-buffer-name "posting" nil newsgroups)) (message-setup `((Newsgroups . ,(or newsgroups "")) (Subject . ,(or subject "")))))) (defun message-alter-recipients-discard-bogus-full-name (addrcell) "Discard mail address in full names. When the full name in reply headers contains the mail address (e.g. \"foo@bar \"), discard full name. ADDRCELL is a cons cell where the car is the mail address and the cdr is the complete address (full name and mail address)." (if (string-match (concat (regexp-quote (car addrcell)) ".*" (regexp-quote (car addrcell))) (cdr addrcell)) (cons (car addrcell) (car addrcell)) addrcell)) (defcustom message-alter-recipients-function nil "Function called to allow alteration of reply header structures. It is called in `message-get-reply-headers' for each recipient. The function is called with one parameter, a cons cell ..." :type '(choice (const :tag "None" nil) (const :tag "Discard bogus full name" message-alter-recipients-discard-bogus-full-name) function) :version "23.1" ;; No Gnus :group 'message-headers) (defun message-get-reply-headers (wide &optional to-address address-headers) (let (follow-to mct never-mct to cc author mft recipients extra) ;; Find all relevant headers we need. (save-restriction (message-narrow-to-headers-or-head) ;; Gmane renames "To". Look at "Original-To", too, if it is present in ;; message-header-synonyms. (setq to (or (message-fetch-field "to") (and (loop for synonym in message-header-synonyms when (memq 'Original-To synonym) return t) (message-fetch-field "original-to"))) cc (message-fetch-field "cc") extra (when message-extra-wide-headers (mapconcat 'identity (mapcar 'message-fetch-field message-extra-wide-headers) ", ")) mct (message-fetch-field "mail-copies-to") author (or (message-fetch-field "mail-reply-to") (message-fetch-field "reply-to") (message-fetch-field "from") "") mft (and message-use-mail-followup-to (message-fetch-field "mail-followup-to")))) ;; Handle special values of Mail-Copies-To. (when mct (cond ((or (equal (downcase mct) "never") (equal (downcase mct) "nobody")) (setq never-mct t) (setq mct nil)) ((or (equal (downcase mct) "always") (equal (downcase mct) "poster")) (setq mct author)))) (save-match-data ;; Build (textual) list of new recipient addresses. (cond ((not wide) (setq recipients (concat ", " author))) (address-headers (dolist (header address-headers) (let ((value (message-fetch-field header))) (when value (setq recipients (concat recipients ", " value)))))) ((and mft (string-match "[^ \t,]" mft) (or (not (eq message-use-mail-followup-to 'ask)) (message-y-or-n-p "Obey Mail-Followup-To? " t "\ You should normally obey the Mail-Followup-To: header. In this article, it has the value of " mft " which directs your response to " (if (string-match "," mft) "the specified addresses" "that address only") ". Most commonly, Mail-Followup-To is used by a mailing list poster to express that responses should be sent to just the list, and not the poster as well. If a message is posted to several mailing lists, Mail-Followup-To may also be used to direct the following discussion to one list only, because discussions that are spread over several lists tend to be fragmented and very difficult to follow. Also, some source/announcement lists are not intended for discussion; responses here are directed to other addresses. You may customize the variable `message-use-mail-followup-to', if you want to get rid of this query permanently."))) (setq recipients (concat ", " mft))) (to-address (setq recipients (concat ", " to-address)) ;; If the author explicitly asked for a copy, we don't deny it to them. (if mct (setq recipients (concat recipients ", " mct)))) (t (setq recipients (if never-mct "" (concat ", " author))) (if to (setq recipients (concat recipients ", " to))) (if cc (setq recipients (concat recipients ", " cc))) (if extra (setq recipients (concat recipients ", " extra))) (if mct (setq recipients (concat recipients ", " mct))))) (if (>= (length recipients) 2) ;; Strip the leading ", ". (setq recipients (substring recipients 2))) ;; Squeeze whitespace. (while (string-match "[ \t][ \t]+" recipients) (setq recipients (replace-match " " t t recipients))) ;; Remove addresses that match `rmail-dont-reply-to-names'. (let ((rmail-dont-reply-to-names (message-dont-reply-to-names))) (setq recipients (rmail-dont-reply-to recipients))) ;; Perhaps "Mail-Copies-To: never" removed the only address? (if (string-equal recipients "") (setq recipients author)) ;; Convert string to a list of (("foo@bar" . "Name ") ...). (setq recipients (mapcar (lambda (addr) (if message-alter-recipients-function (funcall message-alter-recipients-function (cons (downcase (mail-strip-quoted-names addr)) addr)) (cons (downcase (mail-strip-quoted-names addr)) addr))) (message-tokenize-header recipients))) ;; Remove first duplicates. (Why not all duplicates? Is this a bug?) (let ((s recipients)) (while s (setq recipients (delq (assoc (car (pop s)) s) recipients)))) ;; Remove hierarchical lists that are contained within each other, ;; if message-hierarchical-addresses is defined. (when message-hierarchical-addresses (let ((plain-addrs (mapcar 'car recipients)) subaddrs recip) (while plain-addrs (setq subaddrs (assoc (car plain-addrs) message-hierarchical-addresses) plain-addrs (cdr plain-addrs)) (when subaddrs (setq subaddrs (cdr subaddrs)) (while subaddrs (setq recip (assoc (car subaddrs) recipients) subaddrs (cdr subaddrs)) (if recip (setq recipients (delq recip recipients)))))))) ;; Build the header alist. Allow the user to be asked whether ;; or not to reply to all recipients in a wide reply. (setq follow-to (list (cons 'To (cdr (pop recipients))))) (when (and recipients (or (not message-wide-reply-confirm-recipients) (y-or-n-p "Reply to all recipients? "))) (setq recipients (mapconcat (lambda (addr) (cdr addr)) recipients ", ")) (if (string-match "^ +" recipients) (setq recipients (substring recipients (match-end 0)))) (push (cons 'Cc recipients) follow-to))) follow-to)) (defcustom message-simplify-subject-functions '(message-strip-list-identifiers message-strip-subject-re message-strip-subject-trailing-was message-strip-subject-encoded-words) "List of functions taking a string argument that simplify subjects. The functions are applied when replying to a message. Useful functions to put in this list include: `message-strip-list-identifiers', `message-strip-subject-re', `message-strip-subject-trailing-was', and `message-strip-subject-encoded-words'." :version "22.1" ;; Gnus 5.10.9 :group 'message-various :type '(repeat function)) (defun message-simplify-subject (subject &optional functions) "Return simplified SUBJECT." (unless functions ;; Simplify fully: (setq functions message-simplify-subject-functions)) (when (and (memq 'message-strip-list-identifiers functions) gnus-list-identifiers) (setq subject (message-strip-list-identifiers subject))) (when (memq 'message-strip-subject-re functions) (setq subject (concat "Re: " (message-strip-subject-re subject)))) (when (and (memq 'message-strip-subject-trailing-was functions) message-subject-trailing-was-query) (setq subject (message-strip-subject-trailing-was subject))) (when (memq 'message-strip-subject-encoded-words functions) (setq subject (message-strip-subject-encoded-words subject))) subject) ;;;###autoload (defun message-reply (&optional to-address wide) "Start editing a reply to the article in the current buffer." (interactive) (require 'gnus-sum) ; for gnus-list-identifiers (let ((cur (current-buffer)) from subject date reply-to to cc references message-id follow-to (inhibit-point-motion-hooks t) (message-this-is-mail t) gnus-warning) (save-restriction (message-narrow-to-head-1) ;; Allow customizations to have their say. (if (not wide) ;; This is a regular reply. (when (functionp message-reply-to-function) (save-excursion (setq follow-to (funcall message-reply-to-function)))) ;; This is a followup. (when (functionp message-wide-reply-to-function) (save-excursion (setq follow-to (funcall message-wide-reply-to-function))))) (setq message-id (message-fetch-field "message-id" t) references (message-fetch-field "references") date (message-fetch-field "date") from (or (message-fetch-field "from") "nobody") subject (or (message-fetch-field "subject") "none")) ;; Strip list identifiers, "Re: ", and "was:" (setq subject (message-simplify-subject subject)) (when (and (setq gnus-warning (message-fetch-field "gnus-warning")) (string-match "<[^>]+>" gnus-warning)) (setq message-id (match-string 0 gnus-warning))) (unless follow-to (setq follow-to (message-get-reply-headers wide to-address)))) (unless (message-mail-user-agent) (message-pop-to-buffer (message-buffer-name (if wide "wide reply" "reply") from (if wide to-address nil)))) (setq message-reply-headers (vector 0 subject from date message-id references 0 0 "")) (message-setup `((Subject . ,subject) ,@follow-to) cur))) ;;;###autoload (defun message-wide-reply (&optional to-address) "Make a \"wide\" reply to the message in the current buffer." (interactive) (message-reply to-address t)) ;;;###autoload (defun message-followup (&optional to-newsgroups) "Follow up to the message in the current buffer. If TO-NEWSGROUPS, use that as the new Newsgroups line." (interactive) (require 'gnus-sum) ; for gnus-list-identifiers (let ((cur (current-buffer)) from subject date reply-to mrt mct references message-id follow-to (inhibit-point-motion-hooks t) (message-this-is-news t) followup-to distribution newsgroups gnus-warning posted-to) (save-restriction (narrow-to-region (goto-char (point-min)) (if (search-forward "\n\n" nil t) (1- (point)) (point-max))) (when (functionp message-followup-to-function) (setq follow-to (funcall message-followup-to-function))) (setq from (message-fetch-field "from") date (message-fetch-field "date") subject (or (message-fetch-field "subject") "none") references (message-fetch-field "references") message-id (message-fetch-field "message-id" t) followup-to (message-fetch-field "followup-to") newsgroups (message-fetch-field "newsgroups") posted-to (message-fetch-field "posted-to") reply-to (message-fetch-field "reply-to") mrt (message-fetch-field "mail-reply-to") distribution (message-fetch-field "distribution") mct (message-fetch-field "mail-copies-to")) (when (and (setq gnus-warning (message-fetch-field "gnus-warning")) (string-match "<[^>]+>" gnus-warning)) (setq message-id (match-string 0 gnus-warning))) ;; Remove bogus distribution. (when (and (stringp distribution) (let ((case-fold-search t)) (string-match "world" distribution))) (setq distribution nil)) ;; Strip list identifiers, "Re: ", and "was:" (setq subject (message-simplify-subject subject)) (widen)) (message-pop-to-buffer (message-buffer-name "followup" from newsgroups)) (setq message-reply-headers (vector 0 subject from date message-id references 0 0 "")) (message-setup `((Subject . ,subject) ,@(cond (to-newsgroups (list (cons 'Newsgroups to-newsgroups))) (follow-to follow-to) ((and followup-to message-use-followup-to) (list (cond ((equal (downcase followup-to) "poster") (if (or (eq message-use-followup-to 'use) (message-y-or-n-p "Obey Followup-To: poster? " t "\ You should normally obey the Followup-To: header. `Followup-To: poster' sends your response via e-mail instead of news. A typical situation where `Followup-To: poster' is used is when the poster does not read the newsgroup, so he wouldn't see any replies sent to it. You may customize the variable `message-use-followup-to', if you want to get rid of this query permanently.")) (progn (setq message-this-is-news nil) (cons 'To (or mrt reply-to from ""))) (cons 'Newsgroups newsgroups))) (t (if (or (equal followup-to newsgroups) (not (eq message-use-followup-to 'ask)) (message-y-or-n-p (concat "Obey Followup-To: " followup-to "? ") t "\ You should normally obey the Followup-To: header. `Followup-To: " followup-to "' directs your response to " (if (string-match "," followup-to) "the specified newsgroups" "that newsgroup only") ". If a message is posted to several newsgroups, Followup-To is often used to direct the following discussion to one newsgroup only, because discussions that are spread over several newsgroup tend to be fragmented and very difficult to follow. Also, some source/announcement newsgroups are not intended for discussion; responses here are directed to other newsgroups. You may customize the variable `message-use-followup-to', if you want to get rid of this query permanently.")) (cons 'Newsgroups followup-to) (cons 'Newsgroups newsgroups)))))) (posted-to `((Newsgroups . ,posted-to))) (t `((Newsgroups . ,newsgroups)))) ,@(and distribution (list (cons 'Distribution distribution))) ,@(when (and mct (not (or (equal (downcase mct) "never") (equal (downcase mct) "nobody")))) (list (cons 'Cc (if (or (equal (downcase mct) "always") (equal (downcase mct) "poster")) (or mrt reply-to from "") mct))))) cur))) (defun message-is-yours-p () "Non-nil means current article is yours. If you have added 'cancel-messages to `message-shoot-gnksa-feet', all articles are yours except those that have Cancel-Lock header not belonging to you. Instead of shooting GNKSA feet, you should modify `message-alternative-emails' regexp to match all of yours addresses." ;; Canlock-logic as suggested by Per Abrahamsen ;; ;; ;; IF article has cancel-lock THEN ;; IF we can verify it THEN ;; issue cancel ;; ELSE ;; error: cancellock: article is not yours ;; ELSE ;; Use old rules, comparing sender... (save-excursion (save-restriction (message-narrow-to-head-1) (if (message-fetch-field "Cancel-Lock") (if (null (canlock-verify)) t (error "Failed to verify Cancel-lock: This article is not yours")) (let (sender from) (or (message-gnksa-enable-p 'cancel-messages) (and (setq sender (message-fetch-field "sender")) (string-equal (downcase sender) (downcase (message-make-sender)))) ;; Email address in From field equals to our address (and (setq from (message-fetch-field "from")) (string-equal (downcase (car (mail-header-parse-address from))) (downcase (car (mail-header-parse-address (message-make-from)))))) ;; Email address in From field matches ;; 'message-alternative-emails' regexp (and from message-alternative-emails (string-match message-alternative-emails (car (mail-header-parse-address from)))))))))) ;;;###autoload (defun message-cancel-news (&optional arg) "Cancel an article you posted. If ARG, allow editing of the cancellation message." (interactive "P") (unless (message-news-p) (error "This is not a news article; canceling is impossible")) (let (from newsgroups message-id distribution buf) (save-excursion ;; Get header info from original article. (save-restriction (message-narrow-to-head-1) (setq from (message-fetch-field "from") newsgroups (message-fetch-field "newsgroups") message-id (message-fetch-field "message-id" t) distribution (message-fetch-field "distribution"))) ;; Make sure that this article was written by the user. (unless (message-is-yours-p) (error "This article is not yours")) (when (yes-or-no-p "Do you really want to cancel this article? ") ;; Make control message. (if arg (message-news) (setq buf (set-buffer (get-buffer-create " *message cancel*")))) (erase-buffer) (insert "Newsgroups: " newsgroups "\n" "From: " from "\n" "Subject: cmsg cancel " message-id "\n" "Control: cancel " message-id "\n" (if distribution (concat "Distribution: " distribution "\n") "") mail-header-separator "\n" message-cancel-message) (run-hooks 'message-cancel-hook) (unless arg (message "Canceling your article...") (if (let ((message-syntax-checks 'dont-check-for-anything-just-trust-me)) (funcall message-send-news-function)) (message "Canceling your article...done")) (kill-buffer buf)))))) ;;;###autoload (defun message-supersede () "Start composing a message to supersede the current message. This is done simply by taking the old article and adding a Supersedes header line with the old Message-ID." (interactive) (let ((cur (current-buffer))) ;; Check whether the user owns the article that is to be superseded. (unless (message-is-yours-p) (error "This article is not yours")) ;; Get a normal message buffer. (message-pop-to-buffer (message-buffer-name "supersede")) (insert-buffer-substring cur) (mime-to-mml) (message-narrow-to-head-1) ;; Remove unwanted headers. (when message-ignored-supersedes-headers (message-remove-header message-ignored-supersedes-headers t)) (goto-char (point-min)) (if (not (re-search-forward "^Message-ID: " nil t)) (error "No Message-ID in this article") (replace-match "Supersedes: " t t)) (goto-char (point-max)) (insert mail-header-separator) (widen) (forward-line 1))) ;;;###autoload (defun message-recover () "Reread contents of current buffer from its last auto-save file." (interactive) (let ((file-name (make-auto-save-file-name))) (cond ((save-window-excursion (if (not (eq system-type 'vax-vms)) (with-output-to-temp-buffer "*Directory*" (with-current-buffer standard-output (fundamental-mode)) ; for Emacs 20.4+ (buffer-disable-undo standard-output) (let ((default-directory "/")) (call-process "ls" nil standard-output nil "-l" file-name)))) (yes-or-no-p (format "Recover auto save file %s? " file-name))) (let ((buffer-read-only nil)) (erase-buffer) (insert-file-contents file-name nil))) (t (error "message-recover cancelled"))))) ;;; Washing Subject: (defun message-wash-subject (subject) "Remove junk like \"Re:\", \"(fwd)\", etc. added to subject string SUBJECT. Previous forwarders, replyers, etc. may add it." (with-temp-buffer (insert subject) (goto-char (point-min)) ;; strip Re/Fwd stuff off the beginning (while (re-search-forward "\\([Rr][Ee]:\\|[Ff][Ww][Dd]\\(\\[[0-9]*\\]\\)?:\\|[Ff][Ww]:\\)" nil t) (replace-match "")) ;; and gnus-style forwards [foo@bar.com] subject (goto-char (point-min)) (while (re-search-forward "\\[[^ \t]*\\(@\\|\\.\\)[^ \t]*\\]" nil t) (replace-match "")) ;; and off the end (goto-char (point-max)) (while (re-search-backward "([Ff][Ww][Dd])" nil t) (replace-match "")) ;; and finally, any whitespace that was left-over (goto-char (point-min)) (while (re-search-forward "^[ \t]+" nil t) (replace-match "")) (goto-char (point-max)) (while (re-search-backward "[ \t]+$" nil t) (replace-match "")) (buffer-string))) ;;; Forwarding messages. (defvar message-forward-decoded-p nil "Non-nil means the original message is decoded.") (defun message-forward-subject-name-subject (subject) "Generate a SUBJECT for a forwarded message. The form is: [Source] Subject, where if the original message was mail, Source is the name of the sender, and if the original message was news, Source is the list of newsgroups is was posted to." (let* ((group (message-fetch-field "newsgroups")) (from (message-fetch-field "from")) (prefix (if group (gnus-group-decoded-name group) (or (and from (or (car (gnus-extract-address-components from)) (cadr (gnus-extract-address-components from)))) "(nowhere)")))) (concat "[" (if message-forward-decoded-p prefix (mail-decode-encoded-word-string prefix)) "] " subject))) (defun message-forward-subject-author-subject (subject) "Generate a SUBJECT for a forwarded message. The form is: [Source] Subject, where if the original message was mail, Source is the sender, and if the original message was news, Source is the list of newsgroups is was posted to." (let* ((group (message-fetch-field "newsgroups")) (prefix (if group (gnus-group-decoded-name group) (or (message-fetch-field "from") "(nowhere)")))) (concat "[" (if message-forward-decoded-p prefix (mail-decode-encoded-word-string prefix)) "] " subject))) (defun message-forward-subject-fwd (subject) "Generate a SUBJECT for a forwarded message. The form is: Fwd: Subject, where Subject is the original subject of the message." (if (string-match "^Fwd: " subject) subject (concat "Fwd: " subject))) (defun message-make-forward-subject () "Return a Subject header suitable for the message in the current buffer." (save-excursion (save-restriction (message-narrow-to-head-1) (let ((funcs message-make-forward-subject-function) (subject (message-fetch-field "Subject"))) (setq subject (if subject (if message-forward-decoded-p subject (mail-decode-encoded-word-string subject)) "")) (when message-wash-forwarded-subjects (setq subject (message-wash-subject subject))) ;; Make sure funcs is a list. (and funcs (not (listp funcs)) (setq funcs (list funcs))) ;; Apply funcs in order, passing subject generated by previous ;; func to the next one. (dolist (func funcs) (when (functionp func) (setq subject (funcall func subject)))) subject)))) (defvar gnus-article-decoded-p) ;;;###autoload (defun message-forward (&optional news digest) "Forward the current message via mail. Optional NEWS will use news to forward instead of mail. Optional DIGEST will use digest to forward." (interactive "P") (let* ((cur (current-buffer)) (message-forward-decoded-p (if (local-variable-p 'gnus-article-decoded-p (current-buffer)) gnus-article-decoded-p ;; In an article buffer. message-forward-decoded-p)) (subject (message-make-forward-subject))) (if news (message-news nil subject) (message-mail nil subject)) (message-forward-make-body cur digest))) (defun message-forward-make-body-plain (forward-buffer) (insert "\n-------------------- Start of forwarded message --------------------\n") (let ((b (point)) e) (insert (with-temp-buffer (mm-disable-multibyte) (insert (with-current-buffer forward-buffer (mm-with-unibyte-current-buffer (buffer-string)))) (mm-enable-multibyte) (mime-to-mml) (goto-char (point-min)) (when (looking-at "From ") (replace-match "X-From-Line: ")) (buffer-string))) (setq e (point)) (insert "\n-------------------- End of forwarded message --------------------\n") (message-remove-ignored-headers b e))) (defun message-remove-ignored-headers (b e) (when message-forward-ignored-headers (save-restriction (narrow-to-region b e) (goto-char b) (narrow-to-region (point) (or (search-forward "\n\n" nil t) (point))) (let ((ignored (if (stringp message-forward-ignored-headers) (list message-forward-ignored-headers) message-forward-ignored-headers))) (dolist (elem ignored) (message-remove-header elem t)))))) (defun message-forward-make-body-mime (forward-buffer) (let ((b (point))) (insert "\n\n<#part type=message/rfc822 disposition=inline raw=t>\n") (save-restriction (narrow-to-region (point) (point)) (mml-insert-buffer forward-buffer) (goto-char (point-min)) (when (looking-at "From ") (replace-match "X-From-Line: ")) (goto-char (point-max))) (insert "<#/part>\n") ;; Consider there is no illegible text. (add-text-properties b (point) `(no-illegible-text t rear-nonsticky t start-open t)))) (defun message-forward-make-body-mml (forward-buffer) (insert "\n\n<#mml type=message/rfc822 disposition=inline>\n") (let ((b (point)) e) (if (not message-forward-decoded-p) (insert (with-temp-buffer (mm-disable-multibyte) (insert (with-current-buffer forward-buffer (mm-with-unibyte-current-buffer (buffer-string)))) (mm-enable-multibyte) (mime-to-mml) (goto-char (point-min)) (when (looking-at "From ") (replace-match "X-From-Line: ")) (buffer-string))) (save-restriction (narrow-to-region (point) (point)) (mml-insert-buffer forward-buffer) (goto-char (point-min)) (when (looking-at "From ") (replace-match "X-From-Line: ")) (goto-char (point-max)))) (setq e (point)) (insert "<#/mml>\n") (when (and (not message-forward-decoded-p) message-forward-ignored-headers) (message-remove-ignored-headers b e)))) (defun message-forward-make-body-digest-plain (forward-buffer) (insert "\n-------------------- Start of forwarded message --------------------\n") (let ((b (point)) e) (mml-insert-buffer forward-buffer) (setq e (point)) (insert "\n-------------------- End of forwarded message --------------------\n"))) (defun message-forward-make-body-digest-mime (forward-buffer) (insert "\n<#multipart type=digest>\n") (let ((b (point)) e) (insert-buffer-substring forward-buffer) (setq e (point)) (insert "<#/multipart>\n") (save-restriction (narrow-to-region b e) (goto-char b) (narrow-to-region (point) (or (search-forward "\n\n" nil t) (point))) (delete-region (point-min) (point-max))))) (defun message-forward-make-body-digest (forward-buffer) (if message-forward-as-mime (message-forward-make-body-digest-mime forward-buffer) (message-forward-make-body-digest-plain forward-buffer))) (eval-and-compile (autoload 'mm-uu-dissect-text-parts "mm-uu") (autoload 'mm-uu-dissect "mm-uu")) (defun message-signed-or-encrypted-p (&optional dont-emulate-mime handles) "Say whether the current buffer contains signed or encrypted message. If DONT-EMULATE-MIME is nil, this function does the MIME emulation on messages that don't conform to PGP/MIME described in RFC2015. HANDLES is for the internal use." (unless handles (let ((mm-decrypt-option 'never) (mm-verify-option 'never)) (if (setq handles (mm-dissect-buffer nil t)) (unless dont-emulate-mime (mm-uu-dissect-text-parts handles)) (unless dont-emulate-mime (setq handles (mm-uu-dissect)))))) ;; Check text/plain message in which there is a signed or encrypted ;; body that has been encoded by B or Q. (unless (or handles dont-emulate-mime) (let ((cur (current-buffer)) (mm-decrypt-option 'never) (mm-verify-option 'never)) (with-temp-buffer (insert-buffer-substring cur) (when (setq handles (mm-dissect-buffer t t)) (if (and (prog1 (bufferp (car handles)) (mm-destroy-parts handles)) (equal (mm-handle-media-type handles) "text/plain")) (progn (mm-decode-content-transfer-encoding (mm-handle-encoding handles)) (setq handles (mm-uu-dissect))) (setq handles nil)))))) (when handles (prog1 (catch 'found (dolist (handle (if (stringp (car handles)) (if (member (car handles) '("multipart/signed" "multipart/encrypted")) (throw 'found t) (cdr handles)) (list handles))) (if (stringp (car handle)) (when (message-signed-or-encrypted-p dont-emulate-mime handle) (throw 'found t)) (when (and (bufferp (car handle)) (equal (mm-handle-media-type handle) "message/rfc822")) (with-current-buffer (mm-handle-buffer handle) (when (message-signed-or-encrypted-p dont-emulate-mime) (throw 'found t))))))) (mm-destroy-parts handles)))) ;;;###autoload (defun message-forward-make-body (forward-buffer &optional digest) ;; Put point where we want it before inserting the forwarded ;; message. (if message-forward-before-signature (message-goto-body) (goto-char (point-max))) (if digest (message-forward-make-body-digest forward-buffer) (if message-forward-as-mime (if (and message-forward-show-mml (not (and (eq message-forward-show-mml 'best) ;; Use the raw form in the body if it contains ;; signed or encrypted message so as not to be ;; destroyed by re-encoding. (with-current-buffer forward-buffer (condition-case nil (message-signed-or-encrypted-p) (error t)))))) (message-forward-make-body-mml forward-buffer) (message-forward-make-body-mime forward-buffer)) (message-forward-make-body-plain forward-buffer))) (message-position-point)) ;;;###autoload (defun message-forward-rmail-make-body (forward-buffer) (save-window-excursion (set-buffer forward-buffer) (if (rmail-msg-is-pruned) (rmail-msg-restore-non-pruned-header))) (message-forward-make-body forward-buffer)) ;; Fixme: Should have defcustom. ;;;###autoload (defun message-insinuate-rmail () "Let RMAIL use message to forward." (interactive) (setq rmail-enable-mime-composing t) (setq rmail-insert-mime-forwarded-message-function 'message-forward-rmail-make-body)) ;;;###autoload (defun message-resend (address) "Resend the current article to ADDRESS." (interactive (list (message-read-from-minibuffer "Resend message to: "))) (message "Resending message to %s..." address) (save-excursion (let ((cur (current-buffer)) beg) ;; We first set up a normal mail buffer. (unless (message-mail-user-agent) (set-buffer (get-buffer-create " *message resend*")) (erase-buffer)) (let ((message-this-is-mail t) message-generate-hashcash message-setup-hook) (message-setup `((To . ,address)))) ;; Insert our usual headers. (message-generate-headers '(From Date To Message-ID)) (message-narrow-to-headers) ;; Remove X-Draft-From header etc. (message-remove-header message-ignored-mail-headers t) ;; Rename them all to "Resent-*". (goto-char (point-min)) (while (re-search-forward "^[A-Za-z]" nil t) (forward-char -1) (insert "Resent-")) (widen) (forward-line) (delete-region (point) (point-max)) (setq beg (point)) ;; Insert the message to be resent. (insert-buffer-substring cur) (goto-char (point-min)) (search-forward "\n\n") (forward-char -1) (save-restriction (narrow-to-region beg (point)) (message-remove-header message-ignored-resent-headers t) (goto-char (point-max))) (insert mail-header-separator) ;; Rename all old ("Also-")Resent headers. (while (re-search-backward "^\\(Also-\\)*Resent-" beg t) (beginning-of-line) (insert "Also-")) ;; Quote any "From " lines at the beginning. (goto-char beg) (when (looking-at "From ") (replace-match "X-From-Line: ")) ;; Send it. (let ((message-inhibit-body-encoding t) message-required-mail-headers message-generate-hashcash rfc2047-encode-encoded-words) (message-send-mail)) (kill-buffer (current-buffer))) (message "Resending message to %s...done" address))) ;;;###autoload (defun message-bounce () "Re-mail the current message. This only makes sense if the current message is a bounce message that contains some mail you have written which has been bounced back to you." (interactive) (let ((handles (mm-dissect-buffer t)) boundary) (message-pop-to-buffer (message-buffer-name "bounce")) (if (stringp (car handles)) ;; This is a MIME bounce. (mm-insert-part (car (last handles))) ;; This is a non-MIME bounce, so we try to remove things ;; manually. (mm-insert-part handles) (undo-boundary) (goto-char (point-min)) (re-search-forward "\n\n+" nil t) (setq boundary (point)) ;; We remove everything before the bounced mail. (if (or (re-search-forward message-unsent-separator nil t) (progn (search-forward "\n\n" nil 'move) (re-search-backward "^Return-Path:.*\n" boundary t))) (progn (forward-line 1) (delete-region (point-min) (if (re-search-forward "^[^ \n\t]+:" nil t) (match-beginning 0) (point)))) (goto-char boundary) (when (re-search-backward "^.?From .*\n" nil t) (delete-region (match-beginning 0) (match-end 0))))) (mime-to-mml) (save-restriction (message-narrow-to-head-1) (message-remove-header message-ignored-bounced-headers t) (goto-char (point-max)) (insert mail-header-separator)) (message-position-point))) ;;; ;;; Interactive entry points for new message buffers. ;;; ;;;###autoload (defun message-mail-other-window (&optional to subject) "Like `message-mail' command, but display mail buffer in another window." (interactive) (unless (message-mail-user-agent) (let ((pop-up-windows t) (special-display-buffer-names nil) (special-display-regexps nil) (same-window-buffer-names nil) (same-window-regexps nil)) (message-pop-to-buffer (message-buffer-name "mail" to)))) (let ((message-this-is-mail t)) (message-setup `((To . ,(or to "")) (Subject . ,(or subject ""))) nil nil nil 'switch-to-buffer-other-window))) ;;;###autoload (defun message-mail-other-frame (&optional to subject) "Like `message-mail' command, but display mail buffer in another frame." (interactive) (unless (message-mail-user-agent) (let ((pop-up-frames t) (special-display-buffer-names nil) (special-display-regexps nil) (same-window-buffer-names nil) (same-window-regexps nil)) (message-pop-to-buffer (message-buffer-name "mail" to)))) (let ((message-this-is-mail t)) (message-setup `((To . ,(or to "")) (Subject . ,(or subject ""))) nil nil nil 'switch-to-buffer-other-frame))) ;;;###autoload (defun message-news-other-window (&optional newsgroups subject) "Start editing a news article to be sent." (interactive) (let ((pop-up-windows t) (special-display-buffer-names nil) (special-display-regexps nil) (same-window-buffer-names nil) (same-window-regexps nil)) (message-pop-to-buffer (message-buffer-name "posting" nil newsgroups))) (let ((message-this-is-news t)) (message-setup `((Newsgroups . ,(or newsgroups "")) (Subject . ,(or subject "")))))) ;;;###autoload (defun message-news-other-frame (&optional newsgroups subject) "Start editing a news article to be sent." (interactive) (let ((pop-up-frames t) (special-display-buffer-names nil) (special-display-regexps nil) (same-window-buffer-names nil) (same-window-regexps nil)) (message-pop-to-buffer (message-buffer-name "posting" nil newsgroups))) (let ((message-this-is-news t)) (message-setup `((Newsgroups . ,(or newsgroups "")) (Subject . ,(or subject "")))))) ;;; underline.el ;; This code should be moved to underline.el (from which it is stolen). ;;;###autoload (defun message-bold-region (start end) "Bold all nonblank characters in the region. Works by overstriking characters. Called from program, takes two arguments START and END which specify the range to operate on." (interactive "r") (save-excursion (let ((end1 (make-marker))) (move-marker end1 (max start end)) (goto-char (min start end)) (while (< (point) end1) (or (looking-at "[_\^@- ]") (insert (char-after) "\b")) (forward-char 1))))) ;;;###autoload (defun message-unbold-region (start end) "Remove all boldness (overstruck characters) in the region. Called from program, takes two arguments START and END which specify the range to operate on." (interactive "r") (save-excursion (let ((end1 (make-marker))) (move-marker end1 (max start end)) (goto-char (min start end)) (while (search-forward "\b" end1 t) (if (eq (char-after) (char-after (- (point) 2))) (delete-char -2)))))) (defun message-exchange-point-and-mark () "Exchange point and mark, but don't activate region if it was inactive." (unless (prog1 (message-mark-active-p) (exchange-point-and-mark)) (setq mark-active nil))) (defalias 'message-make-overlay 'make-overlay) (defalias 'message-delete-overlay 'delete-overlay) (defalias 'message-overlay-put 'overlay-put) (defun message-kill-all-overlays () (if (featurep 'xemacs) (map-extents (lambda (extent ignore) (delete-extent extent))) (mapcar #'delete-overlay (overlays-in (point-min) (point-max))))) ;; Support for toolbar (defvar tool-bar-mode) ;; Note: The :set function in the `message-tool-bar*' variables will only ;; affect _new_ message buffers. We might add a function that walks thru all ;; message-mode buffers and force the update. (defun message-tool-bar-update (&optional symbol value) "Update message mode toolbar. Setter function for custom variables." (setq-default message-tool-bar-map nil) (when symbol ;; When used as ":set" function: (set-default symbol value))) (defcustom message-tool-bar (if (eq gmm-tool-bar-style 'gnome) 'message-tool-bar-gnome 'message-tool-bar-retro) "Specifies the message mode tool bar. It can be either a list or a symbol refering to a list. See `gmm-tool-bar-from-list' for the format of the list. The default key map is `message-mode-map'. Pre-defined symbols include `message-tool-bar-gnome' and `message-tool-bar-retro'." :type '(repeat gmm-tool-bar-list-item) :type '(choice (const :tag "GNOME style" message-tool-bar-gnome) (const :tag "Retro look" message-tool-bar-retro) (repeat :tag "User defined list" gmm-tool-bar-item) (symbol)) :version "23.1" ;; No Gnus :initialize 'custom-initialize-default :set 'message-tool-bar-update :group 'message) (defcustom message-tool-bar-gnome '((ispell-message "spell" nil :visible (or (not (boundp 'flyspell-mode)) (not flyspell-mode))) (flyspell-buffer "spell" t :visible (and (boundp 'flyspell-mode) flyspell-mode) :help "Flyspell whole buffer") (gmm-ignore "separator") (message-send-and-exit "mail/send") (message-dont-send "mail/save-draft") (message-kill-buffer "close") ;; stock_cancel (mml-attach-file "attach" mml-mode-map) (mml-preview "mail/preview" mml-mode-map) (mml-secure-message-sign-encrypt "lock" mml-mode-map :visible nil) (message-insert-importance-high "important" nil :visible nil) (message-insert-importance-low "unimportant" nil :visible nil) (message-insert-disposition-notification-to "receipt" nil :visible nil) (gmm-customize-mode "preferences" t :help "Edit mode preferences") (message-info "help" t :help "Message manual")) "List of items for the message tool bar (GNOME style). See `gmm-tool-bar-from-list' for details on the format of the list." :type '(repeat gmm-tool-bar-item) :version "23.1" ;; No Gnus :initialize 'custom-initialize-default :set 'message-tool-bar-update :group 'message) (defcustom message-tool-bar-retro '(;; Old Emacs 21 icon for consistency. (message-send-and-exit "gnus/mail-send") (message-kill-buffer "close") (message-dont-send "cancel") (mml-attach-file "attach" mml-mode-map) (ispell-message "spell") (mml-preview "preview" mml-mode-map) (message-insert-importance-high "gnus/important") (message-insert-importance-low "gnus/unimportant") (message-insert-disposition-notification-to "gnus/receipt")) "List of items for the message tool bar (retro style). See `gmm-tool-bar-from-list' for details on the format of the list." :type '(repeat gmm-tool-bar-item) :version "23.1" ;; No Gnus :initialize 'custom-initialize-default :set 'message-tool-bar-update :group 'message) (defcustom message-tool-bar-zap-list '(new-file open-file dired kill-buffer write-file print-buffer customize help) "List of icon items from the global tool bar. These items are not displayed on the message mode tool bar. See `gmm-tool-bar-from-list' for the format of the list." :type 'gmm-tool-bar-zap-list :version "23.1" ;; No Gnus :initialize 'custom-initialize-default :set 'message-tool-bar-update :group 'message) (defvar image-load-path) (defun message-make-tool-bar (&optional force) "Make a message mode tool bar from `message-tool-bar-list'. When FORCE, rebuild the tool bar." (when (and (not (featurep 'xemacs)) (boundp 'tool-bar-mode) tool-bar-mode (or (not message-tool-bar-map) force)) (setq message-tool-bar-map (let* ((load-path (gmm-image-load-path-for-library "message" "mail/save-draft.xpm" nil t)) (image-load-path (cons (car load-path) (when (boundp 'image-load-path) image-load-path)))) (gmm-tool-bar-from-list message-tool-bar message-tool-bar-zap-list 'message-mode-map)))) message-tool-bar-map) ;;; Group name completion. (defcustom message-newgroups-header-regexp "^\\(Newsgroups\\|Followup-To\\|Posted-To\\|Gcc\\):" "Regexp that match headers that lists groups." :group 'message :type 'regexp) (defcustom message-completion-alist (list (cons message-newgroups-header-regexp 'message-expand-group) '("^\\(Resent-\\)?\\(To\\|B?Cc\\):" . message-expand-name) '("^\\(Reply-To\\|From\\|Mail-Followup-To\\|Mail-Copies-To\\):" . message-expand-name) '("^\\(Disposition-Notification-To\\|Return-Receipt-To\\):" . message-expand-name)) "Alist of (RE . FUN). Use FUN for completion on header lines matching RE." :version "22.1" :group 'message :type '(alist :key-type regexp :value-type function)) (defcustom message-expand-name-databases (list 'bbdb 'eudc) "List of databases to try for name completion (`message-expand-name'). Each element is a symbol and can be `bbdb' or `eudc'." :group 'message :type '(set (const bbdb) (const eudc))) (defcustom message-tab-body-function nil "*Function to execute when `message-tab' (TAB) is executed in the body. If nil, the function bound in `text-mode-map' or `global-map' is executed." :version "22.1" :group 'message :link '(custom-manual "(message)Various Commands") :type '(choice (const nil) function)) (declare-function mail-abbrev-in-expansion-header-p "mailabbrev" ()) (defun message-tab () "Complete names according to `message-completion-alist'. Execute function specified by `message-tab-body-function' when not in those headers." (interactive) (let ((alist message-completion-alist)) (while (and alist (let ((mail-abbrev-mode-regexp (caar alist))) (not (mail-abbrev-in-expansion-header-p)))) (setq alist (cdr alist))) (funcall (or (cdar alist) message-tab-body-function (lookup-key text-mode-map "\t") (lookup-key global-map "\t") 'indent-relative)))) (eval-and-compile (condition-case nil (with-temp-buffer (let ((standard-output (current-buffer))) (eval '(display-completion-list nil ""))) (defalias 'message-display-completion-list 'display-completion-list)) (error ;; Don't use `wrong-number-of-arguments' here because of XEmacs. (defun message-display-completion-list (completions &optional ignore) "Display the list of completions, COMPLETIONS, using `standard-output'." (display-completion-list completions))))) (defun message-expand-group () "Expand the group name under point." (let* ((b (save-excursion (save-restriction (narrow-to-region (save-excursion (beginning-of-line) (skip-chars-forward "^:") (1+ (point))) (point)) (skip-chars-backward "^, \t\n") (point)))) (completion-ignore-case t) (string (buffer-substring b (progn (skip-chars-forward "^,\t\n ") (point)))) (hashtb (and (boundp 'gnus-active-hashtb) gnus-active-hashtb)) (completions (all-completions string hashtb)) comp) (delete-region b (point)) (cond ((= (length completions) 1) (if (string= (car completions) string) (progn (insert string) (message "Only matching group")) (insert (car completions)))) ((and (setq comp (try-completion string hashtb)) (not (string= comp string))) (insert comp)) (t (insert string) (if (not comp) (message "No matching groups") (save-selected-window (pop-to-buffer "*Completions*") (buffer-disable-undo) (let ((buffer-read-only nil)) (erase-buffer) (let ((standard-output (current-buffer))) (message-display-completion-list (sort completions 'string<) string)) (setq buffer-read-only nil) (goto-char (point-min)) (delete-region (point) (progn (forward-line 3) (point)))))))))) (defun message-expand-name () (cond ((and (memq 'eudc message-expand-name-databases) (boundp 'eudc-protocol) eudc-protocol) (eudc-expand-inline)) ((and (memq 'bbdb message-expand-name-databases) (fboundp 'bbdb-complete-name)) (bbdb-complete-name)) (t (expand-abbrev)))) ;;; Help stuff. (defun message-talkative-question (ask question show &rest text) "Call FUNCTION with argument QUESTION; optionally display TEXT... args. If SHOW is non-nil, the arguments TEXT... are displayed in a temp buffer. The following arguments may contain lists of values." (if (and show (setq text (message-flatten-list text))) (save-window-excursion (with-output-to-temp-buffer " *MESSAGE information message*" (with-current-buffer " *MESSAGE information message*" (fundamental-mode) ; for Emacs 20.4+ (mapc 'princ text) (goto-char (point-min)))) (funcall ask question)) (funcall ask question))) (defun message-flatten-list (list) "Return a new, flat list that contains all elements of LIST. \(message-flatten-list '(1 (2 3 (4 5 (6))) 7)) => (1 2 3 4 5 6 7)" (cond ((consp list) (apply 'append (mapcar 'message-flatten-list list))) (list (list list)))) (defun message-generate-new-buffer-clone-locals (name &optional varstr) "Create and return a buffer with name based on NAME using `generate-new-buffer'. Then clone the local variables and values from the old buffer to the new one, cloning only the locals having a substring matching the regexp VARSTR." (let ((oldbuf (current-buffer))) (with-current-buffer (generate-new-buffer name) (message-clone-locals oldbuf varstr) (current-buffer)))) (defun message-clone-locals (buffer &optional varstr) "Clone the local variables from BUFFER to the current buffer." (let ((locals (with-current-buffer buffer (buffer-local-variables))) (regexp "^gnus\\|^nn\\|^message\\|^sendmail\\|^smtp\\|^user-mail-address")) (mapcar (lambda (local) (when (and (consp local) (car local) (string-match regexp (symbol-name (car local))) (or (null varstr) (string-match varstr (symbol-name (car local))))) (ignore-errors (set (make-local-variable (car local)) (cdr local))))) locals))) ;;; ;;; MIME functions ;;; (defvar message-inhibit-body-encoding nil) (defun message-encode-message-body () (unless message-inhibit-body-encoding (let ((mail-parse-charset (or mail-parse-charset message-default-charset)) (case-fold-search t) lines content-type-p) (message-goto-body) (save-restriction (narrow-to-region (point) (point-max)) (let ((new (mml-generate-mime))) (when new (delete-region (point-min) (point-max)) (insert new) (goto-char (point-min)) (if (eq (aref new 0) ?\n) (delete-char 1) (search-forward "\n\n") (setq lines (buffer-substring (point-min) (1- (point)))) (delete-region (point-min) (point)))))) (save-restriction (message-narrow-to-headers-or-head) (message-remove-header "Mime-Version") (goto-char (point-max)) (insert "MIME-Version: 1.0\n") (when lines (insert lines)) (setq content-type-p (or mml-boundary (re-search-backward "^Content-Type:" nil t)))) (save-restriction (message-narrow-to-headers-or-head) (message-remove-first-header "Content-Type") (message-remove-first-header "Content-Transfer-Encoding")) ;; We always make sure that the message has a Content-Type ;; header. This is because some broken MTAs and MUAs get ;; awfully confused when confronted with a message with a ;; MIME-Version header and without a Content-Type header. For ;; instance, Solaris' /usr/bin/mail. (unless content-type-p (goto-char (point-min)) ;; For unknown reason, MIME-Version doesn't exist. (when (re-search-forward "^MIME-Version:" nil t) (forward-line 1) (insert "Content-Type: text/plain; charset=us-ascii\n")))))) (defun message-read-from-minibuffer (prompt &optional initial-contents) "Read from the minibuffer while providing abbrev expansion." (if (fboundp 'mail-abbrevs-setup) (let ((mail-abbrev-mode-regexp "") (minibuffer-setup-hook 'mail-abbrevs-setup) (minibuffer-local-map message-minibuffer-local-map)) (read-from-minibuffer prompt initial-contents)) (let ((minibuffer-setup-hook 'mail-abbrev-minibuffer-setup-hook) (minibuffer-local-map message-minibuffer-local-map)) (read-string prompt initial-contents)))) (defun message-use-alternative-email-as-from () "Set From field of the outgoing message to the first matching address in `message-alternative-emails', looking at To, Cc and From headers in the original article." (require 'mail-utils) (let* ((fields '("To" "Cc" "From")) (emails (split-string (mail-strip-quoted-names (mapconcat 'message-fetch-reply-field fields ",")) "[ \f\t\n\r\v,]+")) email) (while emails (if (string-match message-alternative-emails (car emails)) (setq email (car emails) emails nil)) (pop emails)) (unless (or (not email) (equal email user-mail-address)) (message-remove-header "From") (goto-char (point-max)) (insert "From: " (let ((user-mail-address email)) (message-make-from)) "\n")))) (defun message-options-get (symbol) (cdr (assq symbol message-options))) (defun message-options-set (symbol value) (let ((the-cons (assq symbol message-options))) (if the-cons (if value (setcdr the-cons value) (setq message-options (delq the-cons message-options))) (and value (push (cons symbol value) message-options)))) value) (defun message-options-set-recipient () (save-restriction (message-narrow-to-headers-or-head) (message-options-set 'message-sender (mail-strip-quoted-names (message-fetch-field "from"))) (message-options-set 'message-recipients (mail-strip-quoted-names (let ((to (message-fetch-field "to")) (cc (message-fetch-field "cc")) (bcc (message-fetch-field "bcc"))) (concat (or to "") (if (and to cc) ", ") (or cc "") (if (and (or to cc) bcc) ", ") (or bcc ""))))))) (defun message-hide-headers () "Hide headers based on the `message-hidden-headers' variable." (let ((regexps (if (stringp message-hidden-headers) (list message-hidden-headers) message-hidden-headers)) (inhibit-point-motion-hooks t) (after-change-functions nil) (end-of-headers (point-min))) (when regexps (save-excursion (save-restriction (message-narrow-to-headers) (goto-char (point-min)) (while (not (eobp)) (if (not (message-hide-header-p regexps)) (message-next-header) (let ((begin (point)) header header-len) (message-next-header) (setq header (buffer-substring begin (point)) header-len (- (point) begin)) (delete-region begin (point)) (goto-char end-of-headers) (insert header) (setq end-of-headers (+ end-of-headers header-len)))))))) (narrow-to-region end-of-headers (point-max)))) (defun message-hide-header-p (regexps) (let ((result nil) (reverse nil)) (when (eq (car regexps) 'not) (setq reverse t) (pop regexps)) (dolist (regexp regexps) (setq result (or result (looking-at regexp)))) (if reverse (not result) result))) (defun message-put-addresses-in-ecomplete () (dolist (header '("to" "cc" "from" "reply-to")) (let ((value (message-field-value header))) (dolist (string (mail-header-parse-addresses value 'raw)) (setq string (gnus-replace-in-string (gnus-replace-in-string string "^ +\\| +$" "") "\n" "")) (ecomplete-add-item 'mail (car (mail-header-parse-address string)) string)))) (ecomplete-save)) (defun message-display-abbrev (&optional choose) "Display the next possible abbrev for the text before point." (interactive (list t)) (when (and (memq (char-after (point-at-bol)) '(?C ?T ?\t ? )) (message-point-in-header-p) (save-excursion (beginning-of-line) (while (and (memq (char-after) '(?\t ? )) (zerop (forward-line -1)))) (looking-at "To:\\|Cc:"))) (let* ((end (point)) (start (save-excursion (and (re-search-backward "[\n\t ]" nil t) (1+ (point))))) (word (when start (buffer-substring start end))) (match (when (and word (not (zerop (length word)))) (ecomplete-display-matches 'mail word choose)))) (when (and choose match) (delete-region start end) (insert match))))) ;; To send pre-formatted letters like the example below, you can use ;; `message-send-form-letter': ;; --8<---------------cut here---------------start------------->8--- ;; To: alice@invalid.invalid ;; Subject: Verification of your contact information ;; From: Contact verification ;; --text follows this line-- ;; Hi Alice, ;; please verify that your contact information is still valid: ;; Alice A, A avenue 11, 1111 A town, Austria ;; ----------next form letter message follows this line---------- ;; To: bob@invalid.invalid ;; Subject: Verification of your contact information ;; From: Contact verification ;; --text follows this line-- ;; Hi Bob, ;; please verify that your contact information is still valid: ;; Bob, B street 22, 22222 Be town, Belgium ;; ----------next form letter message follows this line---------- ;; To: charlie@invalid.invalid ;; Subject: Verification of your contact information ;; From: Contact verification ;; --text follows this line-- ;; Hi Charlie, ;; please verify that your contact information is still valid: ;; Charlie Chaplin, C plaza 33, 33333 C town, Chile ;; --8<---------------cut here---------------end--------------->8--- ;; FIXME: What is the most common term (circular letter, form letter, serial ;; letter, standard letter) for such kind of letter? See also ;; ;; FIXME: Maybe extent message-mode's font-lock support to recognize ;; `message-form-letter-separator', i.e. highlight each message like a single ;; message. (defcustom message-form-letter-separator "\n----------next form letter message follows this line----------\n" "Separator for `message-send-form-letter'." ;; :group 'message-form-letter :group 'message-various :version "23.1" ;; No Gnus :type 'string) (defcustom message-send-form-letter-delay 1 "Delay in seconds when sending a message with `message-send-form-letter'. Only used when `message-send-form-letter' is called with non-nil argument `force'." ;; :group 'message-form-letter :group 'message-various :version "23.1" ;; No Gnus :type 'integer) (defun message-send-form-letter (&optional force) "Sent all form letter messages from current buffer. Unless FORCE, prompt before sending. The messages are separated by `message-form-letter-separator'. Header and body are separated by `mail-header-separator'." (interactive "P") (let ((sent 0) (skipped 0) start end text buff to done) (goto-char (point-min)) (while (not done) (setq start (point) end (if (search-forward message-form-letter-separator nil t) (- (point) (length message-form-letter-separator) -1) (setq done t) (point-max))) (setq text (buffer-substring-no-properties start end)) (setq buff (generate-new-buffer "*mail - form letter*")) (with-current-buffer buff (insert text) (message-mode) (setq to (message-fetch-field "To")) (switch-to-buffer buff) (when force (sit-for message-send-form-letter-delay)) (if (or force (y-or-n-p (format "Send message to `%s'? " to))) (progn (setq sent (1+ sent)) (message-send-and-exit)) (message (format "Message to `%s' skipped." to)) (setq skipped (1+ skipped))) (when (buffer-live-p buff) (kill-buffer buff)))) (message "%s message(s) sent, %s skipped." sent skipped))) (defun message-replace-header (header new-value &optional after force) "Remove HEADER and insert the NEW-VALUE. If AFTER, insert after this header. If FORCE, insert new field even if NEW-VALUE is empty." ;; Similar to `nnheader-replace-header' but for message buffers. (save-excursion (save-restriction (message-narrow-to-headers) (message-remove-header header)) (when (or force (> (length new-value) 0)) (if after (message-position-on-field header after) (message-position-on-field header)) (insert new-value)))) (defcustom message-recipients-without-full-name (list "ding@gnus.org" "bugs@gnus.org" "emacs-devel@gnu.org" "emacs-pretest-bug@gnu.org" "bug-gnu-emacs@gnu.org") "Mail addresses that have no full name. Used in `message-simplify-recipients'." ;; Maybe the addresses could be extracted from ;; `gnus-parameter-to-list-alist'? :type '(choice (const :tag "None" nil) (repeat string)) :version "23.1" ;; No Gnus :group 'message-headers) (defun message-simplify-recipients () (interactive) (dolist (hdr '("Cc" "To")) (message-replace-header hdr (mapconcat (lambda (addrcomp) (if (and message-recipients-without-full-name (string-match (regexp-opt message-recipients-without-full-name) (cadr addrcomp))) (cadr addrcomp) (if (car addrcomp) (message-make-from (car addrcomp) (cadr addrcomp)) (cadr addrcomp)))) (when (message-fetch-field hdr) (mail-extract-address-components (message-fetch-field hdr) t)) ", ")))) (when (featurep 'xemacs) (require 'messagexmas) (message-xmas-redefine)) (provide 'message) (run-hooks 'message-load-hook) ;; Local Variables: ;; coding: iso-8859-1 ;; End: ;; arch-tag: 94b32cac-4504-4b6c-8181-030ebf380ee0 ;;; message.el ends here gnus-5.11+v0.10.dfsg/lisp/gnus-diary.el0000644000175000017500000003277411004005110017642 0ustar tvainikatvainika;;; gnus-diary.el --- Wrapper around the NNDiary Gnus back end ;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, ;; 2006, 2007, 2008 Free Software Foundation, Inc. ;; Author: Didier Verna ;; Maintainer: Didier Verna ;; Created: Tue Jul 20 10:42:55 1999 ;; Keywords: calendar mail news ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published ;; by the Free Software Foundation; either version 3, or (at your option) ;; any later version. ;; GNU Emacs is distributed in the hope that it will be useful, but ;; WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Commentary: ;; Contents management by FCM version 0.1. ;; Description: ;; =========== ;; gnus-diary is a utility toolkit used on top of the nndiary back end. It is ;; now fully documented in the Gnus manual. ;; Bugs / Todo: ;; =========== ;;; Code: (require 'nndiary) (require 'message) (require 'gnus-art) (defgroup gnus-diary nil "Utilities on top of the nndiary back end for Gnus." :version "22.1" :group 'gnus) (defcustom gnus-diary-summary-line-format "%U%R%z %uD: %(%s%) (%ud)\n" "*Summary line format for nndiary groups." :type 'string :group 'gnus-diary :group 'gnus-summary-format) (defcustom gnus-diary-time-format "%a, %b %e %y, %H:%M" "*Time format to display appointments in nndiary summary buffers. Please refer to `format-time-string' for information on possible values." :type 'string :group 'gnus-diary) (defcustom gnus-diary-delay-format-function 'gnus-diary-delay-format-english "*Function called to format a diary delay string. It is passed two arguments. The first one is non-nil if the delay is in the past. The second one is of the form ((NUM . UNIT) ...) where NUM is an integer and UNIT is one of 'year 'month 'week 'day 'hour or 'minute. It should return strings like \"In 2 months, 3 weeks\", \"3 hours, 1 minute ago\" and so on. There are currently two built-in format functions: `gnus-diary-delay-format-english' (the default) `gnus-diary-delay-format-french'" :type '(choice (const :tag "english" gnus-diary-delay-format-english) (const :tag "french" gnus-diary-delay-format-french) (symbol :tag "other")) :group 'gnus-diary) (defconst gnus-diary-version nndiary-version "Current Diary back end version.") ;; Compatibility functions ================================================== (eval-and-compile (if (fboundp 'kill-entire-line) (defalias 'gnus-diary-kill-entire-line 'kill-entire-line) (defun gnus-diary-kill-entire-line () (beginning-of-line) (let ((kill-whole-line t)) (kill-line))))) ;; Summary line format ====================================================== (defun gnus-diary-delay-format-french (past delay) (if (null delay) "maintenant!" ;; Keep only a precision of two degrees (and (> (length delay) 1) (setcdr (cdr delay) nil)) (concat (if past "il y a " "dans ") (let ((str "") del) (while (setq del (pop delay)) (setq str (concat str (int-to-string (car del)) " " (cond ((eq (cdr del) 'year) "an") ((eq (cdr del) 'month) "mois") ((eq (cdr del) 'week) "semaine") ((eq (cdr del) 'day) "jour") ((eq (cdr del) 'hour) "heure") ((eq (cdr del) 'minute) "minute")) (unless (or (eq (cdr del) 'month) (= (car del) 1)) "s") (if delay ", ")))) str)))) (defun gnus-diary-delay-format-english (past delay) (if (null delay) "now!" ;; Keep only a precision of two degrees (and (> (length delay) 1) (setcdr (cdr delay) nil)) (concat (unless past "in ") (let ((str "") del) (while (setq del (pop delay)) (setq str (concat str (int-to-string (car del)) " " (symbol-name (cdr del)) (and (> (car del) 1) "s") (if delay ", ")))) str) (and past " ago")))) (defun gnus-diary-header-schedule (headers) ;; Same as `nndiary-schedule', but given a set of headers HEADERS (mapcar (lambda (elt) (let ((head (cdr (assoc (intern (format "X-Diary-%s" (car elt))) headers)))) (when head (nndiary-parse-schedule-value head (cadr elt) (car (cddr elt)))))) nndiary-headers)) ;; #### NOTE: Gnus sometimes gives me a HEADER not corresponding to any ;; message, with all fields set to nil here. I don't know what it is for, and ;; I just ignore it. ;;;###autoload (defun gnus-user-format-function-d (header) ;; Returns an aproximative delay string for the next occurence of this ;; message. The delay is given only in the first non zero unit. ;; Code partly stolen from article-make-date-line (let* ((extras (mail-header-extra header)) (sched (gnus-diary-header-schedule extras)) (occur (nndiary-next-occurence sched (current-time))) (now (current-time)) (real-time (subtract-time occur now))) (if (null real-time) "?????" (let* ((sec (+ (* (float (car real-time)) 65536) (cadr real-time))) (past (< sec 0)) delay) (and past (setq sec (- sec))) (unless (zerop sec) ;; This is a bit convoluted, but basically we go through the time ;; units for years, weeks, etc, and divide things to see whether ;; that results in positive answers. (let ((units `((year . ,(* 365.25 24 3600)) (month . ,(* 31 24 3600)) (week . ,(* 7 24 3600)) (day . ,(* 24 3600)) (hour . 3600) (minute . 60))) unit num) (while (setq unit (pop units)) (unless (zerop (setq num (ffloor (/ sec (cdr unit))))) (setq delay (append delay `((,(floor num) . ,(car unit)))))) (setq sec (- sec (* num (cdr unit))))))) (funcall gnus-diary-delay-format-function past delay))) )) ;; #### NOTE: Gnus sometimes gives me a HEADER not corresponding to any ;; message, with all fields set to nil here. I don't know what it is for, and ;; I just ignore it. ;;;###autoload (defun gnus-user-format-function-D (header) ;; Returns a formatted time string for the next occurence of this message. (let* ((extras (mail-header-extra header)) (sched (gnus-diary-header-schedule extras)) (occur (nndiary-next-occurence sched (current-time)))) (format-time-string gnus-diary-time-format occur))) ;; Article sorting functions ================================================ (defun gnus-article-sort-by-schedule (h1 h2) (let* ((now (current-time)) (e1 (mail-header-extra h1)) (e2 (mail-header-extra h2)) (s1 (gnus-diary-header-schedule e1)) (s2 (gnus-diary-header-schedule e2)) (o1 (nndiary-next-occurence s1 now)) (o2 (nndiary-next-occurence s2 now))) (if (and (= (car o1) (car o2)) (= (cadr o1) (cadr o2))) (< (mail-header-number h1) (mail-header-number h2)) (time-less-p o1 o2)))) (defun gnus-thread-sort-by-schedule (h1 h2) (gnus-article-sort-by-schedule (gnus-thread-header h1) (gnus-thread-header h2))) (defun gnus-summary-sort-by-schedule (&optional reverse) "Sort nndiary summary buffers by schedule of appointments. Optional prefix (or REVERSE argument) means sort in reverse order." (interactive "P") (gnus-summary-sort 'schedule reverse)) (defvar gnus-summary-misc-menu) ;; Avoid byte compiler warning. (add-hook 'gnus-summary-menu-hook (lambda () (easy-menu-add-item gnus-summary-misc-menu '("Sort") ["Sort by schedule" gnus-summary-sort-by-schedule (eq (car (gnus-find-method-for-group gnus-newsgroup-name)) 'nndiary)] "Sort by number"))) ;; Group parameters autosetting ============================================= (defun gnus-diary-update-group-parameters (group) ;; Ensure that nndiary groups have convenient group parameters: ;; - a posting style containing X-Diary headers ;; - a nice summary line format ;; - NNDiary specific sorting by schedule functions ;; In general, try not to mess with what the user might have modified. ;; Posting style: (let ((posting-style (gnus-group-get-parameter group 'posting-style t)) (headers nndiary-headers) header) (while headers (setq header (format "X-Diary-%s" (caar headers)) headers (cdr headers)) (unless (assoc header posting-style) (setq posting-style (append posting-style (list (list header "*")))))) (gnus-group-set-parameter group 'posting-style posting-style)) ;; Summary line format: (unless (gnus-group-get-parameter group 'gnus-summary-line-format t) (gnus-group-set-parameter group 'gnus-summary-line-format `(,gnus-diary-summary-line-format))) ;; Sorting by schedule: (unless (gnus-group-get-parameter group 'gnus-article-sort-functions) (gnus-group-set-parameter group 'gnus-article-sort-functions '((append gnus-article-sort-functions (list 'gnus-article-sort-by-schedule))))) (unless (gnus-group-get-parameter group 'gnus-thread-sort-functions) (gnus-group-set-parameter group 'gnus-thread-sort-functions '((append gnus-thread-sort-functions (list 'gnus-thread-sort-by-schedule)))))) ;; Called when a group is subscribed. This is needed because groups created ;; because of mail splitting are *not* created with the back end function. ;; Thus, `nndiary-request-create-group-hooks' is inoperative. (defun gnus-diary-maybe-update-group-parameters (group) (when (eq (car (gnus-find-method-for-group group)) 'nndiary) (gnus-diary-update-group-parameters group))) (add-hook 'nndiary-request-create-group-hooks 'gnus-diary-update-group-parameters) ;; Now that we have `gnus-subscribe-newsgroup-hooks', this is not needed ;; anymore. Maybe I should remove this completely. (add-hook 'nndiary-request-update-info-hooks 'gnus-diary-update-group-parameters) (add-hook 'gnus-subscribe-newsgroup-hooks 'gnus-diary-maybe-update-group-parameters) ;; Diary Message Checking =================================================== (defvar gnus-diary-header-value-history nil ;; History variable for header value prompting ) (defun gnus-diary-narrow-to-headers () "Narrow the current buffer to the header part. Point is left at the beginning of the region. The buffer is assumed to contain a message, but the format is unknown." (cond ((eq major-mode 'message-mode) (message-narrow-to-headers)) (t (goto-char (point-min)) (when (search-forward "\n\n" nil t) (narrow-to-region (point-min) (- (point) 1)) (goto-char (point-min)))) )) (defun gnus-diary-add-header (str) "Add a header to the current buffer. The buffer is assumed to contain a message, but the format is unknown." (cond ((eq major-mode 'message-mode) (message-add-header str)) (t (save-restriction (gnus-diary-narrow-to-headers) (goto-char (point-max)) (if (string-match "\n$" str) (insert str) (insert str ?\n)))) )) (defun gnus-diary-check-message (arg) "Ensure that the current message is a valid for NNDiary. This function checks that all NNDiary required headers are present and valid, and prompts for values / correction otherwise. If ARG (or prefix) is non-nil, force prompting for all fields." (interactive "P") (save-excursion (mapcar (lambda (head) (let ((header (concat "X-Diary-" (car head))) (ask arg) value invalid) ;; First, try to find the header, and checks for validity: (save-restriction (gnus-diary-narrow-to-headers) (when (re-search-forward (concat "^" header ":") nil t) (unless (eq (char-after) ? ) (insert " ")) (setq value (buffer-substring (point) (point-at-eol))) (and (string-match "[ \t]*\\([^ \t]+\\)[ \t]*" value) (setq value (match-string 1 value))) (condition-case () (nndiary-parse-schedule-value value (nth 1 head) (nth 2 head)) (t (setq invalid t))) ;; #### NOTE: this (along with the `gnus-diary-add-header' ;; function) could be rewritten in a better way, in particular ;; not to blindly remove an already present header and reinsert ;; it somewhere else afterwards. (when (or ask invalid) (gnus-diary-kill-entire-line)) )) ;; Now, loop until a valid value is provided: (while (or ask (not value) invalid) (let ((prompt (concat (and invalid (prog1 "(current value invalid) " (beep))) header ": "))) (setq value (if (listp (nth 1 head)) (completing-read prompt (cons '("*" nil) (nth 1 head)) nil t value gnus-diary-header-value-history) (read-string prompt value gnus-diary-header-value-history)))) (setq ask nil) (setq invalid nil) (condition-case () (nndiary-parse-schedule-value value (nth 1 head) (nth 2 head)) (t (setq invalid t)))) (gnus-diary-add-header (concat header ": " value)) )) nndiary-headers) )) (add-hook 'nndiary-request-accept-article-hooks (lambda () (gnus-diary-check-message nil))) (define-key message-mode-map "\C-c\C-fd" 'gnus-diary-check-message) (define-key gnus-article-edit-mode-map "\C-c\C-fd" 'gnus-diary-check-message) ;; The end ================================================================== (defun gnus-diary-version () "Current Diary back end version." (interactive) (message "NNDiary version %s" nndiary-version)) (provide 'gnus-diary) ;; arch-tag: 98467e70-337e-4ddc-b92d-45d403ff1b4b ;;; gnus-diary.el ends here gnus-5.11+v0.10.dfsg/lisp/gnus-dired.el0000644000175000017500000002173611004005110017615 0ustar tvainikatvainika;;; gnus-dired.el --- utility functions where gnus and dired meet ;; Copyright (C) 1996, 1997, 1998, 1999, 2001, 2002, 2003, 2004, ;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc. ;; Authors: Benjamin Rutt , ;; Shenghuo Zhu ;; Keywords: mail, news, extensions ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 3, or (at your option) ;; any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to ;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Commentary: ;; This package provides utility functions for intersections of gnus ;; and dired. To enable the gnus-dired-mode minor mode which will ;; have the effect of installing keybindings in dired-mode, place the ;; following in your ~/.gnus: ;; (require 'gnus-dired) ;, isn't needed due to autoload cookies ;; (add-hook 'dired-mode-hook 'turn-on-gnus-dired-mode) ;; Note that if you visit dired buffers before your ~/.gnus file has ;; been read, those dired buffers won't have the keybindings in ;; effect. To get around that problem, you may want to add the above ;; statements to your ~/.emacs instead. ;;; Code: (require 'dired) (autoload 'mml-attach-file "mml") (autoload 'mm-default-file-encoding "mm-decode");; Shift this to `mailcap.el'? (autoload 'mailcap-extension-to-mime "mailcap") (autoload 'mailcap-mime-info "mailcap") ;; Maybe shift this function to `mailcap.el'? (autoload 'mm-mailcap-command "mm-decode") (autoload 'ps-print-preprint "ps-print") ;; Autoloads to avoid byte-compiler warnings. These are used only if the user ;; customizes `gnus-dired-mail-mode' to use Message and/or Gnus. (autoload 'message-buffers "message") (autoload 'gnus-setup-message "gnus-msg") (autoload 'gnus-print-buffer "gnus-sum") (defvar gnus-dired-mode nil "Minor mode for intersections of MIME mail composition and dired.") (defvar gnus-dired-mode-map nil) (unless gnus-dired-mode-map (setq gnus-dired-mode-map (make-sparse-keymap)) (define-key gnus-dired-mode-map "\C-c\C-m\C-a" 'gnus-dired-attach) (define-key gnus-dired-mode-map "\C-c\C-m\C-l" 'gnus-dired-find-file-mailcap) (define-key gnus-dired-mode-map "\C-c\C-m\C-p" 'gnus-dired-print)) ;; FIXME: Make it customizable, change the default to `mail-user-agent' when ;; this file if renamed (e.g. to `dired-mime.el'). (defcustom gnus-dired-mail-mode 'gnus-user-agent ;; mail-user-agent "Your preference for a mail composition package. See `mail-user-agent' for more information." :group 'mail ;; dired? :version "23.1" ;; No Gnus :type '(radio (function-item :tag "Default Emacs mail" :format "%t\n" sendmail-user-agent) (function-item :tag "Emacs interface to MH" :format "%t\n" mh-e-user-agent) (function-item :tag "Gnus Message package" :format "%t\n" message-user-agent) (function-item :tag "Gnus Message with full Gnus features" :format "%t\n" gnus-user-agent) (function :tag "Other"))) (defun gnus-dired-mode (&optional arg) "Minor mode for intersections of gnus and dired. \\{gnus-dired-mode-map}" (interactive "P") (when (eq major-mode 'dired-mode) (set (make-local-variable 'gnus-dired-mode) (if (null arg) (not gnus-dired-mode) (> (prefix-numeric-value arg) 0))) (when gnus-dired-mode (add-minor-mode 'gnus-dired-mode "" gnus-dired-mode-map) (save-current-buffer (run-hooks 'gnus-dired-mode-hook))))) ;;;###autoload (defun turn-on-gnus-dired-mode () "Convenience method to turn on gnus-dired-mode." (interactive) (gnus-dired-mode 1)) (defun gnus-dired-mail-buffers () "Return a list of active mail composition buffers." (if (and (memq gnus-dired-mail-mode '(message-user-agent gnus-user-agent)) (require 'message) (fboundp 'message-buffers)) (message-buffers) ;; Cf. `message-buffers' in `message.el': (let (buffers) (save-excursion (dolist (buffer (buffer-list t)) (set-buffer buffer) (when (eq major-mode 'mail-mode) (push (buffer-name buffer) buffers)))) (nreverse buffers)))) ;; Method to attach files to a mail composition. (defun gnus-dired-attach (files-to-attach) "Attach dired's marked files to a gnus message composition. If called non-interactively, FILES-TO-ATTACH should be a list of filenames." (interactive (list (delq nil (mapcar ;; don't attach directories (lambda (f) (if (file-directory-p f) nil f)) (nreverse (dired-map-over-marks (dired-get-filename) nil)))))) (let ((destination nil) (files-str nil) (bufs nil)) ;; warn if user tries to attach without any files marked (if (null files-to-attach) (error "No files to attach") (setq files-str (mapconcat (lambda (f) (file-name-nondirectory f)) files-to-attach ", ")) (setq bufs (gnus-dired-mail-buffers)) ;; set up destination mail composition buffer (if (and bufs (y-or-n-p "Attach files to existing mail composition buffer? ")) (setq destination (if (= (length bufs) 1) (get-buffer (car bufs)) (completing-read "Attach to which mail composition buffer: " (mapcar (lambda (b) (cons b (get-buffer b))) bufs) nil t))) ;; setup a new mail composition buffer (if (eq gnus-dired-mail-mode 'gnus-user-agent) (gnus-setup-message 'message (message-mail)) ;; FIXME: Is this the right thing? (compose-mail)) (setq destination (current-buffer))) ;; set buffer to destination buffer, and attach files (set-buffer destination) (goto-char (point-max)) ;attach at end of buffer (while files-to-attach (mml-attach-file (car files-to-attach) (or (mm-default-file-encoding (car files-to-attach)) "application/octet-stream") nil) (setq files-to-attach (cdr files-to-attach))) (message "Attached file(s) %s" files-str)))) (autoload 'mailcap-parse-mailcaps "mailcap" "" t) (defun gnus-dired-find-file-mailcap (&optional file-name arg) "In dired, visit FILE-NAME according to the mailcap file. If ARG is non-nil, open it in a new buffer." (interactive (list (file-name-sans-versions (dired-get-filename) t) current-prefix-arg)) (mailcap-parse-mailcaps) (if (file-exists-p file-name) (let (mime-type method) (if (and (not arg) (not (file-directory-p file-name)) (string-match "\\.[^\\.]+$" file-name) (setq mime-type (mailcap-extension-to-mime (match-string 0 file-name))) (stringp (setq method (cdr (assoc 'viewer (car (mailcap-mime-info mime-type 'all 'no-decode))))))) (let ((view-command (mm-mailcap-command method file-name nil))) (message "viewing via %s" view-command) (start-process "*display*" nil shell-file-name shell-command-switch view-command)) (find-file file-name))) (if (file-symlink-p file-name) (error "File is a symlink to a nonexistent target") (error "File no longer exists; type `g' to update Dired buffer")))) (defun gnus-dired-print (&optional file-name print-to) "In dired, print FILE-NAME according to the mailcap file. If there is no print command, print in a PostScript image. If the optional argument PRINT-TO is nil, send the image to the printer. If PRINT-TO is a string, save the PostScript image in a file with that name. If PRINT-TO is a number, prompt the user for the name of the file to save in." (interactive (list (file-name-sans-versions (dired-get-filename) t) (ps-print-preprint current-prefix-arg))) (mailcap-parse-mailcaps) (cond ((file-directory-p file-name) (error "Can't print a directory")) ((file-exists-p file-name) (let (mime-type method) (if (and (string-match "\\.[^\\.]+$" file-name) (setq mime-type (mailcap-extension-to-mime (match-string 0 file-name))) (stringp (setq method (mailcap-mime-info mime-type "print" 'no-decode)))) (call-process shell-file-name nil (generate-new-buffer " *mm*") nil shell-command-switch (mm-mailcap-command method file-name mime-type)) (with-temp-buffer (insert-file-contents file-name) (if (eq gnus-dired-mail-mode 'gnus-user-agent) (gnus-print-buffer) ;; FIXME: (error "MIME print only implemeted via Gnus"))) (ps-despool print-to)))) ((file-symlink-p file-name) (error "File is a symlink to a nonexistent target")) (t (error "File no longer exists; type `g' to update Dired buffer")))) (provide 'gnus-dired) ;; arch-tag: 44737731-e445-4638-a31e-713c7590ec76 ;;; gnus-dired.el ends here gnus-5.11+v0.10.dfsg/lisp/nnmh.el0000644000175000017500000004555511004005110016521 0ustar tvainikatvainika;;; nnmh.el --- mhspool access for Gnus ;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, ;; 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; Masanobu UMEDA ;; Keywords: news, mail ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 3, or (at your option) ;; any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Commentary: ;; Based on nnspool.el by Masanobu UMEDA . ;; For an overview of what the interface functions do, please see the ;; Gnus sources. ;;; Code: (require 'nnheader) (require 'nnmail) (require 'gnus-start) (require 'nnoo) (eval-when-compile (require 'cl)) (nnoo-declare nnmh) (defvoo nnmh-directory message-directory "Mail spool directory.") (defvoo nnmh-get-new-mail t "If non-nil, nnmh will check the incoming mail file and split the mail.") (defvoo nnmh-prepare-save-mail-hook nil "Hook run narrowed to an article before saving.") (defvoo nnmh-be-safe nil "If non-nil, nnmh will check all articles to make sure whether they are new or not. Go through the .nnmh-articles file and compare with the actual articles in this folder. The articles that are \"new\" will be marked as unread by Gnus.") (defconst nnmh-version "nnmh 1.0" "nnmh version.") (defvoo nnmh-current-directory nil "Current news group directory.") (defvoo nnmh-status-string "") (defvoo nnmh-group-alist nil) ;; Don't even think about setting this variable. It does not exist. ;; Forget about it. Uh-huh. Nope. Nobody here. It's only bound ;; dynamically by certain functions in nndraft. (defvar nnmh-allow-delete-final nil) ;;; Interface functions. (nnoo-define-basics nnmh) (deffoo nnmh-retrieve-headers (articles &optional newsgroup server fetch-old) (with-current-buffer nntp-server-buffer (erase-buffer) (let* ((file nil) (number (length articles)) (large (and (numberp nnmail-large-newsgroup) (> number nnmail-large-newsgroup))) (count 0) (file-name-coding-system nnmail-pathname-coding-system) beg article) (nnmh-possibly-change-directory newsgroup server) ;; We don't support fetching by Message-ID. (if (stringp (car articles)) 'headers (while articles (when (and (file-exists-p (setq file (concat (file-name-as-directory nnmh-current-directory) (int-to-string (setq article (pop articles)))))) (not (file-directory-p file))) (insert (format "221 %d Article retrieved.\n" article)) (setq beg (point)) (nnheader-insert-head file) (goto-char beg) (if (search-forward "\n\n" nil t) (forward-char -1) (goto-char (point-max)) (insert "\n\n")) (insert ".\n") (delete-region (point) (point-max))) (setq count (1+ count)) (and large (zerop (% count 20)) (nnheader-message 5 "nnmh: Receiving headers... %d%%" (/ (* count 100) number)))) (when large (nnheader-message 5 "nnmh: Receiving headers...done")) (nnheader-fold-continuation-lines) 'headers)))) (deffoo nnmh-open-server (server &optional defs) (nnoo-change-server 'nnmh server defs) (when (not (file-exists-p nnmh-directory)) (condition-case () (make-directory nnmh-directory t) (error t))) (cond ((not (file-exists-p nnmh-directory)) (nnmh-close-server) (nnheader-report 'nnmh "Couldn't create directory: %s" nnmh-directory)) ((not (file-directory-p (file-truename nnmh-directory))) (nnmh-close-server) (nnheader-report 'nnmh "Not a directory: %s" nnmh-directory)) (t (nnheader-report 'nnmh "Opened server %s using directory %s" server nnmh-directory) t))) (deffoo nnmh-request-article (id &optional newsgroup server buffer) (nnmh-possibly-change-directory newsgroup server) (let ((file (if (stringp id) nil (concat nnmh-current-directory (int-to-string id)))) (file-name-coding-system nnmail-pathname-coding-system) (nntp-server-buffer (or buffer nntp-server-buffer))) (and (stringp file) (file-exists-p file) (not (file-directory-p file)) (save-excursion (nnmail-find-file file)) (string-to-number (file-name-nondirectory file))))) (deffoo nnmh-request-group (group &optional server dont-check) (nnheader-init-server-buffer) (nnmh-possibly-change-directory group server) (let ((pathname (nnmail-group-pathname group nnmh-directory)) (file-name-coding-system nnmail-pathname-coding-system) dir) (cond ((not (file-directory-p pathname)) (nnheader-report 'nnmh "Can't select group (no such directory): %s" group)) (t (setq nnmh-current-directory pathname) (and nnmh-get-new-mail nnmh-be-safe (nnmh-update-gnus-unreads group)) (cond (dont-check (nnheader-report 'nnmh "Selected group %s" group) t) (t ;; Re-scan the directory if it's on a foreign system. (nnheader-re-read-dir pathname) (setq dir (sort (mapcar 'string-to-number (directory-files pathname nil "^[0-9]+$" t)) '<)) (cond (dir (setq nnmh-group-alist (delq (assoc group nnmh-group-alist) nnmh-group-alist)) (push (list group (cons (car dir) (car (last dir)))) nnmh-group-alist) (nnheader-report 'nnmh "Selected group %s" group) (nnheader-insert "211 %d %d %d %s\n" (length dir) (car dir) (car (last dir)) group)) (t (nnheader-report 'nnmh "Empty group %s" group) (nnheader-insert (format "211 0 1 0 %s\n" group)))))))))) (deffoo nnmh-request-scan (&optional group server) (nnmail-get-new-mail 'nnmh nil nnmh-directory group)) (deffoo nnmh-request-list (&optional server dir) (nnheader-insert "") (nnmh-possibly-change-directory nil server) (let ((file-name-coding-system nnmail-pathname-coding-system) (nnmh-toplev (file-truename (or dir (file-name-as-directory nnmh-directory))))) (nnmh-request-list-1 nnmh-toplev)) (setq nnmh-group-alist (nnmail-get-active)) t) (defvar nnmh-toplev) (defun nnmh-request-list-1 (dir) (setq dir (expand-file-name dir)) ;; Recurse down all directories. (let ((dirs (and (file-readable-p dir) (nnheader-directory-files dir t nil t))) rdir) ;; Recurse down directories. (while (setq rdir (pop dirs)) (when (and (file-directory-p rdir) (file-readable-p rdir) (not (equal (file-truename rdir) (file-truename dir)))) (nnmh-request-list-1 rdir)))) ;; For each directory, generate an active file line. (unless (string= (expand-file-name nnmh-toplev) dir) (let ((files (mapcar 'string-to-number (directory-files dir nil "^[0-9]+$" t)))) (when files (with-current-buffer nntp-server-buffer (goto-char (point-max)) (insert (format "%s %.0f %.0f y\n" (progn (string-match (regexp-quote (file-truename (file-name-as-directory (expand-file-name nnmh-toplev)))) dir) (mm-string-to-multibyte ;Why? Isn't it multibyte already? (mm-encode-coding-string (nnheader-replace-chars-in-string (substring dir (match-end 0)) ?/ ?.) nnmail-pathname-coding-system))) (apply 'max files) (apply 'min files))))))) t) (deffoo nnmh-request-newgroups (date &optional server) (nnmh-request-list server)) (deffoo nnmh-request-expire-articles (articles newsgroup &optional server force) (nnmh-possibly-change-directory newsgroup server) (let ((is-old t) (nnmail-expiry-target (or (gnus-group-find-parameter newsgroup 'expiry-target t) nnmail-expiry-target)) article rest mod-time) (nnheader-init-server-buffer) (while (and articles is-old) (setq article (concat nnmh-current-directory (int-to-string (car articles)))) (when (setq mod-time (nth 5 (file-attributes article))) (if (and (nnmh-deletable-article-p newsgroup (car articles)) (setq is-old (nnmail-expired-article-p newsgroup mod-time force))) (progn ;; Allow a special target group. -- jcn (unless (eq nnmail-expiry-target 'delete) (with-temp-buffer (nnmh-request-article (car articles) newsgroup server (current-buffer)) (nnmail-expiry-target-group nnmail-expiry-target newsgroup))) (nnheader-message 5 "Deleting article %s in %s..." article newsgroup) (condition-case () (funcall nnmail-delete-file-function article) (file-error (nnheader-message 1 "Couldn't delete article %s in %s" article newsgroup) (push (car articles) rest)))) (push (car articles) rest))) (setq articles (cdr articles))) (nnheader-message 5 "") (nconc rest articles))) (deffoo nnmh-close-group (group &optional server) t) (deffoo nnmh-request-move-article (article group server accept-form &optional last move-is-internal) (let ((buf (get-buffer-create " *nnmh move*")) result) (and (nnmh-deletable-article-p group article) (nnmh-request-article article group server) (with-current-buffer buf (erase-buffer) (insert-buffer-substring nntp-server-buffer) (setq result (eval accept-form)) (kill-buffer (current-buffer)) result) (progn (nnmh-possibly-change-directory group server) (condition-case () (funcall nnmail-delete-file-function (concat nnmh-current-directory (int-to-string article))) (file-error nil)))) result)) (deffoo nnmh-request-accept-article (group &optional server last noinsert) (nnmh-possibly-change-directory group server) (nnmail-check-syntax) (when nnmail-cache-accepted-message-ids (nnmail-cache-insert (nnmail-fetch-field "message-id") group (nnmail-fetch-field "subject") (nnmail-fetch-field "from"))) (nnheader-init-server-buffer) (prog1 (if (stringp group) (if noinsert (nnmh-active-number group) (car (nnmh-save-mail (list (cons group (nnmh-active-number group))) noinsert))) (let ((res (nnmail-article-group 'nnmh-active-number))) (if (and (null res) (yes-or-no-p "Moved to `junk' group; delete article? ")) 'junk (car (nnmh-save-mail res noinsert))))) (when (and last nnmail-cache-accepted-message-ids) (nnmail-cache-close)))) (deffoo nnmh-request-replace-article (article group buffer) (nnmh-possibly-change-directory group) (with-current-buffer buffer (nnmh-possibly-create-directory group) (ignore-errors (nnmail-write-region (point-min) (point-max) (concat nnmh-current-directory (int-to-string article)) nil (if (nnheader-be-verbose 5) nil 'nomesg)) t))) (deffoo nnmh-request-create-group (group &optional server args) (nnheader-init-server-buffer) (unless (assoc group nnmh-group-alist) (let (active) (push (list group (setq active (cons 1 0))) nnmh-group-alist) (nnmh-possibly-create-directory group) (nnmh-possibly-change-directory group server) (let ((articles (mapcar 'string-to-number (directory-files nnmh-current-directory nil "^[0-9]+$")))) (when articles (setcar active (apply 'min articles)) (setcdr active (apply 'max articles)))))) t) (deffoo nnmh-request-delete-group (group &optional force server) (nnmh-possibly-change-directory group server) ;; Delete all articles in GROUP. (if (not force) () ; Don't delete the articles. (let ((articles (directory-files nnmh-current-directory t "^[0-9]+$"))) (while articles (when (file-writable-p (car articles)) (nnheader-message 5 "Deleting article %s in %s..." (car articles) group) (funcall nnmail-delete-file-function (car articles))) (setq articles (cdr articles)))) ;; Try to delete the directory itself. (ignore-errors (delete-directory nnmh-current-directory))) ;; Remove the group from all structures. (setq nnmh-group-alist (delq (assoc group nnmh-group-alist) nnmh-group-alist) nnmh-current-directory nil) t) (deffoo nnmh-request-rename-group (group new-name &optional server) (nnmh-possibly-change-directory group server) (let ((new-dir (nnmail-group-pathname new-name nnmh-directory)) (old-dir (nnmail-group-pathname group nnmh-directory))) (when (ignore-errors (make-directory new-dir t) t) ;; We move the articles file by file instead of renaming ;; the directory -- there may be subgroups in this group. ;; One might be more clever, I guess. (let ((files (nnheader-article-to-file-alist old-dir))) (while files (rename-file (concat old-dir (cdar files)) (concat new-dir (cdar files))) (pop files))) (when (<= (length (directory-files old-dir)) 2) (ignore-errors (delete-directory old-dir))) ;; That went ok, so we change the internal structures. (let ((entry (assoc group nnmh-group-alist))) (when entry (setcar entry new-name)) (setq nnmh-current-directory nil) t)))) (nnoo-define-skeleton nnmh) ;;; Internal functions. (defun nnmh-possibly-change-directory (newsgroup &optional server) (when (and server (not (nnmh-server-opened server))) (nnmh-open-server server)) (when newsgroup (let ((pathname (nnmail-group-pathname newsgroup nnmh-directory)) (file-name-coding-system nnmail-pathname-coding-system)) (if (file-directory-p pathname) (setq nnmh-current-directory pathname) (nnheader-report 'nnmh "Not a directory: %s" nnmh-directory))))) (defun nnmh-possibly-create-directory (group) (let (dir dirs) (setq dir (nnmail-group-pathname group nnmh-directory)) (while (not (file-directory-p dir)) (push dir dirs) (setq dir (file-name-directory (directory-file-name dir)))) (while dirs (when (make-directory (directory-file-name (car dirs))) (error "Could not create directory %s" (car dirs))) (nnheader-message 5 "Creating mail directory %s" (car dirs)) (setq dirs (cdr dirs))))) (defun nnmh-save-mail (group-art &optional noinsert) "Called narrowed to an article." (unless noinsert (nnmail-insert-lines) (nnmail-insert-xref group-art)) (run-hooks 'nnmail-prepare-save-mail-hook) (run-hooks 'nnmh-prepare-save-mail-hook) (goto-char (point-min)) (while (looking-at "From ") (replace-match "X-From-Line: ") (forward-line 1)) ;; We save the article in all the newsgroups it belongs in. (let ((ga group-art) first) (while ga (nnmh-possibly-create-directory (caar ga)) (let ((file (concat (nnmail-group-pathname (caar ga) nnmh-directory) (int-to-string (cdar ga))))) (if first ;; It was already saved, so we just make a hard link. (funcall nnmail-crosspost-link-function first file t) ;; Save the article. (nnmail-write-region (point-min) (point-max) file nil nil) (setq first file))) (setq ga (cdr ga)))) group-art) (defun nnmh-active-number (group) "Compute the next article number in GROUP." (let ((active (cadr (assoc group nnmh-group-alist))) (dir (nnmail-group-pathname group nnmh-directory)) (file-name-coding-system nnmail-pathname-coding-system) file) (unless active ;; The group wasn't known to nnmh, so we just create an active ;; entry for it. (setq active (cons 1 0)) (push (list group active) nnmh-group-alist) (unless (file-exists-p dir) (gnus-make-directory dir)) ;; Find the highest number in the group. (let ((files (sort (mapcar 'string-to-number (directory-files dir nil "^[0-9]+$")) '>))) (when files (setcdr active (car files))))) (setcdr active (1+ (cdr active))) (while (or ;; See whether the file exists... (file-exists-p (setq file (concat (nnmail-group-pathname group nnmh-directory) (int-to-string (cdr active))))) ;; ... or there is a buffer that will make that file exist ;; in the future. (get-file-buffer file)) ;; Skip past that file. (setcdr active (1+ (cdr active)))) (cdr active))) (defun nnmh-update-gnus-unreads (group) ;; Go through the .nnmh-articles file and compare with the actual ;; articles in this folder. The articles that are "new" will be ;; marked as unread by Gnus. (let* ((dir nnmh-current-directory) (files (sort (mapcar 'string-to-number (directory-files nnmh-current-directory nil "^[0-9]+$" t)) '<)) (nnmh-file (concat dir ".nnmh-articles")) new articles) ;; Load the .nnmh-articles file. (when (file-exists-p nnmh-file) (setq articles (let (nnmh-newsgroup-articles) (ignore-errors (load nnmh-file nil t t)) nnmh-newsgroup-articles))) ;; Add all new articles to the `new' list. (let ((art files)) (while art (unless (assq (car art) articles) (push (car art) new)) (setq art (cdr art)))) ;; Remove all deleted articles. (let ((art articles)) (while art (unless (memq (caar art) files) (setq articles (delq (car art) articles))) (setq art (cdr art)))) ;; Check whether the articles really are the ones that Gnus thinks ;; they are by looking at the time-stamps. (let ((arts articles) art) (while (setq art (pop arts)) (when (not (equal (nth 5 (file-attributes (concat dir (int-to-string (car art))))) (cdr art))) (setq articles (delq art articles)) (push (car art) new)))) ;; Go through all the new articles and add them, and their ;; time-stamps, to the list. (setq articles (nconc articles (mapcar (lambda (art) (cons art (nth 5 (file-attributes (concat dir (int-to-string art)))))) new))) ;; Make Gnus mark all new articles as unread. (when new (gnus-make-articles-unread (gnus-group-prefixed-name group (list 'nnmh "")) (setq new (sort new '<)))) ;; Sort the article list with highest numbers first. (setq articles (sort articles (lambda (art1 art2) (> (car art1) (car art2))))) ;; Finally write this list back to the .nnmh-articles file. (with-temp-file nnmh-file (insert ";; Gnus article active file for " group "\n\n") (insert "(setq nnmh-newsgroup-articles '") (gnus-prin1 articles) (insert ")\n")))) (defun nnmh-deletable-article-p (group article) "Say whether ARTICLE in GROUP can be deleted." (let ((path (concat nnmh-current-directory (int-to-string article)))) ;; Writable. (and (file-writable-p path) (or ;; We can never delete the last article in the group. (not (eq (cdr (nth 1 (assoc group nnmh-group-alist))) article)) ;; Well, we can. nnmh-allow-delete-final)))) (provide 'nnmh) ;; arch-tag: 36c12a98-3bad-44b3-9953-628078ef0e04 ;;; nnmh.el ends here gnus-5.11+v0.10.dfsg/lisp/gnus-xmas.el0000644000175000017500000010500510765103167017516 0ustar tvainikatvainika;;; gnus-xmas.el --- Gnus functions for XEmacs ;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, ;; 2005, 2006, 2008 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; Keywords: news ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 3, or (at your option) ;; any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Commentary: ;;; Code: (eval-when-compile (autoload 'gnus-active "gnus" nil nil 'macro) (autoload 'gnus-group-entry "gnus" nil nil 'macro) (autoload 'gnus-info-level "gnus" nil nil 'macro) (autoload 'gnus-info-marks "gnus" nil nil 'macro) (autoload 'gnus-info-method "gnus" nil nil 'macro) (autoload 'gnus-info-score "gnus" nil nil 'macro)) (require 'text-props) (defvar menu-bar-mode (featurep 'menubar)) (require 'messagexmas) (require 'wid-edit) (defgroup gnus-xmas nil "XEmacsoid support for Gnus" :group 'gnus) (defcustom gnus-xmas-glyph-directory nil "Directory where Gnus logos and icons are located. If this variable is nil, Gnus will try to locate the directory automatically." :type '(choice (const :tag "autodetect" nil) directory) :group 'gnus-xmas) (unless gnus-xmas-glyph-directory (unless (setq gnus-xmas-glyph-directory (message-xmas-find-glyph-directory "gnus")) (error "Can't find glyph directory. \ Possibly the `etc' directory has not been installed."))) ;;; Internal variables. ;; Don't warn about these undefined variables. ;;defined in gnus.el (defvar gnus-active-hashtb) (defvar gnus-article-buffer) (defvar gnus-auto-center-summary) (defvar gnus-current-headers) (defvar gnus-level-killed) (defvar gnus-level-zombie) (defvar gnus-newsgroup-bookmarks) (defvar gnus-newsgroup-dependencies) (defvar gnus-newsgroup-selected-overlay) (defvar gnus-newsrc-hashtb) (defvar gnus-read-mark) (defvar gnus-refer-article-method) (defvar gnus-reffed-article-number) (defvar gnus-unread-mark) (defvar gnus-version) (defvar gnus-view-pseudos) (defvar gnus-view-pseudos-separately) (defvar gnus-visual) (defvar gnus-zombie-list) ;;defined in gnus-msg.el (defvar gnus-article-copy) (defvar gnus-check-before-posting) ;;defined in gnus-vis.el (defvar gnus-article-button-face) (defvar gnus-article-mouse-face) (defvar gnus-summary-selected-face) (defvar gnus-group-reading-menu) (defvar gnus-group-group-menu) (defvar gnus-group-misc-menu) (defvar gnus-summary-article-menu) (defvar gnus-summary-thread-menu) (defvar gnus-summary-misc-menu) (defvar gnus-summary-post-menu) (defvar gnus-summary-kill-menu) (defvar gnus-article-article-menu) (defvar gnus-article-treatment-menu) (defvar gnus-mouse-2) (defvar standard-display-table) (defvar gnus-tree-minimize-window) ;;`gnus-agent-mode' in gnus-agent.el will define it. (defvar gnus-agent-summary-mode) (defvar gnus-draft-mode) (defun gnus-xmas-highlight-selected-summary () ;; Highlight selected article in summary buffer (when gnus-summary-selected-face (when gnus-newsgroup-selected-overlay (delete-extent gnus-newsgroup-selected-overlay)) (setq gnus-newsgroup-selected-overlay (make-extent (point-at-bol) (point-at-eol))) (set-extent-face gnus-newsgroup-selected-overlay gnus-summary-selected-face))) (defcustom gnus-xmas-force-redisplay nil "*If non-nil, force a redisplay before recentering the summary buffer. This is ugly, but it works around a bug in `window-displayed-height'." :type 'boolean :group 'gnus-xmas) (defun gnus-xmas-switch-horizontal-scrollbar-off () (when (featurep 'scrollbar) (set-specifier scrollbar-height (cons (current-buffer) 0)))) (defun gnus-xmas-summary-recenter () "\"Center\" point in the summary window. If `gnus-auto-center-summary' is nil, or the article buffer isn't displayed, no centering will be performed." ;; Suggested by earle@mahendo.JPL.NASA.GOV (Greg Earle). ;; Recenter only when requested. Suggested by popovich@park.cs.columbia.edu. ;; Force redisplay to get properly computed window height. (when gnus-xmas-force-redisplay (sit-for 0)) (when gnus-auto-center-summary (let* ((height (if (fboundp 'window-displayed-height) (window-displayed-height) (- (window-height) 2))) (top (cond ((< height 4) 0) ((< height 7) 1) (t (if (numberp gnus-auto-center-summary) gnus-auto-center-summary 2)))) (bottom (save-excursion (goto-char (point-max)) (forward-line (- height)) (point))) (window (get-buffer-window (current-buffer)))) (when (get-buffer-window gnus-article-buffer) ;; Only do recentering when the article buffer is displayed, ;; Set the window start to either `bottom', which is the biggest ;; possible valid number, or the second line from the top, ;; whichever is the least. ;; NOFORCE parameter suggested by Daniel Pittman . (set-window-start window (min bottom (save-excursion (forward-line (- top)) (point))) t)) ;; Do horizontal recentering while we're at it. (when (and (get-buffer-window (current-buffer) t) (not (eq gnus-auto-center-summary 'vertical))) (let ((selected (selected-window))) (select-window (get-buffer-window (current-buffer) t)) (gnus-summary-position-point) (gnus-horizontal-recenter) (select-window selected)))))) (defun gnus-xmas-summary-set-display-table () ;; Setup the display table -- like `gnus-summary-setup-display-table', ;; but done in an XEmacsish way. (let ((table (make-display-table)) (i 32)) ;; Nix out all the control chars... (while (>= (setq i (1- i)) 0) (aset table i [??])) ;; ... but not newline and cr, of course. (cr is necessary for the ;; selective display). (aset table ?\n nil) (aset table ?\r nil) ;; We keep TAB as well. (aset table ?\t nil) ;; We nix out any glyphs over 126 below ctl-arrow. (let ((i (if (integerp ctl-arrow) ctl-arrow 160))) (while (>= (setq i (1- i)) 127) (unless (aref table i) (aset table i [??])))) ;; Can't use `set-specifier' because of a bug in 19.14 and earlier (add-spec-to-specifier current-display-table table (current-buffer) nil))) (defun gnus-xmas-add-text-properties (start end props &optional object) (add-text-properties start end props object) (put-text-property start end 'start-closed nil object)) (defun gnus-xmas-put-text-property (start end prop value &optional object) (put-text-property start end prop value object) (put-text-property start end 'start-closed nil object)) (defun gnus-xmas-extent-start-open (point) (map-extents (lambda (extent arg) (set-extent-property extent 'start-open t)) nil point (min (1+ (point)) (point-max)))) (defun gnus-xmas-article-push-button (event) "Check text under the mouse pointer for a callback function. If the text under the mouse pointer has a `gnus-callback' property, call it with the value of the `gnus-data' text property." (interactive "e") (set-buffer (window-buffer (event-window event))) (let* ((pos (event-closest-point event)) (data (get-text-property pos 'gnus-data)) (fun (get-text-property pos 'gnus-callback))) (goto-char pos) (when fun (funcall fun data)))) (defun gnus-xmas-move-overlay (extent start end &optional buffer) (set-extent-endpoints extent start end buffer)) (defun gnus-xmas-kill-all-overlays () "Delete all extents in the current buffer." (map-extents (lambda (extent ignore) (delete-extent extent) nil))) (defun gnus-xmas-window-top-edge (&optional window) (nth 1 (window-pixel-edges window))) (defun gnus-xmas-tree-minimize () (when (and gnus-tree-minimize-window (not (one-window-p))) (let* ((window-min-height 2) (height (1+ (count-lines (point-min) (point-max)))) (min (max (1- window-min-height) height)) (tot (if (numberp gnus-tree-minimize-window) (min gnus-tree-minimize-window min) min)) (win (get-buffer-window (current-buffer))) (wh (and win (1- (window-height win))))) (when (and win (not (eq tot wh))) (let ((selected (selected-window))) (select-window win) (enlarge-window (- tot wh)) (select-window selected)))))) ;; Select the lowest window on the frame. (defun gnus-xmas-select-lowest-window () (let* ((lowest-window (selected-window)) (bottom-edge (car (cdr (cdr (cdr (window-pixel-edges)))))) (last-window (previous-window)) (window-search t)) (while window-search (let* ((this-window (next-window)) (next-bottom-edge (car (cdr (cdr (cdr (window-pixel-edges this-window))))))) (when (< bottom-edge next-bottom-edge) (setq bottom-edge next-bottom-edge) (setq lowest-window this-window)) (select-window this-window) (when (eq last-window this-window) (select-window lowest-window) (setq window-search nil)))))) (defmacro gnus-xmas-menu-add (type &rest menus) `(gnus-xmas-menu-add-1 ',type ',menus)) (put 'gnus-xmas-menu-add 'lisp-indent-function 1) (defun gnus-xmas-menu-add-1 (type menus) (when (and menu-bar-mode (gnus-visual-p (intern (format "%s-menu" type)) 'menu)) (while menus (easy-menu-add (symbol-value (pop menus)))))) (defun gnus-xmas-group-menu-add () (gnus-xmas-menu-add group gnus-group-reading-menu gnus-group-group-menu gnus-group-misc-menu)) (defun gnus-xmas-summary-menu-add () (gnus-xmas-menu-add summary gnus-summary-misc-menu gnus-summary-kill-menu gnus-summary-article-menu gnus-summary-thread-menu gnus-summary-post-menu )) (defun gnus-xmas-article-menu-add () (gnus-xmas-menu-add article gnus-article-article-menu gnus-article-treatment-menu gnus-article-post-menu gnus-article-commands-menu)) (defun gnus-xmas-score-menu-add () (gnus-xmas-menu-add score gnus-score-menu)) (defun gnus-xmas-pick-menu-add () (gnus-xmas-menu-add pick gnus-pick-menu)) (defun gnus-xmas-topic-menu-add () (gnus-xmas-menu-add topic gnus-topic-menu)) (defun gnus-xmas-binary-menu-add () (gnus-xmas-menu-add binary gnus-binary-menu)) (defun gnus-xmas-agent-summary-menu-add () (gnus-xmas-menu-add agent-summary gnus-agent-summary-menu)) (defun gnus-xmas-agent-group-menu-add () (gnus-xmas-menu-add agent-group gnus-agent-group-menu)) (defun gnus-xmas-agent-server-menu-add () (gnus-xmas-menu-add agent-server gnus-agent-server-menu)) (defun gnus-xmas-tree-menu-add () (gnus-xmas-menu-add tree gnus-tree-menu)) (defun gnus-xmas-draft-menu-add () (gnus-xmas-menu-add draft gnus-draft-menu)) (defun gnus-xmas-server-menu-add () (gnus-xmas-menu-add menu gnus-server-server-menu gnus-server-connections-menu)) (defun gnus-xmas-browse-menu-add () (gnus-xmas-menu-add browse gnus-browse-menu)) (defun gnus-xmas-read-event-char (&optional prompt) "Get the next event." (when prompt (message "%s" prompt)) (let ((event (next-command-event))) (sit-for 0) ;; We junk all non-key events. Is this naughty? (while (not (or (key-press-event-p event) (button-press-event-p event))) (dispatch-event event) (setq event (next-command-event))) (cons (and (key-press-event-p event) (event-to-character event)) event))) (defun gnus-xmas-article-describe-bindings (&optional prefix) "Show a list of all defined keys, and their definitions. The optional argument PREFIX, if non-nil, should be a key sequence; then we display only bindings that start with that prefix." (interactive) (gnus-article-check-buffer) (let ((keymap (copy-keymap gnus-article-mode-map)) (map (copy-keymap gnus-article-send-map)) (sumkeys (where-is-internal 'gnus-article-read-summary-keys)) agent draft) (define-key keymap "S" map) (set-keymap-default-binding map nil) (with-current-buffer gnus-article-current-summary (let ((def (key-binding "S")) gnus-pick-mode) (set-keymap-parent map (if (symbolp def) (symbol-value def) def)) (dolist (key sumkeys) (when (setq def (key-binding key)) (define-key keymap key def)))) (when (boundp 'gnus-agent-summary-mode) (setq agent gnus-agent-summary-mode)) (when (boundp 'gnus-draft-mode) (setq draft gnus-draft-mode))) (with-temp-buffer (setq major-mode 'gnus-article-mode) (use-local-map keymap) (set (make-local-variable 'gnus-agent-summary-mode) agent) (set (make-local-variable 'gnus-draft-mode) draft) (describe-bindings prefix)))) (defun gnus-xmas-define () (setq gnus-mouse-2 [button2]) (setq gnus-mouse-3 [button3]) (setq gnus-widget-button-keymap widget-button-keymap) (unless (memq 'underline (face-list)) (and (fboundp 'make-face) (funcall (intern "make-face") 'underline))) ;; Must avoid calling set-face-underline-p directly, because it ;; is a defsubst in emacs19, and will make the .elc files non ;; portable! (unless (face-differs-from-default-p 'underline) (funcall (intern "set-face-underline-p") 'underline t)) (cond ((fboundp 'char-or-char-int-p) ;; Handle both types of marks for XEmacs-20.x. (defalias 'gnus-characterp 'char-or-char-int-p)) ;; V19 of XEmacs, probably. (t (defalias 'gnus-characterp 'characterp))) (defalias 'gnus-make-overlay (lambda (beg end &optional buffer front-advance rear-advance) "Create a new overlay with range BEG to END in BUFFER. FRONT-ADVANCE and REAR-ADVANCE are ignored." (make-extent beg end buffer))) (defalias 'gnus-delete-overlay 'delete-extent) (defalias 'gnus-overlay-put 'set-extent-property) (defalias 'gnus-move-overlay 'gnus-xmas-move-overlay) (defalias 'gnus-overlay-buffer 'extent-object) (defalias 'gnus-overlay-start 'extent-start-position) (defalias 'gnus-overlay-end 'extent-end-position) (defalias 'gnus-kill-all-overlays 'gnus-xmas-kill-all-overlays) (defalias 'gnus-extent-detached-p 'extent-detached-p) (defalias 'gnus-add-text-properties 'gnus-xmas-add-text-properties) (defalias 'gnus-put-text-property 'gnus-xmas-put-text-property) (defalias 'gnus-deactivate-mark 'ignore) (defalias 'gnus-window-edges 'window-pixel-edges) (defalias 'gnus-assq-delete-all 'gnus-xmas-assq-delete-all) (unless (boundp 'standard-display-table) (setq standard-display-table nil)) (defvar gnus-mouse-face-prop 'highlight) (defun gnus-byte-code (func) "Return a form that can be `eval'ed based on FUNC." (let ((fval (indirect-function func))) (if (compiled-function-p fval) (list 'funcall fval) (cons 'progn (cdr (cdr fval)))))) (unless (fboundp 'match-string-no-properties) (defalias 'match-string-no-properties 'match-string)) (defalias 'gnus-x-color-values (if (fboundp 'x-color-values) 'x-color-values (lambda (color) (color-instance-rgb-components (make-color-instance color))))) (unless (fboundp 'char-width) (defalias 'char-width (lambda (ch) 1)))) (defun gnus-xmas-redefine () "Redefine lots of Gnus functions for XEmacs." (defalias 'gnus-summary-set-display-table 'gnus-xmas-summary-set-display-table) (defalias 'gnus-visual-turn-off-edit-menu 'identity) (defalias 'gnus-summary-recenter 'gnus-xmas-summary-recenter) (defalias 'gnus-extent-start-open 'gnus-xmas-extent-start-open) (defalias 'gnus-article-push-button 'gnus-xmas-article-push-button) (defalias 'gnus-window-top-edge 'gnus-xmas-window-top-edge) (defalias 'gnus-read-event-char 'gnus-xmas-read-event-char) (defalias 'gnus-group-startup-message 'gnus-xmas-group-startup-message) (defalias 'gnus-tree-minimize 'gnus-xmas-tree-minimize) (defalias 'gnus-select-lowest-window 'gnus-xmas-select-lowest-window) (defalias 'gnus-mail-strip-quoted-names 'gnus-xmas-mail-strip-quoted-names) (defalias 'gnus-character-to-event 'character-to-event) (defalias 'gnus-mode-line-buffer-identification 'gnus-xmas-mode-line-buffer-identification) (defalias 'gnus-key-press-event-p 'key-press-event-p) (defalias 'gnus-region-active-p 'region-active-p) (defalias 'gnus-mark-active-p 'region-exists-p) (defalias 'gnus-annotation-in-region-p 'gnus-xmas-annotation-in-region-p) (defalias 'gnus-mime-button-menu 'gnus-xmas-mime-button-menu) (defalias 'gnus-mime-security-button-menu 'gnus-xmas-mime-security-button-menu) (defalias 'gnus-image-type-available-p 'gnus-xmas-image-type-available-p) (defalias 'gnus-put-image 'gnus-xmas-put-image) (defalias 'gnus-create-image 'gnus-xmas-create-image) (defalias 'gnus-remove-image 'gnus-xmas-remove-image) (defalias 'gnus-article-describe-bindings 'gnus-xmas-article-describe-bindings) ;; These ones are not defcutom'ed, sometimes not even defvar'ed. They ;; probably should. If that is done, the code below should then be moved ;; where each variable is defined, in order not to mess with user settings. ;; -- didier (add-hook 'gnus-score-mode-hook 'gnus-xmas-score-menu-add) (add-hook 'gnus-binary-mode-hook 'gnus-xmas-binary-menu-add) (add-hook 'gnus-server-mode-hook 'gnus-xmas-server-menu-add) (add-hook 'gnus-browse-mode-hook 'gnus-xmas-browse-menu-add) (add-hook 'gnus-draft-mode-hook 'gnus-xmas-draft-menu-add) (add-hook 'gnus-mailing-list-mode-hook 'gnus-xmas-mailing-list-menu-add)) ;;; XEmacs logo and toolbar. (defun gnus-xmas-group-startup-message (&optional x y) "Insert startup message in current buffer." ;; Insert the message. (erase-buffer) (cond ((and (console-on-window-system-p) (or (featurep 'xpm) (featurep 'xbm))) (let* ((logo-xpm (expand-file-name "gnus.xpm" gnus-xmas-glyph-directory)) (logo-xbm (expand-file-name "gnus.xbm" gnus-xmas-glyph-directory)) (glyph (make-glyph (cond ((featurep 'xpm) `[xpm :file ,logo-xpm :color-symbols (("thing" . ,(car gnus-logo-colors)) ("shadow" . ,(cadr gnus-logo-colors)) ("oort" . "#eeeeee") ("background" . ,(face-background 'default)))]) ((featurep 'xbm) `[xbm :file ,logo-xbm]) (t [nothing]))))) (insert " ") (set-extent-begin-glyph (make-extent (point) (point)) glyph) (goto-char (point-min)) (while (not (eobp)) (insert (make-string (/ (max (- (window-width) (or x 35)) 0) 2) ?\ )) (forward-line 1)) (setq gnus-simple-splash nil)) (goto-char (point-min)) (let* ((pheight (+ 20 (count-lines (point-min) (point-max)))) (wheight (window-height)) (rest (- wheight pheight))) (insert (make-string (max 0 (* 2 (/ rest 3))) ?\n)))) (t (insert (format " %s _ ___ _ _ _ ___ __ ___ __ _ ___ __ _ ___ __ ___ _ ___ _ _ _ __ _ ___ __ _ __ _ _ _ _ _ _ _ _ _ _ __ ___ _ _ _ _ _ _ _ _ _ _ _ __ " "")) ;; And then hack it. (gnus-indent-rigidly (point-min) (point-max) (/ (max (- (window-width) (or x 46)) 0) 2)) (goto-char (point-min)) (forward-line 1) (let* ((pheight (count-lines (point-min) (point-max))) (wheight (window-height)) (rest (- wheight pheight))) (insert (make-string (max 0 (* 2 (/ rest 3))) ?\n))) ;; Paint it. (put-text-property (point-min) (point-max) 'face 'gnus-splash))) (setq modeline-buffer-identification (list (concat gnus-version ": *Group*"))) (set-buffer-modified-p t)) ;;; The toolbar. (defun gnus-xmas-update-toolbars () "Update the toolbars' appearance." (when (and (not noninteractive) (featurep 'gnus-xmas)) (save-excursion (dolist (buffer (buffer-list)) (set-buffer buffer) (cond ((eq major-mode 'gnus-group-mode) (gnus-xmas-setup-group-toolbar)) ((eq major-mode 'gnus-summary-mode) (gnus-xmas-setup-summary-toolbar))))))) (defcustom gnus-use-toolbar (if (featurep 'toolbar) 'default) "*Position to display the toolbar. Nil means do not use a toolbar. If it is non-nil, it should be one of the symbols `default', `top', `bottom', `right', and `left'. `default' means to use the default toolbar, the rest mean to display the toolbar on the place which those names show." :type '(choice (const default) (const top) (const bottom) (const left) (const right) (const :tag "no toolbar" nil)) :set (lambda (symbol value) (set-default symbol (if (or (not value) (memq value (list 'default 'top 'bottom 'right 'left))) value 'default)) (gnus-xmas-update-toolbars)) :group 'gnus-xmas) (defcustom gnus-toolbar-thickness (if (featurep 'toolbar) (cons (specifier-instance default-toolbar-height) (specifier-instance default-toolbar-width))) "*Cons of the height and the width specifying the thickness of a toolbar. The height is used for the toolbar displayed on the top or the bottom, the width is used for the toolbar displayed on the right or the left." :type '(cons :tag "height & width" (integer :tag "height") (integer :tag "width")) :set (lambda (symbol value) (set-default symbol (if (and (consp value) (natnump (car value)) (natnump (cdr value))) value '(37 . 40))) (gnus-xmas-update-toolbars)) :group 'gnus-xmas) (defvar gnus-group-toolbar '([gnus-group-get-new-news gnus-group-get-new-news t "Get new news"] [gnus-group-get-new-news-this-group gnus-group-get-new-news-this-group t "Get new news in this group"] [gnus-group-catchup-current gnus-group-catchup-current t "Catchup group"] [gnus-group-describe-group gnus-group-describe-group t "Describe group"] [gnus-group-unsubscribe gnus-group-unsubscribe t "Unsubscribe group"] [gnus-group-subscribe gnus-group-subscribe t "Subscribe group"] [gnus-group-kill-group gnus-group-kill-group t "Kill group"] [gnus-summary-mail-save gnus-group-save-newsrc t "Save .newsrc files"] ; borrowed icon. [gnus-group-exit gnus-group-exit t "Exit Gnus"]) "The group buffer toolbar.") (defvar gnus-summary-toolbar '([gnus-summary-prev-unread gnus-summary-prev-page-or-article t "Page up"] [gnus-summary-next-unread gnus-summary-next-page t "Page down"] [gnus-summary-post-news gnus-summary-post-news t "Post an article"] [gnus-summary-followup-with-original gnus-summary-followup-with-original t "Post a followup and yank the original"] [gnus-summary-followup gnus-summary-followup t "Post a followup"] [gnus-summary-reply-with-original gnus-summary-reply-with-original t "Mail a reply and yank the original"] [gnus-summary-reply gnus-summary-reply t "Mail a reply"] [gnus-summary-caesar-message gnus-summary-caesar-message t "Rot 13"] [gnus-uu-decode-uu gnus-uu-decode-uu t "Decode uuencoded articles"] [gnus-summary-save-article-file gnus-summary-save-article-file t "Save article in file"] [gnus-summary-save-article gnus-summary-save-article t "Save article"] [gnus-uu-post-news gnus-uu-post-news t "Post a uuencoded article"] [gnus-summary-cancel-article gnus-summary-cancel-article t "Cancel article"] [gnus-summary-catchup gnus-summary-catchup t "Catchup"] [gnus-summary-catchup-and-exit gnus-summary-catchup-and-exit t "Catchup and exit"] [gnus-summary-exit gnus-summary-exit t "Exit this summary"]) "The summary buffer toolbar.") (defvar gnus-summary-mail-toolbar '( [gnus-summary-prev-unread gnus-summary-prev-unread-article t "Prev unread article"] [gnus-summary-next-unread gnus-summary-next-unread-article t "Next unread article"] [gnus-summary-mail-reply gnus-summary-reply t "Reply"] [gnus-summary-mail-originate gnus-summary-post-news t "Originate"] [gnus-summary-mail-save gnus-summary-save-article t "Save"] [gnus-summary-mail-copy gnus-summary-copy-article t "Copy message"] [gnus-summary-mail-forward gnus-summary-mail-forward t "Forward message"] [gnus-summary-caesar-message gnus-summary-caesar-message t "Rot 13"] [gnus-uu-decode-uu gnus-uu-decode-uu t "Decode uuencoded articles"] [gnus-summary-save-article-file gnus-summary-save-article-file t "Save article in file"] [gnus-summary-save-article gnus-summary-save-article t "Save article"] [gnus-summary-cancel-article ; usenet : cancellation :: mail : deletion. gnus-summary-delete-article t "Delete message"] [gnus-summary-catchup gnus-summary-catchup t "Catchup"] [gnus-summary-catchup-and-exit gnus-summary-catchup-and-exit t "Catchup and exit"] [gnus-summary-exit gnus-summary-exit t "Exit this summary"]) "The summary buffer mail toolbar.") (defun gnus-xmas-setup-toolbar (toolbar) (when (featurep 'toolbar) (if (and gnus-use-toolbar (message-xmas-setup-toolbar toolbar nil "gnus")) (let ((bar (or (intern-soft (format "%s-toolbar" gnus-use-toolbar)) 'default-toolbar)) (height (car gnus-toolbar-thickness)) (width (cdr gnus-toolbar-thickness)) (cur (current-buffer)) bars) (set-specifier (symbol-value bar) toolbar cur) (set-specifier default-toolbar-height height cur) (set-specifier default-toolbar-width width cur) (set-specifier top-toolbar-height height cur) (set-specifier bottom-toolbar-height height cur) (set-specifier right-toolbar-width width cur) (set-specifier left-toolbar-width width cur) (if (eq bar 'default-toolbar) (progn (remove-specifier default-toolbar-visible-p cur) (remove-specifier top-toolbar cur) (remove-specifier top-toolbar-visible-p cur) (remove-specifier bottom-toolbar cur) (remove-specifier bottom-toolbar-visible-p cur) (remove-specifier right-toolbar cur) (remove-specifier right-toolbar-visible-p cur) (remove-specifier left-toolbar cur) (remove-specifier left-toolbar-visible-p cur)) (set-specifier (symbol-value (intern (format "%s-visible-p" bar))) t cur) (setq bars (delq bar (list 'default-toolbar 'bottom-toolbar 'top-toolbar 'right-toolbar 'left-toolbar))) (while bars (set-specifier (symbol-value (intern (format "%s-visible-p" (pop bars)))) nil cur)))) (let ((cur (current-buffer))) (set-specifier default-toolbar-visible-p nil cur) (set-specifier top-toolbar-visible-p nil cur) (set-specifier bottom-toolbar-visible-p nil cur) (set-specifier right-toolbar-visible-p nil cur) (set-specifier left-toolbar-visible-p nil cur))))) (defun gnus-xmas-setup-group-toolbar () (gnus-xmas-setup-toolbar gnus-group-toolbar)) (defun gnus-xmas-setup-summary-toolbar () (gnus-xmas-setup-toolbar (if (gnus-news-group-p gnus-newsgroup-name) gnus-summary-toolbar gnus-summary-mail-toolbar))) (defun gnus-xmas-mail-strip-quoted-names (address) "Protect mail-strip-quoted-names from nil input. XEmacs compatibility workaround." (if (null address) nil (mail-strip-quoted-names address))) (defun gnus-xmas-call-region (command &rest args) (apply 'call-process-region (point-min) (point-max) command t '(t nil) nil args)) (defvar gnus-xmas-modeline-left-extent (let ((ext (copy-extent modeline-buffer-id-left-extent))) ext)) (defvar gnus-xmas-modeline-right-extent (let ((ext (copy-extent modeline-buffer-id-right-extent))) ext)) (defvar gnus-xmas-modeline-glyph (progn (let* ((file-xpm (expand-file-name "gnus-pointer.xpm" gnus-xmas-glyph-directory)) (file-xbm (expand-file-name "gnus-pointer.xbm" gnus-xmas-glyph-directory)) (glyph (make-glyph ;; Gag gag gag. (cond ((featurep 'xpm) ;; Let's try a nifty XPM `[xpm :file ,file-xpm]) ((featurep 'xbm) ;; Then a not-so-nifty XBM `[xbm :file ,file-xbm]) ;; Then the simple string (t [string :data "Gnus:"]))))) (set-glyph-face glyph 'modeline-buffer-id) glyph))) (defun gnus-xmas-mode-line-buffer-identification (line) (let ((line (car line)) chop) (cond ;; This is some weird type of id. ((not (stringp line)) (list line)) ;; This is non-standard, so we just pass it through. ((not (string-match "^Gnus:" line)) (list line)) ;; We have a standard line, so we colorize and glyphize it a bit. (t (setq chop (match-end 0)) (list (if gnus-xmas-modeline-glyph (cons gnus-xmas-modeline-left-extent gnus-xmas-modeline-glyph) (cons gnus-xmas-modeline-left-extent (substring line 0 chop))) (cons gnus-xmas-modeline-right-extent (substring line chop))))))) (defun gnus-xmas-splash () (when (eq (device-type) 'x) (gnus-splash))) (defun gnus-xmas-annotation-in-region-p (b e) (or (map-extents (lambda (e u) t) nil b e nil nil 'mm t) (if (= b e) (eq (cadr (memq 'gnus-undeletable (text-properties-at b))) t) (text-property-any b e 'gnus-undeletable t)))) (defun gnus-xmas-mime-button-menu (event prefix) "Construct a context-sensitive menu of MIME commands." (interactive "e\nP") (let ((response (get-popup-menu-response `("MIME Part" ,@(mapcar (lambda (c) `[,(caddr c) ,(car c) t]) gnus-mime-button-commands))))) (set-buffer (event-buffer event)) (goto-char (event-point event)) (funcall (event-function response) (event-object response)))) (defun gnus-xmas-mime-security-button-menu (event prefix) "Construct a context-sensitive menu of security commands." (interactive "e\nP") (let ((response (get-popup-menu-response `("Security Part" ,@(delq nil (mapcar (lambda (c) (unless (eq (car c) 'undefined) `[,(caddr c) ,(car c) t])) gnus-mime-security-button-commands)))))) (set-buffer (event-buffer event)) (goto-char (event-point event)) (funcall (event-function response) (event-object response)))) (defun gnus-group-add-icon () "Add an icon to the current line according to `gnus-group-icon-list'." (let* ((p (point)) (end (point-at-eol)) ;; now find out where the line starts and leave point there. (beg (progn (beginning-of-line) (point)))) (save-restriction (narrow-to-region beg end) (goto-char beg) (when (search-forward "==&&==" nil t) (let* ((group (gnus-group-group-name)) (entry (gnus-group-entry group)) (unread (if (numberp (car entry)) (car entry) 0)) (active (gnus-active group)) (total (if active (1+ (- (cdr active) (car active))) 0)) (info (nth 2 entry)) (method (gnus-server-get-method group (gnus-info-method info))) (marked (gnus-info-marks info)) (mailp (memq 'mail (assoc (symbol-name (car (or method gnus-select-method))) gnus-valid-select-methods))) (level (or (gnus-info-level info) gnus-level-killed)) (score (or (gnus-info-score info) 0)) (ticked (gnus-range-length (cdr (assq 'tick marked)))) (group-age (gnus-group-timestamp-delta group)) (inhibit-read-only t) (list gnus-group-icon-list) (mystart (match-beginning 0)) (myend (match-end 0))) (goto-char (point-min)) (while (and list (not (eval (caar list)))) (setq list (cdr list))) (if list (let* ((file (cdar list)) (glyph (gnus-group-icon-create-glyph (buffer-substring mystart myend) file))) (if glyph (progn (mapc 'delete-annotation (annotations-at myend)) (let ((ext (make-extent mystart myend)) (ant (make-annotation glyph myend 'text))) ;; set text extent params (set-extent-property ext 'end-open t) (set-extent-property ext 'start-open t) (set-extent-property ext 'invisible t))) (delete-region mystart myend))) (delete-region mystart myend)))) (widen)) (goto-char p))) (defun gnus-group-icon-create-glyph (substring pixmap) "Create a glyph for insertion into a group line." (or (cdr-safe (assoc pixmap gnus-group-icon-cache)) (let* ((glyph (make-glyph (list (cons 'x (expand-file-name pixmap gnus-xmas-glyph-directory)) (cons 'mswindows (expand-file-name pixmap gnus-xmas-glyph-directory)) (cons 'tty substring))))) (setq gnus-group-icon-cache (cons (cons pixmap glyph) gnus-group-icon-cache)) (set-glyph-face glyph 'default) glyph))) (defun gnus-xmas-mailing-list-menu-add () (gnus-xmas-menu-add mailing-list gnus-mailing-list-menu)) (defun gnus-xmas-image-type-available-p (type) (and (if (fboundp 'display-images-p) (display-images-p) window-system) (featurep (if (eq type 'pbm) 'xbm type)))) (defun gnus-xmas-create-image (file &optional type data-p &rest props) (let ((type (if type (symbol-name type) (car (last (split-string file "[.]"))))) (face (plist-get props :face)) glyph) (when (equal type "pbm") (with-temp-buffer (if data-p (insert file) (insert-file-contents-literally file)) (shell-command-on-region (point-min) (point-max) "ppmtoxpm 2>/dev/null" t) (setq file (buffer-string) type "xpm" data-p t))) (setq glyph (if (equal type "xbm") (make-glyph (list (cons 'x file))) (with-temp-buffer (if data-p (insert file) (insert-file-contents-literally file)) (make-glyph (vector (or (intern type) (mm-image-type-from-buffer)) :data (buffer-string)))))) (when face (set-glyph-face glyph face)) glyph)) (defun gnus-xmas-put-image (glyph &optional string category) "Insert STRING, but display GLYPH. Warning: Don't insert text immediately after the image." (let ((begin (point)) extent) (if (and (bobp) (not string)) (setq string " ")) (if string (insert string) (setq begin (1- begin))) (setq extent (make-extent begin (point))) (set-extent-property extent 'gnus-image category) (set-extent-property extent 'duplicable t) (if string (set-extent-property extent 'invisible t)) (set-extent-property extent 'end-glyph glyph)) glyph) (defun gnus-xmas-remove-image (image &optional category) "Remove the image matching IMAGE and CATEGORY found first." (map-extents (lambda (ext unused) (when (equal (extent-end-glyph ext) image) (set-extent-property ext 'invisible nil) (set-extent-property ext 'end-glyph nil) t)) nil nil nil nil nil 'gnus-image category)) (defun gnus-xmas-assq-delete-all (key alist) (let ((elem nil)) (while (setq elem (assq key alist)) (setq alist (delq elem alist))) alist)) (provide 'gnus-xmas) ;;; arch-tag: 4e84de3f-ea0a-4ee3-bfeb-e03d46fcacef ;;; gnus-xmas.el ends here gnus-5.11+v0.10.dfsg/lisp/nndoc.el0000644000175000017500000010456111004005110016653 0ustar tvainikatvainika;;; nndoc.el --- single file access for Gnus ;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, ;; 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; Masanobu UMEDA ;; Keywords: news ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 3, or (at your option) ;; any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Commentary: ;; For Outlook mail boxes format, see http://mbx2mbox.sourceforge.net/ ;;; Code: (require 'nnheader) (require 'message) (require 'nnmail) (require 'nnoo) (require 'gnus-util) (require 'mm-util) (eval-when-compile (require 'cl)) (nnoo-declare nndoc) (defvoo nndoc-article-type 'guess "*Type of the file. One of `mbox', `babyl', `digest', `news', `rnews', `mmdf', `forward', `rfc934', `rfc822-forward', `mime-parts', `standard-digest', `slack-digest', `clari-briefs', `nsmail', `outlook', `oe-dbx', `mailman', `exim-bounce', or `guess'.") (defvoo nndoc-post-type 'mail "*Whether the nndoc group is `mail' or `post'.") (defvoo nndoc-open-document-hook 'nnheader-ms-strip-cr "Hook run after opening a document. The default function removes all trailing carriage returns from the document.") (defvar nndoc-type-alist `((mmdf (article-begin . "^\^A\^A\^A\^A\n") (body-end . "^\^A\^A\^A\^A\n")) (mime-digest (article-begin . "") (head-begin . "^ ?\n") (head-end . "^ ?$") (body-end . "") (file-end . "") (subtype digest guess)) (mime-parts (generate-head-function . nndoc-generate-mime-parts-head) (article-transform-function . nndoc-transform-mime-parts)) (nsmail (article-begin . "^From - ")) (news (article-begin . "^Path:")) (rnews (article-begin . "^#! *rnews +\\([0-9]+\\) *\n") (body-end-function . nndoc-rnews-body-end)) (mbox (article-begin-function . nndoc-mbox-article-begin) (body-end-function . nndoc-mbox-body-end)) (babyl (article-begin . "\^_\^L *\n") (body-end . "\^_") (body-begin-function . nndoc-babyl-body-begin) (head-begin-function . nndoc-babyl-head-begin)) (exim-bounce (article-begin . "^------ This is a copy of the message, including all the headers. ------\n\n") (body-end-function . nndoc-exim-bounce-body-end-function)) (rfc934 (article-begin . "^--.*\n+") (body-end . "^--.*$") (prepare-body-function . nndoc-unquote-dashes)) (mailman (article-begin . "^--__--__--\n\nMessage:") (body-end . "^--__--__--$") (prepare-body-function . nndoc-unquote-dashes)) (clari-briefs (article-begin . "^ \\*") (body-end . "^\t------*[ \t]^*\n^ \\*") (body-begin . "^\t") (head-end . "^\t") (generate-head-function . nndoc-generate-clari-briefs-head) (article-transform-function . nndoc-transform-clari-briefs)) (standard-digest (first-article . ,(concat "^" (make-string 70 ?-) "\n *\n+")) (article-begin . ,(concat "^\n" (make-string 30 ?-) "\n *\n+")) (prepare-body-function . nndoc-unquote-dashes) (body-end-function . nndoc-digest-body-end) (head-end . "^ *$") (body-begin . "^ *\n") (file-end . "^End of .*digest.*[0-9].*\n\\*\\*\\|^End of.*Digest *$") (subtype digest guess)) (slack-digest (article-begin . "^------------------------------*[\n \t]+") (head-end . "^ ?$") (body-end-function . nndoc-digest-body-end) (body-begin . "^ ?$") (file-end . "^End of") (prepare-body-function . nndoc-unquote-dashes) (subtype digest guess)) (lanl-gov-announce (article-begin . "^\\\\\\\\\n") (head-begin . "^\\(Paper.*:\\|arXiv:\\)") (head-end . "\\(^\\\\\\\\.*\n\\|-----------------\\)") (body-begin . "") (body-end . "\\(-------------------------------------------------\\|%-%-%-%-%-%-%-%-%-%-%-%-%-%-\\|%%--%%--%%--%%--%%--%%--%%--%%--\\|%%%---%%%---%%%---%%%---\\)") (file-end . "\\(^Title: Recent Seminal\\|%%%---%%%---%%%---%%%---\\)") (generate-head-function . nndoc-generate-lanl-gov-head) (article-transform-function . nndoc-transform-lanl-gov-announce) (subtype preprints guess)) (rfc822-forward (article-begin . "^\n+") (body-end-function . nndoc-rfc822-forward-body-end-function) (generate-head-function . nndoc-rfc822-forward-generate-head) (generate-article-function . nndoc-rfc822-forward-generate-article)) (outlook (article-begin-function . nndoc-outlook-article-begin) (body-end . "\0")) (oe-dbx ;; Outlook Express DBX format (dissection-function . nndoc-oe-dbx-dissection) (generate-head-function . nndoc-oe-dbx-generate-head) (generate-article-function . nndoc-oe-dbx-generate-article)) (forward (article-begin . "^-+ \\(Start of \\)?forwarded message.*\n+") (body-end . "^-+ End \\(of \\)?forwarded message.*$") (prepare-body-function . nndoc-unquote-dashes)) (mail-in-mail ;; Wild guess on mailer daemon's messages or others (article-begin-function . nndoc-mail-in-mail-article-begin)) (guess (guess . t) (subtype nil)) (digest (guess . t) (subtype nil)) (preprints (guess . t) (subtype nil)))) (defvar nndoc-binary-file-names ".[Dd][Bb][Xx]$" "Regexp for binary nndoc file names.") (defvoo nndoc-file-begin nil) (defvoo nndoc-first-article nil) (defvoo nndoc-article-begin nil) (defvoo nndoc-head-begin nil) (defvoo nndoc-head-end nil) (defvoo nndoc-file-end nil) (defvoo nndoc-body-begin nil) (defvoo nndoc-body-end-function nil) (defvoo nndoc-body-begin-function nil) (defvoo nndoc-head-begin-function nil) (defvoo nndoc-body-end nil) ;; nndoc-dissection-alist is a list of sublists. Each sublist holds the ;; following items. ARTICLE acts as the association key and is an ordinal ;; starting at 1. HEAD-BEGIN [0], HEAD-END [1], BODY-BEGIN [2] and BODY-END ;; [3] are positions in the `nndoc' buffer. LINE-COUNT [4] is a count of ;; lines in the body. For MIME dissections only, ARTICLE-INSERT [5] and ;; SUMMARY-INSERT [6] give headers to insert for full article or summary line ;; generation, respectively. Other headers usually follow directly from the ;; buffer. Value `nil' means no insert. (defvoo nndoc-dissection-alist nil) (defvoo nndoc-prepare-body-function nil) (defvoo nndoc-generate-head-function nil) (defvoo nndoc-article-transform-function nil) (defvoo nndoc-article-begin-function nil) (defvoo nndoc-generate-article-function nil) (defvoo nndoc-dissection-function nil) (defvoo nndoc-status-string "") (defvoo nndoc-group-alist nil) (defvoo nndoc-current-buffer nil "Current nndoc news buffer.") (defvoo nndoc-address nil) (defconst nndoc-version "nndoc 1.0" "nndoc version.") ;;; Interface functions (nnoo-define-basics nndoc) (deffoo nndoc-retrieve-headers (articles &optional newsgroup server fetch-old) (when (nndoc-possibly-change-buffer newsgroup server) (save-excursion (set-buffer nntp-server-buffer) (erase-buffer) (let (article entry) (if (stringp (car articles)) 'headers (while articles (when (setq entry (cdr (assq (setq article (pop articles)) nndoc-dissection-alist))) (insert (format "221 %d Article retrieved.\n" article)) (if nndoc-generate-head-function (funcall nndoc-generate-head-function article) (insert-buffer-substring nndoc-current-buffer (car entry) (nth 1 entry))) (goto-char (point-max)) (unless (eq (char-after (1- (point))) ?\n) (insert "\n")) (insert (format "Lines: %d\n" (nth 4 entry))) (insert ".\n"))) (nnheader-fold-continuation-lines) 'headers))))) (deffoo nndoc-request-article (article &optional newsgroup server buffer) (nndoc-possibly-change-buffer newsgroup server) (save-excursion (let ((buffer (or buffer nntp-server-buffer)) (entry (cdr (assq article nndoc-dissection-alist))) beg) (set-buffer buffer) (erase-buffer) (when entry (cond ((stringp article) nil) (nndoc-generate-article-function (funcall nndoc-generate-article-function article)) (t (insert-buffer-substring nndoc-current-buffer (car entry) (nth 1 entry)) (insert "\n") (setq beg (point)) (insert-buffer-substring nndoc-current-buffer (nth 2 entry) (nth 3 entry)) (goto-char beg) (when nndoc-prepare-body-function (funcall nndoc-prepare-body-function)) (when nndoc-article-transform-function (funcall nndoc-article-transform-function article)) t)))))) (deffoo nndoc-request-group (group &optional server dont-check) "Select news GROUP." (let (number) (cond ((not (nndoc-possibly-change-buffer group server)) (nnheader-report 'nndoc "No such file or buffer: %s" nndoc-address)) (dont-check (nnheader-report 'nndoc "Selected group %s" group) t) ((zerop (setq number (length nndoc-dissection-alist))) (nndoc-close-group group) (nnheader-report 'nndoc "No articles in group %s" group)) (t (nnheader-insert "211 %d %d %d %s\n" number 1 number group))))) (deffoo nndoc-request-type (group &optional article) (cond ((not article) 'unknown) (nndoc-post-type nndoc-post-type) (t 'unknown))) (deffoo nndoc-close-group (group &optional server) (nndoc-possibly-change-buffer group server) (and nndoc-current-buffer (buffer-name nndoc-current-buffer) (kill-buffer nndoc-current-buffer)) (setq nndoc-group-alist (delq (assoc group nndoc-group-alist) nndoc-group-alist)) (setq nndoc-current-buffer nil) (nnoo-close-server 'nndoc server) (setq nndoc-dissection-alist nil) t) (deffoo nndoc-request-list (&optional server) nil) (deffoo nndoc-request-newgroups (date &optional server) nil) (deffoo nndoc-request-list-newsgroups (&optional server) nil) ;;; Internal functions. (defun nndoc-possibly-change-buffer (group source) (let (buf) (cond ;; The current buffer is this group's buffer. ((and nndoc-current-buffer (buffer-name nndoc-current-buffer) (eq nndoc-current-buffer (setq buf (cdr (assoc group nndoc-group-alist)))))) ;; We change buffers by taking an old from the group alist. ;; `source' is either a string (a file name) or a buffer object. (buf (setq nndoc-current-buffer buf)) ;; It's a totally new group. ((or (and (bufferp nndoc-address) (buffer-name nndoc-address)) (and (stringp nndoc-address) (file-exists-p nndoc-address) (not (file-directory-p nndoc-address)))) (push (cons group (setq nndoc-current-buffer (get-buffer-create (concat " *nndoc " group "*")))) nndoc-group-alist) (setq nndoc-dissection-alist nil) (save-excursion (set-buffer nndoc-current-buffer) (erase-buffer) (if (and (stringp nndoc-address) (string-match nndoc-binary-file-names nndoc-address)) (let ((coding-system-for-read 'binary)) (mm-insert-file-contents nndoc-address)) (if (stringp nndoc-address) (nnheader-insert-file-contents nndoc-address) (insert-buffer-substring nndoc-address)) (run-hooks 'nndoc-open-document-hook))))) ;; Initialize the nndoc structures according to this new document. (when (and nndoc-current-buffer (not nndoc-dissection-alist)) (save-excursion (set-buffer nndoc-current-buffer) (nndoc-set-delims) (if (eq nndoc-article-type 'mime-parts) (nndoc-dissect-mime-parts) (nndoc-dissect-buffer)))) (unless nndoc-current-buffer (nndoc-close-server)) ;; Return whether we managed to select a file. nndoc-current-buffer)) ;;; ;;; Deciding what document type we have ;;; (defun nndoc-set-delims () "Set the nndoc delimiter variables according to the type of the document." (let ((vars '(nndoc-file-begin nndoc-first-article nndoc-article-begin-function nndoc-head-begin nndoc-head-end nndoc-file-end nndoc-article-begin nndoc-body-begin nndoc-body-end-function nndoc-body-end nndoc-prepare-body-function nndoc-article-transform-function nndoc-generate-head-function nndoc-body-begin-function nndoc-head-begin-function nndoc-generate-article-function nndoc-dissection-function))) (while vars (set (pop vars) nil))) (let (defs) ;; Guess away until we find the real file type. (while (assq 'guess (setq defs (cdr (assq nndoc-article-type nndoc-type-alist)))) (setq nndoc-article-type (nndoc-guess-type nndoc-article-type))) ;; Set the nndoc variables. (while defs (set (intern (format "nndoc-%s" (caar defs))) (cdr (pop defs)))))) (defun nndoc-guess-type (subtype) (let ((alist nndoc-type-alist) results result entry) (while (and (not result) (setq entry (pop alist))) (when (memq subtype (or (cdr (assq 'subtype entry)) '(guess))) (goto-char (point-min)) ;; Remove blank lines. (while (eq (following-char) ?\n) (delete-char 1)) (when (numberp (setq result (funcall (intern (format "nndoc-%s-type-p" (car entry)))))) (push (cons result entry) results) (setq result nil)))) (unless (or result results) (error "Document is not of any recognized type")) (if result (car entry) (cadar (last (sort results 'car-less-than-car)))))) ;;; ;;; Built-in type predicates and functions ;;; (defun nndoc-mbox-type-p () (when (looking-at message-unix-mail-delimiter) t)) (defun nndoc-mbox-article-begin () (when (re-search-forward (concat "^" message-unix-mail-delimiter) nil t) (goto-char (match-beginning 0)))) (defun nndoc-mbox-body-end () (let ((beg (point)) len end) (when (save-excursion (and (re-search-backward (concat "^" message-unix-mail-delimiter) nil t) (setq end (point)) (search-forward "\n\n" beg t) (re-search-backward "^Content-Length:[ \t]*\\([0-9]+\\) *$" end t) (setq len (string-to-number (match-string 1))) (search-forward "\n\n" beg t) (unless (= (setq len (+ (point) len)) (point-max)) (and (< len (point-max)) (goto-char len) (looking-at message-unix-mail-delimiter))))) (goto-char len)))) (defun nndoc-mmdf-type-p () (when (looking-at "\^A\^A\^A\^A$") t)) (defun nndoc-news-type-p () (when (looking-at "^Path:.*\n") t)) (defun nndoc-rnews-type-p () (when (looking-at "#! *rnews") t)) (defun nndoc-rnews-body-end () (and (re-search-backward nndoc-article-begin nil t) (forward-line 1) (goto-char (+ (point) (string-to-number (match-string 1)))))) (defun nndoc-babyl-type-p () (when (re-search-forward "\^_\^L *\n" nil t) t)) (defun nndoc-babyl-body-begin () (re-search-forward "^\n" nil t) (when (looking-at "\\*\\*\\* EOOH \\*\\*\\*") (let ((next (or (save-excursion (re-search-forward nndoc-article-begin nil t)) (point-max)))) (unless (re-search-forward "^\n" next t) (goto-char next) (forward-line -1) (insert "\n") (forward-line -1))))) (defun nndoc-babyl-head-begin () (when (re-search-forward "^[0-9].*\n" nil t) (when (looking-at "\\*\\*\\* EOOH \\*\\*\\*") (forward-line 1)) t)) (defun nndoc-forward-type-p () (when (and (re-search-forward "^-+ \\(Start of \\)?forwarded message.*\n+" nil t) (looking-at "[\r\n]*[a-zA-Z][a-zA-Z0-9-]*:\\|^>?From ")) t)) (defun nndoc-rfc934-type-p () (when (and (re-search-forward "^-+ Start of forwarded.*\n+" nil t) (not (re-search-forward "^Subject:.*digest" nil t)) (not (re-search-backward "^From:" nil t 2)) (not (re-search-forward "^From:" nil t 2))) t)) (defun nndoc-mailman-type-p () (when (re-search-forward "^--__--__--\n+" nil t) t)) (defun nndoc-rfc822-forward-type-p () (save-restriction (message-narrow-to-head) (when (re-search-forward "^Content-Type: *message/rfc822" nil t) t))) (defun nndoc-rfc822-forward-body-end-function () (goto-char (point-max))) (defun nndoc-rfc822-forward-generate-article (article &optional head) (let ((entry (cdr (assq article nndoc-dissection-alist))) (begin (point)) encoding) (with-current-buffer nndoc-current-buffer (save-restriction (message-narrow-to-head) (setq encoding (message-fetch-field "content-transfer-encoding")))) (insert-buffer-substring nndoc-current-buffer (car entry) (nth 3 entry)) (when encoding (save-restriction (narrow-to-region begin (point-max)) (mm-decode-content-transfer-encoding (intern (downcase (mail-header-strip encoding)))))) (when head (goto-char begin) (when (search-forward "\n\n" nil t) (delete-region (1- (point)) (point-max))))) t) (defun nndoc-rfc822-forward-generate-head (article) (nndoc-rfc822-forward-generate-article article 'head)) (defun nndoc-mime-parts-type-p () (let ((case-fold-search t) (limit (search-forward "\n\n" nil t))) (goto-char (point-min)) (when (and limit (re-search-forward (concat "\ ^Content-Type:[ \t]*multipart/[a-z]+ *; *\\(\\(\n[ \t]\\)?.*;\\)*" "\\(\n[ \t]\\)?[ \t]*boundary=\"?[^\"\n]*[^\" \t\n]") limit t)) t))) (defun nndoc-transform-mime-parts (article) (let* ((entry (cdr (assq article nndoc-dissection-alist))) (headers (nth 5 entry))) (when headers (goto-char (point-min)) (insert headers)))) (defun nndoc-generate-mime-parts-head (article) (let* ((entry (cdr (assq article nndoc-dissection-alist))) (headers (nth 6 entry))) (save-restriction (narrow-to-region (point) (point)) (insert-buffer-substring nndoc-current-buffer (car entry) (nth 1 entry)) (goto-char (point-max))) (when headers (insert headers)))) (defun nndoc-clari-briefs-type-p () (when (let ((case-fold-search nil)) (re-search-forward "^\t[^a-z]+ ([^a-z]+) --" nil t)) t)) (defun nndoc-transform-clari-briefs (article) (goto-char (point-min)) (when (looking-at " *\\*\\(.*\\)\n") (replace-match "" t t)) (nndoc-generate-clari-briefs-head article)) (defun nndoc-generate-clari-briefs-head (article) (let ((entry (cdr (assq article nndoc-dissection-alist))) subject from) (save-excursion (set-buffer nndoc-current-buffer) (save-restriction (narrow-to-region (car entry) (nth 3 entry)) (goto-char (point-min)) (when (looking-at " *\\*\\(.*\\)$") (setq subject (match-string 1)) (when (string-match "[ \t]+$" subject) (setq subject (substring subject 0 (match-beginning 0))))) (when (let ((case-fold-search nil)) (re-search-forward "^\t\\([^a-z]+\\(,[^(]+\\)? ([^a-z]+)\\) --" nil t)) (setq from (match-string 1))))) (insert "From: " "clari@clari.net (" (or from "unknown") ")" "\nSubject: " (or subject "(no subject)") "\n"))) (defun nndoc-exim-bounce-type-p () (and (re-search-forward "^------ This is a copy of the message, including all the headers. ------" nil t) t)) (defun nndoc-exim-bounce-body-end-function () (goto-char (point-max))) (defun nndoc-mime-digest-type-p () (let ((case-fold-search t) boundary-id b-delimiter entry) (when (and (re-search-forward (concat "^Content-Type: *multipart/digest;[ \t\n]*[ \t]" "boundary=\"?\\([^\"\n]*[^\" \t\n]\\)") nil t) (match-beginning 1)) (setq boundary-id (match-string 1) b-delimiter (concat "\n--" boundary-id "[ \t]*$")) (setq entry (assq 'mime-digest nndoc-type-alist)) (setcdr entry (list (cons 'head-begin "^ ?\n") (cons 'head-end "^ ?$") (cons 'body-begin "^ ?\n") (cons 'article-begin b-delimiter) (cons 'body-end-function 'nndoc-digest-body-end) (cons 'file-end (concat "^--" boundary-id "--[ \t]*$")))) t))) (defun nndoc-standard-digest-type-p () (when (and (re-search-forward (concat "^" (make-string 70 ?-) "\n\n") nil t) (re-search-forward (concat "\n\n" (make-string 30 ?-) "\n\n") nil t)) t)) (defun nndoc-digest-body-end () (and (re-search-forward nndoc-article-begin nil t) (goto-char (match-beginning 0)))) (defun nndoc-slack-digest-type-p () 0) (defun nndoc-lanl-gov-announce-type-p () (when (let ((case-fold-search nil)) (re-search-forward "^\\\\\\\\\n\\(Paper\\( (\\*cross-listing\\*)\\)?: [a-zA-Z-\\.]+/[0-9]+\\|arXiv:\\)" nil t)) t)) (defun nndoc-transform-lanl-gov-announce (article) (let ((case-fold-search nil)) (goto-char (point-max)) (when (re-search-backward "^\\\\\\\\ +( *\\([^ ]*\\) , *\\([^ ]*\\))" nil t) (replace-match "\n\nGet it at \\1 (\\2)" t nil)) (goto-char (point-min)) (while (re-search-forward "^\\\\\\\\$" nil t) (replace-match "" t nil)) (goto-char (point-min)) (when (re-search-forward "^replaced with revised version +\\(.*[^ ]\\) +" nil t) (replace-match "Date: \\1 (revised) " t nil)) (goto-char (point-min)) (unless (re-search-forward "^From" nil t) (goto-char (point-min)) (when (re-search-forward "^Authors?: \\(.*\\)" nil t) (goto-char (point-min)) (insert "From: " (match-string 1) "\n"))) (when (re-search-forward "^arXiv:" nil t) (replace-match "Paper: arXiv:" t nil)))) (defun nndoc-generate-lanl-gov-head (article) (let ((entry (cdr (assq article nndoc-dissection-alist))) (from "") subject date) (save-excursion (set-buffer nndoc-current-buffer) (save-restriction (narrow-to-region (car entry) (nth 1 entry)) (goto-char (point-min)) (when (looking-at "^\\(Paper.*: \\|arXiv:\\)\\([0-9a-zA-Z-\\./]+\\)") (setq subject (concat " (" (match-string 2) ")")) (when (re-search-forward "^From: \\(.*\\)" nil t) (setq from (concat "<" (cadr (funcall gnus-extract-address-components (match-string 1))) ">"))) (if (re-search-forward "^Date: +\\([^(]*\\)" nil t) (setq date (match-string 1)) (when (re-search-forward "^replaced with revised version +\\([^(]*\\)" nil t) (setq date (match-string 1)))) (when (re-search-forward "^Title: \\([^\f]*\\)\nAuthors?: \\(.*\\)" nil t) (setq subject (concat (match-string 1) subject)) (setq from (concat (match-string 2) " " from)))))) (while (and from (string-match "(\[^)\]*)" from)) (setq from (replace-match "" t t from))) (insert "From: " (or from "unknown") "\nSubject: " (or subject "(no subject)") "\n") (if date (insert "Date: " date)))) (defun nndoc-nsmail-type-p () (when (looking-at "From - ") t)) (defun nndoc-outlook-article-begin () (prog1 (re-search-forward "From:\\|Received:" nil t) (goto-char (match-beginning 0)))) (defun nndoc-outlook-type-p () ;; FIXME: Is JMF the magic of outlook mailbox? -- ShengHuo. (looking-at "JMF")) (defun nndoc-oe-dbx-type-p () (looking-at (mm-string-to-multibyte "\317\255\022\376"))) (defun nndoc-read-little-endian () (+ (prog1 (char-after) (forward-char 1)) (lsh (prog1 (char-after) (forward-char 1)) 8) (lsh (prog1 (char-after) (forward-char 1)) 16) (lsh (prog1 (char-after) (forward-char 1)) 24))) (defun nndoc-oe-dbx-decode-block () (list (nndoc-read-little-endian) ;; this address (nndoc-read-little-endian) ;; next address offset (nndoc-read-little-endian) ;; blocksize (nndoc-read-little-endian))) ;; next address (defun nndoc-oe-dbx-dissection () (let ((i 0) blk p tp) (goto-char 60117) ;; 0x0000EAD4+1 (setq p (point)) (unless (eobp) (setq blk (nndoc-oe-dbx-decode-block))) (while (and blk (> (car blk) 0) (or (zerop (nth 3 blk)) (> (nth 3 blk) p))) (push (list (incf i) p nil nil nil 0) nndoc-dissection-alist) (while (and (> (car blk) 0) (> (nth 3 blk) p)) (goto-char (1+ (nth 3 blk))) (setq blk (nndoc-oe-dbx-decode-block))) (if (or (<= (car blk) p) (<= (nth 1 blk) 0) (not (zerop (nth 3 blk)))) (setq blk nil) (setq tp (+ (car blk) (nth 1 blk) 17)) (if (or (<= tp p) (>= tp (point-max))) (setq blk nil) (goto-char tp) (setq p tp blk (nndoc-oe-dbx-decode-block))))))) (defun nndoc-oe-dbx-generate-article (article &optional head) (let ((entry (cdr (assq article nndoc-dissection-alist))) (cur (current-buffer)) (begin (point)) blk p) (with-current-buffer nndoc-current-buffer (setq p (car entry)) (while (> p (point-min)) (goto-char p) (setq blk (nndoc-oe-dbx-decode-block)) (setq p (point)) (with-current-buffer cur (insert-buffer-substring nndoc-current-buffer p (+ p (nth 2 blk)))) (setq p (1+ (nth 3 blk))))) (goto-char begin) (while (re-search-forward "\r$" nil t) (delete-backward-char 1)) (when head (goto-char begin) (when (search-forward "\n\n" nil t) (setcar (cddddr entry) (count-lines (point) (point-max))) (delete-region (1- (point)) (point-max)))) t)) (defun nndoc-oe-dbx-generate-head (article) (nndoc-oe-dbx-generate-article article 'head)) (defun nndoc-mail-in-mail-type-p () (let (found) (save-excursion (catch 'done (while (re-search-forward "\n\n[-A-Za-z0-9]+:" nil t) (setq found 0) (forward-line) (while (looking-at "[ \t]\\|[-A-Za-z0-9]+:") (if (looking-at "[-A-Za-z0-9]+:") (setq found (1+ found))) (forward-line)) (if (and (> found 0) (looking-at "\n")) (throw 'done 9999))) nil)))) (defun nndoc-mail-in-mail-article-begin () (let (point found) (if (catch 'done (while (re-search-forward "\n\n\\([-A-Za-z0-9]+:\\)" nil t) (setq found 0) (setq point (match-beginning 1)) (forward-line) (while (looking-at "[ \t]\\|[-A-Za-z0-9]+:") (if (looking-at "[-A-Za-z0-9]+:") (setq found (1+ found))) (forward-line)) (if (and (> found 0) (looking-at "\n")) (throw 'done t))) nil) (goto-char point)))) (deffoo nndoc-request-accept-article (group &optional server last) nil) ;;; ;;; Functions for dissecting the documents ;;; (defun nndoc-search (regexp) (prog1 (re-search-forward regexp nil t) (beginning-of-line))) (defun nndoc-dissect-buffer () "Go through the document and partition it into heads/bodies/articles." (let ((i 0) (first t) art-begin head-begin head-end body-begin body-end) (setq nndoc-dissection-alist nil) (save-excursion (set-buffer nndoc-current-buffer) (goto-char (point-min)) ;; Remove blank lines. (while (eq (following-char) ?\n) (delete-char 1)) (if nndoc-dissection-function (funcall nndoc-dissection-function) ;; Find the beginning of the file. (when nndoc-file-begin (nndoc-search nndoc-file-begin)) ;; Go through the file. (while (if (and first nndoc-first-article) (nndoc-search nndoc-first-article) (if art-begin (goto-char art-begin) (nndoc-article-begin))) (setq first nil art-begin nil) (cond (nndoc-head-begin-function (funcall nndoc-head-begin-function)) (nndoc-head-begin (nndoc-search nndoc-head-begin))) (if (or (eobp) (and nndoc-file-end (looking-at nndoc-file-end))) (goto-char (point-max)) (setq head-begin (point)) (nndoc-search (or nndoc-head-end "^$")) (setq head-end (point)) (if nndoc-body-begin-function (funcall nndoc-body-begin-function) (nndoc-search (or nndoc-body-begin "^\n"))) (setq body-begin (point)) (or (and nndoc-body-end-function (funcall nndoc-body-end-function)) (and nndoc-body-end (nndoc-search nndoc-body-end)) (and (nndoc-article-begin) (setq art-begin (point))) (progn (goto-char (point-max)) (when nndoc-file-end (and (re-search-backward nndoc-file-end nil t) (beginning-of-line))))) (setq body-end (point)) (push (list (incf i) head-begin head-end body-begin body-end (count-lines body-begin body-end)) nndoc-dissection-alist))))))) (defun nndoc-article-begin () (if nndoc-article-begin-function (funcall nndoc-article-begin-function) (ignore-errors (nndoc-search nndoc-article-begin)))) (defun nndoc-unquote-dashes () "Unquote quoted non-separators in digests." (while (re-search-forward "^- -"nil t) (replace-match "-" t t))) ;; Against compiler warnings. (defvar nndoc-mime-split-ordinal) (defun nndoc-dissect-mime-parts () "Go through a MIME composite article and partition it into sub-articles. When a MIME entity contains sub-entities, dissection produces one article for the header of this entity, and one article per sub-entity." (setq nndoc-dissection-alist nil nndoc-mime-split-ordinal 0) (save-excursion (set-buffer nndoc-current-buffer) (nndoc-dissect-mime-parts-sub (point-min) (point-max) nil nil nil))) (defun nndoc-dissect-mime-parts-sub (head-begin body-end article-insert position parent) "Dissect an entity, within a composite MIME message. The complete message or MIME entity extends from HEAD-BEGIN to BODY-END. ARTICLE-INSERT should be added at beginning for generating a full article. The string POSITION holds a dotted decimal representation of the article position in the hierarchical structure, it is nil for the outer entity. PARENT is the message-ID of the parent summary line, or nil for none." (let ((case-fold-search t) (message-id (nnmail-message-id)) head-end body-begin summary-insert message-rfc822 multipart-any subject content-type type subtype boundary-regexp) ;; Gracefully handle a missing body. (goto-char head-begin) (if (or (and (eq (char-after) ?\n) (or (forward-char 1) t)) (search-forward "\n\n" body-end t)) (setq head-end (1- (point)) body-begin (point)) (setq head-end body-end body-begin body-end)) (narrow-to-region head-begin head-end) ;; Save MIME attributes. (goto-char head-begin) (setq content-type (message-fetch-field "Content-Type")) (when content-type (when (string-match "^ *\\([^ \t\n/;]+\\)/\\([^ \t\n/;]+\\)" content-type) (setq type (downcase (match-string 1 content-type)) subtype (downcase (match-string 2 content-type)) message-rfc822 (and (string= type "message") (string= subtype "rfc822")) multipart-any (string= type "multipart"))) (when (string-match ";[ \t\n]*name=\\([^ \t\n;]+\\)" content-type) (setq subject (match-string 1 content-type))) (when (string-match "boundary=\"?\\([^\"\n]*[^\" \t\n]\\)" content-type) (setq boundary-regexp (concat "^--" (regexp-quote (match-string 1 content-type)) "\\(--\\)?[ \t]*\n")))) (unless subject (when (or multipart-any (not article-insert)) (setq subject (message-fetch-field "Subject")))) (unless type (setq type "text" subtype "plain")) ;; Prepare the article and summary inserts. (unless article-insert (setq article-insert (buffer-string) head-end head-begin)) ;; Fix MIME-Version (unless (string-match "MIME-Version:" article-insert) (setq article-insert (concat article-insert "MIME-Version: 1.0\n"))) (setq summary-insert article-insert) ;; - summary Subject. (setq summary-insert (let ((line (concat "Subject: <" position (and position multipart-any ".") (and multipart-any "*") (and (or position multipart-any) " ") (cond ((string= subtype "plain") type) ((string= subtype "basic") type) (t subtype)) ">" (and subject " ") subject "\n"))) (if (string-match "Subject:.*\n\\([ \t].*\n\\)*" summary-insert) (replace-match line t t summary-insert) (concat summary-insert line)))) ;; - summary Message-ID. (setq summary-insert (let ((line (concat "Message-ID: " message-id "\n"))) (if (string-match "Message-ID:.*\n\\([ \t].*\n\\)*" summary-insert) (replace-match line t t summary-insert) (concat summary-insert line)))) ;; - summary References. (when parent (setq summary-insert (let ((line (concat "References: " parent "\n"))) (if (string-match "References:.*\n\\([ \t].*\n\\)*" summary-insert) (replace-match line t t summary-insert) (concat summary-insert line))))) ;; Generate dissection information for this entity. (push (list (incf nndoc-mime-split-ordinal) head-begin head-end body-begin body-end (count-lines body-begin body-end) article-insert summary-insert) nndoc-dissection-alist) ;; Recurse for all sub-entities, if any. (widen) (cond (message-rfc822 (save-excursion (nndoc-dissect-mime-parts-sub body-begin body-end nil position message-id))) ((and multipart-any boundary-regexp) (let ((part-counter 0) part-begin part-end eof-flag) (while (string-match "\ ^\\(Lines\\|Content-\\(Type\\|Transfer-Encoding\\|Disposition\\)\\):.*\n\\([ \t].*\n\\)*" article-insert) (setq article-insert (replace-match "" t t article-insert))) (let ((case-fold-search nil)) (goto-char body-begin) (setq eof-flag (not (re-search-forward boundary-regexp body-end t))) (while (not eof-flag) (setq part-begin (point)) (cond ((re-search-forward boundary-regexp body-end t) (or (not (match-string 1)) (string= (match-string 1) "") (setq eof-flag t)) (forward-line -1) (setq part-end (point)) (forward-line 1)) (t (setq part-end body-end eof-flag t))) (save-excursion (nndoc-dissect-mime-parts-sub part-begin part-end article-insert (concat position (and position ".") (format "%d" (incf part-counter))) message-id))))))))) ;;;###autoload (defun nndoc-add-type (definition &optional position) "Add document DEFINITION to the list of nndoc document definitions. If POSITION is nil or `last', the definition will be added as the last checked definition, if t or `first', add as the first definition, and if any other symbol, add after that symbol in the alist." ;; First remove any old instances. (gnus-pull (car definition) nndoc-type-alist) ;; Then enter the new definition in the proper place. (cond ((or (null position) (eq position 'last)) (setq nndoc-type-alist (nconc nndoc-type-alist (list definition)))) ((or (eq position t) (eq position 'first)) (push definition nndoc-type-alist)) (t (let ((list (memq (assq position nndoc-type-alist) nndoc-type-alist))) (unless list (error "No such position: %s" position)) (setcdr list (cons definition (cdr list))))))) (provide 'nndoc) ;; arch-tag: f5c2970e-0387-47ac-a0b3-6cc317dffabe ;;; nndoc.el ends here gnus-5.11+v0.10.dfsg/lisp/nnwfm.el0000644000175000017500000003304211004005110016672 0ustar tvainikatvainika;;; nnwfm.el --- interfacing with a web forum ;; Copyright (C) 2000, 2002, 2003, 2004, 2005, ;; 2006, 2007, 2008 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; Keywords: news ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 3, or (at your option) ;; any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Commentary: ;; Note: You need to have `url' and `w3' installed for this ;; backend to work. ;;; Code: (eval-when-compile (require 'cl)) (require 'nnoo) (require 'message) (require 'gnus-util) (require 'gnus) (require 'nnmail) (require 'mm-util) (require 'mm-url) (require 'nnweb) (autoload 'w3-parse-buffer "w3-parse") (nnoo-declare nnwfm) (defvoo nnwfm-directory (nnheader-concat gnus-directory "wfm/") "Where nnwfm will save its files.") (defvoo nnwfm-address "" "The address of the Ultimate bulletin board.") ;;; Internal variables (defvar nnwfm-groups-alist nil) (defvoo nnwfm-groups nil) (defvoo nnwfm-headers nil) (defvoo nnwfm-articles nil) (defvar nnwfm-table-regexp "postings.*editpost\\|forumdisplay\\|Forum[0-9]+/HTML\\|getbio") ;;; Interface functions (nnoo-define-basics nnwfm) (deffoo nnwfm-retrieve-headers (articles &optional group server fetch-old) (nnwfm-possibly-change-server group server) (unless gnus-nov-is-evil (let* ((last (car (last articles))) (did nil) (start 1) (entry (assoc group nnwfm-groups)) (sid (nth 2 entry)) (topics (nth 4 entry)) (mapping (nth 5 entry)) (old-total (or (nth 6 entry) 1)) (nnwfm-table-regexp "Thread.asp") headers article subject score from date lines parent point contents tinfo fetchers map elem a href garticles topic old-max inc datel table string current-page total-contents pages farticles forum-contents parse furl-fetched mmap farticle thread-id tables hstuff bstuff time) (setq map mapping) (while (and (setq article (car articles)) map) (while (and map (or (> article (caar map)) (< (cadar map) (caar map)))) (pop map)) (when (setq mmap (car map)) (setq farticle -1) (while (and article (<= article (nth 1 mmap))) ;; Do we already have a fetcher for this topic? (if (setq elem (assq (nth 2 mmap) fetchers)) ;; Yes, so we just add the spec to the end. (nconc elem (list (cons article (+ (nth 3 mmap) (incf farticle))))) ;; No, so we add a new one. (push (list (nth 2 mmap) (cons article (+ (nth 3 mmap) (incf farticle)))) fetchers)) (pop articles) (setq article (car articles))))) ;; Now we have the mapping from/to Gnus/nnwfm article numbers, ;; so we start fetching the topics that we need to satisfy the ;; request. (if (not fetchers) (save-excursion (set-buffer nntp-server-buffer) (erase-buffer)) (setq nnwfm-articles nil) (mm-with-unibyte-buffer (dolist (elem fetchers) (erase-buffer) (setq subject (nth 2 (assq (car elem) topics)) thread-id (nth 0 (assq (car elem) topics))) (mm-url-insert (concat nnwfm-address (format "Item.asp?GroupID=%d&ThreadID=%d" sid thread-id))) (goto-char (point-min)) (setq tables (caddar (caddar (cdr (caddar (caddar (ignore-errors (w3-parse-buffer (current-buffer))))))))) (setq tables (cdr (caddar (memq (assq 'div tables) tables)))) (setq contents nil) (dolist (table tables) (when (eq (car table) 'table) (setq table (caddar (caddar (caddr table))) hstuff (delete ":link" (nnweb-text (car table))) bstuff (car (caddar (cdr table))) from (car hstuff)) (when (nth 2 hstuff) (setq time (nnwfm-date-to-time (nth 2 hstuff))) (push (list from time bstuff) contents)))) (setq contents (nreverse contents)) (dolist (art (cdr elem)) (push (list (car art) (nth (1- (cdr art)) contents) subject) nnwfm-articles)))) (setq nnwfm-articles (sort nnwfm-articles 'car-less-than-car)) ;; Now we have all the articles, conveniently in an alist ;; where the key is the Gnus article number. (dolist (articlef nnwfm-articles) (setq article (nth 0 articlef) contents (nth 1 articlef) subject (nth 2 articlef)) (setq from (nth 0 contents) date (message-make-date (nth 1 contents))) (push (cons article (make-full-mail-header article subject from (or date "") (concat "<" (number-to-string sid) "%" (number-to-string article) "@wfm>") "" 0 (/ (length (mapconcat 'identity (nnweb-text (nth 2 contents)) "")) 70) nil nil)) headers)) (setq nnwfm-headers (sort headers 'car-less-than-car)) (save-excursion (set-buffer nntp-server-buffer) (mm-with-unibyte-current-buffer (erase-buffer) (dolist (header nnwfm-headers) (nnheader-insert-nov (cdr header)))))) 'nov))) (deffoo nnwfm-request-group (group &optional server dont-check) (nnwfm-possibly-change-server nil server) (when (not nnwfm-groups) (nnwfm-request-list)) (unless dont-check (nnwfm-create-mapping group)) (let ((elem (assoc group nnwfm-groups))) (cond ((not elem) (nnheader-report 'nnwfm "Group does not exist")) (t (nnheader-report 'nnwfm "Opened group %s" group) (nnheader-insert "211 %d %d %d %s\n" (cadr elem) 1 (cadr elem) (prin1-to-string group)))))) (deffoo nnwfm-request-close () (setq nnwfm-groups-alist nil nnwfm-groups nil)) (deffoo nnwfm-request-article (article &optional group server buffer) (nnwfm-possibly-change-server group server) (let ((contents (cdr (assq article nnwfm-articles)))) (when (setq contents (nth 2 (car contents))) (save-excursion (set-buffer (or buffer nntp-server-buffer)) (erase-buffer) (nnweb-insert-html contents) (goto-char (point-min)) (insert "Content-Type: text/html\nMIME-Version: 1.0\n") (let ((header (cdr (assq article nnwfm-headers)))) (mm-with-unibyte-current-buffer (nnheader-insert-header header))) (nnheader-report 'nnwfm "Fetched article %s" article) (cons group article))))) (deffoo nnwfm-request-list (&optional server) (nnwfm-possibly-change-server nil server) (mm-with-unibyte-buffer (mm-url-insert (if (string-match "/$" nnwfm-address) (concat nnwfm-address "Group.asp") nnwfm-address)) (let* ((nnwfm-table-regexp "Thread.asp") (contents (w3-parse-buffer (current-buffer))) sid elem description articles a href group forum a1 a2) (dolist (row (cdr (nth 2 (car (nth 2 (nnwfm-find-forum-table contents)))))) (setq row (nth 2 row)) (when (setq a (nnweb-parse-find 'a row)) (setq group (car (last (nnweb-text a))) href (cdr (assq 'href (nth 1 a)))) (setq description (car (last (nnweb-text (nth 1 row))))) (setq articles (string-to-number (gnus-replace-in-string (car (last (nnweb-text (nth 3 row)))) "," ""))) (when (and href (string-match "GroupId=\\([0-9]+\\)" href)) (setq forum (string-to-number (match-string 1 href))) (if (setq elem (assoc group nnwfm-groups)) (setcar (cdr elem) articles) (push (list group articles forum description nil nil nil nil) nnwfm-groups)))))) (nnwfm-write-groups) (nnwfm-generate-active) t)) (deffoo nnwfm-request-newgroups (date &optional server) (nnwfm-possibly-change-server nil server) (nnwfm-generate-active) t) (nnoo-define-skeleton nnwfm) ;;; Internal functions (defun nnwfm-new-threads-p (group time) "See whether we want to fetch the threads for GROUP written before TIME." (let ((old-time (nth 7 (assoc group nnwfm-groups)))) (or (null old-time) (time-less-p old-time time)))) (defun nnwfm-create-mapping (group) (let* ((entry (assoc group nnwfm-groups)) (sid (nth 2 entry)) (topics (nth 4 entry)) (mapping (nth 5 entry)) (old-total (or (nth 6 entry) 1)) (current-time (current-time)) (nnwfm-table-regexp "Thread.asp") (furls (list (concat nnwfm-address (format "Thread.asp?GroupId=%d" sid)))) fetched-urls contents forum-contents a subject href garticles topic tinfo old-max inc parse elem date url time) (mm-with-unibyte-buffer (while furls (erase-buffer) (push (car furls) fetched-urls) (mm-url-insert (pop furls)) (goto-char (point-min)) (while (re-search-forward " wr(" nil t) (forward-char -1) (setq elem (message-tokenize-header (gnus-replace-in-string (buffer-substring (1+ (point)) (progn (forward-sexp 1) (1- (point)))) "\\\\[\"\\\\]" ""))) (push (list (string-to-number (nth 1 elem)) (gnus-replace-in-string (nth 2 elem) "\"" "") (string-to-number (nth 5 elem))) forum-contents)) (when (re-search-forward "href=\"\\(Thread.*DateLast=\\([^\"]+\\)\\)" nil t) (setq url (match-string 1) time (nnwfm-date-to-time (gnus-url-unhex-string (match-string 2)))) (when (and (nnwfm-new-threads-p group time) (not (member (setq url (concat nnwfm-address (mm-url-decode-entities-string url))) fetched-urls))) (push url furls)))) ;; The main idea here is to map Gnus article numbers to ;; nnwfm article numbers. Say there are three topics in ;; this forum, the first with 4 articles, the seconds with 2, ;; and the third with 1. Then this will translate into 7 Gnus ;; article numbers, where 1-4 comes from the first topic, 5-6 ;; from the second and 7 from the third. Now, then next time ;; the group is entered, there's 2 new articles in topic one ;; and 1 in topic three. Then Gnus article number 8-9 be 5-6 ;; in topic one and 10 will be the 2 in topic three. (dolist (elem (nreverse forum-contents)) (setq subject (nth 1 elem) topic (nth 0 elem) garticles (nth 2 elem)) (if (setq tinfo (assq topic topics)) (progn (setq old-max (cadr tinfo)) (setcar (cdr tinfo) garticles)) (setq old-max 0) (push (list topic garticles subject) topics) (setcar (nthcdr 4 entry) topics)) (when (not (= old-max garticles)) (setq inc (- garticles old-max)) (setq mapping (nconc mapping (list (list old-total (1- (incf old-total inc)) topic (1+ old-max))))) (incf old-max inc) (setcar (nthcdr 5 entry) mapping) (setcar (nthcdr 6 entry) old-total)))) (setcar (nthcdr 7 entry) current-time) (setcar (nthcdr 1 entry) (1- old-total)) (nnwfm-write-groups) mapping)) (defun nnwfm-possibly-change-server (&optional group server) (nnwfm-init server) (when (and server (not (nnwfm-server-opened server))) (nnwfm-open-server server)) (unless nnwfm-groups-alist (nnwfm-read-groups) (setq nnwfm-groups (cdr (assoc nnwfm-address nnwfm-groups-alist))))) (deffoo nnwfm-open-server (server &optional defs connectionless) (nnheader-init-server-buffer) (if (nnwfm-server-opened server) t (unless (assq 'nnwfm-address defs) (setq defs (append defs (list (list 'nnwfm-address server))))) (nnoo-change-server 'nnwfm server defs))) (defun nnwfm-read-groups () (setq nnwfm-groups-alist nil) (let ((file (expand-file-name "groups" nnwfm-directory))) (when (file-exists-p file) (mm-with-unibyte-buffer (insert-file-contents file) (goto-char (point-min)) (setq nnwfm-groups-alist (read (current-buffer))))))) (defun nnwfm-write-groups () (setq nnwfm-groups-alist (delq (assoc nnwfm-address nnwfm-groups-alist) nnwfm-groups-alist)) (push (cons nnwfm-address nnwfm-groups) nnwfm-groups-alist) (with-temp-file (expand-file-name "groups" nnwfm-directory) (prin1 nnwfm-groups-alist (current-buffer)))) (defun nnwfm-init (server) "Initialize buffers and such." (unless (file-exists-p nnwfm-directory) (gnus-make-directory nnwfm-directory))) (defun nnwfm-generate-active () (save-excursion (set-buffer nntp-server-buffer) (erase-buffer) (dolist (elem nnwfm-groups) (insert (prin1-to-string (car elem)) " " (number-to-string (cadr elem)) " 1 y\n")))) (defun nnwfm-find-forum-table (contents) (catch 'found (nnwfm-find-forum-table-1 contents))) (defun nnwfm-find-forum-table-1 (contents) (dolist (element contents) (unless (stringp element) (when (and (eq (car element) 'table) (nnwfm-forum-table-p element)) (throw 'found element)) (when (nth 2 element) (nnwfm-find-forum-table-1 (nth 2 element)))))) (defun nnwfm-forum-table-p (parse) (when (not (apply 'gnus-or (mapcar (lambda (p) (nnweb-parse-find 'table p)) (nth 2 parse)))) (let ((href (cdr (assq 'href (nth 1 (nnweb-parse-find 'a parse 20))))) case-fold-search) (when (and href (string-match nnwfm-table-regexp href)) t)))) (defun nnwfm-date-to-time (date) (let ((time (mapcar #'string-to-number (split-string date "[\\.\\+ :]")))) (encode-time 0 (nth 4 time) (nth 3 time) (nth 0 time) (nth 1 time) (if (< (nth 2 time) 70) (+ 2000 (nth 2 time)) (+ 1900 (nth 2 time)))))) (provide 'nnwfm) ;; Local Variables: ;; coding: iso-8859-1 ;; End: ;; arch-tag: d813966a-4211-4557-ad11-d1ac2bc86536 ;;; nnwfm.el ends here gnus-5.11+v0.10.dfsg/lisp/mm-uu.el0000644000175000017500000005562611004005110016621 0ustar tvainikatvainika;;; mm-uu.el --- Return uu stuff as mm handles ;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, ;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc. ;; Author: Shenghuo Zhu ;; Keywords: postscript uudecode binhex shar forward gnatsweb pgp ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 3, or (at your option) ;; any later version. ;; ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Commentary: ;;; Code: (eval-when-compile (require 'cl)) (require 'mail-parse) (require 'nnheader) (require 'mm-decode) (require 'mailcap) (require 'mml2015) (autoload 'uudecode-decode-region "uudecode") (autoload 'uudecode-decode-region-external "uudecode") (autoload 'uudecode-decode-region-internal "uudecode") (autoload 'binhex-decode-region "binhex") (autoload 'binhex-decode-region-external "binhex") (autoload 'binhex-decode-region-internal "binhex") (autoload 'yenc-decode-region "yenc") (autoload 'yenc-extract-filename "yenc") (defcustom mm-uu-decode-function 'uudecode-decode-region "*Function to uudecode. Internal function is done in Lisp by default, therefore decoding may appear to be horribly slow. You can make Gnus use an external decoder, such as uudecode." :type '(choice (function-item :tag "Auto detect" uudecode-decode-region) (function-item :tag "Internal" uudecode-decode-region-internal) (function-item :tag "External" uudecode-decode-region-external)) :group 'gnus-article-mime) (defcustom mm-uu-binhex-decode-function 'binhex-decode-region "*Function to binhex decode. Internal function is done in elisp by default, therefore decoding may appear to be horribly slow . You can make Gnus use the external Unix decoder, such as hexbin." :type '(choice (function-item :tag "Auto detect" binhex-decode-region) (function-item :tag "Internal" binhex-decode-region-internal) (function-item :tag "External" binhex-decode-region-external)) :group 'gnus-article-mime) (defvar mm-uu-yenc-decode-function 'yenc-decode-region) (defvar mm-uu-beginning-regexp nil) (defvar mm-dissect-disposition "inline" "The default disposition of uu parts. This can be either \"inline\" or \"attachment\".") (defcustom mm-uu-emacs-sources-regexp "\\.emacs\\.sources" "The regexp of Emacs sources groups." :version "22.1" :type 'regexp :group 'gnus-article-mime) (defcustom mm-uu-diff-groups-regexp "\\(gmane\\|gnu\\)\\..*\\(diff\\|commit\\|cvs\\|bug\\|devel\\)" "Regexp matching diff groups." :version "22.1" :type 'regexp :group 'gnus-article-mime) (defcustom mm-uu-tex-groups-regexp "\\.tex\\>" "*Regexp matching TeX groups." :version "23.1" :type 'regexp :group 'gnus-article-mime) (defvar mm-uu-type-alist '((postscript "^%!PS-" "^%%EOF$" mm-uu-postscript-extract nil) (uu ;; Maybe we should have a more strict test here. "^begin[ \t]+0?[0-7][0-7][0-7][ \t]+" "^end[ \t]*$" mm-uu-uu-extract mm-uu-uu-filename) (binhex "^:.\\{63,63\\}$" ":$" mm-uu-binhex-extract nil mm-uu-binhex-filename) (yenc "^=ybegin.*size=[0-9]+.*name=.*$" "^=yend.*size=[0-9]+" mm-uu-yenc-extract mm-uu-yenc-filename) (shar "^#! */bin/sh" "^exit 0$" mm-uu-shar-extract) (forward ;; Thanks to Edward J. Sabol and ;; Peter von der Ah\'e "^-+ \\(Start of \\)?Forwarded message" "^-+ End \\(of \\)?forwarded message" mm-uu-forward-extract nil mm-uu-forward-test) (gnatsweb "^----gnatsweb-attachment----" nil mm-uu-gnatsweb-extract) (pgp-signed "^-----BEGIN PGP SIGNED MESSAGE-----" "^-----END PGP SIGNATURE-----" mm-uu-pgp-signed-extract nil nil) (pgp-encrypted "^-----BEGIN PGP MESSAGE-----" "^-----END PGP MESSAGE-----" mm-uu-pgp-encrypted-extract nil nil) (pgp-key "^-----BEGIN PGP PUBLIC KEY BLOCK-----" "^-----END PGP PUBLIC KEY BLOCK-----" mm-uu-pgp-key-extract mm-uu-gpg-key-skip-to-last nil) (emacs-sources "^;;;?[ \t]*[^ \t]+\\.el[ \t]*--" "^;;;?[ \t]*\\([^ \t]+\\.el\\)[ \t]+ends here" mm-uu-emacs-sources-extract nil mm-uu-emacs-sources-test) (diff "^Index: " nil mm-uu-diff-extract nil mm-uu-diff-test) (message-marks ;; Text enclosed with tags similar to `message-mark-insert-begin' and ;; `message-mark-insert-end'. Don't use those variables to avoid ;; dependency on `message.el'. "^-+[8<>]*-\\{9,\\}[a-z ]+-\\{9,\\}[a-z ]+-\\{9,\\}[8<>]*-+$" "^-+[8<>]*-\\{9,\\}[a-z ]+-\\{9,\\}[a-z ]+-\\{9,\\}[8<>]*-+$" (lambda () (mm-uu-verbatim-marks-extract -1 0 1 -1)) nil) ;; Omitting [a-z8<] leads to false positives (bogus signature separators ;; and mailing list banners). (insert-marks "^ *\\(-\\|_\\)\\{30,\\}.*[a-z8<].*\\(-\\|_\\)\\{30,\\} *$" "^ *\\(-\\|_\\)\\{30,\\}.*[a-z8<].*\\(-\\|_\\)\\{30,\\} *$" (lambda () (mm-uu-verbatim-marks-extract 0 0 1 -1)) nil) (verbatim-marks ;; slrn-style verbatim marks, see ;; http://www.slrn.org/manual/slrn-manual-6.html#ss6.81 "^#v\\+" "^#v\\-$" (lambda () (mm-uu-verbatim-marks-extract 0 0)) nil) (LaTeX "^\\([\\\\%][^\n]+\n\\)*\\\\documentclass.*[[{%]" "^\\\\end{document}" mm-uu-latex-extract nil mm-uu-latex-test)) "A list of specifications for non-MIME attachments. Each element consist of the following entries: label, start-regexp, end-regexp, extract-function, test-function. After modifying this list you must run \\[mm-uu-configure]. You can disable elements from this list by customizing `mm-uu-configure-list'.") (defcustom mm-uu-configure-list '((shar . disabled)) "A list of mm-uu configuration. To disable dissecting shar codes, for instance, add `(shar . disabled)' to this list." :type 'alist :options (mapcar (lambda (entry) (list (car entry) '(const disabled))) mm-uu-type-alist) :group 'gnus-article-mime) (defvar mm-uu-text-plain-type '("text/plain" (charset . gnus-decoded)) "MIME type and parameters for text/plain parts. `gnus-decoded' is a fake charset, which means no further decoding.") ;; functions (defsubst mm-uu-type (entry) (car entry)) (defsubst mm-uu-beginning-regexp (entry) (nth 1 entry)) (defsubst mm-uu-end-regexp (entry) (nth 2 entry)) (defsubst mm-uu-function-extract (entry) (nth 3 entry)) (defsubst mm-uu-function-1 (entry) (nth 4 entry)) (defsubst mm-uu-function-2 (entry) (nth 5 entry)) ;; In Emacs 22, we could use `min-colors' in the face definition. But Emacs ;; 21 and XEmacs don't support it. (defcustom mm-uu-hide-markers (< 16 (or (and (fboundp 'defined-colors) (length (defined-colors))) (and (fboundp 'device-color-cells) (device-color-cells)) 0)) "If non-nil, hide verbatim markers. The value should be nil on displays where the face `mm-uu-extract' isn't distinguishable to the face `default'." :type '(choice (const :tag "Hide" t) (const :tag "Don't hide" nil)) :version "23.1" ;; No Gnus :group 'gnus-article-mime) (defface mm-uu-extract '(;; Inspired by `gnus-cite-3' (((type tty) (class color) (background dark)) (:background "dark blue")) (((class color) (background dark)) (:foreground "light yellow" :background "dark green")) (((type tty) (class color) (background light)) (:foreground "dark blue")) (((class color) (background light)) (:foreground "dark green" :background "light yellow")) (t ())) "Face for extracted buffers." ;; See `mm-uu-verbatim-marks-extract'. :version "23.1" ;; No Gnus :group 'gnus-article-mime) (defun mm-uu-copy-to-buffer (&optional from to properties) "Copy the contents of the current buffer to a fresh buffer. Return that buffer. If PROPERTIES is non-nil, PROPERTIES are applied to the buffer, see `set-text-properties'. If PROPERTIES equals t, this means to apply the face `mm-uu-extract'." (let ((obuf (current-buffer)) (multi (and (boundp 'enable-multibyte-characters) enable-multibyte-characters)) (coding-system ;; Might not exist in non-MULE XEmacs (when (boundp 'buffer-file-coding-system) buffer-file-coding-system))) (with-current-buffer (generate-new-buffer " *mm-uu*") (if multi (mm-enable-multibyte) (mm-disable-multibyte)) (setq buffer-file-coding-system coding-system) (insert-buffer-substring obuf from to) (cond ((eq properties t) (set-text-properties (point-min) (point-max) '(face mm-uu-extract))) (properties (set-text-properties (point-min) (point-max) properties))) (current-buffer)))) (defun mm-uu-configure-p (key val) (member (cons key val) mm-uu-configure-list)) (defun mm-uu-configure (&optional symbol value) "Configure detection of non-MIME attachments." (interactive) (if symbol (set-default symbol value)) (setq mm-uu-beginning-regexp nil) (mapcar (lambda (entry) (if (mm-uu-configure-p (mm-uu-type entry) 'disabled) nil (setq mm-uu-beginning-regexp (concat mm-uu-beginning-regexp (if mm-uu-beginning-regexp "\\|") (mm-uu-beginning-regexp entry))))) mm-uu-type-alist)) (mm-uu-configure) (defvar file-name) (defvar start-point) (defvar end-point) (defvar entry) (defun mm-uu-uu-filename () (if (looking-at ".+") (setq file-name (let ((nnheader-file-name-translation-alist '((?/ . ?,) (?\ . ?_) (?* . ?_) (?$ . ?_)))) (nnheader-translate-file-chars (match-string 0)))))) (defun mm-uu-binhex-filename () (setq file-name (ignore-errors (binhex-decode-region start-point end-point t)))) (defun mm-uu-yenc-filename () (goto-char start-point) (setq file-name (ignore-errors (yenc-extract-filename)))) (defun mm-uu-forward-test () (save-excursion (goto-char start-point) (forward-line) (looking-at "[\r\n]*[a-zA-Z][a-zA-Z0-9-]*:"))) (defun mm-uu-postscript-extract () (mm-make-handle (mm-uu-copy-to-buffer start-point end-point) '("application/postscript"))) (defun mm-uu-verbatim-marks-extract (start-offset end-offset &optional start-hide end-hide) (let ((start (or (and mm-uu-hide-markers start-hide) start-offset 1)) (end (or (and mm-uu-hide-markers end-hide) end-offset -1))) (mm-make-handle (mm-uu-copy-to-buffer (progn (goto-char start-point) (forward-line start) (point)) (progn (goto-char end-point) (forward-line end) (point)) t) '("text/x-verbatim" (charset . gnus-decoded))))) (defun mm-uu-latex-extract () (mm-make-handle (mm-uu-copy-to-buffer start-point end-point t) ;; application/x-tex? '("text/x-verbatim" (charset . gnus-decoded)))) (defun mm-uu-emacs-sources-extract () (mm-make-handle (mm-uu-copy-to-buffer start-point end-point) '("application/emacs-lisp" (charset . gnus-decoded)) nil nil (list mm-dissect-disposition (cons 'filename file-name)))) (defvar gnus-newsgroup-name) (defun mm-uu-emacs-sources-test () (setq file-name (match-string 1)) (and gnus-newsgroup-name mm-uu-emacs-sources-regexp (string-match mm-uu-emacs-sources-regexp gnus-newsgroup-name))) (defun mm-uu-diff-extract () (mm-make-handle (mm-uu-copy-to-buffer start-point end-point) '("text/x-patch" (charset . gnus-decoded)))) (defun mm-uu-diff-test () (and gnus-newsgroup-name mm-uu-diff-groups-regexp (string-match mm-uu-diff-groups-regexp gnus-newsgroup-name))) (defun mm-uu-latex-test () (and gnus-newsgroup-name mm-uu-tex-groups-regexp (string-match mm-uu-tex-groups-regexp gnus-newsgroup-name))) (defun mm-uu-forward-extract () (mm-make-handle (mm-uu-copy-to-buffer (progn (goto-char start-point) (forward-line) (point)) (progn (goto-char end-point) (forward-line -1) (point))) '("message/rfc822" (charset . gnus-decoded)))) (defun mm-uu-uu-extract () (mm-make-handle (mm-uu-copy-to-buffer start-point end-point) (list (or (and file-name (string-match "\\.[^\\.]+$" file-name) (mailcap-extension-to-mime (match-string 0 file-name))) "application/octet-stream")) 'x-uuencode nil (if (and file-name (not (equal file-name ""))) (list mm-dissect-disposition (cons 'filename file-name))))) (defun mm-uu-binhex-extract () (mm-make-handle (mm-uu-copy-to-buffer start-point end-point) (list (or (and file-name (string-match "\\.[^\\.]+$" file-name) (mailcap-extension-to-mime (match-string 0 file-name))) "application/octet-stream")) 'x-binhex nil (if (and file-name (not (equal file-name ""))) (list mm-dissect-disposition (cons 'filename file-name))))) (defvar gnus-original-article-buffer) ; gnus.el (defun mm-uu-yenc-extract () ;; This might not be exactly correct, but we sure can't get the ;; binary data from the article buffer, since that's already in a ;; non-binary charset. So get it from the original article buffer. (mm-make-handle (with-current-buffer gnus-original-article-buffer (mm-uu-copy-to-buffer start-point end-point)) (list (or (and file-name (string-match "\\.[^\\.]+$" file-name) (mailcap-extension-to-mime (match-string 0 file-name))) "application/octet-stream")) 'x-yenc nil (if (and file-name (not (equal file-name ""))) (list mm-dissect-disposition (cons 'filename file-name))))) (defun mm-uu-shar-extract () (mm-make-handle (mm-uu-copy-to-buffer start-point end-point) '("application/x-shar"))) (defun mm-uu-gnatsweb-extract () (save-restriction (goto-char start-point) (forward-line) (narrow-to-region (point) end-point) (mm-dissect-buffer t))) (defun mm-uu-pgp-signed-test (&rest rest) (and mml2015-use (mml2015-clear-verify-function) (cond ((eq mm-verify-option 'never) nil) ((eq mm-verify-option 'always) t) ((eq mm-verify-option 'known) t) (t (prog1 (y-or-n-p "Verify pgp signed part? ") (message "")))))) (defvar gnus-newsgroup-charset) (defun mm-uu-pgp-signed-extract-1 (handles ctl) (let ((buf (mm-uu-copy-to-buffer (point-min) (point-max)))) (with-current-buffer buf (if (mm-uu-pgp-signed-test) (progn (mml2015-clean-buffer) (let ((coding-system-for-write (or gnus-newsgroup-charset 'iso-8859-1)) (coding-system-for-read (or gnus-newsgroup-charset 'iso-8859-1))) (funcall (mml2015-clear-verify-function)))) (when (and mml2015-use (null (mml2015-clear-verify-function))) (mm-set-handle-multipart-parameter mm-security-handle 'gnus-details (format "Clear verification not supported by `%s'.\n" mml2015-use))) (mml2015-extract-cleartext-signature)) (list (mm-make-handle buf mm-uu-text-plain-type))))) (defun mm-uu-pgp-signed-extract () (let ((mm-security-handle (list (format "multipart/signed")))) (mm-set-handle-multipart-parameter mm-security-handle 'protocol "application/x-gnus-pgp-signature") (save-restriction (narrow-to-region start-point end-point) (add-text-properties 0 (length (car mm-security-handle)) (list 'buffer (mm-uu-copy-to-buffer)) (car mm-security-handle)) (setcdr mm-security-handle (mm-uu-pgp-signed-extract-1 nil mm-security-handle))) mm-security-handle)) (defun mm-uu-pgp-encrypted-test (&rest rest) (and mml2015-use (mml2015-clear-decrypt-function) (cond ((eq mm-decrypt-option 'never) nil) ((eq mm-decrypt-option 'always) t) ((eq mm-decrypt-option 'known) t) (t (prog1 (y-or-n-p "Decrypt pgp encrypted part? ") (message "")))))) (defun mm-uu-pgp-encrypted-extract-1 (handles ctl) (let ((buf (mm-uu-copy-to-buffer (point-min) (point-max))) (first t) charset) ;; Make sure there's a blank line between header and body. (with-current-buffer buf (goto-char (point-min)) (while (prog2 (forward-line 1) (if first (looking-at "[^\t\n ]+:") (looking-at "[^\t\n ]+:\\|[\t ]")) (setq first nil))) (unless (memq (char-after) '(?\n nil)) (insert "\n")) (save-restriction (narrow-to-region (point-min) (point)) (setq charset (mail-fetch-field "charset"))) (if (and (mm-uu-pgp-encrypted-test) (progn (mml2015-clean-buffer) (funcall (mml2015-clear-decrypt-function)) (equal (mm-handle-multipart-ctl-parameter mm-security-handle 'gnus-info) "OK"))) (progn ;; Decode charset. (if (and (or charset (setq charset gnus-newsgroup-charset)) (setq charset (mm-charset-to-coding-system charset)) (not (eq charset 'ascii))) ;; Assume that buffer's multibyteness is turned off. ;; See `mml2015-pgg-clear-decrypt'. (insert (mm-decode-coding-string (prog1 (buffer-string) (erase-buffer) (mm-enable-multibyte)) charset)) (mm-enable-multibyte)) (list (mm-make-handle buf mm-uu-text-plain-type))) (list (mm-make-handle buf '("application/pgp-encrypted"))))))) (defun mm-uu-pgp-encrypted-extract () (let ((mm-security-handle (list (format "multipart/encrypted")))) (mm-set-handle-multipart-parameter mm-security-handle 'protocol "application/x-gnus-pgp-encrypted") (save-restriction (narrow-to-region start-point end-point) (add-text-properties 0 (length (car mm-security-handle)) (list 'buffer (mm-uu-copy-to-buffer)) (car mm-security-handle)) (setcdr mm-security-handle (mm-uu-pgp-encrypted-extract-1 nil mm-security-handle))) mm-security-handle)) (defun mm-uu-gpg-key-skip-to-last () (let ((point (point)) (end-regexp (mm-uu-end-regexp entry)) (beginning-regexp (mm-uu-beginning-regexp entry))) (when (and end-regexp (not (mm-uu-configure-p (mm-uu-type entry) 'disabled))) (while (re-search-forward end-regexp nil t) (skip-chars-forward " \t\n\r") (if (looking-at beginning-regexp) (setq point (match-end 0))))) (goto-char point))) (defun mm-uu-pgp-key-extract () (let ((buf (mm-uu-copy-to-buffer start-point end-point))) (mm-make-handle buf '("application/pgp-keys")))) ;;;###autoload (defun mm-uu-dissect (&optional noheader mime-type) "Dissect the current buffer and return a list of uu handles. The optional NOHEADER means there's no header in the buffer. MIME-TYPE specifies a MIME type and parameters, which defaults to the value of `mm-uu-text-plain-type'." (let ((case-fold-search t) (mm-uu-text-plain-type (or mime-type mm-uu-text-plain-type)) text-start start-point end-point file-name result entry func) (save-excursion (goto-char (point-min)) (cond (noheader) ((looking-at "\n") (forward-line)) ((search-forward "\n\n" nil t) t) (t (goto-char (point-max)))) (setq text-start (point)) (while (re-search-forward mm-uu-beginning-regexp nil t) (setq start-point (match-beginning 0) entry nil) (let ((alist mm-uu-type-alist) (beginning-regexp (match-string 0))) (while (not entry) (if (string-match (mm-uu-beginning-regexp (car alist)) beginning-regexp) (setq entry (car alist)) (pop alist)))) (if (setq func (mm-uu-function-1 entry)) (funcall func)) (forward-line);; in case of failure (when (and (not (mm-uu-configure-p (mm-uu-type entry) 'disabled)) (let ((end-regexp (mm-uu-end-regexp entry))) (if (not end-regexp) (or (setq end-point (point-max)) t) (prog1 (re-search-forward end-regexp nil t) (forward-line) (setq end-point (point))))) (or (not (setq func (mm-uu-function-2 entry))) (funcall func))) (if (and (> start-point text-start) (progn (goto-char text-start) (re-search-forward "." start-point t))) (push (mm-make-handle (mm-uu-copy-to-buffer text-start start-point) mm-uu-text-plain-type) result)) (push (funcall (mm-uu-function-extract entry)) result) (goto-char (setq text-start end-point)))) (when result (if (and (> (point-max) (1+ text-start)) (save-excursion (goto-char text-start) (re-search-forward "." nil t))) (push (mm-make-handle (mm-uu-copy-to-buffer text-start (point-max)) mm-uu-text-plain-type) result)) (setq result (cons "multipart/mixed" (nreverse result)))) result))) ;;;###autoload (defun mm-uu-dissect-text-parts (handle &optional decoded) "Dissect text parts and put uu handles into HANDLE. Assume text has been decoded if DECODED is non-nil." (let ((buffer (mm-handle-buffer handle))) (cond ((stringp buffer) (dolist (elem (cdr handle)) (mm-uu-dissect-text-parts elem decoded))) ((bufferp buffer) (let ((type (mm-handle-media-type handle)) (case-fold-search t) ;; string-match children charset encoding) (when (and (stringp type) ;; Mutt still uses application/pgp even though ;; it has already been withdrawn. (string-match "\\`text/\\|\\`application/pgp\\'" type) (setq children (with-current-buffer buffer (cond ((or decoded (eq (setq charset (mail-content-type-get (mm-handle-type handle) 'charset)) 'gnus-decoded)) (setq decoded t) (mm-uu-dissect t (cons type '((charset . gnus-decoded))))) (charset (setq decoded t) (mm-with-multibyte-buffer (insert (mm-decode-string (mm-get-part handle) charset)) (mm-uu-dissect t (cons type '((charset . gnus-decoded)))))) ((setq encoding (mm-handle-encoding handle)) (setq decoded nil) ;; Inherit the multibyteness of the `buffer'. (with-temp-buffer (insert-buffer-substring buffer) (mm-decode-content-transfer-encoding encoding type) (mm-uu-dissect t (list type)))) (t (setq decoded nil) (mm-uu-dissect t (list type))))))) ;; Ignore it if a given part is dissected into a single ;; part of which the type is the same as the given one. (if (and (<= (length children) 2) (string-equal (mm-handle-media-type (cadr children)) type)) (kill-buffer (mm-handle-buffer (cadr children))) (kill-buffer buffer) (setcdr handle (cdr children)) (setcar handle (car children)) ;; "multipart/mixed" (dolist (elem (cdr children)) (mm-uu-dissect-text-parts elem decoded)))))) (t (dolist (elem handle) (mm-uu-dissect-text-parts elem decoded)))))) (provide 'mm-uu) ;; arch-tag: 7db076bf-53db-4320-aa19-ca76a1d2ab2c ;;; mm-uu.el ends here gnus-5.11+v0.10.dfsg/lisp/auth-source.el0000644000175000017500000001337111004423012020014 0ustar tvainikatvainika;;; auth-source.el --- authentication sources for Gnus and Emacs ;; Copyright (C) 2008 Free Software Foundation, Inc. ;; Author: Ted Zlatanov ;; Keywords: news ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 3, or (at your option) ;; any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Commentary: ;; This is the auth-source.el package. It lets users tell Gnus how to ;; authenticate in a single place. Simplicity is the goal. Instead ;; of providing 5000 options, we'll stick to simple, easy to ;; understand options. ;; Easy setup: ;; (require 'auth-source) ;; (customize-variable 'auth-sources) ;; optional ;; now, whatever sources you've defined for password have to be available ;; if you want encrypted sources, which is strongly recommended, do ;; (require 'epa-file) ;; (epa-file-mode) ;; before you put some data in ~/.authinfo.gpg (the default place) ;;; Code: (eval-when-compile (require 'cl)) (eval-when-compile (require 'netrc)) (defgroup auth-source nil "Authentication sources." :version "23.1" ;; No Gnus :group 'gnus) (defcustom auth-source-protocols '((imap "imap" "imaps" "143" "993") (pop3 "pop3" "pop" "pop3s" "110" "995") (ssh "ssh" "22") (sftp "sftp" "115") (smtp "smtp" "25")) "List of authentication protocols and their names" :group 'auth-source :version "23.1" ;; No Gnus :type '(repeat :tag "Authentication Protocols" (cons :tag "Protocol Entry" (symbol :tag "Protocol") (repeat :tag "Names" (string :tag "Name"))))) ;;; generate all the protocols in a format Customize can use (defconst auth-source-protocols-customize (mapcar (lambda (a) (let ((p (car-safe a))) (list 'const :tag (upcase (symbol-name p)) p))) auth-source-protocols)) ;;; this default will be changed to ~/.authinfo.gpg (defcustom auth-sources '((:source "~/.authinfo.enc" :host t :protocol t)) "List of authentication sources. Each entry is the authentication type with optional properties." :group 'auth-source :version "23.1" ;; No Gnus :type `(repeat :tag "Authentication Sources" (list :tag "Source definition" (const :format "" :value :source) (string :tag "Authentication Source") (const :format "" :value :host) (choice :tag "Host (machine) choice" (const :tag "Any" t) (regexp :tag "Host (machine) regular expression (TODO)") (const :tag "Fallback" nil)) (const :format "" :value :protocol) (choice :tag "Protocol" (const :tag "Any" t) (const :tag "Fallback" nil) ,@auth-source-protocols-customize)))) ;; temp for debugging ;; (unintern 'auth-source-protocols) ;; (unintern 'auth-sources) ;; (customize-variable 'auth-sources) ;; (setq auth-sources nil) ;; (format "%S" auth-sources) ;; (customize-variable 'auth-source-protocols) ;; (setq auth-source-protocols nil) ;; (format "%S" auth-source-protocols) ;; (auth-source-pick "a" 'imap) ;; (auth-source-user-or-password "login" "imap.myhost.com" 'imap) ;; (auth-source-user-or-password "password" "imap.myhost.com" 'imap) ;; (auth-source-user-or-password-imap "login" "imap.myhost.com") ;; (auth-source-user-or-password-imap "password" "imap.myhost.com") ;; (auth-source-protocol-defaults 'imap) (defun auth-source-pick (host protocol &optional fallback) "Parse `auth-sources' for HOST, and PROTOCOL matches. Returns fallback choices (where PROTOCOL or HOST are nil) with FALLBACK t." (interactive "sHost: \nsProtocol: \n") ;for testing (let (choices) (dolist (choice auth-sources) (let ((h (plist-get choice :host)) (p (plist-get choice :protocol))) (when (and (or (equal t h) (and (stringp h) (string-match h host)) (and fallback (equal h nil))) (or (equal t p) (and (symbolp p) (equal p protocol)) (and fallback (equal p nil)))) (push choice choices)))) (if choices choices (unless fallback (auth-source-pick host protocol t))))) (defun auth-source-user-or-password (mode host protocol) "Find user or password (from the string MODE) matching HOST and PROTOCOL." (let (found) (dolist (choice (auth-source-pick host protocol)) (setq found (netrc-machine-user-or-password mode (plist-get choice :source) (list host) (list (format "%s" protocol)) (auth-source-protocol-defaults protocol))) (when found (return found))))) (defun auth-source-protocol-defaults (protocol) "Return a list of default ports and names for PROTOCOL." (cdr-safe (assoc protocol auth-source-protocols))) (defun auth-source-user-or-password-imap (mode host) (auth-source-user-or-password mode host 'imap)) (defun auth-source-user-or-password-pop3 (mode host) (auth-source-user-or-password mode host 'pop3)) (defun auth-source-user-or-password-ssh (mode host) (auth-source-user-or-password mode host 'ssh)) (defun auth-source-user-or-password-sftp (mode host) (auth-source-user-or-password mode host 'sftp)) (defun auth-source-user-or-password-smtp (mode host) (auth-source-user-or-password mode host 'smtp)) (provide 'auth-source) ;; arch-tag: ff1afe78-06e9-42c2-b693-e9f922cbe4ab ;;; auth-source.el ends here gnus-5.11+v0.10.dfsg/lisp/yenc.el0000644000175000017500000001220011004005111016475 0ustar tvainikatvainika;;; yenc.el --- elisp native yenc decoder ;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc. ;; Author: Jesper Harder ;; Keywords: yenc news ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 3, or (at your option) ;; any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Commentary: ;; Functions for decoding yenc encoded messages. ;; ;; Limitations: ;; ;; * Does not handle multipart messages. ;; * No support for external decoders. ;; * Doesn't check the crc32 checksum (if present). ;;; Code: (eval-when-compile (require 'cl)) (defconst yenc-begin-line "^=ybegin.*$") (defconst yenc-decoding-vector [214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213]) (defun yenc-first-part-p () "Say whether the buffer contains the first part of a yEnc file." (save-excursion (goto-char (point-min)) (re-search-forward "^=ybegin part=1 " nil t))) (defun yenc-last-part-p () "Say whether the buffer contains the last part of a yEnc file." (save-excursion (goto-char (point-min)) (let (total-size end-size) (when (re-search-forward "^=ybegin.*size=\\([0-9]+\\)" nil t) (setq total-size (match-string 1))) (when (re-search-forward "^=ypart.*end=\\([0-9]+\\)" nil t) (setq end-size (match-string 1))) (and total-size end-size (string= total-size end-size))))) ;;;###autoload (defun yenc-decode-region (start end) "Yenc decode region between START and END using an internal decoder." (interactive "r") (let (work-buffer) (unwind-protect (save-excursion (goto-char start) (when (re-search-forward yenc-begin-line end t) (let ((first (match-end 0)) (header-alist (yenc-parse-line (match-string 0))) bytes last footer-alist char) (when (re-search-forward "^=ypart.*$" end t) (setq first (match-end 0))) (when (re-search-forward "^=yend.*$" end t) (setq last (match-beginning 0)) (setq footer-alist (yenc-parse-line (match-string 0))) (let (default-enable-multibyte-characters) (setq work-buffer (generate-new-buffer " *yenc-work*"))) (while (< first last) (setq char (char-after first)) (cond ((or (eq char ?\r) (eq char ?\n))) ((eq char ?=) (setq char (char-after (incf first))) (with-current-buffer work-buffer (insert-char (mod (- char 106) 256) 1))) (t (with-current-buffer work-buffer ;;(insert-char (mod (- char 42) 256) 1) (insert-char (aref yenc-decoding-vector char) 1)))) (incf first)) (setq bytes (buffer-size work-buffer)) (unless (and (= (cdr (assq 'size header-alist)) bytes) (= (cdr (assq 'size footer-alist)) bytes)) (message "Warning: Size mismatch while decoding.")) (goto-char start) (delete-region start end) (insert-buffer-substring work-buffer)))) (and work-buffer (kill-buffer work-buffer)))))) ;;;###autoload (defun yenc-extract-filename () "Extract file name from an yenc header." (save-excursion (when (re-search-forward yenc-begin-line nil t) (cdr (assoc 'name (yenc-parse-line (match-string 0))))))) (defun yenc-parse-line (str) "Extract file name and size from STR." (let (result name) (when (string-match "^=y.*size=\\([0-9]+\\)" str) (push (cons 'size (string-to-number (match-string 1 str))) result)) (when (string-match "^=y.*name=\\(.*\\)$" str) (setq name (match-string 1 str)) ;; Remove trailing white space (when (string-match " +$" name) (setq name (substring name 0 (match-beginning 0)))) (push (cons 'name name) result)) result)) (provide 'yenc) ;; arch-tag: 74df17e8-6fa8-4071-9f7d-54d548d79d9a ;;; yenc.el ends here gnus-5.11+v0.10.dfsg/lisp/gnus-delay.el0000644000175000017500000001535010744555355017656 0ustar tvainikatvainika;;; gnus-delay.el --- Delayed posting of articles ;; Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc. ;; Author: Kai Großjohann ;; Keywords: mail, news, extensions ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published ;; by the Free Software Foundation; either version 3, or (at your ;; option) any later version. ;; GNU Emacs is distributed in the hope that it will be useful, but ;; WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to ;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Commentary: ;; Provide delayed posting of articles. ;;; Todo: ;; * `gnus-delay-send-queue' barfs when group does not exist. ;; * Integrate gnus-delay.el into the rest of Gnus automatically. How ;; should this be done? Basically, we need to do what ;; `gnus-delay-initialize' does. But in which files? ;;; Code: (require 'nndraft) (require 'gnus-draft) (autoload 'parse-time-string "parse-time" nil nil) (defgroup gnus-delay nil "Arrange for sending postings later." :version "22.1" :group 'gnus) (defcustom gnus-delay-group "delayed" "Group name for storing delayed articles." :type 'string :group 'gnus-delay) (defcustom gnus-delay-header "X-Gnus-Delayed" "Header name for storing info about delayed articles." :type 'string :group 'gnus-delay) (defcustom gnus-delay-default-delay "3d" "*Default length of delay." :type 'string :group 'gnus-delay) (defcustom gnus-delay-default-hour 8 "*If deadline is given as date, then assume this time of day." :version "22.1" :type 'integer :group 'gnus-delay) ;;;###autoload (defun gnus-delay-article (delay) "Delay this article by some time. DELAY is a string, giving the length of the time. Possible values are: * for in minutes (`m'), hours (`h'), days (`d'), weeks (`w'), months (`M'), or years (`Y'); * YYYY-MM-DD for a specific date. The time of day is given by the variable `gnus-delay-default-hour', minute and second are zero. * hh:mm for a specific time. Use 24h format. If it is later than this time, then the deadline is tomorrow, else today." (interactive (list (read-string "Target date (YYYY-MM-DD) or length of delay (units in [mhdwMY]): " gnus-delay-default-delay))) (let (num unit days year month day hour minute deadline) (cond ((string-match "\\([0-9][0-9][0-9]?[0-9]?\\)-\\([0-9]+\\)-\\([0-9]+\\)" delay) (setq year (string-to-number (match-string 1 delay)) month (string-to-number (match-string 2 delay)) day (string-to-number (match-string 3 delay))) (setq deadline (message-make-date (encode-time 0 0 ; second and minute gnus-delay-default-hour day month year)))) ((string-match "\\([0-9]+\\):\\([0-9]+\\)" delay) (setq hour (string-to-number (match-string 1 delay)) minute (string-to-number (match-string 2 delay))) ;; Use current time, except... (setq deadline (apply 'vector (decode-time (current-time)))) ;; ... for minute and hour. (aset deadline 1 minute) (aset deadline 2 hour) ;; Convert to seconds. (setq deadline (time-to-seconds (apply 'encode-time (append deadline nil)))) ;; If this time has passed already, add a day. (when (< deadline (time-to-seconds (current-time))) (setq deadline (+ 3600 deadline))) ;3600 secs/day ;; Convert seconds to date header. (setq deadline (message-make-date (seconds-to-time deadline)))) ((string-match "\\([0-9]+\\)\\s-*\\([mhdwMY]\\)" delay) (setq num (match-string 1 delay)) (setq unit (match-string 2 delay)) ;; Start from seconds, then multiply into needed units. (setq num (string-to-number num)) (cond ((string= unit "Y") (setq delay (* num 60 60 24 365))) ((string= unit "M") (setq delay (* num 60 60 24 30))) ((string= unit "w") (setq delay (* num 60 60 24 7))) ((string= unit "d") (setq delay (* num 60 60 24))) ((string= unit "h") (setq delay (* num 60 60))) (t (setq delay (* num 60)))) (setq deadline (message-make-date (seconds-to-time (+ (time-to-seconds (current-time)) delay))))) (t (error "Malformed delay `%s'" delay))) (message-add-header (format "%s: %s" gnus-delay-header deadline))) (set-buffer-modified-p t) ;; If group does not exist, create it. (let ((group (format "nndraft:%s" gnus-delay-group))) (gnus-agent-queue-setup gnus-delay-group)) (message-disassociate-draft) (nndraft-request-associate-buffer gnus-delay-group) (save-buffer 0) (kill-buffer (current-buffer)) (message-do-actions message-postpone-actions)) ;;;###autoload (defun gnus-delay-send-queue () "Send all the delayed messages that are due now." (interactive) (save-excursion (let* ((group (format "nndraft:%s" gnus-delay-group)) (message-send-hook (copy-sequence message-send-hook)) articles article deadline) (when (gnus-group-entry group) (gnus-activate-group group) (add-hook 'message-send-hook '(lambda () (message-remove-header gnus-delay-header))) (setq articles (nndraft-articles)) (while (setq article (pop articles)) (gnus-request-head article group) (set-buffer nntp-server-buffer) (goto-char (point-min)) (if (re-search-forward (concat "^" (regexp-quote gnus-delay-header) ":\\s-+") nil t) (progn (setq deadline (nnheader-header-value)) (setq deadline (apply 'encode-time (parse-time-string deadline))) (setq deadline (time-since deadline)) (when (and (>= (nth 0 deadline) 0) (>= (nth 1 deadline) 0)) (message "Sending delayed article %d" article) (gnus-draft-send article group) (message "Sending delayed article %d...done" article))) (message "Delay header missing for article %d" article))))))) ;;;###autoload (defun gnus-delay-initialize (&optional no-keymap no-check) "Initialize the gnus-delay package. This sets up a key binding in `message-mode' to delay a message. This tells Gnus to look for delayed messages after getting new news. The optional arg NO-KEYMAP is ignored. Checking delayed messages is skipped if optional arg NO-CHECK is non-nil." (unless no-check (add-hook 'gnus-get-new-news-hook 'gnus-delay-send-queue))) (provide 'gnus-delay) ;; Local Variables: ;; coding: iso-8859-1 ;; End: ;; arch-tag: fb2ad634-a897-4142-a503-f5991ec2349d ;;; gnus-delay.el ends here gnus-5.11+v0.10.dfsg/lisp/netrc.el0000644000175000017500000001545511004005110016670 0ustar tvainikatvainika;;; netrc.el --- .netrc parsing functionality ;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, ;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; Keywords: news ;; Modularized by Ted Zlatanov ;; when it was part of Gnus. ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 3, or (at your option) ;; any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Commentary: ;; Just the .netrc parsing functionality, abstracted so other packages ;; besides Gnus can use it. ;;; Code: ;;; ;;; .netrc and .authinfo rc parsing ;;; ;; use encrypt if loaded (encrypt-file-alist has to be set as well) (eval-and-compile (autoload 'encrypt-find-model "encrypt") (autoload 'encrypt-insert-file-contents "encrypt")) (defalias 'netrc-point-at-eol (if (fboundp 'point-at-eol) 'point-at-eol 'line-end-position)) (eval-when-compile (defvar encrypt-file-alist) ;; This is unnecessary in the compiled version as it is a macro. (if (fboundp 'bound-and-true-p) (defalias 'netrc-bound-and-true-p 'bound-and-true-p) (defmacro netrc-bound-and-true-p (var) "Return the value of symbol VAR if it is bound, else nil." `(and (boundp (quote ,var)) ,var)))) (defgroup netrc nil "Netrc configuration." :group 'comm) (defvar netrc-services-file "/etc/services" "The name of the services file.") (defun netrc-parse (file) (interactive "fFile to Parse: ") "Parse FILE and return a list of all entries in the file." (when (file-exists-p file) (with-temp-buffer (let ((tokens '("machine" "default" "login" "password" "account" "macdef" "force" "port")) (encryption-model (when (netrc-bound-and-true-p encrypt-file-alist) (encrypt-find-model file))) alist elem result pair) (if encryption-model (encrypt-insert-file-contents file encryption-model) (insert-file-contents file)) (goto-char (point-min)) ;; Go through the file, line by line. (while (not (eobp)) (narrow-to-region (point) (point-at-eol)) ;; For each line, get the tokens and values. (while (not (eobp)) (skip-chars-forward "\t ") ;; Skip lines that begin with a "#". (if (eq (char-after) ?#) (goto-char (point-max)) (unless (eobp) (setq elem (if (= (following-char) ?\") (read (current-buffer)) (buffer-substring (point) (progn (skip-chars-forward "^\t ") (point))))) (cond ((equal elem "macdef") ;; We skip past the macro definition. (widen) (while (and (zerop (forward-line 1)) (looking-at "$"))) (narrow-to-region (point) (point))) ((member elem tokens) ;; Tokens that don't have a following value are ignored, ;; except "default". (when (and pair (or (cdr pair) (equal (car pair) "default"))) (push pair alist)) (setq pair (list elem))) (t ;; Values that haven't got a preceding token are ignored. (when pair (setcdr pair elem) (push pair alist) (setq pair nil))))))) (when alist (push (nreverse alist) result)) (setq alist nil pair nil) (widen) (forward-line 1)) (nreverse result))))) (defun netrc-machine (list machine &optional port defaultport) "Return the netrc values from LIST for MACHINE or for the default entry. If PORT specified, only return entries with matching port tokens. Entries without port tokens default to DEFAULTPORT." (let ((rest list) result) (while list (when (equal (cdr (assoc "machine" (car list))) machine) (push (car list) result)) (pop list)) (unless result ;; No machine name matches, so we look for default entries. (while rest (when (assoc "default" (car rest)) (push (car rest) result)) (pop rest))) (when result (setq result (nreverse result)) (while (and result (not (netrc-port-equal (or port defaultport "nntp") (or (netrc-get (car result) "port") defaultport "nntp")))) (pop result)) (car result)))) (defun netrc-machine-user-or-password (mode authinfo-file-or-list machines ports defaults) "Get the user name or password according to MODE from AUTHINFO-FILE-OR-LIST. Matches a machine from MACHINES and a port from PORTS, giving default ports DEFAULTS to `netrc-machine'. MODE can be \"login\" or \"password\", suitable for passing to `netrc-get'." (let ((authinfo-list (if (stringp authinfo-file-or-list) (netrc-parse authinfo-file-or-list) authinfo-file-or-list)) (ports (or ports '(nil))) (defaults (or defaults '(nil))) info) (dolist (machine machines) (dolist (default defaults) (dolist (port ports) (let ((alist (netrc-machine authinfo-list machine port default))) (setq info (or (netrc-get alist mode) info)))))) info)) (defun netrc-get (alist type) "Return the value of token TYPE from ALIST." (cdr (assoc type alist))) (defun netrc-port-equal (port1 port2) (when (numberp port1) (setq port1 (or (netrc-find-service-name port1) port1))) (when (numberp port2) (setq port2 (or (netrc-find-service-name port2) port2))) (equal port1 port2)) (defun netrc-parse-services () (when (file-exists-p netrc-services-file) (let ((services nil)) (with-temp-buffer (insert-file-contents netrc-services-file) (while (search-forward "#" nil t) (delete-region (1- (point)) (point-at-eol))) (goto-char (point-min)) (while (re-search-forward "^ *\\([^ \n\t]+\\)[ \t]+\\([0-9]+\\)/\\([^ \t\n]+\\)" nil t) (push (list (match-string 1) (string-to-number (match-string 2)) (intern (downcase (match-string 3)))) services)) (nreverse services))))) (defun netrc-find-service-name (number &optional type) (let ((services (netrc-parse-services)) service) (setq type (or type 'tcp)) (while (and (setq service (pop services)) (not (and (= number (cadr service)) (eq type (car (cddr service))))))) (car service))) (defun netrc-find-service-number (name &optional type) (let ((services (netrc-parse-services)) service) (setq type (or type 'tcp)) (while (and (setq service (pop services)) (not (and (string= name (car service)) (eq type (car (cddr service))))))) (cadr service))) (provide 'netrc) ;; arch-tag: af9929cc-2d12-482f-936e-eb4366f9fa55 ;;; netrc.el ends here gnus-5.11+v0.10.dfsg/lisp/password-cache.el0000644000175000017500000001100111004005111020440 0ustar tvainikatvainika;;; password-cache.el --- Read passwords, possibly using a password cache. ;; Copyright (C) 1999, 2000, 2003, 2004, 2005, 2006, 2007, 2008 ;; Free Software Foundation, Inc. ;; Author: Simon Josefsson ;; Created: 2003-12-21 ;; Keywords: password cache passphrase key ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 3, or (at your option) ;; any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Commentary: ;; Greatly influenced by pgg.el written by Daiki Ueno, with timer ;; fixes for XEmacs by Katsumi Yamaoka. In fact, this is mostly just ;; a rip-off. ;; ;; (password-read "Password? " "test") ;; ;; Minibuffer prompt for password. ;; => "foo" ;; ;; (password-cache-add "test" "foo") ;; => nil ;; (password-read "Password? " "test") ;; ;; No minibuffer prompt ;; => "foo" ;; ;; (password-read "Password? " "test") ;; ;; No minibuffer prompt ;; => "foo" ;; ;; ;; Wait `password-cache-expiry' seconds. ;; ;; (password-read "Password? " "test") ;; ;; Minibuffer prompt for password is back. ;; => "foo" ;;; Code: (defcustom password-cache t "Whether to cache passwords." :group 'password :type 'boolean) (defcustom password-cache-expiry 16 "How many seconds passwords are cached, or nil to disable expiring. Whether passwords are cached at all is controlled by `password-cache'." :group 'password :type '(choice (const :tag "Never" nil) (integer :tag "Seconds"))) (defvar password-data (make-vector 7 0)) (defun password-read-from-cache (key) "Obtain passphrase for KEY from time-limited passphrase cache. Custom variables `password-cache' and `password-cache-expiry' regulate cache behavior." (and password-cache key (symbol-value (intern-soft key password-data)))) (defun password-read (prompt &optional key) "Read password, for use with KEY, from user, or from cache if wanted. KEY indicate the purpose of the password, so the cache can separate passwords. The cache is not used if KEY is nil. It is typically a string. The variable `password-cache' control whether the cache is used." (or (password-read-from-cache key) (read-passwd prompt))) (defun password-read-and-add (prompt &optional key) "Read password, for use with KEY, from user, or from cache if wanted. Then store the password in the cache. Uses `password-read' and `password-cache-add'. Custom variables `password-cache' and `password-cache-expiry' regulate cache behavior. Warning: the password is cached without checking that it is correct. It is better to check the password before caching. If you must use this function, take care to check passwords and remove incorrect ones from the cache." (let ((password (password-read prompt key))) (when (and password key) (password-cache-add key password)) password)) (make-obsolete 'password-read-and-add 'password-read "23.1") (defun password-cache-remove (key) "Remove password indexed by KEY from password cache. This is typically run be a timer setup from `password-cache-add', but can be invoked at any time to forcefully remove passwords from the cache. This may be useful when it has been detected that a password is invalid, so that `password-read' query the user again." (let ((password (symbol-value (intern-soft key password-data)))) (when password (if (fboundp 'clear-string) (clear-string password) (fillarray password ?_)) (unintern key password-data)))) (defun password-cache-add (key password) "Add password to cache. The password is removed by a timer after `password-cache-expiry' seconds." (when (and password-cache-expiry (null (intern-soft key password-data))) (run-at-time password-cache-expiry nil #'password-cache-remove key)) (set (intern key password-data) password) nil) (defun password-reset () "Clear the password cache." (interactive) (fillarray password-data 0)) (provide 'password-cache) ;; arch-tag: ab160494-16c8-4c68-a4a1-73eebf6686e5 ;;; password-cache.el ends here gnus-5.11+v0.10.dfsg/lisp/sasl.el0000644000175000017500000002056711004005110016517 0ustar tvainikatvainika;;; sasl.el --- SASL client framework ;; Copyright (C) 2000, 2007, 2008 Free Software Foundation, Inc. ;; Author: Daiki Ueno ;; Keywords: SASL ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 3, or (at your option) ;; any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Commentary: ;; This module provides common interface functions to share several ;; SASL mechanism drivers. The toplevel is designed to be mostly ;; compatible with [Java-SASL]. ;; ;; [SASL] J. Myers, "Simple Authentication and Security Layer (SASL)", ;; RFC 2222, October 1997. ;; ;; [Java-SASL] R. Weltman & R. Lee, "The Java SASL Application Program ;; Interface", draft-weltman-java-sasl-03.txt, March 2000. ;;; Code: (defvar sasl-mechanisms '("CRAM-MD5" "DIGEST-MD5" "PLAIN" "LOGIN" "ANONYMOUS" "NTLM" "SCRAM-MD5")) (defvar sasl-mechanism-alist '(("CRAM-MD5" sasl-cram) ("DIGEST-MD5" sasl-digest) ("PLAIN" sasl-plain) ("LOGIN" sasl-login) ("ANONYMOUS" sasl-anonymous) ("NTLM" sasl-ntlm) ("SCRAM-MD5" sasl-scram))) (defvar sasl-unique-id-function #'sasl-unique-id-function) (put 'sasl-error 'error-message "SASL error") (put 'sasl-error 'error-conditions '(sasl-error error)) (defun sasl-error (datum) (signal 'sasl-error (list datum))) ;;; @ SASL client ;;; (defun sasl-make-client (mechanism name service server) "Return a newly allocated SASL client. NAME is name of the authorization. SERVICE is name of the service desired. SERVER is the fully qualified host name of the server to authenticate to." (vector mechanism name service server (make-symbol "sasl-client-properties"))) (defun sasl-client-mechanism (client) "Return the authentication mechanism driver of CLIENT." (aref client 0)) (defun sasl-client-name (client) "Return the authorization name of CLIENT, a string." (aref client 1)) (defun sasl-client-service (client) "Return the service name of CLIENT, a string." (aref client 2)) (defun sasl-client-server (client) "Return the server name of CLIENT, a string." (aref client 3)) (defun sasl-client-set-properties (client plist) "Destructively set the properties of CLIENT. The second argument PLIST is the new property list." (setplist (aref client 4) plist)) (defun sasl-client-set-property (client property value) "Add the given property/value to CLIENT." (put (aref client 4) property value)) (defun sasl-client-property (client property) "Return the value of the PROPERTY of CLIENT." (get (aref client 4) property)) (defun sasl-client-properties (client) "Return the properties of CLIENT." (symbol-plist (aref client 4))) ;;; @ SASL mechanism ;;; (defun sasl-make-mechanism (name steps) "Make an authentication mechanism. NAME is a IANA registered SASL mechanism name. STEPS is list of continuation function." (vector name (mapcar (lambda (step) (let ((symbol (make-symbol (symbol-name step)))) (fset symbol (symbol-function step)) symbol)) steps))) (defun sasl-mechanism-name (mechanism) "Return name of MECHANISM, a string." (aref mechanism 0)) (defun sasl-mechanism-steps (mechanism) "Return the authentication steps of MECHANISM, a list of functions." (aref mechanism 1)) (defun sasl-find-mechanism (mechanisms) "Retrieve an apropriate mechanism object from MECHANISMS hints." (let* ((sasl-mechanisms sasl-mechanisms) (mechanism (catch 'done (while sasl-mechanisms (if (member (car sasl-mechanisms) mechanisms) (throw 'done (nth 1 (assoc (car sasl-mechanisms) sasl-mechanism-alist)))) (setq sasl-mechanisms (cdr sasl-mechanisms)))))) (if mechanism (require mechanism)) (get mechanism 'sasl-mechanism))) ;;; @ SASL authentication step ;;; (defun sasl-step-data (step) "Return the data which STEP holds, a string." (aref step 1)) (defun sasl-step-set-data (step data) "Store DATA string to STEP." (aset step 1 data)) (defun sasl-next-step (client step) "Evaluate the challenge and prepare an appropriate next response. The data type of the value and optional 2nd argument STEP is nil or opaque authentication step which holds the reference to the next action and the current challenge. At the first time STEP should be set to nil." (let* ((steps (sasl-mechanism-steps (sasl-client-mechanism client))) (function (if (vectorp step) (nth 1 (memq (aref step 0) steps)) (car steps)))) (if function (vector function (funcall function client step))))) (defvar sasl-read-passphrase nil) (defun sasl-read-passphrase (prompt) (if (not sasl-read-passphrase) (if (functionp 'read-passwd) (setq sasl-read-passphrase 'read-passwd) (if (load "passwd" t) (setq sasl-read-passphrase 'read-passwd) (autoload 'ange-ftp-read-passwd "ange-ftp") (setq sasl-read-passphrase 'ange-ftp-read-passwd)))) (funcall sasl-read-passphrase prompt)) (defun sasl-unique-id () "Compute a data string which must be different each time. It contain at least 64 bits of entropy." (concat (funcall sasl-unique-id-function)(funcall sasl-unique-id-function))) (defvar sasl-unique-id-char nil) ;; stolen (and renamed) from message.el (defun sasl-unique-id-function () ;; Don't use microseconds from (current-time), they may be unsupported. ;; Instead we use this randomly inited counter. (setq sasl-unique-id-char (% (1+ (or sasl-unique-id-char (logand (random t) (1- (lsh 1 20))))) ;; (current-time) returns 16-bit ints, ;; and 2^16*25 just fits into 4 digits i base 36. (* 25 25))) (let ((tm (current-time))) (concat (sasl-unique-id-number-base36 (+ (car tm) (lsh (% sasl-unique-id-char 25) 16)) 4) (sasl-unique-id-number-base36 (+ (nth 1 tm) (lsh (/ sasl-unique-id-char 25) 16)) 4)))) (defun sasl-unique-id-number-base36 (num len) (if (if (< len 0) (<= num 0) (= len 0)) "" (concat (sasl-unique-id-number-base36 (/ num 36) (1- len)) (char-to-string (aref "zyxwvutsrqponmlkjihgfedcba9876543210" (% num 36)))))) ;;; PLAIN (RFC2595 Section 6) (defconst sasl-plain-steps '(sasl-plain-response)) (defun sasl-plain-response (client step) (let ((passphrase (sasl-read-passphrase (format "PLAIN passphrase for %s: " (sasl-client-name client)))) (authenticator-name (sasl-client-property client 'authenticator-name)) (name (sasl-client-name client))) (unwind-protect (if (and authenticator-name (not (string= authenticator-name name))) (concat authenticator-name "\0" name "\0" passphrase) (concat "\0" name "\0" passphrase)) (fillarray passphrase 0)))) (put 'sasl-plain 'sasl-mechanism (sasl-make-mechanism "PLAIN" sasl-plain-steps)) (provide 'sasl-plain) ;;; LOGIN (No specification exists) (defconst sasl-login-steps '(ignore ;no initial response sasl-login-response-1 sasl-login-response-2)) (defun sasl-login-response-1 (client step) ;;; (unless (string-match "^Username:" (sasl-step-data step)) ;;; (sasl-error (format "Unexpected response: %s" (sasl-step-data step)))) (sasl-client-name client)) (defun sasl-login-response-2 (client step) ;;; (unless (string-match "^Password:" (sasl-step-data step)) ;;; (sasl-error (format "Unexpected response: %s" (sasl-step-data step)))) (sasl-read-passphrase (format "LOGIN passphrase for %s: " (sasl-client-name client)))) (put 'sasl-login 'sasl-mechanism (sasl-make-mechanism "LOGIN" sasl-login-steps)) (provide 'sasl-login) ;;; ANONYMOUS (RFC2245) (defconst sasl-anonymous-steps '(ignore ;no initial response sasl-anonymous-response)) (defun sasl-anonymous-response (client step) (or (sasl-client-property client 'trace) (sasl-client-name client))) (put 'sasl-anonymous 'sasl-mechanism (sasl-make-mechanism "ANONYMOUS" sasl-anonymous-steps)) (provide 'sasl-anonymous) (provide 'sasl) ;; arch-tag: 8b3326fa-4978-4fda-93e2-cb2c6255f887 ;;; sasl.el ends here gnus-5.11+v0.10.dfsg/lisp/dgnushack.el0000644000175000017500000004556210767343124017557 0ustar tvainikatvainika;;; dgnushack.el --- a hack to set the load path for byte-compiling ;; Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2003, ;; 2004, 2005, 2006, 2007, 2008 ;; Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; Version: 4.19 ;; Keywords: news, path ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 3, or (at your option) ;; any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Commentary: ;;; Code: (defvar dgnushack-default-load-path (copy-sequence load-path)) (defalias 'facep 'ignore) (require 'cl) (defvar srcdir (or (getenv "srcdir") ".")) (defvar loaddir (and load-file-name (file-name-directory load-file-name))) (defun my-getenv (str) (let ((val (getenv str))) (if (equal val "no") nil val))) (if (my-getenv "lispdir") (push (my-getenv "lispdir") load-path)) (push (or (my-getenv "URLDIR") (expand-file-name "../../url/lisp/" loaddir)) load-path) (push (or (my-getenv "W3DIR") (expand-file-name "../../w3/lisp/" loaddir)) load-path) ;(push "/usr/share/emacs/site-lisp" load-path) ;; If we are building w3 in a different directory than the source ;; directory, we must read *.el from source directory and write *.elc ;; into the building directory. For that, we define this function ;; before loading bytecomp. Bytecomp doesn't overwrite this function. (defun byte-compile-dest-file (filename) "Convert an Emacs Lisp source file name to a compiled file name. In addition, remove directory name part from FILENAME." (setq filename (byte-compiler-base-file-name filename)) (setq filename (file-name-sans-versions filename)) (setq filename (file-name-nondirectory filename)) (if (memq system-type '(win32 w32 mswindows windows-nt)) (setq filename (downcase filename))) (cond ((eq system-type 'vax-vms) (concat (substring filename 0 (string-match ";" filename)) "c")) ((string-match emacs-lisp-file-regexp filename) (concat (substring filename 0 (match-beginning 0)) ".elc")) (t (concat filename ".elc")))) (require 'bytecomp) ;; To avoid having defsubsts and inlines happen. ;(if (featurep 'xemacs) ; (require 'byte-optimize) ; (require 'byte-opt)) ;(defun byte-optimize-inline-handler (form) ; "byte-optimize-handler for the `inline' special-form." ; (cons 'progn (cdr form))) ;(defalias 'byte-compile-file-form-defsubst 'byte-compile-file-form-defun) (when (and (not (featurep 'xemacs)) (= emacs-major-version 21) (>= emacs-minor-version 3) (condition-case code (let ((byte-compile-error-on-warn t)) (byte-optimize-form (quote (pop x)) t) nil) (error (string-match "called for effect" (error-message-string code))))) (defadvice byte-optimize-form-code-walker (around silence-warn-for-pop (form for-effect) activate) "Silence the warning \"...called for effect\" for the `pop' form. It is effective only when the `pop' macro is defined by cl.el rather than subr.el." (let (tmp) (if (and (eq (car-safe form) 'car) for-effect (setq tmp (get 'car 'side-effect-free)) (not byte-compile-delete-errors) (not (eq tmp 'error-free)) (eq (car-safe (cadr form)) 'prog1) (let ((var (cadr (cadr form))) (last (nth 2 (cadr form)))) (and (symbolp var) (null (nthcdr 3 (cadr form))) (eq (car-safe last) 'setq) (eq (cadr last) var) (eq (car-safe (nth 2 last)) 'cdr) (eq (cadr (nth 2 last)) var)))) (progn (put 'car 'side-effect-free 'error-free) (unwind-protect ad-do-it (put 'car 'side-effect-free tmp))) ad-do-it)))) (when (and (not (featurep 'xemacs)) (byte-optimize-form '(and (> 0 1) (message "This should not appear in the byte-code.")) t)) (defadvice byte-optimize-form-code-walker (around fix-bug-in-and/or-forms (form for-effect) activate) "Optimize the rest of the and/or forms. It has been fixed in XEmacs before releasing 21.4 and also has been fixed in Emacs 22." (if (and for-effect (memq (car-safe form) '(and or))) (let ((fn (car form)) (backwards (reverse (cdr form)))) (while (and backwards (null (setcar backwards (byte-optimize-form (car backwards) t)))) (setq backwards (cdr backwards))) (if (and (cdr form) (null backwards)) (byte-compile-log " all subforms of %s called for effect; deleted" form)) (when backwards (setcdr backwards (mapcar 'byte-optimize-form (cdr backwards)))) (setq ad-return-value (cons fn (nreverse backwards)))) ad-do-it))) ;; Work around for an incompatibility (XEmacs 21.4 vs. 21.5), see the ;; following threads: ;; ;; http://thread.gmane.org/gmane.emacs.gnus.general/56414 ;; Subject: attachment problems found but not fixed ;; ;; http://thread.gmane.org/gmane.emacs.gnus.general/56459 ;; Subject: Splitting mail -- XEmacs 21.4 vs 21.5 ;; ;; http://thread.gmane.org/gmane.emacs.xemacs.beta/20519 ;; Subject: XEmacs 21.5 and Gnus fancy splitting. ;; ;; Should be fixed in XEmacs (March 2007). ;; http://thread.gmane.org/gmane.emacs.xemacs.patches/8124 ;; When should we remove this workaround? ;; (when (and (featurep 'xemacs) (let ((table (copy-syntax-table emacs-lisp-mode-syntax-table))) (modify-syntax-entry ?= " " table) (with-temp-buffer (with-syntax-table table (insert "foo=bar") (goto-char (point-min)) (forward-sexp 1) (eolp))))) ;; The original `with-syntax-table' uses `copy-syntax-table' which ;; doesn't seem to copy modified syntax entries in XEmacs 21.5. (defmacro with-syntax-table (syntab &rest body) "Evaluate BODY with the SYNTAB as the current syntax table." `(let ((stab (syntax-table))) (unwind-protect (progn ;;(set-syntax-table (copy-syntax-table ,syntab)) (set-syntax-table ,syntab) ,@body) (set-syntax-table stab))))) (push srcdir load-path) (push loaddir load-path) (load (expand-file-name "lpath.el" loaddir) nil t) (defalias 'device-sound-enabled-p 'ignore) (defalias 'play-sound-file 'ignore) (defalias 'nndb-request-article 'ignore) (defalias 'efs-re-read-dir 'ignore) (defalias 'ange-ftp-re-read-dir 'ignore) (defalias 'define-mail-user-agent 'ignore) (eval-and-compile (unless (featurep 'xemacs) (defalias 'get-popup-menu-response 'ignore) (defalias 'event-object 'ignore) (defalias 'x-defined-colors 'ignore) (defalias 'read-color 'ignore))) (eval-and-compile (when (featurep 'xemacs) (unless (fboundp 'defadvice) (autoload 'defadvice "advice" nil nil 'macro)) (autoload 'Info-directory "info" nil t) (autoload 'Info-index "info" nil t) (autoload 'Info-index-next "info" nil t) (autoload 'Info-menu "info" nil t) (autoload 'ad-add-advice "advice") (autoload 'annotations-at "annotations") (autoload 'apropos "apropos" nil t) (autoload 'apropos-command "apropos" nil t) (autoload 'bbdb-complete-name "bbdb-com" nil t) (autoload 'browse-url "browse-url" nil t) (autoload 'browse-url-of-file "browse-url" nil t) (autoload 'c-mode "cc-mode" nil t) (autoload 'customize-apropos "cus-edit" nil t) (autoload 'customize-group "cus-edit" nil t) (autoload 'customize-save-variable "cus-edit" nil t) (autoload 'customize-set-variable "cus-edit" nil t) (autoload 'customize-variable "cus-edit" nil t) (if (featurep 'mule) (unless (locate-library "mule-ccl") (autoload 'define-ccl-program "ccl" nil nil 'macro)) (defalias 'define-ccl-program 'ignore)) (autoload 'delete-annotation "annotations") (autoload 'dolist "cl-macs" nil nil 'macro) (autoload 'enriched-decode "enriched") (autoload 'executable-find "executable") (autoload 'font-lock-fontify-buffer "font-lock" nil t) (autoload 'info "info" nil t) (autoload 'mail-extract-address-components "mail-extr") (autoload 'mail-fetch-field "mail-utils") (autoload 'make-annotation "annotations") (autoload 'make-display-table "disp-table") (autoload 'pp "pp") (autoload 'ps-despool "ps-print" nil t) (autoload 'ps-spool-buffer "ps-print" nil t) (autoload 'ps-spool-buffer-with-faces "ps-print" nil t) (autoload 'read-passwd "passwd") (autoload 'regexp-opt "regexp-opt") (autoload 'reporter-submit-bug-report "reporter") (if (and (emacs-version>= 21 5) (not (featurep 'sxemacs))) (autoload 'setenv "process" nil t) (autoload 'setenv "env" nil t)) (autoload 'sgml-mode "psgml" nil t) (autoload 'smtpmail-send-it "smtpmail") (autoload 'sort-numeric-fields "sort" nil t) (autoload 'sort-subr "sort") (autoload 'toggle-truncate-lines "view-less" nil t) (autoload 'trace-function-background "trace" nil t) (autoload 'unmorse-region "morse" nil t) (autoload 'w3-do-setup "w3") (autoload 'w3-prepare-buffer "w3-display") (autoload 'w3-region "w3-display" nil t) (defalias 'frame-char-height 'frame-height) (defalias 'frame-char-width 'frame-width) (defalias 'frame-parameter 'frame-property) (defalias 'make-overlay 'ignore) (defalias 'overlay-end 'ignore) (defalias 'overlay-get 'ignore) (defalias 'overlay-put 'ignore) (defalias 'overlay-start 'ignore) (defalias 'overlays-in 'ignore) (defalias 'replace-dehighlight 'ignore) (defalias 'replace-highlight 'ignore) (defalias 'w3-coding-system-for-mime-charset 'ignore))) (defun dgnushack-emacs-compile-defcustom-p () "Return non-nil if Emacs byte compiles `defcustom' forms. Those Emacsen will warn against undefined variables and functions used in `defcustom' forms." (let ((outbuf (with-temp-buffer (insert "(defcustom foo (1+ (random)) \"\" :group 'emacs)\n") (byte-compile-from-buffer (current-buffer) "foo.el")))) (when outbuf (prog1 (with-current-buffer outbuf (goto-char (point-min)) (search-forward " 'foo '(byte-code " nil t)) (kill-buffer outbuf))))) (when (dgnushack-emacs-compile-defcustom-p) (maybe-fbind '(defined-colors face-attribute)) (maybe-bind '(idna-program installation-directory))) (defun dgnushack-compile-verbosely () "Call dgnushack-compile with warnings ENABLED. If you are compiling patches to gnus, you should consider modifying make.bat to call dgnushack-compile-verbosely. All other users should continue to use dgnushack-compile." (dgnushack-compile t)) (defun dgnushack-compile (&optional warn) ;;(setq byte-compile-dynamic t) (unless warn (setq byte-compile-warnings '(free-vars unresolved callargs redefine))) (let ((files (directory-files srcdir nil "^[^=].*\\.el$")) ;;(byte-compile-generate-call-tree t) file elc) ;; Avoid barfing (from gnus-xmas) because the etc directory is not yet ;; installed. (when (featurep 'xemacs) (setq gnus-xmas-glyph-directory "dummy")) (dolist (file '("dgnushack.el" "lpath.el")) (setq files (delete file files))) (when (featurep 'base64) (setq files (delete "base64.el" files))) (condition-case code (require 'w3-parse) (error (message "No w3: %s %s" (cadr code) (or (locate-library "w3-parse") "")) (dolist (file '("nnultimate.el" "webmail.el" "nnwfm.el")) (setq files (delete file files))))) (condition-case code (require 'mh-e) (error (message "No mh-e: %s %s" (cadr code) (or (locate-library "mh-e") "")) (setq files (delete "gnus-mh.el" files)))) (condition-case code (require 'xml) (error (message "No xml: %s %s" (cadr code) (or (locate-library "xml") "")) (setq files (delete "nnrss.el" files)))) (dolist (file (if (featurep 'xemacs) '("md5.el") '("gnus-xmas.el" "messagexmas.el" "nnheaderxm.el"))) (setq files (delete file files))) (dolist (file files) (setq file (expand-file-name file srcdir)) (when (and (file-exists-p (setq elc (concat (file-name-nondirectory file) "c"))) (file-newer-than-file-p file elc)) (delete-file elc))) (while (setq file (pop files)) (setq file (expand-file-name file srcdir)) (when (or (not (file-exists-p (setq elc (concat (file-name-nondirectory file) "c")))) (file-newer-than-file-p file elc)) (ignore-errors (byte-compile-file file)))))) (defun dgnushack-recompile () (require 'gnus) (byte-recompile-directory "." 0)) (defvar dgnushack-gnus-load-file (if (featurep 'xemacs) (expand-file-name "auto-autoloads.el") (expand-file-name "gnus-load.el"))) (defvar dgnushack-cus-load-file (if (featurep 'xemacs) (expand-file-name "custom-load.el") (expand-file-name "cus-load.el"))) (defun dgnushack-make-cus-load () (load "cus-dep") (let ((cusload-base-file dgnushack-cus-load-file)) (if (fboundp 'custom-make-dependencies) (custom-make-dependencies) (Custom-make-dependencies)) (when (featurep 'xemacs) (message "Compiling %s..." dgnushack-cus-load-file) (byte-compile-file dgnushack-cus-load-file)))) (defun dgnushack-make-auto-load () (require 'autoload) (unless (make-autoload '(define-derived-mode child parent name "docstring" body) "file") (defadvice make-autoload (around handle-define-derived-mode activate) "Handle `define-derived-mode'." (if (eq (car-safe (ad-get-arg 0)) 'define-derived-mode) (setq ad-return-value (list 'autoload (list 'quote (nth 1 (ad-get-arg 0))) (ad-get-arg 1) (nth 4 (ad-get-arg 0)) t nil)) ad-do-it)) (put 'define-derived-mode 'doc-string-elt 3)) (let ((generated-autoload-file dgnushack-gnus-load-file) (make-backup-files nil) (autoload-package-name "gnus")) (if (featurep 'xemacs) (if (file-exists-p generated-autoload-file) (delete-file generated-autoload-file)) (with-temp-file generated-autoload-file (insert ?\014))) (batch-update-autoloads))) (defun dgnushack-make-load () (unless (featurep 'xemacs) (message "Generating %s..." dgnushack-gnus-load-file) (with-temp-file dgnushack-gnus-load-file (insert-file-contents dgnushack-cus-load-file) (delete-file dgnushack-cus-load-file) (goto-char (point-min)) (search-forward ";;; Code:") (forward-line) (delete-region (point-min) (point)) (insert "\ ;;; gnus-load.el --- automatically extracted custom dependencies and autoload ;; ;;; Code: ") (goto-char (point-max)) (if (search-backward "custom-versions-load-alist" nil t) (forward-line -1) (forward-line -1) (while (eq (char-after) ?\;) (forward-line -1)) (forward-line)) (delete-region (point) (point-max)) (insert "\n") ;; smiley-* are duplicated. Remove them all. (let ((point (point))) (insert-file-contents dgnushack-gnus-load-file) (goto-char point) (while (search-forward "smiley-" nil t) (beginning-of-line) (if (looking-at "(autoload ") (delete-region (point) (progn (forward-sexp) (point))) (forward-line)))) ;; (goto-char (point-max)) (when (search-backward "\n(provide " nil t) (forward-line -1) (delete-region (point) (point-max))) (insert "\ \(provide 'gnus-load) ;;; Local Variables: ;;; version-control: never ;;; no-byte-compile: t ;;; no-update-autoloads: t ;;; End: ;;; gnus-load.el ends here ") )) (message "Compiling %s..." dgnushack-gnus-load-file) (byte-compile-file dgnushack-gnus-load-file) (when (featurep 'xemacs) (message "Creating dummy gnus-load.el...") (with-temp-file (expand-file-name "gnus-load.el") (insert "\ \(provide 'gnus-load) ;;; Local Variables: ;;; version-control: never ;;; no-byte-compile: t ;;; no-update-autoloads: t ;;; End: ;;; gnus-load.el ends here")))) (defun dgnushack-find-lisp-shadows (&optional lispdir) "Return a list of directories in which other Gnus installations exist. This function looks for the other Gnus installations which will shadow the new Gnus Lisp modules which have been installed in LISPDIR, using the default `load-path'. The return value will make sense only when LISPDIR is existent and is listed in the default `load-path'. Assume LISPDIR will be prepended to `load-path' by a user if the default `load-path' does not contain it." (unless lispdir (setq lispdir (getenv "lispdir"))) (when (and lispdir (file-directory-p lispdir)) (setq lispdir (file-truename (directory-file-name lispdir))) (let ((indices '("gnus.elc" "gnus.el" "gnus.el.bz2" "gnus.el.gz" "message.elc" "message.el" "message.el.bz2" "message.el.gz")) (path (delq nil (mapcar (lambda (p) (condition-case nil (when (and p (file-directory-p p)) (file-truename (directory-file-name p))) (error nil))) dgnushack-default-load-path))) rest elcs) (while path (setq rest (cons (car path) rest) path (delete (car rest) (cdr path)))) (setq path (nreverse (cdr (member lispdir rest))) rest nil) (while path (setq elcs indices) (while elcs (when (file-exists-p (expand-file-name (pop elcs) (car path))) (setq rest (cons (car path) rest) elcs nil))) (setq path (cdr path))) (prog1 (setq path (nreverse rest)) (when path (let (print-level print-length) (princ (concat "\n\ WARNING: The other Gnus installation" (if (cdr path) "s have" " has") "\ been detected in:\n\n " (mapconcat 'identity path "\n ") "\n\n\ You will need to modify the run-time `load-path', remove them manually, or remove them using `make remove-installed-shadows'.\n\n")))))))) (defun dgnushack-remove-lisp-shadows (&optional lispdir) "Remove the other Gnus installations which shadow the recent one." (let ((path (with-temp-buffer (let ((standard-output (current-buffer))) (dgnushack-find-lisp-shadows lispdir)))) elcs files shadows file) (when path (unless (setq elcs (directory-files srcdir nil "\\.elc\\'")) (error "You should build .elc files first.")) (setq files (apply 'append (mapcar (lambda (el) (list (concat el "c") el (concat el ".bz2") (concat el ".gz"))) (append (list (file-name-nondirectory dgnushack-gnus-load-file) (file-name-nondirectory dgnushack-cus-load-file)) (mapcar (lambda (elc) (substring elc 0 -1)) elcs))))) (while path (setq shadows files) (while shadows (setq file (expand-file-name (pop shadows) (car path))) (when (file-exists-p file) (princ (concat " Removing " file "...")) (condition-case nil (progn (delete-file file) (princ "done\n")) (error (princ "failed\n"))))) (setq path (cdr path)))))) ;;; dgnushack.el ends here ;;; arch-tag: 579f585a-24eb-4e1c-8d34-4808e11b68f2 gnus-5.11+v0.10.dfsg/lisp/gnus-uu.el0000644000175000017500000022132111004005111017150 0ustar tvainikatvainika;;; gnus-uu.el --- extract (uu)encoded files in Gnus ;; Copyright (C) 1985, 1986, 1987, 1993, 1994, 1995, 1996, 1997, 1998, ;; 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; Created: 2 Oct 1993 ;; Keyword: news ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 3, or (at your option) ;; any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Commentary: ;;; Code: (eval-when-compile (require 'cl)) (require 'gnus) (require 'gnus-art) (require 'message) (require 'gnus-msg) (require 'mm-decode) (require 'yenc) (defgroup gnus-extract nil "Extracting encoded files." :prefix "gnus-uu-" :group 'gnus) (defgroup gnus-extract-view nil "Viewwing extracted files." :group 'gnus-extract) (defgroup gnus-extract-archive nil "Extracting encoded archives." :group 'gnus-extract) (defgroup gnus-extract-post nil "Extracting encoded archives." :prefix "gnus-uu-post" :group 'gnus-extract) ;; Default viewing action rules (defcustom gnus-uu-default-view-rules '(("\\.te?xt$\\|\\.doc$\\|read.*me\\|\\.c?$\\|\\.h$\\|\\.bat$\\|\\.asm$\\|makefile" "cat %s | sed 's/\r$//'") ("\\.pas$" "cat %s | sed 's/\r$//'") ("\\.[1-9]$" "groff -mandoc -Tascii %s | sed s/\b.//g") ("\\.\\(jpe?g\\|gif\\|tiff?\\|p[pgb]m\\|xwd\\|xbm\\|pcx\\)$" "display") ("\\.tga$" "tgatoppm %s | ee -") ("\\.\\(wav\\|aiff\\|hcom\\|u[blw]\\|s[bfw]\\|voc\\|smp\\)$" "sox -v .5 %s -t .au -u - > /dev/audio") ("\\.au$" "cat %s > /dev/audio") ("\\.midi?$" "playmidi -f") ("\\.mod$" "str32") ("\\.ps$" "ghostview") ("\\.dvi$" "xdvi") ("\\.html$" "xmosaic") ("\\.mpe?g$" "mpeg_play") ("\\.\\(flc\\|fli\\|rle\\|iff\\|pfx\\|avi\\|sme\\|rpza\\|dl\\|qt\\|rsrc\\|mov\\)$" "xanim") ("\\.\\(tar\\|arj\\|zip\\|zoo\\|arc\\|gz\\|Z\\|lzh\\|ar\\|lha\\)$" "gnus-uu-archive")) "*Default actions to be taken when the user asks to view a file. To change the behavior, you can either edit this variable or set `gnus-uu-user-view-rules' to something useful. For example: To make gnus-uu use 'xli' to display JPEG and GIF files, put the following in your .emacs file: (setq gnus-uu-user-view-rules '((\"jpg$\\\\|gif$\" \"xli\"))) Both these variables are lists of lists with two string elements. The first string is a regular expression. If the file name matches this regular expression, the command in the second string is executed with the file as an argument. If the command string contains \"%s\", the file name will be inserted at that point in the command string. If there's no \"%s\" in the command string, the file name will be appended to the command string before executing. There are several user variables to tailor the behavior of gnus-uu to your needs. First we have `gnus-uu-user-view-rules', which is the variable gnus-uu first consults when trying to decide how to view a file. If this variable contains no matches, gnus-uu examines the default rule variable provided in this package. If gnus-uu finds no match here, it uses `gnus-uu-user-view-rules-end' to try to make a match." :group 'gnus-extract-view :type '(repeat (group regexp (string :tag "Command")))) (defcustom gnus-uu-user-view-rules nil "What actions are to be taken to view a file. See the documentation on the `gnus-uu-default-view-rules' variable for details." :group 'gnus-extract-view :type '(repeat (group regexp (string :tag "Command")))) (defcustom gnus-uu-user-view-rules-end '(("" "file")) "*What actions are to be taken if no rule matched the file name. See the documentation on the `gnus-uu-default-view-rules' variable for details." :group 'gnus-extract-view :type '(repeat (group regexp (string :tag "Command")))) ;; Default unpacking commands (defcustom gnus-uu-default-archive-rules '(("\\.tar$" "tar xf") ("\\.zip$" "unzip -o") ("\\.ar$" "ar x") ("\\.arj$" "unarj x") ("\\.zoo$" "zoo -e") ("\\.\\(lzh\\|lha\\)$" "lha x") ("\\.Z$" "uncompress") ("\\.gz$" "gunzip") ("\\.arc$" "arc -x")) "*See `gnus-uu-user-archive-rules'." :group 'gnus-extract-archive :type '(repeat (group regexp (string :tag "Command")))) (defvar gnus-uu-destructive-archivers (list "uncompress" "gunzip")) (defcustom gnus-uu-user-archive-rules nil "A list that can be set to override the default archive unpacking commands. To use, for instance, 'untar' to unpack tar files and 'zip -x' to unpack zip files, say the following: (setq gnus-uu-user-archive-rules '((\"\\\\.tar$\" \"untar\") (\"\\\\.zip$\" \"zip -x\")))" :group 'gnus-extract-archive :type '(repeat (group regexp (string :tag "Command")))) (defcustom gnus-uu-ignore-files-by-name nil "*A regular expression saying what files should not be viewed based on name. If, for instance, you want gnus-uu to ignore all .au and .wav files, you could say something like (setq gnus-uu-ignore-files-by-name \"\\\\.au$\\\\|\\\\.wav$\") Note that this variable can be used in conjunction with the `gnus-uu-ignore-files-by-type' variable." :group 'gnus-extract :type '(choice (const :tag "off" nil) (regexp :format "%v"))) (defcustom gnus-uu-ignore-files-by-type nil "*A regular expression saying what files that shouldn't be viewed, based on MIME file type. If, for instance, you want gnus-uu to ignore all audio files and all mpegs, you could say something like (setq gnus-uu-ignore-files-by-type \"audio/\\\\|video/mpeg\") Note that this variable can be used in conjunction with the `gnus-uu-ignore-files-by-name' variable." :group 'gnus-extract :type '(choice (const :tag "off" nil) (regexp :format "%v"))) ;; Pseudo-MIME support (defconst gnus-uu-ext-to-mime-list '(("\\.gif$" "image/gif") ("\\.jpe?g$" "image/jpeg") ("\\.tiff?$" "image/tiff") ("\\.xwd$" "image/xwd") ("\\.pbm$" "image/pbm") ("\\.pgm$" "image/pgm") ("\\.ppm$" "image/ppm") ("\\.xbm$" "image/xbm") ("\\.pcx$" "image/pcx") ("\\.tga$" "image/tga") ("\\.ps$" "image/postscript") ("\\.fli$" "video/fli") ("\\.wav$" "audio/wav") ("\\.aiff$" "audio/aiff") ("\\.hcom$" "audio/hcom") ("\\.voc$" "audio/voc") ("\\.smp$" "audio/smp") ("\\.mod$" "audio/mod") ("\\.dvi$" "image/dvi") ("\\.mpe?g$" "video/mpeg") ("\\.au$" "audio/basic") ("\\.\\(te?xt\\|doc\\|c\\|h\\)$" "text/plain") ("\\.\\(c\\|h\\)$" "text/source") ("read.*me" "text/plain") ("\\.html$" "text/html") ("\\.bat$" "text/bat") ("\\.[1-6]$" "text/man") ("\\.flc$" "video/flc") ("\\.rle$" "video/rle") ("\\.pfx$" "video/pfx") ("\\.avi$" "video/avi") ("\\.sme$" "video/sme") ("\\.rpza$" "video/prza") ("\\.dl$" "video/dl") ("\\.qt$" "video/qt") ("\\.rsrc$" "video/rsrc") ("\\..*$" "unknown/unknown"))) ;; Various variables users may set (defcustom gnus-uu-tmp-dir (cond ((fboundp 'temp-directory) (temp-directory)) ((boundp 'temporary-file-directory) temporary-file-directory) ("/tmp/")) "*Variable saying where gnus-uu is to do its work. Default is \"/tmp/\"." :group 'gnus-extract :type 'directory) (defcustom gnus-uu-do-not-unpack-archives nil "*Non-nil means that gnus-uu won't peek inside archives looking for files to display. Default is nil." :group 'gnus-extract-archive :type 'boolean) (defcustom gnus-uu-ignore-default-view-rules nil "*Non-nil means that gnus-uu will ignore the default viewing rules. Only the user viewing rules will be consulted. Default is nil." :group 'gnus-extract-view :type 'boolean) (defcustom gnus-uu-grabbed-file-functions nil "Functions run on each file after successful decoding. They will be called with the name of the file as the argument. Likely functions you can use in this list are `gnus-uu-grab-view' and `gnus-uu-grab-move'." :group 'gnus-extract :options '(gnus-uu-grab-view gnus-uu-grab-move) :type 'hook) (defcustom gnus-uu-ignore-default-archive-rules nil "*Non-nil means that gnus-uu will ignore the default archive unpacking commands. Only the user unpacking commands will be consulted. Default is nil." :group 'gnus-extract-archive :type 'boolean) (defcustom gnus-uu-kill-carriage-return t "*Non-nil means that gnus-uu will strip all carriage returns from articles. Default is t." :group 'gnus-extract :type 'boolean) (defcustom gnus-uu-view-with-metamail nil "*Non-nil means that files will be viewed with metamail. The gnus-uu viewing functions will be ignored and gnus-uu will try to guess at a content-type based on file name suffixes. Default it nil." :group 'gnus-extract :type 'boolean) (defcustom gnus-uu-unmark-articles-not-decoded nil "*Non-nil means that gnus-uu will mark articles that were unsuccessfully decoded as unread. Default is nil." :group 'gnus-extract :type 'boolean) (defcustom gnus-uu-correct-stripped-uucode nil "*Non-nil means that gnus-uu will *try* to fix uuencoded files that have had trailing spaces deleted. Default is nil." :group 'gnus-extract :type 'boolean) (defcustom gnus-uu-save-in-digest nil "*Non-nil means that gnus-uu, when asked to save without decoding, will save in digests. If this variable is nil, gnus-uu will just save everything in a file without any embellishments. The digesting almost conforms to RFC1153 - no easy way to specify any meaningful volume and issue numbers were found, so I simply dropped them." :group 'gnus-extract :type 'boolean) (defcustom gnus-uu-pre-uudecode-hook nil "Hook run before sending a message to uudecode." :group 'gnus-extract :type 'hook) (defcustom gnus-uu-digest-headers '("^Date:" "^From:" "^To:" "^Cc:" "^Subject:" "^Message-ID:" "^Keywords:" "^Summary:" "^References:" "^Content-Type:" "^Content-Transfer-Encoding:" "^MIME-Version:" "^Content-Disposition:" "^Content-Description:" "^Content-ID:") "*List of regexps to match headers included in digested messages. The headers will be included in the sequence they are matched. If nil include all headers." :group 'gnus-extract :type '(repeat regexp)) (defcustom gnus-uu-save-separate-articles nil "*Non-nil means that gnus-uu will save articles in separate files." :group 'gnus-extract :type 'boolean) (defcustom gnus-uu-be-dangerous 'ask "*Specifies what to do if unusual situations arise during decoding. If nil, be as conservative as possible. If t, ignore things that didn't work, and overwrite existing files. Otherwise, ask each time." :group 'gnus-extract :type '(choice (const :tag "conservative" nil) (const :tag "ask" ask) (const :tag "liberal" t))) ;; Internal variables (defvar gnus-uu-saved-article-name nil) (defvar gnus-uu-begin-string "^begin[ \t]+0?[0-7][0-7][0-7][ \t]+\\(.*\\)$") (defvar gnus-uu-end-string "^end[ \t]*$") (defvar gnus-uu-body-line "^M") (let ((i 61)) (while (> (setq i (1- i)) 0) (setq gnus-uu-body-line (concat gnus-uu-body-line "[^a-z]"))) (setq gnus-uu-body-line (concat gnus-uu-body-line ".?$"))) ;"^M.............................................................?$" (defvar gnus-uu-shar-begin-string "^#! */bin/sh") (defvar gnus-uu-shar-file-name nil) (defvar gnus-uu-shar-name-marker "begin 0?[0-7][0-7][0-7][ \t]+\\(\\(\\w\\|[.\\:]\\)*\\b\\)") (defvar gnus-uu-postscript-begin-string "^%!PS-") (defvar gnus-uu-postscript-end-string "^%%EOF$") (defvar gnus-uu-file-name nil) (defvar gnus-uu-uudecode-process nil) (defvar gnus-uu-binhex-article-name nil) (defvar gnus-uu-yenc-article-name nil) (defvar gnus-uu-work-dir nil) (defvar gnus-uu-output-buffer-name " *Gnus UU Output*") (defvar gnus-uu-default-dir gnus-article-save-directory) (defvar gnus-uu-digest-from-subject nil) (defvar gnus-uu-digest-buffer nil) ;; Commands. (defun gnus-uu-decode-uu (&optional n) "Uudecodes the current article." (interactive "P") (gnus-uu-decode-with-method 'gnus-uu-uustrip-article n)) (defun gnus-uu-decode-uu-and-save (n dir) "Decodes and saves the resulting file." (interactive (list current-prefix-arg (file-name-as-directory (read-file-name "Uudecode and save in dir: " gnus-uu-default-dir gnus-uu-default-dir t)))) (gnus-uu-decode-with-method 'gnus-uu-uustrip-article n dir nil nil t)) (defun gnus-uu-decode-unshar (&optional n) "Unshars the current article." (interactive "P") (gnus-uu-decode-with-method 'gnus-uu-unshar-article n nil nil 'scan t)) (defun gnus-uu-decode-unshar-and-save (n dir) "Unshars and saves the current article." (interactive (list current-prefix-arg (file-name-as-directory (read-file-name "Unshar and save in dir: " gnus-uu-default-dir gnus-uu-default-dir t)))) (gnus-uu-decode-with-method 'gnus-uu-unshar-article n dir nil 'scan t)) (defun gnus-uu-decode-save (n file) "Saves the current article." (interactive (list current-prefix-arg (read-file-name (if gnus-uu-save-separate-articles "Save articles in dir: " "Save articles in file: ") gnus-uu-default-dir gnus-uu-default-dir))) (setq gnus-uu-saved-article-name file) (gnus-uu-decode-with-method 'gnus-uu-save-article n nil t)) (defun gnus-uu-decode-binhex (n dir) "Unbinhexes the current article." (interactive (list current-prefix-arg (file-name-as-directory (read-file-name "Unbinhex and save in dir: " gnus-uu-default-dir gnus-uu-default-dir)))) (setq gnus-uu-binhex-article-name (mm-make-temp-file (expand-file-name "binhex" gnus-uu-work-dir))) (gnus-uu-decode-with-method 'gnus-uu-binhex-article n dir)) (defun gnus-uu-decode-yenc (n dir) "Decode the yEnc-encoded current article." (interactive (list current-prefix-arg (file-name-as-directory (read-file-name "yEnc decode and save in dir: " gnus-uu-default-dir gnus-uu-default-dir)))) (setq gnus-uu-yenc-article-name nil) (gnus-uu-decode-with-method 'gnus-uu-yenc-article n dir nil t)) (defun gnus-uu-decode-uu-view (&optional n) "Uudecodes and views the current article." (interactive "P") (let ((gnus-view-pseudos (or gnus-view-pseudos 'automatic))) (gnus-uu-decode-uu n))) (defun gnus-uu-decode-uu-and-save-view (n dir) "Decodes, views and saves the resulting file." (interactive (list current-prefix-arg (read-file-name "Uudecode, view and save in dir: " gnus-uu-default-dir gnus-uu-default-dir t))) (let ((gnus-view-pseudos (or gnus-view-pseudos 'automatic))) (gnus-uu-decode-uu-and-save n dir))) (defun gnus-uu-decode-unshar-view (&optional n) "Unshars and views the current article." (interactive "P") (let ((gnus-view-pseudos (or gnus-view-pseudos 'automatic))) (gnus-uu-decode-unshar n))) (defun gnus-uu-decode-unshar-and-save-view (n dir) "Unshars and saves the current article." (interactive (list current-prefix-arg (read-file-name "Unshar, view and save in dir: " gnus-uu-default-dir gnus-uu-default-dir t))) (let ((gnus-view-pseudos (or gnus-view-pseudos 'automatic))) (gnus-uu-decode-unshar-and-save n dir))) (defun gnus-uu-decode-save-view (n file) "Saves and views the current article." (interactive (list current-prefix-arg (read-file-name (if gnus-uu-save-separate-articles "Save articles is dir: " "Save articles in file: ") gnus-uu-default-dir gnus-uu-default-dir))) (let ((gnus-view-pseudos (or gnus-view-pseudos 'automatic))) (gnus-uu-decode-save n file))) (defun gnus-uu-decode-binhex-view (n file) "Unbinhexes and views the current article." (interactive (list current-prefix-arg (read-file-name "Unbinhex, view and save in dir: " gnus-uu-default-dir gnus-uu-default-dir))) (setq gnus-uu-binhex-article-name (mm-make-temp-file (expand-file-name "binhex" gnus-uu-work-dir))) (let ((gnus-view-pseudos (or gnus-view-pseudos 'automatic))) (gnus-uu-decode-binhex n file))) ;; Digest and forward articles (defun gnus-uu-digest-mail-forward (&optional n post) "Digests and forwards all articles in this series." (interactive "P") (let ((gnus-uu-save-in-digest t) (file (mm-make-temp-file (nnheader-concat gnus-uu-tmp-dir "forward"))) (message-forward-as-mime message-forward-as-mime) (mail-parse-charset gnus-newsgroup-charset) (mail-parse-ignored-charsets gnus-newsgroup-ignored-charsets) gnus-uu-digest-buffer subject from) (if (and n (not (numberp n))) (setq message-forward-as-mime (not message-forward-as-mime) n nil)) (let ((gnus-article-reply (gnus-summary-work-articles n))) (when (and (not n) (= (length gnus-article-reply) 1)) ;; The case where neither a number of articles nor a region is ;; specified. (gnus-summary-top-thread) (setq gnus-article-reply (nreverse (gnus-uu-find-articles-matching)))) (gnus-setup-message 'forward (setq gnus-uu-digest-from-subject nil) (setq gnus-uu-digest-buffer (gnus-get-buffer-create " *gnus-uu-forward*")) ;; Specify articles to be forwarded. Note that they should be ;; reversed; see `gnus-uu-get-list-of-articles'. (let ((gnus-newsgroup-processable (reverse gnus-article-reply))) (gnus-uu-decode-save n file) (setq gnus-article-reply gnus-newsgroup-processable)) ;; Restore the value of `gnus-newsgroup-processable' to which ;; it should be set when it is not `let'-bound. (setq gnus-newsgroup-processable (reverse gnus-article-reply)) (switch-to-buffer gnus-uu-digest-buffer) (let ((fs gnus-uu-digest-from-subject)) (when fs (setq from (caar fs) subject (gnus-simplify-subject-fuzzy (cdar fs)) fs (cdr fs)) (while (and fs (or from subject)) (when from (unless (string= from (caar fs)) (setq from nil))) (when subject (unless (string= (gnus-simplify-subject-fuzzy (cdar fs)) subject) (setq subject nil))) (setq fs (cdr fs)))) (unless subject (setq subject "Digested Articles")) (unless from (setq from (if (gnus-news-group-p gnus-newsgroup-name) gnus-newsgroup-name "Various")))) (goto-char (point-min)) (when (re-search-forward "^Subject: ") (delete-region (point) (point-at-eol)) (insert subject)) (goto-char (point-min)) (when (re-search-forward "^From:") (delete-region (point) (point-at-eol)) (insert " " from)) (let ((message-forward-decoded-p t)) (message-forward post t)))) (setq gnus-uu-digest-from-subject nil))) (defun gnus-uu-digest-post-forward (&optional n) "Digest and forward to a newsgroup." (interactive "P") (gnus-uu-digest-mail-forward n t)) ;; Process marking. (defun gnus-message-process-mark (unmarkp new-marked) (let ((old (- (length gnus-newsgroup-processable) (length new-marked)))) (gnus-message 6 "%d mark%s %s%s" (length new-marked) (if (= (length new-marked) 1) "" "s") (if unmarkp "removed" "added") (cond ((and (zerop old) (not unmarkp)) "") (unmarkp (format ", %d remain marked" (length gnus-newsgroup-processable))) (t (format ", %d already marked" old)))))) (defun gnus-new-processable (unmarkp articles) (if unmarkp (gnus-intersection gnus-newsgroup-processable articles) (gnus-set-difference articles gnus-newsgroup-processable))) (defun gnus-uu-mark-by-regexp (regexp &optional unmark) "Set the process mark on articles whose subjects match REGEXP. When called interactively, prompt for REGEXP. Optional UNMARK non-nil means unmark instead of mark." (interactive "sMark (regexp): \nP") (save-excursion (let* ((articles (gnus-uu-find-articles-matching regexp)) (new-marked (gnus-new-processable unmark articles))) (while articles (if unmark (gnus-summary-remove-process-mark (pop articles)) (gnus-summary-set-process-mark (pop articles)))) (gnus-message-process-mark unmark new-marked))) (gnus-summary-position-point)) (defun gnus-uu-unmark-by-regexp (regexp) "Remove the process mark from articles whose subjects match REGEXP. When called interactively, prompt for REGEXP." (interactive "sUnmark (regexp): ") (gnus-uu-mark-by-regexp regexp t)) (defun gnus-uu-mark-series (&optional silent) "Mark the current series with the process mark." (interactive) (let* ((articles (gnus-uu-find-articles-matching)) (l (length articles))) (while articles (gnus-summary-set-process-mark (car articles)) (setq articles (cdr articles))) (unless silent (gnus-message 6 "Marked %d articles" l)) (gnus-summary-position-point) l)) (defun gnus-uu-mark-region (beg end &optional unmark) "Set the process mark on all articles between point and mark." (interactive "r") (save-excursion (goto-char beg) (while (< (point) end) (if unmark (gnus-summary-remove-process-mark (gnus-summary-article-number)) (gnus-summary-set-process-mark (gnus-summary-article-number))) (forward-line 1))) (gnus-summary-position-point)) (defun gnus-uu-unmark-region (beg end) "Remove the process mark from all articles between point and mark." (interactive "r") (gnus-uu-mark-region beg end t)) (defun gnus-uu-mark-buffer () "Set the process mark on all articles in the buffer." (interactive) (gnus-uu-mark-region (point-min) (point-max))) (defun gnus-uu-unmark-buffer () "Remove the process mark on all articles in the buffer." (interactive) (gnus-uu-mark-region (point-min) (point-max) t)) (defun gnus-uu-mark-thread () "Marks all articles downwards in this thread." (interactive) (gnus-save-hidden-threads (let ((level (gnus-summary-thread-level))) (while (and (gnus-summary-set-process-mark (gnus-summary-article-number)) (zerop (gnus-summary-next-subject 1 nil t)) (> (gnus-summary-thread-level) level))))) (gnus-summary-position-point)) (defun gnus-uu-unmark-thread () "Unmarks all articles downwards in this thread." (interactive) (let ((level (gnus-summary-thread-level))) (while (and (gnus-summary-remove-process-mark (gnus-summary-article-number)) (zerop (gnus-summary-next-subject 1)) (> (gnus-summary-thread-level) level)))) (gnus-summary-position-point)) (defun gnus-uu-invert-processable () "Invert the list of process-marked articles." (interactive) (let ((data gnus-newsgroup-data) number) (save-excursion (while data (if (memq (setq number (gnus-data-number (pop data))) gnus-newsgroup-processable) (gnus-summary-remove-process-mark number) (gnus-summary-set-process-mark number))))) (gnus-summary-position-point)) (defun gnus-uu-mark-over (&optional score) "Mark all articles with a score over SCORE (the prefix)." (interactive "P") (let ((score (or score gnus-summary-default-score 0)) (data gnus-newsgroup-data)) (save-excursion (while data (when (> (or (cdr (assq (gnus-data-number (car data)) gnus-newsgroup-scored)) gnus-summary-default-score 0) score) (gnus-summary-set-process-mark (caar data))) (setq data (cdr data)))) (gnus-summary-position-point))) (defun gnus-uu-mark-sparse () "Mark all series that have some articles marked." (interactive) (let ((marked (nreverse gnus-newsgroup-processable)) subject articles total headers) (unless marked (error "No articles marked with the process mark")) (setq gnus-newsgroup-processable nil) (save-excursion (while marked (and (vectorp (setq headers (gnus-summary-article-header (car marked)))) (setq subject (mail-header-subject headers) articles (gnus-uu-find-articles-matching (gnus-uu-reginize-string subject)) total (nconc total articles))) (while articles (gnus-summary-set-process-mark (car articles)) (setcdr marked (delq (car articles) (cdr marked))) (setq articles (cdr articles))) (setq marked (cdr marked))) (setq gnus-newsgroup-processable (nreverse total))) (gnus-summary-position-point))) (defun gnus-uu-mark-all () "Mark all articles in \"series\" order." (interactive) (setq gnus-newsgroup-processable nil) (save-excursion (let ((data gnus-newsgroup-data) (count 0) number) (while data (when (and (not (memq (setq number (gnus-data-number (car data))) gnus-newsgroup-processable)) (vectorp (gnus-data-header (car data)))) (gnus-summary-goto-subject number) (setq count (+ count (gnus-uu-mark-series t)))) (setq data (cdr data))) (gnus-message 6 "Marked %d articles" count))) (gnus-summary-position-point)) ;; All PostScript functions written by Erik Selberg . (defun gnus-uu-decode-postscript (&optional n) "Gets postscript of the current article." (interactive "P") (gnus-uu-decode-with-method 'gnus-uu-decode-postscript-article n)) (defun gnus-uu-decode-postscript-view (&optional n) "Gets and views the current article." (interactive "P") (let ((gnus-view-pseudos (or gnus-view-pseudos 'automatic))) (gnus-uu-decode-postscript n))) (defun gnus-uu-decode-postscript-and-save (n dir) "Extracts postscript and saves the current article." (interactive (list current-prefix-arg (file-name-as-directory (read-file-name "Save in dir: " gnus-uu-default-dir gnus-uu-default-dir t)))) (gnus-uu-decode-with-method 'gnus-uu-decode-postscript-article n dir nil nil t)) (defun gnus-uu-decode-postscript-and-save-view (n dir) "Decodes, views and saves the resulting file." (interactive (list current-prefix-arg (read-file-name "Where do you want to save the file(s)? " gnus-uu-default-dir gnus-uu-default-dir t))) (let ((gnus-view-pseudos (or gnus-view-pseudos 'automatic))) (gnus-uu-decode-postscript-and-save n dir))) ;; Internal functions. (defun gnus-uu-decode-with-method (method n &optional save not-insert scan cdir) (gnus-uu-initialize scan) (when save (setq gnus-uu-default-dir save)) ;; Create the directory we save to. (when (and scan cdir save (not (file-exists-p save))) (make-directory save t)) (let ((articles (gnus-uu-get-list-of-articles n)) files) (setq files (gnus-uu-grab-articles articles method t)) (let ((gnus-current-article (car articles))) (when scan (setq files (gnus-uu-scan-directory gnus-uu-work-dir)))) (when save (gnus-uu-save-files files save)) (when (eq gnus-uu-do-not-unpack-archives nil) (setq files (gnus-uu-unpack-files files))) (setq files (nreverse (gnus-uu-get-actions files))) (or not-insert (not gnus-insert-pseudo-articles) (gnus-summary-insert-pseudos files save)))) (defun gnus-uu-scan-directory (dir &optional rec) "Return a list of all files under DIR." (let ((files (directory-files dir t)) out file) (while (setq file (pop files)) (unless (member (file-name-nondirectory file) '("." "..")) (push (list (cons 'name file) (cons 'article gnus-current-article)) out) (when (file-directory-p file) (setq out (nconc (gnus-uu-scan-directory file t) out))))) (if rec out (nreverse out)))) (defun gnus-uu-save-files (files dir) "Save FILES in DIR." (let ((len (length files)) (reg (concat "^" (regexp-quote gnus-uu-work-dir))) to-file file fromdir) (while (setq file (cdr (assq 'name (pop files)))) (when (file-exists-p file) (string-match reg file) (setq fromdir (substring file (match-end 0))) (if (file-directory-p file) (gnus-make-directory (concat dir fromdir)) (setq to-file (concat dir fromdir)) (when (or (not (file-exists-p to-file)) (eq gnus-uu-be-dangerous t) (and gnus-uu-be-dangerous (gnus-y-or-n-p (format "%s exists; overwrite? " to-file)))) (copy-file file to-file t t))))) (gnus-message 5 "Saved %d file%s" len (if (= len 1) "" "s")))) ;; Functions for saving and possibly digesting articles without ;; any decoding. ;; Function called by gnus-uu-grab-articles to treat each article. (defun gnus-uu-save-article (buffer in-state) (cond (gnus-uu-save-separate-articles (save-excursion (set-buffer buffer) (let ((coding-system-for-write mm-text-coding-system)) (gnus-write-buffer (concat gnus-uu-saved-article-name gnus-current-article))) (cond ((eq in-state 'first) (list gnus-uu-saved-article-name 'begin)) ((eq in-state 'first-and-last) (list gnus-uu-saved-article-name 'begin 'end)) ((eq in-state 'last) (list 'end)) (t (list 'middle))))) ((not gnus-uu-save-in-digest) (save-excursion (set-buffer buffer) (write-region (point-min) (point-max) gnus-uu-saved-article-name t) (cond ((eq in-state 'first) (list gnus-uu-saved-article-name 'begin)) ((eq in-state 'first-and-last) (list gnus-uu-saved-article-name 'begin 'end)) ((eq in-state 'last) (list 'end)) (t (list 'middle))))) (t (let ((header (gnus-summary-article-header))) (push (cons (mail-header-from header) (mail-header-subject header)) gnus-uu-digest-from-subject)) (let ((name (file-name-nondirectory gnus-uu-saved-article-name)) beg subj headers headline sorthead body end-string state) (if (or (eq in-state 'first) (eq in-state 'first-and-last)) (progn (setq state (list 'begin)) (save-excursion (set-buffer (gnus-get-buffer-create "*gnus-uu-body*")) (erase-buffer)) (save-excursion (set-buffer (gnus-get-buffer-create "*gnus-uu-pre*")) (erase-buffer) (insert (format "Date: %s\nFrom: %s\nSubject: %s Digest\n\n" (message-make-date) name name)) (when (and message-forward-as-mime gnus-uu-digest-buffer) (insert "<#mml type=message/rfc822>\nSubject: Topics\n\n<#/mml>\n") (forward-line -1)) (insert "Topics:\n"))) (when (not (eq in-state 'end)) (setq state (list 'middle)))) (save-excursion (set-buffer "*gnus-uu-body*") (goto-char (setq beg (point-max))) (save-excursion (save-restriction (set-buffer buffer) (let (buffer-read-only) (set-text-properties (point-min) (point-max) nil) ;; These two are necessary for XEmacs 19.12 fascism. (put-text-property (point-min) (point-max) 'invisible nil) (put-text-property (point-min) (point-max) 'intangible nil)) (when (and message-forward-as-mime message-forward-show-mml gnus-uu-digest-buffer) (mm-enable-multibyte) (mime-to-mml)) (goto-char (point-min)) (search-forward "\n\n") (unless (and message-forward-as-mime gnus-uu-digest-buffer) ;; Quote all 30-dash lines. (save-excursion (while (re-search-forward "^-" nil t) (beginning-of-line) (delete-char 1) (insert "- ")))) (setq body (buffer-substring (1- (point)) (point-max))) (narrow-to-region (point-min) (point)) (if (not (setq headers gnus-uu-digest-headers)) (setq sorthead (buffer-string)) (while headers (setq headline (car headers)) (setq headers (cdr headers)) (goto-char (point-min)) (while (re-search-forward headline nil t) (setq sorthead (concat sorthead (buffer-substring (match-beginning 0) (or (and (re-search-forward "^[^ \t]" nil t) (1- (point))) (progn (forward-line 1) (point))))))))) (widen))) (if (and message-forward-as-mime gnus-uu-digest-buffer) (if message-forward-show-mml (progn (insert "\n<#mml type=message/rfc822>\n") (insert sorthead) (goto-char (point-max)) (insert body) (goto-char (point-max)) (insert "\n<#/mml>\n")) (let ((buf (mml-generate-new-buffer " *mml*"))) (with-current-buffer buf (insert sorthead) (goto-char (point-min)) (when (re-search-forward "^Subject: \\(.*\\)$" nil t) (setq subj (buffer-substring (match-beginning 1) (match-end 1)))) (goto-char (point-max)) (insert body)) (insert "\n<#part type=message/rfc822" " buffer=\"" (buffer-name buf) "\">\n"))) (insert sorthead) (goto-char (point-max)) (insert body) (goto-char (point-max)) (insert (concat "\n" (make-string 30 ?-) "\n\n"))) (goto-char beg) (when (re-search-forward "^Subject: \\(.*\\)$" nil t) (setq subj (buffer-substring (match-beginning 1) (match-end 1)))) (when subj (save-excursion (set-buffer "*gnus-uu-pre*") (insert (format " %s\n" subj))))) (when (or (eq in-state 'last) (eq in-state 'first-and-last)) (if (and message-forward-as-mime gnus-uu-digest-buffer) (with-current-buffer gnus-uu-digest-buffer (erase-buffer) (insert-buffer-substring "*gnus-uu-pre*") (goto-char (point-max)) (insert-buffer-substring "*gnus-uu-body*")) (save-excursion (set-buffer "*gnus-uu-pre*") (insert (format "\n\n%s\n\n" (make-string 70 ?-))) (if gnus-uu-digest-buffer (with-current-buffer gnus-uu-digest-buffer (erase-buffer) (insert-buffer-substring "*gnus-uu-pre*")) (let ((coding-system-for-write mm-text-coding-system)) (gnus-write-buffer gnus-uu-saved-article-name)))) (save-excursion (set-buffer "*gnus-uu-body*") (goto-char (point-max)) (insert (concat (setq end-string (format "End of %s Digest" name)) "\n")) (insert (concat (make-string (length end-string) ?*) "\n")) (if gnus-uu-digest-buffer (with-current-buffer gnus-uu-digest-buffer (goto-char (point-max)) (insert-buffer-substring "*gnus-uu-body*")) (let ((coding-system-for-write mm-text-coding-system) (file-name-coding-system nnmail-pathname-coding-system)) (write-region (point-min) (point-max) gnus-uu-saved-article-name t))))) (gnus-kill-buffer "*gnus-uu-pre*") (gnus-kill-buffer "*gnus-uu-body*") (push 'end state)) (if (memq 'begin state) (cons gnus-uu-saved-article-name state) state))))) ;; Binhex treatment - not very advanced. (defvar gnus-uu-binhex-body-line "^[^:]...............................................................$") (defvar gnus-uu-binhex-begin-line "^:...............................................................$") (defvar gnus-uu-binhex-end-line ":$") (defun gnus-uu-binhex-article (buffer in-state) (let (state start-char) (save-excursion (set-buffer buffer) (widen) (goto-char (point-min)) (when (not (re-search-forward gnus-uu-binhex-begin-line nil t)) (when (not (re-search-forward gnus-uu-binhex-body-line nil t)) (setq state (list 'wrong-type)))) (if (memq 'wrong-type state) () (beginning-of-line) (setq start-char (point)) (if (looking-at gnus-uu-binhex-begin-line) (progn (setq state (list 'begin)) (write-region (point-min) (point-min) gnus-uu-binhex-article-name)) (setq state (list 'middle))) (goto-char (point-max)) (re-search-backward (concat gnus-uu-binhex-body-line "\\|" gnus-uu-binhex-end-line) nil t) (when (looking-at gnus-uu-binhex-end-line) (setq state (if (memq 'begin state) (cons 'end state) (list 'end)))) (beginning-of-line) (forward-line 1) (when (file-exists-p gnus-uu-binhex-article-name) (mm-append-to-file start-char (point) gnus-uu-binhex-article-name)))) (if (memq 'begin state) (cons gnus-uu-binhex-article-name state) state))) ;; yEnc (defun gnus-uu-yenc-article (buffer in-state) (save-excursion (set-buffer gnus-original-article-buffer) (widen) (let ((file-name (yenc-extract-filename)) state start-char) (when (not file-name) (setq state (list 'wrong-type))) (if (memq 'wrong-type state) () (when (yenc-first-part-p) (setq gnus-uu-yenc-article-name (expand-file-name file-name gnus-uu-work-dir)) (push 'begin state)) (when (yenc-last-part-p) (push 'end state)) (unless state (push 'middle state)) (mm-with-unibyte-buffer (insert-buffer-substring gnus-original-article-buffer) (yenc-decode-region (point-min) (point-max)) (when (and (member 'begin state) (file-exists-p gnus-uu-yenc-article-name)) (delete-file gnus-uu-yenc-article-name)) (mm-append-to-file (point-min) (point-max) gnus-uu-yenc-article-name))) (if (memq 'begin state) (cons file-name state) state)))) ;; PostScript (defun gnus-uu-decode-postscript-article (process-buffer in-state) (let ((state (list 'ok)) start-char end-char file-name) (save-excursion (set-buffer process-buffer) (goto-char (point-min)) (if (not (re-search-forward gnus-uu-postscript-begin-string nil t)) (setq state (list 'wrong-type)) (beginning-of-line) (setq start-char (point)) (if (not (re-search-forward gnus-uu-postscript-end-string nil t)) (setq state (list 'wrong-type)) (setq end-char (point)) (set-buffer (gnus-get-buffer-create gnus-uu-output-buffer-name)) (insert-buffer-substring process-buffer start-char end-char) (setq file-name (concat gnus-uu-work-dir (cdr gnus-article-current) ".ps")) (write-region (point-min) (point-max) file-name) (setq state (list file-name 'begin 'end))))) state)) ;; Find actions. (defun gnus-uu-get-actions (files) (let ((ofiles files) action name) (while files (setq name (cdr (assq 'name (car files)))) (and (setq action (gnus-uu-get-action name)) (setcar files (nconc (list (if (string= action "gnus-uu-archive") (cons 'action "file") (cons 'action action)) (cons 'execute (gnus-uu-command action name))) (car files)))) (setq files (cdr files))) ofiles)) (defun gnus-uu-get-action (file-name) (let (action) (setq action (gnus-uu-choose-action file-name (append gnus-uu-user-view-rules (if gnus-uu-ignore-default-view-rules nil gnus-uu-default-view-rules) gnus-uu-user-view-rules-end))) (when (and (not (string= (or action "") "gnus-uu-archive")) gnus-uu-view-with-metamail) (when (setq action (gnus-uu-choose-action file-name gnus-uu-ext-to-mime-list)) (setq action (format "metamail -d -b -c \"%s\"" action)))) action)) ;; Functions for treating subjects and collecting series. (defun gnus-uu-reginize-string (string) ;; Takes a string and puts a \ in front of every special character; ;; replaces the last thing that looks like "2/3" with "[0-9]+/3" ;; or, if it can't find something like that, tries "2 of 3", then ;; finally just replaces the next to last number with "[0-9]+". (save-excursion (set-buffer (gnus-get-buffer-create gnus-uu-output-buffer-name)) (buffer-disable-undo) (erase-buffer) (insert (regexp-quote string)) (setq case-fold-search nil) (end-of-line) (if (re-search-backward "\\([^0-9]\\)[0-9]+/\\([0-9]+\\)" nil t) (replace-match "\\1[0-9]+/\\2") (end-of-line) (if (re-search-backward "\\([^0-9]\\)[0-9]+[ \t]*of[ \t]*\\([0-9]+\\)" nil t) (replace-match "\\1[0-9]+ of \\2") (end-of-line) (if (re-search-backward "\\([^0-9]\\)[0-9]+\\([^0-9]+\\)[0-9]+" nil t) (replace-match "\\1[0-9]+\\2[0-9]+" t nil nil nil)))) (goto-char (point-min)) (while (re-search-forward "[ \t]+" nil t) (replace-match "[ \t]+" t t)) (buffer-string))) (defun gnus-uu-get-list-of-articles (n) ;; If N is non-nil, the article numbers of the N next articles ;; will be returned. ;; If any articles have been marked as processable, they will be ;; returned. ;; Failing that, articles that have subjects that are part of the ;; same "series" as the current will be returned. (let (articles) (cond (n (setq n (prefix-numeric-value n)) (let ((backward (< n 0)) (n (abs n))) (save-excursion (while (and (> n 0) (push (gnus-summary-article-number) articles) (gnus-summary-search-forward nil nil backward)) (setq n (1- n)))) (nreverse articles))) (gnus-newsgroup-processable (reverse gnus-newsgroup-processable)) (t (gnus-uu-find-articles-matching))))) (defun gnus-uu-string< (l1 l2) (string< (car l1) (car l2))) (defun gnus-uu-find-articles-matching (&optional subject only-unread do-not-translate) ;; Finds all articles that matches the regexp SUBJECT. If it is ;; nil, the current article name will be used. If ONLY-UNREAD is ;; non-nil, only unread articles are chosen. If DO-NOT-TRANSLATE is ;; non-nil, article names are not equalized before sorting. (let ((subject (or subject (gnus-uu-reginize-string (gnus-summary-article-subject)))) list-of-subjects) (save-excursion (when subject ;; Collect all subjects matching subject. (let ((case-fold-search t) (data gnus-newsgroup-data) subj mark d) (while data (setq d (pop data)) (and (not (gnus-data-pseudo-p d)) (or (not only-unread) (= (setq mark (gnus-data-mark d)) gnus-unread-mark) (= mark gnus-ticked-mark) (= mark gnus-dormant-mark)) (setq subj (mail-header-subject (gnus-data-header d))) (string-match subject subj) (push (cons subj (gnus-data-number d)) list-of-subjects)))) ;; Expand numbers, sort, and return the list of article ;; numbers. (mapcar 'cdr (sort (gnus-uu-expand-numbers list-of-subjects (not do-not-translate)) 'gnus-uu-string<)))))) (defun gnus-uu-expand-numbers (string-list &optional translate) ;; Takes a list of strings and "expands" all numbers in all the ;; strings. That is, this function makes all numbers equal length by ;; prepending lots of zeroes before each number. This is to ease later ;; sorting to find out what sequence the articles are supposed to be ;; decoded in. Returns the list of expanded strings. (let ((out-list string-list) string) (save-excursion (set-buffer (gnus-get-buffer-create gnus-uu-output-buffer-name)) (buffer-disable-undo) (while string-list (erase-buffer) (insert (caar string-list)) ;; Translate multiple spaces to one space. (goto-char (point-min)) (while (re-search-forward "[ \t]+" nil t) (replace-match " ")) ;; Translate all characters to "a". (goto-char (point-min)) (when translate (while (re-search-forward "[A-Za-z]" nil t) (replace-match "a" t t))) ;; Expand numbers. (goto-char (point-min)) (while (re-search-forward "[0-9]+" nil t) (ignore-errors (replace-match (format "%06d" (string-to-number (buffer-substring (match-beginning 0) (match-end 0))))))) (setq string (buffer-substring (point-min) (point-max))) (setcar (car string-list) string) (setq string-list (cdr string-list)))) out-list)) ;; `gnus-uu-grab-articles' is the general multi-article treatment ;; function. It takes a list of articles to be grabbed and a function ;; to apply to each article. ;; ;; The function to be called should take two parameters. The first ;; parameter is the article buffer. The function should leave the ;; result, if any, in this buffer. Most treatment functions will just ;; generate files... ;; ;; The second parameter is the state of the list of articles, and can ;; have four values: `first', `middle', `last' and `first-and-last'. ;; ;; The function should return a list. The list may contain the ;; following symbols: ;; `error' if an error occurred ;; `begin' if the beginning of an encoded file has been received ;; If the list returned contains a `begin', the first element of ;; the list *must* be a string with the file name of the decoded ;; file. ;; `end' if the end of an encoded file has been received ;; `middle' if the article was a body part of an encoded file ;; `wrong-type' if the article was not a part of an encoded file ;; `ok', which can be used everything is ok (defvar gnus-uu-has-been-grabbed nil) (defun gnus-uu-unmark-list-of-grabbed (&optional dont-unmark-last-article) (let (art) (if (not (and gnus-uu-has-been-grabbed gnus-uu-unmark-articles-not-decoded)) () (when dont-unmark-last-article (setq art (car gnus-uu-has-been-grabbed)) (setq gnus-uu-has-been-grabbed (cdr gnus-uu-has-been-grabbed))) (while gnus-uu-has-been-grabbed (gnus-summary-tick-article (car gnus-uu-has-been-grabbed) t) (setq gnus-uu-has-been-grabbed (cdr gnus-uu-has-been-grabbed))) (when dont-unmark-last-article (setq gnus-uu-has-been-grabbed (list art)))))) ;; This function takes a list of articles and a function to apply to ;; each article grabbed. ;; ;; This function returns a list of files decoded if the grabbing and ;; the process-function has been successful and nil otherwise. (defun gnus-uu-grab-articles (articles process-function &optional sloppy limit no-errors) (let ((state 'first) (gnus-asynchronous nil) (gnus-inhibit-treatment t) has-been-begin article result-file result-files process-state gnus-summary-display-article-function gnus-article-prepare-hook gnus-display-mime-function article-series files) (while (and articles (not (memq 'error process-state)) (or sloppy (not (memq 'end process-state)))) (setq article (pop articles)) (when (vectorp (gnus-summary-article-header article)) (push article article-series) (unless articles (if (eq state 'first) (setq state 'first-and-last) (setq state 'last))) (let ((part (gnus-uu-part-number article))) (gnus-message 6 "Getting article %d%s..." article (if (string= part "") "" (concat ", " part)))) (gnus-summary-display-article article) ;; Push the article to the processing function. (save-excursion (set-buffer gnus-original-article-buffer) (let ((buffer-read-only nil)) (save-excursion (set-buffer gnus-summary-buffer) (setq process-state (funcall process-function gnus-original-article-buffer state))))) (gnus-summary-remove-process-mark article) ;; If this is the beginning of a decoded file, we push it ;; on to a list. (when (or (memq 'begin process-state) (and (or (eq state 'first) (eq state 'first-and-last)) (memq 'ok process-state))) (when has-been-begin ;; If there is a `result-file' here, that means that the ;; file was unsuccessfully decoded, so we delete it. (when (and result-file (file-exists-p result-file) (not gnus-uu-be-dangerous) (or (eq gnus-uu-be-dangerous t) (gnus-y-or-n-p (format "Delete unsuccessfully decoded file %s? " result-file)))) (delete-file result-file))) (when (memq 'begin process-state) (setq result-file (car process-state))) (setq has-been-begin t)) ;; Check whether we have decoded one complete file. (when (memq 'end process-state) (setq article-series nil) (setq has-been-begin nil) (if (stringp result-file) (setq files (list result-file)) (setq files result-file)) (setq result-file (car files)) (while files (push (list (cons 'name (pop files)) (cons 'article article)) result-files)) ;; Allow user-defined functions to be run on this file. (when gnus-uu-grabbed-file-functions (let ((funcs gnus-uu-grabbed-file-functions)) (unless (listp funcs) (setq funcs (list funcs))) (while funcs (funcall (pop funcs) result-file)))) (setq result-file nil) ;; Check whether we have decoded enough articles. (and limit (= (length result-files) limit) (setq articles nil))) ;; If this is the last article to be decoded, and ;; we still haven't reached the end, then we delete ;; the partially decoded file. (and (or (eq state 'last) (eq state 'first-and-last)) (not (memq 'end process-state)) result-file (file-exists-p result-file) (not gnus-uu-be-dangerous) (or (eq gnus-uu-be-dangerous t) (gnus-y-or-n-p (format "Delete incomplete file %s? " result-file))) (delete-file result-file)) ;; If this was a file of the wrong sort, then (when (and (or (memq 'wrong-type process-state) (memq 'error process-state)) gnus-uu-unmark-articles-not-decoded) (gnus-summary-tick-article article t)) ;; Set the new series state. (if (and (not has-been-begin) (not sloppy) (or (memq 'end process-state) (memq 'middle process-state))) (progn (setq process-state (list 'error)) (gnus-message 2 "No begin part at the beginning") (sleep-for 2)) (setq state 'middle)))) ;; When there are no result-files, then something must be wrong. (if result-files (message "") (cond ((not has-been-begin) (gnus-message 2 "Wrong type file")) ((memq 'error process-state) (gnus-message 2 "An error occurred during decoding")) ((not (or (memq 'ok process-state) (memq 'end process-state))) (gnus-message 2 "End of articles reached before end of file"))) ;; Make unsuccessfully decoded articles unread. (when gnus-uu-unmark-articles-not-decoded (while article-series (gnus-summary-tick-article (pop article-series) t)))) ;; The original article buffer is hosed, shoot it down. (gnus-kill-buffer gnus-original-article-buffer) (setq gnus-current-article nil) result-files)) (defun gnus-uu-grab-view (file) "View FILE using the gnus-uu methods." (let ((action (gnus-uu-get-action file))) (gnus-execute-command (if (string-match "%" action) (format action file) (concat action " " file)) (eq gnus-view-pseudos 'not-confirm)))) (defun gnus-uu-grab-move (file) "Move FILE to somewhere." (when gnus-uu-default-dir (let ((to-file (concat (file-name-as-directory gnus-uu-default-dir) (file-name-nondirectory file)))) (rename-file file to-file) (unless (file-exists-p file) (make-symbolic-link to-file file))))) (defun gnus-uu-part-number (article) (let* ((header (gnus-summary-article-header article)) (subject (and header (mail-header-subject header))) (part nil)) (if subject (while (string-match "[0-9]+/[0-9]+\\|[0-9]+[ \t]+of[ \t]+[0-9]+" subject) (setq part (match-string 0 subject)) (setq subject (substring subject (match-end 0))))) (or part (while (string-match "[0-9]+[^0-9]+[0-9]+" subject) (setq part (match-string 0 subject)) (setq subject (substring subject (match-end 0))))) (or part ""))) (defun gnus-uu-uudecode-sentinel (process event) (delete-process (get-process process))) (defun gnus-uu-uustrip-article (process-buffer in-state) ;; Uudecodes a file asynchronously. (save-excursion (set-buffer process-buffer) (let ((state (list 'wrong-type)) process-connection-type case-fold-search buffer-read-only files start-char) (goto-char (point-min)) ;; Deal with ^M at the end of the lines. (when gnus-uu-kill-carriage-return (save-excursion (while (search-forward "\r" nil t) (delete-backward-char 1)))) (while (or (re-search-forward gnus-uu-begin-string nil t) (re-search-forward gnus-uu-body-line nil t)) (setq state (list 'ok)) ;; Ok, we are at the first uucoded line. (beginning-of-line) (setq start-char (point)) (if (not (looking-at gnus-uu-begin-string)) (setq state (list 'middle)) ;; This is the beginning of a uuencoded article. ;; We replace certain characters that could make things messy. (setq gnus-uu-file-name (gnus-map-function mm-file-name-rewrite-functions (file-name-nondirectory (match-string 1)))) (replace-match (concat "begin 644 " gnus-uu-file-name) t t) ;; Remove any non gnus-uu-body-line right after start. (forward-line 1) (while (and (not (eobp)) (not (looking-at gnus-uu-body-line))) (gnus-delete-line)) ;; If a process is running, we kill it. (when (and gnus-uu-uudecode-process (memq (process-status gnus-uu-uudecode-process) '(run stop))) (delete-process gnus-uu-uudecode-process) (gnus-uu-unmark-list-of-grabbed t)) ;; Start a new uudecoding process. (let ((cdir default-directory)) (unwind-protect (progn (cd gnus-uu-work-dir) (setq gnus-uu-uudecode-process (start-process "*uudecode*" (gnus-get-buffer-create gnus-uu-output-buffer-name) shell-file-name shell-command-switch (format "cd %s %s uudecode" gnus-uu-work-dir gnus-shell-command-separator)))) (cd cdir))) (set-process-sentinel gnus-uu-uudecode-process 'gnus-uu-uudecode-sentinel) (setq state (list 'begin)) (push (concat gnus-uu-work-dir gnus-uu-file-name) files)) ;; We look for the end of the thing to be decoded. (if (re-search-forward gnus-uu-end-string nil t) (push 'end state) (goto-char (point-max)) (re-search-backward gnus-uu-body-line nil t)) (forward-line 1) (when gnus-uu-uudecode-process (when (memq (process-status gnus-uu-uudecode-process) '(run stop)) ;; Try to correct mishandled uucode. (when gnus-uu-correct-stripped-uucode (gnus-uu-check-correct-stripped-uucode start-char (point))) (gnus-run-hooks 'gnus-uu-pre-uudecode-hook) ;; Send the text to the process. (condition-case nil (process-send-region gnus-uu-uudecode-process start-char (point)) (error (progn (delete-process gnus-uu-uudecode-process) (gnus-message 2 "gnus-uu: Couldn't uudecode") (setq state (list 'wrong-type))))) (if (memq 'end state) (progn ;; Send an EOF, just in case. (ignore-errors (process-send-eof gnus-uu-uudecode-process)) (while (memq (process-status gnus-uu-uudecode-process) '(open run)) (accept-process-output gnus-uu-uudecode-process 1))) (when (or (not gnus-uu-uudecode-process) (not (memq (process-status gnus-uu-uudecode-process) '(run stop)))) (setq state (list 'wrong-type))))))) (if (memq 'begin state) (cons (if (= (length files) 1) (car files) files) state) state)))) (defvar gnus-uu-unshar-warning "*** WARNING *** Shell archives are an archaic method of bundling files for distribution across computer networks. During the unpacking process, arbitrary commands are executed on your system, and all kinds of nasty things can happen. Please examine the archive very carefully before you instruct Emacs to unpack it. You can browse the archive buffer using \\[scroll-other-window]. If you are unsure what to do, please answer \"no\"." "Text of warning message displayed by `gnus-uu-unshar-article'. Make sure that this text consists only of few text lines. Otherwise, Gnus might fail to display all of it.") ;; This function is used by `gnus-uu-grab-articles' to treat ;; a shared article. (defun gnus-uu-unshar-article (process-buffer in-state) (let ((state (list 'ok)) start-char) (save-excursion (set-buffer process-buffer) (goto-char (point-min)) (if (not (re-search-forward gnus-uu-shar-begin-string nil t)) (setq state (list 'wrong-type)) (save-window-excursion (save-excursion (switch-to-buffer (current-buffer)) (delete-other-windows) (let ((buffer (get-buffer-create (generate-new-buffer-name "*Warning*")))) (unless (unwind-protect (with-current-buffer buffer (insert (substitute-command-keys gnus-uu-unshar-warning)) (goto-char (point-min)) (display-buffer buffer) (yes-or-no-p "This is a shell archive, unshar it? ")) (kill-buffer buffer)) (setq state (list 'error)))))) (unless (memq 'error state) (beginning-of-line) (setq start-char (point)) (call-process-region start-char (point-max) shell-file-name nil (gnus-get-buffer-create gnus-uu-output-buffer-name) nil shell-command-switch (concat "cd " gnus-uu-work-dir " " gnus-shell-command-separator " sh"))))) state)) ;; Returns the name of what the shar file is going to unpack. (defun gnus-uu-find-name-in-shar () (let ((oldpoint (point)) res) (goto-char (point-min)) (when (re-search-forward gnus-uu-shar-name-marker nil t) (setq res (buffer-substring (match-beginning 1) (match-end 1)))) (goto-char oldpoint) res)) ;; `gnus-uu-choose-action' chooses what action to perform given the name ;; and `gnus-uu-file-action-list'. Returns either nil if no action is ;; found, or the name of the command to run if such a rule is found. (defun gnus-uu-choose-action (file-name file-action-list &optional no-ignore) (let ((action-list (copy-sequence file-action-list)) (case-fold-search t) rule action) (and (unless no-ignore (and (not (and gnus-uu-ignore-files-by-name (string-match gnus-uu-ignore-files-by-name file-name))) (not (and gnus-uu-ignore-files-by-type (string-match gnus-uu-ignore-files-by-type (or (gnus-uu-choose-action file-name gnus-uu-ext-to-mime-list t) "")))))) (while (not (or (eq action-list ()) action)) (setq rule (car action-list)) (setq action-list (cdr action-list)) (when (string-match (car rule) file-name) (setq action (cadr rule))))) action)) (defun gnus-uu-treat-archive (file-path) ;; Unpacks an archive. Returns t if unpacking is successful. (let ((did-unpack t) action command dir) (setq action (gnus-uu-choose-action file-path (append gnus-uu-user-archive-rules (if gnus-uu-ignore-default-archive-rules nil gnus-uu-default-archive-rules)))) (when (not action) (error "No unpackers for the file %s" file-path)) (string-match "/[^/]*$" file-path) (setq dir (substring file-path 0 (match-beginning 0))) (when (member action gnus-uu-destructive-archivers) (copy-file file-path (concat file-path "~") t)) (setq command (format "cd %s ; %s" dir (gnus-uu-command action file-path))) (save-excursion (set-buffer (gnus-get-buffer-create gnus-uu-output-buffer-name)) (erase-buffer)) (gnus-message 5 "Unpacking: %s..." (gnus-uu-command action file-path)) (if (eq 0 (call-process shell-file-name nil (gnus-get-buffer-create gnus-uu-output-buffer-name) nil shell-command-switch command)) (message "") (gnus-message 2 "Error during unpacking of archive") (setq did-unpack nil)) (when (member action gnus-uu-destructive-archivers) (rename-file (concat file-path "~") file-path t)) did-unpack)) (defun gnus-uu-dir-files (dir) (let ((dirs (directory-files dir t "[^/][^\\.][^\\.]?$")) files file) (while dirs (if (file-directory-p (setq file (car dirs))) (setq files (append files (gnus-uu-dir-files file))) (push file files)) (setq dirs (cdr dirs))) files)) (defun gnus-uu-unpack-files (files &optional ignore) ;; Go through FILES and look for files to unpack. (let* ((totfiles (gnus-uu-ls-r gnus-uu-work-dir)) (ofiles files) file did-unpack) (while files (setq file (cdr (assq 'name (car files)))) (when (and (not (member file ignore)) (equal (gnus-uu-get-action (file-name-nondirectory file)) "gnus-uu-archive")) (push file did-unpack) (unless (gnus-uu-treat-archive file) (gnus-message 2 "Error during unpacking of %s" file)) (let* ((newfiles (gnus-uu-ls-r gnus-uu-work-dir)) (nfiles newfiles)) (while nfiles (unless (member (car nfiles) totfiles) (push (list (cons 'name (car nfiles)) (cons 'original file)) ofiles)) (setq nfiles (cdr nfiles))) (setq totfiles newfiles))) (setq files (cdr files))) (if did-unpack (gnus-uu-unpack-files ofiles (append did-unpack ignore)) ofiles))) (defun gnus-uu-ls-r (dir) (let* ((files (gnus-uu-directory-files dir t)) (ofiles files)) (while files (when (file-directory-p (car files)) (setq ofiles (delete (car files) ofiles)) (setq ofiles (append ofiles (gnus-uu-ls-r (car files))))) (setq files (cdr files))) ofiles)) ;; Various stuff (defun gnus-uu-directory-files (dir &optional full) (let (files out file) (setq files (directory-files dir full)) (while files (setq file (car files)) (setq files (cdr files)) (unless (member (file-name-nondirectory file) '("." "..")) (push file out))) (setq out (nreverse out)) out)) (defun gnus-uu-check-correct-stripped-uucode (start end) (save-excursion (let (found beg length) (unless gnus-uu-correct-stripped-uucode (goto-char start) (if (re-search-forward " \\|`" end t) (progn (goto-char start) (while (not (eobp)) (progn (when (looking-at "\n") (replace-match "")) (forward-line 1)))) (while (not (eobp)) (unless (looking-at (concat gnus-uu-begin-string "\\|" gnus-uu-end-string)) (when (not found) (setq length (- (point-at-eol) (point-at-bol)))) (setq found t) (beginning-of-line) (setq beg (point)) (end-of-line) (unless (= length (- (point) beg)) (insert (make-string (- length (- (point) beg)) ? )))) (forward-line 1))))))) (defvar gnus-uu-tmp-alist nil) (defun gnus-uu-initialize (&optional scan) (let (entry) (if (and (not scan) (when (setq entry (assoc gnus-newsgroup-name gnus-uu-tmp-alist)) (if (file-exists-p (cdr entry)) (setq gnus-uu-work-dir (cdr entry)) (setq gnus-uu-tmp-alist (delq entry gnus-uu-tmp-alist)) nil))) t (setq gnus-uu-tmp-dir (file-name-as-directory (expand-file-name gnus-uu-tmp-dir))) (if (not (file-directory-p gnus-uu-tmp-dir)) (error "Temp directory %s doesn't exist" gnus-uu-tmp-dir) (when (not (file-writable-p gnus-uu-tmp-dir)) (error "Temp directory %s can't be written to" gnus-uu-tmp-dir))) (setq gnus-uu-work-dir (mm-make-temp-file (concat gnus-uu-tmp-dir "gnus") 'dir)) (gnus-set-file-modes gnus-uu-work-dir 448) (setq gnus-uu-work-dir (file-name-as-directory gnus-uu-work-dir)) (push (cons gnus-newsgroup-name gnus-uu-work-dir) gnus-uu-tmp-alist)))) ;; Kills the temporary uu buffers, kills any processes, etc. (defun gnus-uu-clean-up () (let (buf) (and gnus-uu-uudecode-process (memq (process-status (or gnus-uu-uudecode-process "nevair")) '(stop run)) (delete-process gnus-uu-uudecode-process)) (when (setq buf (get-buffer gnus-uu-output-buffer-name)) (kill-buffer buf)))) ;; Inputs an action and a filename and returns a full command, making sure ;; that the filename will be treated as a single argument when the shell ;; executes the command. (defun gnus-uu-command (action file) (let ((quoted-file (shell-quote-argument file))) (if (string-match "%s" action) (format action quoted-file) (concat action " " quoted-file)))) (defun gnus-uu-delete-work-dir (&optional dir) "Delete recursively all files and directories under `gnus-uu-work-dir'." (if dir (gnus-message 7 "Deleting directory %s..." dir) (setq dir gnus-uu-work-dir)) (when (and dir (file-exists-p dir)) (let ((files (directory-files dir t nil t)) file) (while (setq file (pop files)) (unless (member (file-name-nondirectory file) '("." "..")) (if (file-directory-p file) (gnus-uu-delete-work-dir file) (gnus-message 9 "Deleting file %s..." file) (condition-case err (delete-file file) (error (gnus-message 3 "Deleting file %s failed... %s" file err)))))) (condition-case err (delete-directory dir) (error (gnus-message 3 "Deleting directory %s failed... %s" file err)))) (gnus-message 7 ""))) ;; Initializing (add-hook 'gnus-exit-group-hook 'gnus-uu-clean-up) (add-hook 'gnus-exit-group-hook 'gnus-uu-delete-work-dir) ;;; ;;; uuencoded posting ;;; ;; Any function that is to be used as and encoding method will take two ;; parameters: PATH-NAME and FILE-NAME. (E.g. "/home/gaga/spiral.jpg" ;; and "spiral.jpg", respectively.) The function should return nil if ;; the encoding wasn't successful. (defcustom gnus-uu-post-encode-method 'gnus-uu-post-encode-uuencode "Function used for encoding binary files. There are three functions supplied with gnus-uu for encoding files: `gnus-uu-post-encode-uuencode', which does straight uuencoding; `gnus-uu-post-encode-mime', which encodes with base64 and adds MIME headers; and `gnus-uu-post-encode-mime-uuencode', which encodes with uuencode and adds MIME headers." :group 'gnus-extract-post :type '(radio (function-item gnus-uu-post-encode-uuencode) (function-item gnus-uu-post-encode-mime) (function-item gnus-uu-post-encode-mime-uuencode) (function :tag "Other"))) (defcustom gnus-uu-post-include-before-composing nil "Non-nil means that gnus-uu will ask for a file to encode before you compose the article. If this variable is t, you can either include an encoded file with \\[gnus-uu-post-insert-binary-in-article] or have one included for you when you post the article." :group 'gnus-extract-post :type 'boolean) (defcustom gnus-uu-post-length 990 "Maximum length of an article. The encoded file will be split into how many articles it takes to post the entire file." :group 'gnus-extract-post :type 'integer) (defcustom gnus-uu-post-threaded nil "Non-nil means that gnus-uu will post the encoded file in a thread. This may not be smart, as no other decoder I have seen are able to follow threads when collecting uuencoded articles. (Well, I have seen one package that does that - gnus-uu, but somehow, I don't think that counts...) The default is nil." :group 'gnus-extract-post :type 'boolean) (defcustom gnus-uu-post-separate-description t "Non-nil means that the description will be posted in a separate article. The first article will typically be numbered (0/x). If this variable is nil, the description the user enters will be included at the beginning of the first article, which will be numbered (1/x). Default is t." :group 'gnus-extract-post :type 'boolean) (defvar gnus-uu-post-binary-separator "--binary follows this line--") (defvar gnus-uu-post-message-id nil) (defvar gnus-uu-post-inserted-file-name nil) (defvar gnus-uu-winconf-post-news nil) (defun gnus-uu-post-news () "Compose an article and post an encoded file." (interactive) (setq gnus-uu-post-inserted-file-name nil) (setq gnus-uu-winconf-post-news (current-window-configuration)) (gnus-summary-post-news) (let ((map (make-sparse-keymap))) (set-keymap-parent map (current-local-map)) (use-local-map map)) ;;(local-set-key "\C-c\C-c" 'gnus-summary-edit-article-done) (local-set-key "\C-c\C-c" 'gnus-uu-post-news-inews) (local-set-key "\C-c\C-s" 'gnus-uu-post-news-inews) (local-set-key "\C-c\C-i" 'gnus-uu-post-insert-binary-in-article) (when gnus-uu-post-include-before-composing (save-excursion (setq gnus-uu-post-inserted-file-name (gnus-uu-post-insert-binary))))) (defun gnus-uu-post-insert-binary-in-article () "Inserts an encoded file in the buffer. The user will be asked for a file name." (interactive) (save-excursion (setq gnus-uu-post-inserted-file-name (gnus-uu-post-insert-binary)))) ;; Encodes with uuencode and substitutes all spaces with backticks. (defun gnus-uu-post-encode-uuencode (path file-name) (when (gnus-uu-post-encode-file "uuencode" path file-name) (goto-char (point-min)) (forward-line 1) (while (search-forward " " nil t) (replace-match "`")) t)) ;; Encodes with uuencode and adds MIME headers. (defun gnus-uu-post-encode-mime-uuencode (path file-name) (when (gnus-uu-post-encode-uuencode path file-name) (gnus-uu-post-make-mime file-name "x-uue") t)) ;; Encodes with base64 and adds MIME headers (defun gnus-uu-post-encode-mime (path file-name) (when (eq 0 (call-process shell-file-name nil t nil shell-command-switch (format "%s %s -o %s" "mmencode" path file-name))) (gnus-uu-post-make-mime file-name "base64") t)) ;; Adds MIME headers. (defun gnus-uu-post-make-mime (file-name encoding) (goto-char (point-min)) (insert (format "Content-Type: %s; name=\"%s\"\n" (gnus-uu-choose-action file-name gnus-uu-ext-to-mime-list) file-name)) (insert (format "Content-Transfer-Encoding: %s\n\n" encoding)) (save-restriction (set-buffer gnus-message-buffer) (goto-char (point-min)) (re-search-forward (concat "^" (regexp-quote mail-header-separator) "$")) (forward-line -1) (narrow-to-region (point-min) (point)) (unless (mail-fetch-field "mime-version") (widen) (insert "MIME-Version: 1.0\n")) (widen))) ;; Encodes a file PATH with COMMAND, leaving the result in the ;; current buffer. (defun gnus-uu-post-encode-file (command path file-name) (eq 0 (call-process shell-file-name nil t nil shell-command-switch (format "%s %s %s" command path file-name)))) (defun gnus-uu-post-news-inews () "Posts the composed news article and encoded file. If no file has been included, the user will be asked for a file." (interactive) (let (file-name) (if gnus-uu-post-inserted-file-name (setq file-name gnus-uu-post-inserted-file-name) (setq file-name (gnus-uu-post-insert-binary))) (gnus-uu-post-encoded file-name gnus-uu-post-threaded)) (setq gnus-uu-post-inserted-file-name nil) (when gnus-uu-winconf-post-news (set-window-configuration gnus-uu-winconf-post-news))) ;; Asks for a file to encode, encodes it and inserts the result in ;; the current buffer. Returns the file name the user gave. (defun gnus-uu-post-insert-binary () (let ((uuencode-buffer-name "*uuencode buffer*") file-path uubuf file-name) (setq file-path (read-file-name "What file do you want to encode? ")) (when (not (file-exists-p file-path)) (error "%s: No such file" file-path)) (goto-char (point-max)) (insert (format "\n%s\n" gnus-uu-post-binary-separator)) ;; #### Unix-specific? (when (string-match "^~/" file-path) (setq file-path (concat "$HOME" (substring file-path 1)))) ;; #### Unix-specific? (if (string-match "/[^/]*$" file-path) (setq file-name (substring file-path (1+ (match-beginning 0)))) (setq file-name file-path)) (unwind-protect (if (save-excursion (set-buffer (setq uubuf (gnus-get-buffer-create uuencode-buffer-name))) (erase-buffer) (funcall gnus-uu-post-encode-method file-path file-name)) (insert-buffer-substring uubuf) (error "Encoding unsuccessful")) (kill-buffer uubuf)) file-name)) ;; Posts the article and all of the encoded file. (defun gnus-uu-post-encoded (file-name &optional threaded) (let ((send-buffer-name "*uuencode send buffer*") (encoded-buffer-name "*encoded buffer*") (top-string "[ cut here %s (%s %d/%d) %s gnus-uu ]") (separator (concat mail-header-separator "\n\n")) uubuf length parts header i end beg beg-line minlen post-buf whole-len beg-binary end-binary) (setq post-buf (current-buffer)) (goto-char (point-min)) (when (not (re-search-forward (if gnus-uu-post-separate-description (concat "^" (regexp-quote gnus-uu-post-binary-separator) "$") (concat "^" (regexp-quote mail-header-separator) "$")) nil t)) (error "Internal error: No binary/header separator")) (beginning-of-line) (forward-line 1) (setq beg-binary (point)) (setq end-binary (point-max)) (save-excursion (set-buffer (setq uubuf (gnus-get-buffer-create encoded-buffer-name))) (erase-buffer) (insert-buffer-substring post-buf beg-binary end-binary) (goto-char (point-min)) (setq length (count-lines (point-min) (point-max))) (setq parts (/ length gnus-uu-post-length)) (unless (< (% length gnus-uu-post-length) 4) (incf parts))) (when gnus-uu-post-separate-description (forward-line -1)) (delete-region (point) (point-max)) (goto-char (point-min)) (re-search-forward (concat "^" (regexp-quote mail-header-separator) "$") nil t) (setq header (buffer-substring (point-min) (point-at-bol))) (goto-char (point-min)) (when gnus-uu-post-separate-description (when (re-search-forward "^Subject: " nil t) (end-of-line) (insert (format " (0/%d)" parts))) (save-excursion (message-send)) (setq gnus-uu-post-message-id (message-fetch-field "message-id"))) (save-excursion (setq i 1) (setq beg 1) (while (not (> i parts)) (set-buffer (gnus-get-buffer-create send-buffer-name)) (erase-buffer) (insert header) (when (and threaded gnus-uu-post-message-id) (insert "References: " gnus-uu-post-message-id "\n")) (insert separator) (setq whole-len (- 62 (length (format top-string "" file-name i parts "")))) (when (> 1 (setq minlen (/ whole-len 2))) (setq minlen 1)) (setq beg-line (format top-string (make-string minlen ?-) file-name i parts (make-string (if (= 0 (% whole-len 2)) (1- minlen) minlen) ?-))) (goto-char (point-min)) (when (re-search-forward "^Subject: " nil t) (end-of-line) (insert (format " (%d/%d)" i parts))) (goto-char (point-max)) (save-excursion (set-buffer uubuf) (goto-char beg) (if (= i parts) (goto-char (point-max)) (forward-line gnus-uu-post-length)) (when (and (= (1+ i) parts) (< (count-lines (point) (point-max)) 4)) (forward-line -4)) (setq end (point))) (insert-buffer-substring uubuf beg end) (insert beg-line "\n") (setq beg end) (incf i) (goto-char (point-min)) (re-search-forward (concat "^" (regexp-quote mail-header-separator) "$") nil t) (beginning-of-line) (forward-line 2) (when (re-search-forward (concat "^" (regexp-quote gnus-uu-post-binary-separator) "$") nil t) (replace-match "") (forward-line 1)) (insert beg-line) (insert "\n") (let (message-sent-message-via) (save-excursion (message-send)) (setq gnus-uu-post-message-id (concat (message-fetch-field "references") " " (message-fetch-field "message-id")))))) (gnus-kill-buffer send-buffer-name) (gnus-kill-buffer encoded-buffer-name) (when (not gnus-uu-post-separate-description) (set-buffer-modified-p nil) (bury-buffer)))) (provide 'gnus-uu) ;; arch-tag: 05312384-0a83-4720-9a58-b3160b888853 ;;; gnus-uu.el ends here gnus-5.11+v0.10.dfsg/lisp/encrypt.el0000644000175000017500000002602710732046302017255 0ustar tvainikatvainika;;; encrypt.el --- file encryption routines ;; Copyright (C) 2002, 2003, 2004, 2005 Free Software Foundation, Inc. ;; Author: Teodor Zlatanov ;; Created: 2003/01/24 ;; Keywords: files ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 3, or (at your option) ;; any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Commentary: ;;; This module addresses data encryption. Page breaks are used for ;;; grouping declarations and documentation relating to each ;;; particular aspect. ;;; Use in Gnus like this: ;;; (require 'encrypt) ;;; (setq ;;; nnimap-authinfo-file "~/.authinfo.enc" ;;; nntp-authinfo-file "~/.authinfo.enc" ;;; smtpmail-auth-credentials "~/.authinfo.enc" ;;; ;; GnuPG using the AES256 cipher, feel free to use your own favorite ;;; encrypt-file-alist (quote (("~/.authinfo.enc" (gpg "AES256")))) ;;; password-cache-expiry 600) ;;; Then write ~/.authinfo.enc: ;;; 1) open the old authinfo ;;; C-x C-f ~/.authinfo ;;; 2) write the new authinfo.enc ;;; M-x encrypt-write-file-contents RET ~/.authinfo.enc ;;; 3) verify the new authinfo is correct ;;; (this will insert the contents in the current buffer) ;;; M-: (encrypt-insert-file-contents "~/.authinfo.enc") ;;; Code: ;; autoload password (eval-and-compile (if (locate-library "password-cache") (require 'password-cache) (require 'password))) (defgroup encrypt '((password-cache custom-variable) (password-cache-expiry custom-variable)) "File encryption configuration." :group 'applications) (defcustom encrypt-file-alist nil "List of file names or regexes matched with encryptions. Format example: '((\"beta\" (gpg \"AES\")) (\"gamma\\\\*\" (pgg)) (\"/home/tzz/alpha\" (encrypt-xor \"Semi-Secret\")))" :type '(repeat (list :tag "Encryption entry" (radio :tag "What to encrypt" (file :tag "Filename") (regexp :tag "Regular expression match")) (radio :tag "How to encrypt it" (list :tag "GPG Encryption via PGG (including passphrases)" (const :tag "GPG via PGG" pgg)) (list :tag "GPG Encryption" (const :tag "GPG Program" gpg) (radio :tag "Choose a cipher" (const :tag "3DES Encryption" "3DES") (const :tag "CAST5 Encryption" "CAST5") (const :tag "Blowfish Encryption" "BLOWFISH") (const :tag "AES Encryption" "AES") (const :tag "AES192 Encryption" "AES192") (const :tag "AES256 Encryption" "AES256") (const :tag "Twofish Encryption" "TWOFISH") (string :tag "Cipher Name"))) (list :tag "Built-in simple XOR" (const :tag "XOR Encryption" encrypt-xor) (string :tag "XOR Cipher Value (seed value)"))))) :group 'encrypt) ;; TODO: now, load gencrypt.el and if successful, modify the ;; custom-type of encrypt-file-alist to add the gencrypt.el options ;; (plist-get (symbol-plist 'encrypt-file-alist) 'custom-type) ;; then use plist-put (defcustom encrypt-gpg-path (executable-find "gpg") "Path to the GPG program." :type '(radio (file :tag "Location of the GPG executable") (const :tag "GPG is not installed" nil)) :group 'encrypt) (defvar encrypt-temp-prefix "encrypt" "Prefix for temporary filenames") ;;;###autoload (defun encrypt-find-model (filename) "Given a filename, find a encrypt-file-alist entry" (dolist (entry encrypt-file-alist) (let ((match (nth 0 entry)) (model (nth 1 entry))) (when (or (eq match filename) (string-match match filename)) (return model))))) ;;;###autoload (defun encrypt-insert-file-contents (file &optional model erase) "Decrypt FILE into the current buffer." (interactive "fFile to insert: ") (let* ((model (or model (encrypt-find-model file))) (method (nth 0 model)) (cipher (nth 1 model)) (passphrase (encrypt-get-passphrase-if-needed file method cipher t)) (buffer-file-coding-system 'binary) (coding-system-for-read 'binary) outdata) ;; note we only insert-file-contents if the method is known to be valid (with-temp-buffer (cond ((eq method 'gpg) (insert-file-contents file) (setq outdata (encrypt-gpg-decode-buffer passphrase cipher))) ((eq method 'pgg) (insert-file-contents file) (setq outdata (encrypt-pgg-decode-buffer))) ((eq method 'encrypt-xor) (insert-file-contents file) (setq outdata (encrypt-xor-decode-buffer passphrase cipher))))) (if outdata (progn (message "%s was decrypted with %s" file (encrypt-message-method-and-cipher method cipher)) (when erase (delete-region (point-min) (point-max))) (insert outdata)) ;; the decryption failed, alas (password-cache-remove (encrypt-password-key file method cipher)) (gnus-error 5 "%s was NOT decrypted with %s" file (encrypt-message-method-and-cipher method cipher))))) (defun encrypt-get-file-contents (file &optional model) "Decrypt FILE and return the contents." (interactive "fFile to decrypt: ") (with-temp-buffer (encrypt-insert-file-contents file model) (buffer-string))) (defun encrypt-put-file-contents (file data &optional model) "Encrypt the DATA to FILE, then continue normally." (with-temp-buffer (insert data) (encrypt-write-file-contents file model))) (defun encrypt-write-file-contents (file &optional model) "Encrypt the current buffer to FILE, then continue normally." (interactive "sFile to write: ") (setq model (or model (encrypt-find-model file))) (if model (let* ((method (nth 0 model)) (cipher (nth 1 model)) (passphrase (encrypt-get-passphrase-if-needed file method cipher)) (outdata (cond ((eq method 'gpg) (encrypt-gpg-encode-buffer passphrase cipher)) ((eq method 'pgg) (encrypt-pgg-encode-buffer)) ((eq method 'encrypt-xor) (encrypt-xor-encode-buffer passphrase cipher))))) (if outdata (progn (message "%s was encrypted with %s" file (encrypt-message-method-and-cipher method cipher)) (with-temp-buffer (insert outdata) ;; do not confirm overwrites (write-file file nil))) ;; the decryption failed, alas (password-cache-remove (encrypt-password-key file method cipher)) (gnus-error 5 "%s was NOT encrypted with %s" file (encrypt-message-method-and-cipher method cipher)))) (gnus-error 1 "%s has no associated encryption model! See encrypt-file-alist." file))) (defun encrypt-password-key (file method cipher) (format "encrypt-password-%s-%s %s" (symbol-name method) cipher file)) (defun encrypt-get-passphrase-if-needed (file method cipher &optional add) "Read the passphrase for FILE, METHOD, CIPHER if necessary." (when (not (eq method 'pgg)) (let ((password-key (encrypt-password-key file method cipher)) (password-question (format "password for %s (file %s)? " (encrypt-message-method-and-cipher method cipher) file))) (if add (password-read-and-add password-question password-key) (password-read password-question password-key))))) (defun encrypt-message-method-and-cipher (method cipher) (format "method %s%s" (symbol-name method) (if cipher (format " (cipher %s)" cipher) ""))) (defun encrypt-xor-encode-buffer (passphrase cipher) (encrypt-xor-process-buffer passphrase cipher t)) (defun encrypt-xor-decode-buffer (passphrase cipher) (encrypt-xor-process-buffer passphrase cipher nil)) (defun encrypt-xor-process-buffer (passphrase cipher &optional encode) "Given PASSPHRASE, xor-encode or decode the contents of the current buffer." (let* ((bs (buffer-substring-no-properties (point-min) (point-max))) ;; passphrase-sum is a simple additive checksum of the ;; passphrase and the cipher (passphrase-sum (when (stringp passphrase) (apply '+ (append cipher passphrase nil)))) new-list) (with-temp-buffer (if encode (progn (dolist (x (append bs nil)) (setq new-list (cons (logxor x passphrase-sum) new-list))) (dolist (x new-list) (insert (format "%d " x)))) (progn (setq new-list (reverse (split-string bs))) (dolist (x new-list) (setq x (string-to-number x)) (insert (format "%c" (logxor x passphrase-sum)))))) (buffer-substring-no-properties (point-min) (point-max))))) (defun encrypt-gpg-encode-buffer (passphrase cipher) (encrypt-gpg-process-buffer passphrase cipher t)) (defun encrypt-gpg-decode-buffer (passphrase cipher) (encrypt-gpg-process-buffer passphrase cipher nil)) (defun encrypt-gpg-process-buffer (passphrase cipher &optional encode) "With PASSPHRASE, use GPG to encode or decode the current buffer." (let* ((program encrypt-gpg-path) (input (buffer-substring-no-properties (point-min) (point-max))) (temp-maker (if (fboundp 'make-temp-file) 'make-temp-file 'make-temp-name)) (temp-file (funcall temp-maker encrypt-temp-prefix)) (default-enable-multibyte-characters nil) (args `("--cipher-algo" ,cipher "--status-fd" "2" "--logger-fd" "2" "--passphrase-fd" "0" "--no-tty")) exit-status exit-data) (when encode (setq args (append args '("--symmetric" "--armor")))) (if program (with-temp-buffer (when passphrase (insert passphrase "\n")) (insert input) (setq exit-status (apply #'call-process-region (point-min) (point-max) program t `(t ,temp-file) nil args)) (if (equal exit-status 0) (setq exit-data (buffer-substring-no-properties (point-min) (point-max))) (with-temp-buffer (when (file-exists-p temp-file) (insert-file-contents temp-file)) (gnus-error 5 (format "%s exited abnormally: '%s' [%s]" program exit-status (buffer-string))))) (delete-file temp-file)) (gnus-error 5 "GPG is not installed.")) exit-data)) (defun encrypt-pgg-encode-buffer () (encrypt-pgg-process-buffer t)) (defun encrypt-pgg-decode-buffer () (encrypt-pgg-process-buffer)) (defun encrypt-pgg-process-buffer (&optional encode) "Use PGG to encode or decode the current buffer." (let ((pfft (if encode 'pgg-encrypt-symmetric 'pgg-decrypt)) (default-enable-multibyte-characters nil) (input (buffer-substring-no-properties (point-min) (point-max))) exit-data) (with-temp-buffer (insert input) ;; note that we call pfft before pgg-display-output-buffer (pgg-display-output-buffer (point-min) (point-max) (funcall pfft)) (setq exit-data (buffer-substring-no-properties (point-min) (point-max)))) (debug exit-data) exit-data)) (provide 'encrypt) ;;; encrypt.el ends here ;; arch-tag: d907e4f1-71b5-42b1-a180-fc7b84ff0648 gnus-5.11+v0.10.dfsg/lisp/sha1.el0000644000175000017500000003711611004005111016410 0ustar tvainikatvainika;;; sha1.el --- SHA1 Secure Hash Algorithm in Emacs-Lisp ;; Copyright (C) 1999, 2001, 2002, 2003, 2004, ;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc. ;; Author: Shuhei KOBAYASHI ;; Keywords: SHA1, FIPS 180-1 ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 3, or (at your option) ;; any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Commentary: ;; This program is implemented from the definition of SHA-1 in FIPS PUB ;; 180-1 (Federal Information Processing Standards Publication 180-1), ;; "Announcing the Standard for SECURE HASH STANDARD". ;; ;; (EXCEPTION; two optimizations taken from GnuPG/cipher/sha1.c) ;; ;; Test cases from FIPS PUB 180-1. ;; ;; (sha1 "abc") ;; => a9993e364706816aba3e25717850c26c9cd0d89d ;; ;; (sha1 "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq") ;; => 84983e441c3bd26ebaae4aa1f95129e5e54670f1 ;; ;; (sha1 (make-string 1000000 ?a)) ;; => 34aa973cd4c4daa4f61eeb2bdbad27316534016f ;; ;; BUGS: ;; * It is assumed that length of input string is less than 2^29 bytes. ;; * It is caller's responsibility to make string (or region) unibyte. ;; ;; TODO: ;; * Rewrite from scratch! ;; This version is much faster than Keiichi Suzuki's another sha1.el, ;; but it is too dirty. ;;; Code: (require 'hex-util) ;;; ;;; external SHA1 function. ;;; (defgroup sha1 nil "Elisp interface for SHA1 hash computation." :version "22.1" :group 'extensions) (defcustom sha1-maximum-internal-length 500 "*Maximum length of message to use Lisp version of SHA1 function. If message is longer than this, `sha1-program' is used instead. If this variable is set to 0, use external program only. If this variable is set to nil, use internal function only." :type 'integer :group 'sha1) (defcustom sha1-program '("sha1sum") "*Name of program to compute SHA1. It must be a string \(program name\) or list of strings \(name and its args\)." :type '(repeat string) :group 'sha1) (defcustom sha1-use-external (condition-case () (executable-find (car sha1-program)) (error)) "*Use external SHA1 program. If this variable is set to nil, use internal function only." :type 'boolean :group 'sha1) (defun sha1-string-external (string &optional binary) (let (prog args digest) (if (consp sha1-program) (setq prog (car sha1-program) args (cdr sha1-program)) (setq prog sha1-program args nil)) (with-temp-buffer (set-buffer-multibyte nil) (insert string) (apply (function call-process-region) (point-min) (point-max) prog t t nil args) ;; SHA1 is 40 bytes long in hexadecimal form. (setq digest (buffer-substring (point-min)(+ (point-min) 40)))) (if binary (decode-hex-string digest) digest))) (defun sha1-region-external (beg end &optional binary) (sha1-string-external (buffer-substring-no-properties beg end) binary)) ;;; ;;; internal SHA1 function. ;;; (eval-when-compile ;; optional second arg of string-to-number is new in v20. (defconst sha1-K0-high 23170) ; (string-to-number "5A82" 16) (defconst sha1-K0-low 31129) ; (string-to-number "7999" 16) (defconst sha1-K1-high 28377) ; (string-to-number "6ED9" 16) (defconst sha1-K1-low 60321) ; (string-to-number "EBA1" 16) (defconst sha1-K2-high 36635) ; (string-to-number "8F1B" 16) (defconst sha1-K2-low 48348) ; (string-to-number "BCDC" 16) (defconst sha1-K3-high 51810) ; (string-to-number "CA62" 16) (defconst sha1-K3-low 49622) ; (string-to-number "C1D6" 16) ;; original definition of sha1-F0. ;; (defmacro sha1-F0 (B C D) ;; (` (logior (logand (, B) (, C)) ;; (logand (lognot (, B)) (, D))))) ;; a little optimization from GnuPG/cipher/sha1.c. (defmacro sha1-F0 (B C D) `(logxor ,D (logand ,B (logxor ,C ,D)))) (defmacro sha1-F1 (B C D) `(logxor ,B ,C ,D)) ;; original definition of sha1-F2. ;; (defmacro sha1-F2 (B C D) ;; (` (logior (logand (, B) (, C)) ;; (logand (, B) (, D)) ;; (logand (, C) (, D))))) ;; a little optimization from GnuPG/cipher/sha1.c. (defmacro sha1-F2 (B C D) `(logior (logand ,B ,C) (logand ,D (logior ,B ,C)))) (defmacro sha1-F3 (B C D) `(logxor ,B ,C ,D)) (defmacro sha1-S1 (W-high W-low) `(let ((W-high ,W-high) (W-low ,W-low)) (setq S1W-high (+ (% (* W-high 2) 65536) (/ W-low ,(/ 65536 2)))) (setq S1W-low (+ (/ W-high ,(/ 65536 2)) (% (* W-low 2) 65536))))) (defmacro sha1-S5 (A-high A-low) `(progn (setq S5A-high (+ (% (* ,A-high 32) 65536) (/ ,A-low ,(/ 65536 32)))) (setq S5A-low (+ (/ ,A-high ,(/ 65536 32)) (% (* ,A-low 32) 65536))))) (defmacro sha1-S30 (B-high B-low) `(progn (setq S30B-high (+ (/ ,B-high 4) (* (% ,B-low 4) ,(/ 65536 4)))) (setq S30B-low (+ (/ ,B-low 4) (* (% ,B-high 4) ,(/ 65536 4)))))) (defmacro sha1-OP (round) `(progn (sha1-S5 sha1-A-high sha1-A-low) (sha1-S30 sha1-B-high sha1-B-low) (setq sha1-A-low (+ (,(intern (format "sha1-F%d" round)) sha1-B-low sha1-C-low sha1-D-low) sha1-E-low ,(symbol-value (intern (format "sha1-K%d-low" round))) (aref block-low idx) (progn (setq sha1-E-low sha1-D-low) (setq sha1-D-low sha1-C-low) (setq sha1-C-low S30B-low) (setq sha1-B-low sha1-A-low) S5A-low))) (setq carry (/ sha1-A-low 65536)) (setq sha1-A-low (% sha1-A-low 65536)) (setq sha1-A-high (% (+ (,(intern (format "sha1-F%d" round)) sha1-B-high sha1-C-high sha1-D-high) sha1-E-high ,(symbol-value (intern (format "sha1-K%d-high" round))) (aref block-high idx) (progn (setq sha1-E-high sha1-D-high) (setq sha1-D-high sha1-C-high) (setq sha1-C-high S30B-high) (setq sha1-B-high sha1-A-high) S5A-high) carry) 65536)))) (defmacro sha1-add-to-H (H X) `(progn (setq ,(intern (format "sha1-%s-low" H)) (+ ,(intern (format "sha1-%s-low" H)) ,(intern (format "sha1-%s-low" X)))) (setq carry (/ ,(intern (format "sha1-%s-low" H)) 65536)) (setq ,(intern (format "sha1-%s-low" H)) (% ,(intern (format "sha1-%s-low" H)) 65536)) (setq ,(intern (format "sha1-%s-high" H)) (% (+ ,(intern (format "sha1-%s-high" H)) ,(intern (format "sha1-%s-high" X)) carry) 65536)))) ) ;;; buffers (H0 H1 H2 H3 H4). (defvar sha1-H0-high) (defvar sha1-H0-low) (defvar sha1-H1-high) (defvar sha1-H1-low) (defvar sha1-H2-high) (defvar sha1-H2-low) (defvar sha1-H3-high) (defvar sha1-H3-low) (defvar sha1-H4-high) (defvar sha1-H4-low) (defun sha1-block (block-high block-low) (let (;; step (c) --- initialize buffers (A B C D E). (sha1-A-high sha1-H0-high) (sha1-A-low sha1-H0-low) (sha1-B-high sha1-H1-high) (sha1-B-low sha1-H1-low) (sha1-C-high sha1-H2-high) (sha1-C-low sha1-H2-low) (sha1-D-high sha1-H3-high) (sha1-D-low sha1-H3-low) (sha1-E-high sha1-H4-high) (sha1-E-low sha1-H4-low) (idx 16)) ;; step (b). (let (;; temporary variables used in sha1-S1 macro. S1W-high S1W-low) (while (< idx 80) (sha1-S1 (logxor (aref block-high (- idx 3)) (aref block-high (- idx 8)) (aref block-high (- idx 14)) (aref block-high (- idx 16))) (logxor (aref block-low (- idx 3)) (aref block-low (- idx 8)) (aref block-low (- idx 14)) (aref block-low (- idx 16)))) (aset block-high idx S1W-high) (aset block-low idx S1W-low) (setq idx (1+ idx)))) ;; step (d). (setq idx 0) (let (;; temporary variables used in sha1-OP macro. S5A-high S5A-low S30B-high S30B-low carry) (while (< idx 20) (sha1-OP 0) (setq idx (1+ idx))) (while (< idx 40) (sha1-OP 1) (setq idx (1+ idx))) (while (< idx 60) (sha1-OP 2) (setq idx (1+ idx))) (while (< idx 80) (sha1-OP 3) (setq idx (1+ idx)))) ;; step (e). (let (;; temporary variables used in sha1-add-to-H macro. carry) (sha1-add-to-H H0 A) (sha1-add-to-H H1 B) (sha1-add-to-H H2 C) (sha1-add-to-H H3 D) (sha1-add-to-H H4 E)))) (defun sha1-binary (string) "Return the SHA1 of STRING in binary form." (let (;; prepare buffers for a block. byte-length of block is 64. ;; input block is split into two vectors. ;; ;; input block: 00 01 02 03 04 05 06 07 08 09 0A 0B 0C 0D 0E 0F ... ;; block-high: +-0-+ +-1-+ +-2-+ +-3-+ ;; block-low: +-0-+ +-1-+ +-2-+ +-3-+ ;; ;; length of each vector is 80, and elements of each vector are ;; 16bit integers. elements 0x10-0x4F of each vector are ;; assigned later in `sha1-block'. (block-high (eval-when-compile (make-vector 80 nil))) (block-low (eval-when-compile (make-vector 80 nil)))) (unwind-protect (let* (;; byte-length of input string. (len (length string)) (lim (* (/ len 64) 64)) (rem (% len 4)) (idx 0)(pos 0)) ;; initialize buffers (H0 H1 H2 H3 H4). (setq sha1-H0-high 26437 ; (string-to-number "6745" 16) sha1-H0-low 8961 ; (string-to-number "2301" 16) sha1-H1-high 61389 ; (string-to-number "EFCD" 16) sha1-H1-low 43913 ; (string-to-number "AB89" 16) sha1-H2-high 39098 ; (string-to-number "98BA" 16) sha1-H2-low 56574 ; (string-to-number "DCFE" 16) sha1-H3-high 4146 ; (string-to-number "1032" 16) sha1-H3-low 21622 ; (string-to-number "5476" 16) sha1-H4-high 50130 ; (string-to-number "C3D2" 16) sha1-H4-low 57840) ; (string-to-number "E1F0" 16) ;; loop for each 64 bytes block. (while (< pos lim) ;; step (a). (setq idx 0) (while (< idx 16) (aset block-high idx (+ (* (aref string pos) 256) (aref string (1+ pos)))) (setq pos (+ pos 2)) (aset block-low idx (+ (* (aref string pos) 256) (aref string (1+ pos)))) (setq pos (+ pos 2)) (setq idx (1+ idx))) (sha1-block block-high block-low)) ;; last block. (if (prog1 (< (- len lim) 56) (setq lim (- len rem)) (setq idx 0) (while (< pos lim) (aset block-high idx (+ (* (aref string pos) 256) (aref string (1+ pos)))) (setq pos (+ pos 2)) (aset block-low idx (+ (* (aref string pos) 256) (aref string (1+ pos)))) (setq pos (+ pos 2)) (setq idx (1+ idx))) ;; this is the last (at most) 32bit word. (cond ((= rem 3) (aset block-high idx (+ (* (aref string pos) 256) (aref string (1+ pos)))) (setq pos (+ pos 2)) (aset block-low idx (+ (* (aref string pos) 256) 128))) ((= rem 2) (aset block-high idx (+ (* (aref string pos) 256) (aref string (1+ pos)))) (aset block-low idx 32768)) ((= rem 1) (aset block-high idx (+ (* (aref string pos) 256) 128)) (aset block-low idx 0)) (t ;; (= rem 0) (aset block-high idx 32768) (aset block-low idx 0))) (setq idx (1+ idx)) (while (< idx 16) (aset block-high idx 0) (aset block-low idx 0) (setq idx (1+ idx)))) ;; last block has enough room to write the length of string. (progn ;; write bit length of string to last 4 bytes of the block. (aset block-low 15 (* (% len 8192) 8)) (setq len (/ len 8192)) (aset block-high 15 (% len 65536)) ;; XXX: It is not practical to compute SHA1 of ;; such a huge message on emacs. ;; (setq len (/ len 65536)) ; for 64bit emacs. ;; (aset block-low 14 (% len 65536)) ;; (aset block-high 14 (/ len 65536)) (sha1-block block-high block-low)) ;; need one more block. (sha1-block block-high block-low) (fillarray block-high 0) (fillarray block-low 0) ;; write bit length of string to last 4 bytes of the block. (aset block-low 15 (* (% len 8192) 8)) (setq len (/ len 8192)) (aset block-high 15 (% len 65536)) ;; XXX: It is not practical to compute SHA1 of ;; such a huge message on emacs. ;; (setq len (/ len 65536)) ; for 64bit emacs. ;; (aset block-low 14 (% len 65536)) ;; (aset block-high 14 (/ len 65536)) (sha1-block block-high block-low)) ;; make output string (in binary form). (let ((result (make-string 20 0))) (aset result 0 (/ sha1-H0-high 256)) (aset result 1 (% sha1-H0-high 256)) (aset result 2 (/ sha1-H0-low 256)) (aset result 3 (% sha1-H0-low 256)) (aset result 4 (/ sha1-H1-high 256)) (aset result 5 (% sha1-H1-high 256)) (aset result 6 (/ sha1-H1-low 256)) (aset result 7 (% sha1-H1-low 256)) (aset result 8 (/ sha1-H2-high 256)) (aset result 9 (% sha1-H2-high 256)) (aset result 10 (/ sha1-H2-low 256)) (aset result 11 (% sha1-H2-low 256)) (aset result 12 (/ sha1-H3-high 256)) (aset result 13 (% sha1-H3-high 256)) (aset result 14 (/ sha1-H3-low 256)) (aset result 15 (% sha1-H3-low 256)) (aset result 16 (/ sha1-H4-high 256)) (aset result 17 (% sha1-H4-high 256)) (aset result 18 (/ sha1-H4-low 256)) (aset result 19 (% sha1-H4-low 256)) result)) ;; do not leave a copy of input string. (fillarray block-high nil) (fillarray block-low nil)))) (defun sha1-string-internal (string &optional binary) (if binary (sha1-binary string) (encode-hex-string (sha1-binary string)))) (defun sha1-region-internal (beg end &optional binary) (sha1-string-internal (buffer-substring-no-properties beg end) binary)) ;;; ;;; application interface. ;;; (defun sha1-region (beg end &optional binary) (if (and sha1-use-external sha1-maximum-internal-length (> (abs (- end beg)) sha1-maximum-internal-length)) (sha1-region-external beg end binary) (sha1-region-internal beg end binary))) (defun sha1-string (string &optional binary) (if (and sha1-use-external sha1-maximum-internal-length (> (length string) sha1-maximum-internal-length)) (sha1-string-external string binary) (sha1-string-internal string binary))) ;;;###autoload (defun sha1 (object &optional beg end binary) "Return the SHA1 (Secure Hash Algorithm) of an object. OBJECT is either a string or a buffer. Optional arguments BEG and END denote buffer positions for computing the hash of a portion of OBJECT. If BINARY is non-nil, return a string in binary form." (if (stringp object) (sha1-string object binary) (with-current-buffer object (sha1-region (or beg (point-min)) (or end (point-max)) binary)))) (provide 'sha1) ;; arch-tag: c0f9abd0-ffc1-4557-aac6-ece7f2d4c901 ;;; sha1.el ends here gnus-5.11+v0.10.dfsg/lisp/spam-stat.el0000644000175000017500000005623511004005111017470 0ustar tvainikatvainika;;; spam-stat.el --- detecting spam based on statistics ;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc. ;; Author: Alex Schroeder ;; Keywords: network ;; URL: http://www.emacswiki.org/cgi-bin/wiki.pl?SpamStat ;; This file is part of GNU Emacs. ;; This is free software; you can redistribute it and/or modify it ;; under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 3, or (at your option) ;; any later version. ;; This is distributed in the hope that it will be useful, but WITHOUT ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY ;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public ;; License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Commentary: ;; This implements spam analysis according to Paul Graham in "A Plan ;; for Spam". The basis for all this is a statistical distribution of ;; words for your spam and non-spam mails. We need this information ;; in a hash-table so that the analysis can use the information when ;; looking at your mails. Therefore, before you begin, you need tons ;; of mails (Graham uses 4000 non-spam and 4000 spam mails for his ;; experiments). ;; ;; The main interface to using spam-stat, are the following functions: ;; ;; `spam-stat-buffer-is-spam' -- called in a buffer, that buffer is ;; considered to be a new spam mail; use this for new mail that has ;; not been processed before ;; ;; `spam-stat-buffer-is-non-spam' -- called in a buffer, that buffer ;; is considered to be a new non-spam mail; use this for new mail that ;; has not been processed before ;; ;; `spam-stat-buffer-change-to-spam' -- called in a buffer, that ;; buffer is no longer considered to be normal mail but spam; use this ;; to change the status of a mail that has already been processed as ;; non-spam ;; ;; `spam-stat-buffer-change-to-non-spam' -- called in a buffer, that ;; buffer is no longer considered to be spam but normal mail; use this ;; to change the status of a mail that has already been processed as ;; spam ;; ;; `spam-stat-save' -- save the hash table to the file; the filename ;; used is stored in the variable `spam-stat-file' ;; ;; `spam-stat-load' -- load the hash table from a file; the filename ;; used is stored in the variable `spam-stat-file' ;; ;; `spam-stat-score-word' -- return the spam score for a word ;; ;; `spam-stat-score-buffer' -- return the spam score for a buffer ;; ;; `spam-stat-split-fancy' -- for fancy mail splitting; add ;; the rule (: spam-stat-split-fancy) to `nnmail-split-fancy' ;; ;; This requires the following in your ~/.gnus file: ;; ;; (require 'spam-stat) ;; (spam-stat-load) ;;; Testing: ;; Typical test will involve calls to the following functions: ;; ;; Reset: (spam-stat-reset) ;; Learn spam: (spam-stat-process-spam-directory "~/Mail/mail/spam") ;; Learn non-spam: (spam-stat-process-non-spam-directory "~/Mail/mail/misc") ;; Save table: (spam-stat-save) ;; File size: (nth 7 (file-attributes spam-stat-file)) ;; Number of words: (hash-table-count spam-stat) ;; Test spam: (spam-stat-test-directory "~/Mail/mail/spam") ;; Test non-spam: (spam-stat-test-directory "~/Mail/mail/misc") ;; Reduce table size: (spam-stat-reduce-size) ;; Save table: (spam-stat-save) ;; File size: (nth 7 (file-attributes spam-stat-file)) ;; Number of words: (hash-table-count spam-stat) ;; Test spam: (spam-stat-test-directory "~/Mail/mail/spam") ;; Test non-spam: (spam-stat-test-directory "~/Mail/mail/misc") ;;; Dictionary Creation: ;; Typically, you will filter away mailing lists etc. using specific ;; rules in `nnmail-split-fancy'. Somewhere among these rules, you ;; will filter spam. Here is how you would create your dictionary: ;; Reset: (spam-stat-reset) ;; Learn spam: (spam-stat-process-spam-directory "~/Mail/mail/spam") ;; Learn non-spam: (spam-stat-process-non-spam-directory "~/Mail/mail/misc") ;; Repeat for any other non-spam group you need... ;; Reduce table size: (spam-stat-reduce-size) ;; Save table: (spam-stat-save) ;;; Todo: ;; Speed it up. Integrate with Gnus such that it uses spam and expiry ;; marks to call the appropriate functions when leaving the summary ;; buffer and saves the hash table when leaving Gnus. More testing: ;; More mails, disabling SpamAssassin, double checking algorithm, find ;; improved algorithm. ;;; Thanks: ;; Ted Zlatanov ;; Jesper Harder ;; Dan Schmidt ;; Lasse Rasinen ;; Milan Zamazal ;;; Code: (require 'mail-parse) (defvar gnus-original-article-buffer) (defgroup spam-stat nil "Statistical spam detection for Emacs. Use the functions to build a dictionary of words and their statistical distribution in spam and non-spam mails. Then use a function to determine whether a buffer contains spam or not." :version "22.1" :group 'gnus) (defcustom spam-stat-file "~/.spam-stat.el" "File used to save and load the dictionary. See `spam-stat-to-hash-table' for the format of the file." :type 'file :group 'spam-stat) (defcustom spam-stat-install-hooks t "Whether spam-stat should install its hooks in Gnus. This is set to nil if you use spam-stat through spam.el." :type 'boolean :group 'spam-stat) (defcustom spam-stat-unknown-word-score 0.2 "The score to use for unknown words. Also used for words that don't appear often enough." :type 'number :group 'spam-stat) (defcustom spam-stat-max-word-length 15 "Only words shorter than this will be considered." :type 'integer :group 'spam-stat) (defcustom spam-stat-max-buffer-length 10240 "Only the beginning of buffers will be analyzed. This variable says how many characters this will be." :type 'integer :group 'spam-stat) (defcustom spam-stat-split-fancy-spam-group "mail.spam" "Name of the group where spam should be stored. If `spam-stat-split-fancy' is used in fancy splitting rules. Has no effect when spam-stat is invoked through spam.el." :type 'string :group 'spam-stat) (defcustom spam-stat-split-fancy-spam-threshold 0.9 "Spam score threshold in spam-stat-split-fancy." :type 'number :group 'spam-stat) (defcustom spam-stat-washing-hook nil "Hook applied to each message before analysis." :type 'hook :group 'spam-stat) (defcustom spam-stat-score-buffer-user-functions nil "List of additional scoring functions. Called one by one on the buffer. If all of these functions return non-nil answers, these numerical answers are added to the computed spam stat score on the buffer. If you defun such functions, make sure they don't return the buffer in a narrowed state or such: use, for example, `save-excursion'. Each of your functions is also passed the initial spam-stat score which might aid in your scoring. Also be careful when defining such functions. If they take a long time, they will slow down your mail splitting. Thus, if the buffer is large, don't forget to use smaller regions, by wrapping your work in, say, `with-spam-stat-max-buffer-size'." :type '(repeat sexp) :group 'spam-stat) (defcustom spam-stat-process-directory-age 90 "Max. age of files to be processed in directory, in days. When using `spam-stat-process-spam-directory' or `spam-stat-process-non-spam-directory', only files that have been touched in this many days will be considered. Without this filter, re-training spam-stat with several thousand messages will start to take a very long time." :type 'number :group 'spam-stat) (defvar spam-stat-last-saved-at nil "Time stamp of last change of spam-stat-file on this run") (defvar spam-stat-syntax-table (let ((table (copy-syntax-table text-mode-syntax-table))) (modify-syntax-entry ?- "w" table) (modify-syntax-entry ?_ "w" table) (modify-syntax-entry ?. "w" table) (modify-syntax-entry ?! "w" table) (modify-syntax-entry ?? "w" table) (modify-syntax-entry ?+ "w" table) table) "Syntax table used when processing mails for statistical analysis. The important part is which characters are word constituents.") (defvar spam-stat-dirty nil "Whether the spam-stat database needs saving.") (defvar spam-stat-buffer nil "Buffer to use for scoring while splitting. This is set by hooking into Gnus.") (defvar spam-stat-buffer-name " *spam stat buffer*" "Name of the `spam-stat-buffer'.") (defvar spam-stat-coding-system (if (mm-coding-system-p 'emacs-mule) 'emacs-mule 'raw-text) "Coding system used for `spam-stat-file'.") ;; Hooking into Gnus (defun spam-stat-store-current-buffer () "Store a copy of the current buffer in `spam-stat-buffer'." (let ((buf (current-buffer))) (with-current-buffer (get-buffer-create spam-stat-buffer-name) (erase-buffer) (insert-buffer-substring buf) (setq spam-stat-buffer (current-buffer))))) (defun spam-stat-store-gnus-article-buffer () "Store a copy of the current article in `spam-stat-buffer'. This uses `gnus-article-buffer'." (with-current-buffer gnus-original-article-buffer (spam-stat-store-current-buffer))) ;; Data -- not using defstruct in order to save space and time (defvar spam-stat (make-hash-table :test 'equal) "Hash table used to store the statistics. Use `spam-stat-load' to load the file. Every word is used as a key in this table. The value is a vector. Use `spam-stat-ngood', `spam-stat-nbad', `spam-stat-good', `spam-stat-bad', and `spam-stat-score' to access this vector.") (defvar spam-stat-ngood 0 "The number of good mails in the dictionary.") (defvar spam-stat-nbad 0 "The number of bad mails in the dictionary.") (defvar spam-stat-error-holder nil "A holder for condition-case errors while scoring buffers.") (defsubst spam-stat-good (entry) "Return the number of times this word belongs to good mails." (aref entry 0)) (defsubst spam-stat-bad (entry) "Return the number of times this word belongs to bad mails." (aref entry 1)) (defsubst spam-stat-score (entry) "Set the score of this word." (if entry (aref entry 2) spam-stat-unknown-word-score)) (defsubst spam-stat-set-good (entry value) "Set the number of times this word belongs to good mails." (aset entry 0 value)) (defsubst spam-stat-set-bad (entry value) "Set the number of times this word belongs to bad mails." (aset entry 1 value)) (defsubst spam-stat-set-score (entry value) "Set the score of this word." (aset entry 2 value)) (defsubst spam-stat-make-entry (good bad) "Return a vector with the given properties." (let ((entry (vector good bad nil))) (spam-stat-set-score entry (spam-stat-compute-score entry)) entry)) ;; Computing (defun spam-stat-compute-score (entry) "Compute the score of this word. 1.0 means spam." ;; promote all numbers to floats for the divisions (let* ((g (* 2.0 (spam-stat-good entry))) (b (float (spam-stat-bad entry)))) (cond ((< (+ g b) 5) .2) ((= 0 spam-stat-ngood) .99) ((= 0 spam-stat-nbad) .01) (t (max .01 (min .99 (/ (/ b spam-stat-nbad) (+ (/ g spam-stat-ngood) (/ b spam-stat-nbad))))))))) ;; Parsing (defmacro with-spam-stat-max-buffer-size (&rest body) "Narrow the buffer down to the first 4k characters, then evaluate BODY." `(save-restriction (when (> (- (point-max) (point-min)) spam-stat-max-buffer-length) (narrow-to-region (point-min) (+ (point-min) spam-stat-max-buffer-length))) ,@body)) (defun spam-stat-buffer-words () "Return a hash table of words and number of occurrences in the buffer." (run-hooks 'spam-stat-washing-hook) (with-spam-stat-max-buffer-size (with-syntax-table spam-stat-syntax-table (goto-char (point-min)) (let ((result (make-hash-table :test 'equal)) word count) (while (re-search-forward "\\w+" nil t) (setq word (match-string-no-properties 0) count (1+ (gethash word result 0))) (when (< (length word) spam-stat-max-word-length) (puthash word count result))) result)))) (defun spam-stat-buffer-is-spam () "Consider current buffer to be a new spam mail." (setq spam-stat-nbad (1+ spam-stat-nbad)) (maphash (lambda (word count) (let ((entry (gethash word spam-stat))) (if entry (spam-stat-set-bad entry (+ count (spam-stat-bad entry))) (setq entry (spam-stat-make-entry 0 count))) (spam-stat-set-score entry (spam-stat-compute-score entry)) (puthash word entry spam-stat))) (spam-stat-buffer-words)) (setq spam-stat-dirty t)) (defun spam-stat-buffer-is-non-spam () "Consider current buffer to be a new non-spam mail." (setq spam-stat-ngood (1+ spam-stat-ngood)) (maphash (lambda (word count) (let ((entry (gethash word spam-stat))) (if entry (spam-stat-set-good entry (+ count (spam-stat-good entry))) (setq entry (spam-stat-make-entry count 0))) (spam-stat-set-score entry (spam-stat-compute-score entry)) (puthash word entry spam-stat))) (spam-stat-buffer-words)) (setq spam-stat-dirty t)) (autoload 'gnus-message "gnus-util") (defun spam-stat-buffer-change-to-spam () "Consider current buffer no longer normal mail but spam." (setq spam-stat-nbad (1+ spam-stat-nbad) spam-stat-ngood (1- spam-stat-ngood)) (maphash (lambda (word count) (let ((entry (gethash word spam-stat))) (if (not entry) (gnus-message 8 "This buffer has unknown words in it") (spam-stat-set-good entry (- (spam-stat-good entry) count)) (spam-stat-set-bad entry (+ (spam-stat-bad entry) count)) (spam-stat-set-score entry (spam-stat-compute-score entry)) (puthash word entry spam-stat)))) (spam-stat-buffer-words)) (setq spam-stat-dirty t)) (defun spam-stat-buffer-change-to-non-spam () "Consider current buffer no longer spam but normal mail." (setq spam-stat-nbad (1- spam-stat-nbad) spam-stat-ngood (1+ spam-stat-ngood)) (maphash (lambda (word count) (let ((entry (gethash word spam-stat))) (if (not entry) (gnus-message 8 "This buffer has unknown words in it") (spam-stat-set-good entry (+ (spam-stat-good entry) count)) (spam-stat-set-bad entry (- (spam-stat-bad entry) count)) (spam-stat-set-score entry (spam-stat-compute-score entry)) (puthash word entry spam-stat)))) (spam-stat-buffer-words)) (setq spam-stat-dirty t)) ;; Saving and Loading (defun spam-stat-save (&optional force) "Save the `spam-stat' hash table as lisp file. With a prefix argument save unconditionally." (interactive "P") (when (or force spam-stat-dirty) (let ((coding-system-for-write spam-stat-coding-system)) (with-temp-file spam-stat-file (let ((standard-output (current-buffer)) (font-lock-maximum-size 0)) (insert (format ";-*- coding: %s; -*-\n" spam-stat-coding-system)) (insert (format "(setq spam-stat-ngood %d spam-stat-nbad %d spam-stat (spam-stat-to-hash-table '(" spam-stat-ngood spam-stat-nbad)) (maphash (lambda (word entry) (prin1 (list word (spam-stat-good entry) (spam-stat-bad entry)))) spam-stat) (insert ")))")))) (message "Saved %s." spam-stat-file) (setq spam-stat-dirty nil spam-stat-last-saved-at (nth 5 (file-attributes spam-stat-file))))) (defun spam-stat-load () "Read the `spam-stat' hash table from disk." ;; TODO: maybe we should warn the user if spam-stat-dirty is t? (let ((coding-system-for-read spam-stat-coding-system)) (cond (spam-stat-dirty (message "Spam stat not loaded: spam-stat-dirty t")) ((or (not (boundp 'spam-stat-last-saved-at)) (null spam-stat-last-saved-at) (not (equal spam-stat-last-saved-at (nth 5 (file-attributes spam-stat-file))))) (progn (load-file spam-stat-file) (setq spam-stat-dirty nil spam-stat-last-saved-at (nth 5 (file-attributes spam-stat-file))))) (t (message "Spam stat file not loaded: no change in disk.."))))) (defun spam-stat-to-hash-table (entries) "Turn list ENTRIES into a hash table and store as `spam-stat'. Every element in ENTRIES has the form \(WORD GOOD BAD) where WORD is the word string, NGOOD is the number of good mails it has appeared in, NBAD is the number of bad mails it has appeared in, GOOD is the number of times it appeared in good mails, and BAD is the number of times it has appeared in bad mails." (let ((table (make-hash-table :size (length entries) :test 'equal))) (mapc (lambda (l) (puthash (car l) (spam-stat-make-entry (nth 1 l) (nth 2 l)) table)) entries) table)) (defun spam-stat-reset () "Reset `spam-stat' to an empty hash-table. This deletes all the statistics." (interactive) (setq spam-stat (make-hash-table :test 'equal) spam-stat-ngood 0 spam-stat-nbad 0) (setq spam-stat-dirty t)) ;; Scoring buffers (defvar spam-stat-score-data nil "Raw data used in the last run of `spam-stat-score-buffer'.") (defsubst spam-stat-score-word (word) "Return score for WORD. The default score for unknown words is stored in `spam-stat-unknown-word-score'." (spam-stat-score (gethash word spam-stat))) (defun spam-stat-buffer-words-with-scores () "Process current buffer, return the 15 most conspicuous words. These are the words whose spam-stat differs the most from 0.5. The list returned contains elements of the form \(WORD SCORE DIFF), where DIFF is the difference between SCORE and 0.5." (let (result word score) (maphash (lambda (word ignore) (setq score (spam-stat-score-word word) result (cons (list word score (abs (- score 0.5))) result))) (spam-stat-buffer-words)) (setq result (sort result (lambda (a b) (< (nth 2 b) (nth 2 a))))) (setcdr (nthcdr 14 result) nil) result)) (defun spam-stat-score-buffer () "Return a score describing the spam-probability for this buffer. Add user supplied modifications if supplied." (interactive) ; helps in debugging. (setq spam-stat-score-data (spam-stat-buffer-words-with-scores)) (let* ((probs (mapcar 'cadr spam-stat-score-data)) (prod (apply #'* probs)) (score0 (/ prod (+ prod (apply #'* (mapcar #'(lambda (x) (- 1 x)) probs))))) (score1s (condition-case spam-stat-error-holder (spam-stat-score-buffer-user score0) (error nil))) (ans (if score1s (+ score0 score1s) score0))) (when (interactive-p) (message "%S" ans)) ans)) (defun spam-stat-score-buffer-user (&rest args) (let* ((scores (mapcar (lambda (fn) (apply fn args)) spam-stat-score-buffer-user-functions))) (if (memq nil scores) nil (apply #'+ scores)))) (defun spam-stat-split-fancy () "Return the name of the spam group if the current mail is spam. Use this function on `nnmail-split-fancy'. If you are interested in the raw data used for the last run of `spam-stat-score-buffer', check the variable `spam-stat-score-data'." (condition-case spam-stat-error-holder (progn (set-buffer spam-stat-buffer) (goto-char (point-min)) (when (> (spam-stat-score-buffer) spam-stat-split-fancy-spam-threshold) (when (boundp 'nnmail-split-trace) (mapc (lambda (entry) (push entry nnmail-split-trace)) spam-stat-score-data)) spam-stat-split-fancy-spam-group)) (error (message "Error in spam-stat-split-fancy: %S" spam-stat-error-holder) nil))) ;; Testing (defun spam-stat-strip-xref () "Strip the the Xref header." (save-restriction (mail-narrow-to-head) (when (re-search-forward "^Xref:.*\n" nil t) (delete-region (match-beginning 0) (match-end 0))))) (defun spam-stat-process-directory (dir func) "Process all the regular files in directory DIR using function FUNC." (let* ((files (directory-files dir t "^[^.]")) (max (/ (length files) 100.0)) (count 0)) (with-temp-buffer (dolist (f files) (when (and (file-readable-p f) (file-regular-p f) (> (nth 7 (file-attributes f)) 0) (< (time-to-number-of-days (time-since (nth 5 (file-attributes f)))) spam-stat-process-directory-age)) (setq count (1+ count)) (message "Reading %s: %.2f%%" dir (/ count max)) (insert-file-contents-literally f) (spam-stat-strip-xref) (funcall func) (erase-buffer)))))) (defun spam-stat-process-spam-directory (dir) "Process all the regular files in directory DIR as spam." (interactive "D") (spam-stat-process-directory dir 'spam-stat-buffer-is-spam)) (defun spam-stat-process-non-spam-directory (dir) "Process all the regular files in directory DIR as non-spam." (interactive "D") (spam-stat-process-directory dir 'spam-stat-buffer-is-non-spam)) (defun spam-stat-count () "Return size of `spam-stat'." (interactive) (hash-table-count spam-stat)) (defun spam-stat-test-directory (dir &optional verbose) "Test all the regular files in directory DIR for spam. If the result is 1.0, then all files are considered spam. If the result is 0.0, non of the files is considered spam. You can use this to determine error rates. If VERBOSE is non-nil display names of files detected as spam or non-spam in a temporary buffer. If it is the symbol `ham', display non-spam files; otherwise display spam files." (interactive "DDirectory: ") (let* ((files (directory-files dir t "^[^.]")) display-files buffer-score (total (length files)) (score 0.0); float (max (/ total 100.0)); float (count 0)) (with-temp-buffer (dolist (f files) (when (and (file-readable-p f) (file-regular-p f) (> (nth 7 (file-attributes f)) 0)) (setq count (1+ count)) (message "Reading %.2f%%, score %.2f" (/ count max) (/ score count)) (insert-file-contents-literally f) (setq buffer-score (spam-stat-score-buffer)) (when (> buffer-score 0.9) (setq score (1+ score))) (when verbose (if (> buffer-score 0.9) (unless (eq verbose 'ham) (push f display-files)) (when (eq verbose 'ham) (push f display-files)))) (erase-buffer)))) (when display-files (with-output-to-temp-buffer "*spam-stat results*" (dolist (file display-files) (princ file) (terpri)))) (message "Final score: %d / %d = %f" score total (/ score total)))) ;; Shrinking the dictionary (defun spam-stat-reduce-size (&optional count) "Reduce the size of `spam-stat'. This removes all words that occur less than COUNT from the dictionary. COUNT defaults to 5" (interactive) (setq count (or count 5)) (maphash (lambda (key entry) (when (< (+ (spam-stat-good entry) (spam-stat-bad entry)) count) (remhash key spam-stat))) spam-stat) (setq spam-stat-dirty t)) (defun spam-stat-install-hooks-function () "Install the spam-stat function hooks." (interactive) (add-hook 'nnmail-prepare-incoming-message-hook 'spam-stat-store-current-buffer) (add-hook 'gnus-select-article-hook 'spam-stat-store-gnus-article-buffer)) (when spam-stat-install-hooks (spam-stat-install-hooks-function)) (defun spam-stat-unload-hook () "Uninstall the spam-stat function hooks." (interactive) (remove-hook 'nnmail-prepare-incoming-message-hook 'spam-stat-store-current-buffer) (remove-hook 'gnus-select-article-hook 'spam-stat-store-gnus-article-buffer)) (add-hook 'spam-stat-unload-hook 'spam-stat-unload-hook) (provide 'spam-stat) ;; arch-tag: ff1d2200-8ddb-42fb-bb7b-1b5e20448554 ;;; spam-stat.el ends here gnus-5.11+v0.10.dfsg/lisp/utf7.el0000644000175000017500000002116611004005111016437 0ustar tvainikatvainika;;; utf7.el --- UTF-7 encoding/decoding for Emacs -*-coding: iso-8859-1;-*- ;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, ;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc. ;; Author: Jon K Hellan ;; Maintainer: bugs@gnus.org ;; Keywords: mail ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 3, or (at your option) ;; any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to ;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Commentary: ;; UTF-7 - A Mail-Safe Transformation Format of Unicode - RFC 2152 ;; This is a transformation format of Unicode that contains only 7-bit ;; ASCII octets and is intended to be readable by humans in the limiting ;; case that the document consists of characters from the US-ASCII ;; repertoire. ;; In short, runs of characters outside US-ASCII are encoded as base64 ;; inside delimiters. ;; A variation of UTF-7 is specified in IMAP 4rev1 (RFC 2060) as the way ;; to represent characters outside US-ASCII in mailbox names in IMAP. ;; This library supports both variants, but the IMAP variation was the ;; reason I wrote it. ;; The routines convert UTF-7 -> UTF-16 (16 bit encoding of Unicode) ;; -> current character set, and vice versa. ;; However, until Emacs supports Unicode, the only Emacs character set ;; supported here is ISO-8859.1, which can trivially be converted to/from ;; Unicode. ;; When decoding results in a character outside the Emacs character set, ;; an error is thrown. It is up to the application to recover. ;; UTF-7 should be done by providing a coding system. Mule-UCS does ;; already, but I don't know if it does the IMAP version and it's not ;; clear whether that should really be a coding system. The UTF-16 ;; part of the conversion can be done with coding systems available ;; with Mule-UCS or some versions of Emacs. Unfortunately these were ;; done wrongly (regarding handling of byte-order marks and how the ;; variants were named), so we don't have a consistent name for the ;; necessary coding system. The code below doesn't seem to DTRT ;; generally. E.g.: ;; ;; (utf7-encode "a+£") ;; => "a+ACsAow-" ;; ;; $ echo "a+£"|iconv -f iso-8859-1 -t utf-7 ;; a+-+AKM ;; ;; -- fx ;;; Code: (require 'base64) (eval-when-compile (require 'cl)) (require 'mm-util) (defconst utf7-direct-encoding-chars " -%'-*,-[]-}" "Character ranges which do not need escaping in UTF-7.") (defconst utf7-imap-direct-encoding-chars (concat utf7-direct-encoding-chars "+\\~") "Character ranges which do not need escaping in the IMAP variant of UTF-7.") (defconst utf7-utf-16-coding-system (cond ((mm-coding-system-p 'utf-16-be-no-signature) ; Mule-UCS 'utf-16-be-no-signature) ((and (mm-coding-system-p 'utf-16-be) ; Emacs 21.3, Emacs 22 ;; Avoid versions with BOM. (= 2 (length (encode-coding-string "a" 'utf-16-be)))) 'utf-16-be) ((mm-coding-system-p 'utf-16-be-nosig) ; ? 'utf-16-be-nosig)) "Coding system which encodes big endian UTF-16 without a BOM signature.") (defsubst utf7-imap-get-pad-length (len modulus) "Return required length of padding for IMAP modified base64 fragment." (mod (- len) modulus)) (defun utf7-encode-internal (&optional for-imap) "Encode text in (temporary) buffer as UTF-7. Use IMAP modification if FOR-IMAP is non-nil." (let ((start (point-min)) (end (point-max))) (narrow-to-region start end) (goto-char start) (let* ((esc-char (if for-imap ?& ?+)) (direct-encoding-chars (if for-imap utf7-imap-direct-encoding-chars utf7-direct-encoding-chars)) (not-direct-encoding-chars (concat "^" direct-encoding-chars))) (while (not (eobp)) (skip-chars-forward direct-encoding-chars) (unless (eobp) (insert esc-char) (let ((p (point)) (fc (following-char)) (run-length (skip-chars-forward not-direct-encoding-chars))) (if (and (= fc esc-char) (= run-length 1)) ; Lone esc-char? (delete-backward-char 1) ; Now there's one too many (utf7-fragment-encode p (point) for-imap)) (insert "-"))))))) (defun utf7-fragment-encode (start end &optional for-imap) "Encode text from START to END in buffer as UTF-7 escape fragment. Use IMAP modification if FOR-IMAP is non-nil." (save-restriction (narrow-to-region start end) (funcall (utf7-get-u16char-converter 'to-utf-16)) (mm-with-unibyte-current-buffer (base64-encode-region start (point-max))) (goto-char start) (let ((pm (point-max))) (when for-imap (while (search-forward "/" nil t) (replace-match ","))) (skip-chars-forward "^= \t\n" pm) (delete-region (point) pm)))) (defun utf7-decode-internal (&optional for-imap) "Decode UTF-7 text in (temporary) buffer. Use IMAP modification if FOR-IMAP is non-nil." (let ((start (point-min)) (end (point-max))) (goto-char start) (let* ((esc-pattern (concat "^" (char-to-string (if for-imap ?& ?+)))) (base64-chars (concat "A-Za-z0-9+" (char-to-string (if for-imap ?, ?/))))) (while (not (eobp)) (skip-chars-forward esc-pattern) (unless (eobp) (forward-char) (let ((p (point)) (run-length (skip-chars-forward base64-chars))) (when (and (not (eobp)) (= (following-char) ?-)) (delete-char 1)) (unless (= run-length 0) ; Encoded lone esc-char? (save-excursion (utf7-fragment-decode p (point) for-imap) (goto-char p) (delete-backward-char 1))))))))) (defun utf7-fragment-decode (start end &optional for-imap) "Decode base64 encoded fragment from START to END of UTF-7 text in buffer. Use IMAP modification if FOR-IMAP is non-nil." (save-restriction (narrow-to-region start end) (when for-imap (goto-char start) (while (search-forward "," nil 'move-to-end) (replace-match "/"))) (let ((pl (utf7-imap-get-pad-length (- end start) 4))) (insert (make-string pl ?=)) (base64-decode-region start (+ end pl))) (funcall (utf7-get-u16char-converter 'from-utf-16)))) (defun utf7-get-u16char-converter (which-way) "Return a function to convert between UTF-16 and current character set." (if utf7-utf-16-coding-system (if (eq which-way 'to-utf-16) (lambda () (encode-coding-region (point-min) (point-max) utf7-utf-16-coding-system)) (lambda () (decode-coding-region (point-min) (point-max) utf7-utf-16-coding-system))) ;; Add test to check if we are really Latin-1. (if (eq which-way 'to-utf-16) 'utf7-latin1-u16-char-converter 'utf7-u16-latin1-char-converter))) (defun utf7-latin1-u16-char-converter () "Convert latin 1 (ISO-8859.1) characters to 16 bit Unicode. Characters are converted to raw byte pairs in narrowed buffer." (mm-encode-coding-region (point-min) (point-max) 'iso-8859-1) (mm-disable-multibyte) (goto-char (point-min)) (while (not (eobp)) (insert 0) (forward-char))) (defun utf7-u16-latin1-char-converter () "Convert 16 bit Unicode characters to latin 1 (ISO-8859.1). Characters are in raw byte pairs in narrowed buffer." (goto-char (point-min)) (while (not (eobp)) (if (= 0 (following-char)) (delete-char 1) (error "Unable to convert from Unicode")) (forward-char)) (mm-decode-coding-region (point-min) (point-max) 'iso-8859-1) (mm-enable-multibyte)) (defun utf7-encode (string &optional for-imap) "Encode UTF-7 STRING. Use IMAP modification if FOR-IMAP is non-nil." (if (and (coding-system-p 'utf-7) (coding-system-p 'utf-7-imap)) ;; Emacs 23 with proper support for IMAP (encode-coding-string string (if for-imap 'utf-7-imap 'utf-7)) (let ((default-enable-multibyte-characters t)) (with-temp-buffer (insert string) (utf7-encode-internal for-imap) (buffer-string))))) (defun utf7-decode (string &optional for-imap) "Decode UTF-7 STRING. Use IMAP modification if FOR-IMAP is non-nil." (if (and (coding-system-p 'utf-7) (coding-system-p 'utf-7-imap)) ;; Emacs 23 with proper support for IMAP (decode-coding-string string (if for-imap 'utf-7-imap 'utf-7)) (let ((default-enable-multibyte-characters nil)) (with-temp-buffer (insert string) (utf7-decode-internal for-imap) (mm-enable-multibyte) (buffer-string))))) (provide 'utf7) ;; arch-tag: 96078b55-85c7-4161-aed2-932c24b282c7 ;;; utf7.el ends here gnus-5.11+v0.10.dfsg/lisp/pgg-gpg.el0000644000175000017500000003625511004005110017106 0ustar tvainikatvainika;;; pgg-gpg.el --- GnuPG support for PGG. ;; Copyright (C) 1999, 2000, 2002, 2003, 2004, ;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc. ;; Author: Daiki Ueno ;; Symmetric encryption and gpg-agent support added by: ;; Sascha Wilde ;; Created: 1999/10/28 ;; Keywords: PGP, OpenPGP, GnuPG ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 3, or (at your option) ;; any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Code: (eval-when-compile (require 'cl) ; for gpg macros (require 'pgg)) (defgroup pgg-gpg () "GnuPG interface." :group 'pgg) (defcustom pgg-gpg-program "gpg" "The GnuPG executable." :group 'pgg-gpg :type 'string) (defcustom pgg-gpg-extra-args nil "Extra arguments for every GnuPG invocation." :group 'pgg-gpg :type '(repeat (string :tag "Argument"))) (defcustom pgg-gpg-recipient-argument "--recipient" "GnuPG option to specify recipient." :group 'pgg-gpg :type '(choice (const :tag "New `--recipient' option" "--recipient") (const :tag "Old `--remote-user' option" "--remote-user"))) (defcustom pgg-gpg-use-agent t "Whether to use gnupg agent for key caching." :group 'pgg-gpg :type 'boolean) (defvar pgg-gpg-user-id nil "GnuPG ID of your default identity.") (defun pgg-gpg-process-region (start end passphrase program args) (let* ((use-agent (and (null passphrase) (pgg-gpg-use-agent-p))) (output-file-name (pgg-make-temp-file "pgg-output")) (args `("--status-fd" "2" ,@(if use-agent '("--use-agent") (if passphrase '("--passphrase-fd" "0"))) "--yes" ; overwrite "--output" ,output-file-name ,@pgg-gpg-extra-args ,@args)) (output-buffer pgg-output-buffer) (errors-buffer pgg-errors-buffer) (orig-mode (default-file-modes)) (process-connection-type nil) (inhibit-redisplay t) process status exit-status passphrase-with-newline encoded-passphrase-with-new-line) (with-current-buffer (get-buffer-create errors-buffer) (buffer-disable-undo) (erase-buffer)) (unwind-protect (progn (set-default-file-modes 448) (let ((coding-system-for-write 'binary)) (setq process (apply #'start-process "*GnuPG*" errors-buffer program args))) (set-process-sentinel process #'ignore) (when passphrase (setq passphrase-with-newline (concat passphrase "\n")) (if pgg-passphrase-coding-system (progn (setq encoded-passphrase-with-new-line (encode-coding-string passphrase-with-newline (coding-system-change-eol-conversion pgg-passphrase-coding-system 'unix))) (pgg-clear-string passphrase-with-newline)) (setq encoded-passphrase-with-new-line passphrase-with-newline passphrase-with-newline nil)) (process-send-string process encoded-passphrase-with-new-line)) (process-send-region process start end) (process-send-eof process) (while (eq 'run (process-status process)) (accept-process-output process 5)) (setq status (process-status process) exit-status (process-exit-status process)) (delete-process process) (with-current-buffer (get-buffer-create output-buffer) (buffer-disable-undo) (erase-buffer) (if (file-exists-p output-file-name) (let ((coding-system-for-read (if pgg-text-mode 'raw-text 'binary))) (insert-file-contents output-file-name))) (set-buffer errors-buffer) (if (memq status '(stop signal)) (error "%s exited abnormally: '%s'" program exit-status)) (if (= 127 exit-status) (error "%s could not be found" program)))) (if passphrase-with-newline (pgg-clear-string passphrase-with-newline)) (if encoded-passphrase-with-new-line (pgg-clear-string encoded-passphrase-with-new-line)) (if (and process (eq 'run (process-status process))) (interrupt-process process)) (if (file-exists-p output-file-name) (delete-file output-file-name)) (set-default-file-modes orig-mode)))) (defun pgg-gpg-possibly-cache-passphrase (passphrase &optional key notruncate) (if (and passphrase pgg-cache-passphrase (progn (goto-char (point-min)) (re-search-forward "^\\[GNUPG:] \\(GOOD_PASSPHRASE\\>\\)\\|\\(SIG_CREATED\\)" nil t))) (pgg-add-passphrase-to-cache (or key (progn (goto-char (point-min)) (if (re-search-forward "^\\[GNUPG:] NEED_PASSPHRASE\\(_PIN\\)? \\w+ ?\\w*" nil t) (substring (match-string 0) -8)))) passphrase notruncate))) (defvar pgg-gpg-all-secret-keys 'unknown) (defun pgg-gpg-lookup-all-secret-keys () "Return all secret keys present in secret key ring." (when (eq pgg-gpg-all-secret-keys 'unknown) (setq pgg-gpg-all-secret-keys '()) (let ((args (list "--with-colons" "--no-greeting" "--batch" "--list-secret-keys"))) (with-temp-buffer (apply #'call-process pgg-gpg-program nil t nil args) (goto-char (point-min)) (while (re-search-forward "^\\(sec\\|pub\\):[^:]*:[^:]*:[^:]*:\\([^:]*\\)" nil t) (push (substring (match-string 2) 8) pgg-gpg-all-secret-keys))))) pgg-gpg-all-secret-keys) (defun pgg-gpg-lookup-key (string &optional type) "Search keys associated with STRING." (let ((args (list "--with-colons" "--no-greeting" "--batch" (if type "--list-secret-keys" "--list-keys") string))) (with-temp-buffer (apply #'call-process pgg-gpg-program nil t nil args) (goto-char (point-min)) (if (re-search-forward "^\\(sec\\|pub\\):[^:]*:[^:]*:[^:]*:\\([^:]*\\)" nil t) (substring (match-string 2) 8))))) (defun pgg-gpg-lookup-key-owner (string &optional all) "Search keys associated with STRING and return owner of identified key. The value may be just the bare key id, or it may be a combination of the user name associated with the key and the key id, with the key id enclosed in \"<...>\" angle brackets. Optional ALL non-nil means search all keys, including secret keys." (let ((args (list "--with-colons" "--no-greeting" "--batch" (if all "--list-secret-keys" "--list-keys") string)) (key-regexp (concat "^\\(sec\\|pub\\)" ":[^:]*:[^:]*:[^:]*:\\([^:]*\\):[^:]*" ":[^:]*:[^:]*:[^:]*:\\([^:]*\\):"))) (with-temp-buffer (apply #'call-process pgg-gpg-program nil t nil args) (goto-char (point-min)) (if (re-search-forward key-regexp nil t) (match-string 3))))) (defun pgg-gpg-key-id-from-key-owner (key-owner) (cond ((not key-owner) nil) ;; Extract bare key id from outermost paired angle brackets, if any: ((string-match "[^<]*<\\(.+\\)>[^>]*" key-owner) (substring key-owner (match-beginning 1)(match-end 1))) (key-owner))) (defun pgg-gpg-encrypt-region (start end recipients &optional sign passphrase) "Encrypt the current region between START and END. If optional argument SIGN is non-nil, do a combined sign and encrypt. If optional PASSPHRASE is not specified, it will be obtained from the passphrase cache or user." (let* ((pgg-gpg-user-id (or pgg-gpg-user-id pgg-default-user-id)) (passphrase (or passphrase (when (and sign (not (pgg-gpg-use-agent-p))) (pgg-read-passphrase (format "GnuPG passphrase for %s: " pgg-gpg-user-id) pgg-gpg-user-id)))) (args (append (list "--batch" "--armor" "--always-trust" "--encrypt") (if pgg-text-mode (list "--textmode")) (if sign (list "--sign" "--local-user" pgg-gpg-user-id)) (if (or recipients pgg-encrypt-for-me) (apply #'nconc (mapcar (lambda (rcpt) (list pgg-gpg-recipient-argument rcpt)) (append recipients (if pgg-encrypt-for-me (list pgg-gpg-user-id))))))))) (pgg-gpg-process-region start end passphrase pgg-gpg-program args) (when sign (with-current-buffer pgg-errors-buffer ;; Possibly cache passphrase under, e.g. "jas", for future sign. (pgg-gpg-possibly-cache-passphrase passphrase pgg-gpg-user-id) ;; Possibly cache passphrase under, e.g. B565716F, for future decrypt. (pgg-gpg-possibly-cache-passphrase passphrase))) (pgg-process-when-success))) (defun pgg-gpg-encrypt-symmetric-region (start end &optional passphrase) "Encrypt the current region between START and END with symmetric cipher. If optional PASSPHRASE is not specified, it will be obtained from the passphrase cache or user." (let* ((passphrase (or passphrase (when (not (pgg-gpg-use-agent-p)) (pgg-read-passphrase "GnuPG passphrase for symmetric encryption: ")))) (args (append (list "--batch" "--armor" "--symmetric" ) (if pgg-text-mode (list "--textmode"))))) (pgg-gpg-process-region start end passphrase pgg-gpg-program args) (pgg-process-when-success))) (defun pgg-gpg-decrypt-region (start end &optional passphrase) "Decrypt the current region between START and END. If optional PASSPHRASE is not specified, it will be obtained from the passphrase cache or user." (let* ((current-buffer (current-buffer)) (message-keys (with-temp-buffer (insert-buffer-substring current-buffer) (pgg-decode-armor-region (point-min) (point-max)))) (secret-keys (pgg-gpg-lookup-all-secret-keys)) ;; XXX the user is stuck if they need to use the passphrase for ;; any but the first secret key for which the message is ;; encrypted. ideally, we would incrementally give them a ;; chance with subsequent keys each time they fail with one. (key (pgg-gpg-select-matching-key message-keys secret-keys)) (key-owner (and key (pgg-gpg-lookup-key-owner key t))) (key-id (pgg-gpg-key-id-from-key-owner key-owner)) (pgg-gpg-user-id (or key-id key pgg-gpg-user-id pgg-default-user-id)) (passphrase (or passphrase (when (not (pgg-gpg-use-agent-p)) (pgg-read-passphrase (format (if (pgg-gpg-symmetric-key-p message-keys) "Passphrase for symmetric decryption: " "GnuPG passphrase for %s: ") (or key-owner "??")) pgg-gpg-user-id)))) (args '("--batch" "--decrypt"))) (pgg-gpg-process-region start end passphrase pgg-gpg-program args) (with-current-buffer pgg-errors-buffer (pgg-gpg-possibly-cache-passphrase passphrase pgg-gpg-user-id) (goto-char (point-min)) (re-search-forward "^\\[GNUPG:] DECRYPTION_OKAY\\>" nil t)))) ;;;###autoload (defun pgg-gpg-symmetric-key-p (message-keys) "True if decoded armor MESSAGE-KEYS has symmetric encryption indicator." (let (result) (dolist (key message-keys result) (when (and (eq (car key) 3) (member '(symmetric-key-algorithm) key)) (setq result key))))) (defun pgg-gpg-select-matching-key (message-keys secret-keys) "Choose a key from MESSAGE-KEYS that matches one of the keys in SECRET-KEYS." (loop for message-key in message-keys for message-key-id = (and (equal (car message-key) 1) (cdr (assq 'key-identifier (cdr message-key)))) for key = (and message-key-id (pgg-lookup-key message-key-id 'encrypt)) when (and key (member key secret-keys)) return key)) (defun pgg-gpg-sign-region (start end &optional cleartext passphrase) "Make detached signature from text between START and END." (let* ((pgg-gpg-user-id (or pgg-gpg-user-id pgg-default-user-id)) (passphrase (or passphrase (when (not (pgg-gpg-use-agent-p)) (pgg-read-passphrase (format "GnuPG passphrase for %s: " pgg-gpg-user-id) pgg-gpg-user-id)))) (args (append (list (if cleartext "--clearsign" "--detach-sign") "--armor" "--batch" "--verbose" "--local-user" pgg-gpg-user-id) (if pgg-text-mode (list "--textmode")))) (inhibit-read-only t) buffer-read-only) (pgg-gpg-process-region start end passphrase pgg-gpg-program args) (with-current-buffer pgg-errors-buffer ;; Possibly cache passphrase under, e.g. "jas", for future sign. (pgg-gpg-possibly-cache-passphrase passphrase pgg-gpg-user-id) ;; Possibly cache passphrase under, e.g. B565716F, for future decrypt. (pgg-gpg-possibly-cache-passphrase passphrase)) (pgg-process-when-success))) (defun pgg-gpg-verify-region (start end &optional signature) "Verify region between START and END as the detached signature SIGNATURE." (let ((args '("--batch" "--verify"))) (when (stringp signature) (setq args (append args (list signature)))) (setq args (append args '("-"))) (pgg-gpg-process-region start end nil pgg-gpg-program args) (with-current-buffer pgg-errors-buffer (goto-char (point-min)) (while (re-search-forward "^gpg: \\(.*\\)\n" nil t) (with-current-buffer pgg-output-buffer (insert-buffer-substring pgg-errors-buffer (match-beginning 1) (match-end 0))) (delete-region (match-beginning 0) (match-end 0))) (goto-char (point-min)) (re-search-forward "^\\[GNUPG:] GOODSIG\\>" nil t)))) (defun pgg-gpg-insert-key () "Insert public key at point." (let* ((pgg-gpg-user-id (or pgg-gpg-user-id pgg-default-user-id)) (args (list "--batch" "--export" "--armor" pgg-gpg-user-id))) (pgg-gpg-process-region (point)(point) nil pgg-gpg-program args) (insert-buffer-substring pgg-output-buffer))) (defun pgg-gpg-snarf-keys-region (start end) "Add all public keys in region between START and END to the keyring." (let ((args '("--import" "--batch" "-")) status) (pgg-gpg-process-region start end nil pgg-gpg-program args) (set-buffer pgg-errors-buffer) (goto-char (point-min)) (when (re-search-forward "^\\[GNUPG:] IMPORT_RES\\>" nil t) (setq status (buffer-substring (match-end 0) (progn (end-of-line)(point))) status (vconcat (mapcar #'string-to-number (split-string status)))) (erase-buffer) (insert (format "Imported %d key(s). \tArmor contains %d key(s) [%d bad, %d old].\n" (+ (aref status 2) (aref status 10)) (aref status 0) (aref status 1) (+ (aref status 4) (aref status 11))) (if (zerop (aref status 9)) "" "\tSecret keys are imported.\n"))) (append-to-buffer pgg-output-buffer (point-min)(point-max)) (pgg-process-when-success))) (defun pgg-gpg-update-agent () "Try to connet to gpg-agent and send UPDATESTARTUPTTY." (if (fboundp 'make-network-process) (let* ((agent-info (getenv "GPG_AGENT_INFO")) (socket (and agent-info (string-match "^\\([^:]*\\)" agent-info) (match-string 1 agent-info))) (conn (and socket (make-network-process :name "gpg-agent-process" :host 'local :family 'local :service socket)))) (when (and conn (eq (process-status conn) 'open)) (process-send-string conn "UPDATESTARTUPTTY\n") (delete-process conn) t)) ;; We can't check, so assume gpg-agent is up. t)) (defun pgg-gpg-use-agent-p () "Return t if `pgg-gpg-use-agent' is t and gpg-agent is available." (and pgg-gpg-use-agent (pgg-gpg-update-agent))) (provide 'pgg-gpg) ;; arch-tag: 2aa5d5d8-93a0-4865-9312-33e29830e000 ;;; pgg-gpg.el ends here gnus-5.11+v0.10.dfsg/lisp/legacy-gnus-agent.el0000644000175000017500000002623610744555355021125 0ustar tvainikatvainika;;; gnus-agent.el --- Legacy unplugged support for Gnus ;; Copyright (C) 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc. ;; Author: Kevin Greiner ;; Keywords: news ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 3, or (at your option) ;; any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Commentary: ;; Conversion functions for the Agent. ;;; Code: (require 'gnus-start) (require 'gnus-util) (require 'gnus-range) (require 'gnus-agent) ;; Oort Gnus v0.08 - This release updated agent to no longer use ;; history file and to support a compressed alist. (defvar gnus-agent-compressed-agentview-search-only nil) (defun gnus-agent-convert-to-compressed-agentview (converting-to) "Iterates over all agentview files to ensure that they have been converted to the compressed format." (let ((search-in (list gnus-agent-directory)) here members member converted-something) (while (setq here (pop search-in)) (setq members (directory-files here t)) (while (setq member (pop members)) (cond ((string-match "/\\.\\.?$" member) nil) ((file-directory-p member) (push member search-in)) ((equal (file-name-nondirectory member) ".agentview") (setq converted-something (or (gnus-agent-convert-agentview member) converted-something)))))) (if converted-something (gnus-message 4 "Successfully converted Gnus %s offline (agent) files to %s" gnus-newsrc-file-version converting-to)))) (defun gnus-agent-convert-to-compressed-agentview-prompt () (catch 'found-file-to-convert (let ((gnus-agent-compressed-agentview-search-only t)) (gnus-agent-convert-to-compressed-agentview nil)))) (gnus-convert-mark-converter-prompt 'gnus-agent-convert-to-compressed-agentview 'gnus-agent-convert-to-compressed-agentview-prompt) (defun gnus-agent-convert-agentview (file) "Load FILE and do a `read' there." (with-temp-buffer (nnheader-insert-file-contents file) (goto-char (point-min)) (let ((inhibit-quit t) (alist (read (current-buffer))) (version (condition-case nil (read (current-buffer)) (end-of-file 0))) changed-version history-file) (cond ((= version 0) (let (entry (gnus-command-method nil)) (mm-disable-multibyte) ;; everything is binary (erase-buffer) (insert "\n") (let ((file (concat (file-name-directory file) "/history"))) (when (file-exists-p file) (nnheader-insert-file-contents file) (setq history-file file))) (goto-char (point-min)) (while (not (eobp)) (if (and (looking-at "[^\t\n]+\t\\([0-9]+\\)\t\\([^ \n]+\\) \\([0-9]+\\)") (string= (gnus-agent-article-name ".agentview" (match-string 2)) file) (setq entry (assoc (string-to-number (match-string 3)) alist))) (setcdr entry (string-to-number (match-string 1)))) (forward-line 1)) (setq changed-version t))) ((= version 1) (setq changed-version t))) (when changed-version (when gnus-agent-compressed-agentview-search-only (throw 'found-file-to-convert t)) (erase-buffer) (let (article-id day-of-download comp-list compressed) (while alist (setq article-id (caar alist) day-of-download (cdar alist) comp-list (assq day-of-download compressed) alist (cdr alist)) (if comp-list (setcdr comp-list (cons article-id (cdr comp-list))) (push (list day-of-download article-id) compressed))) (setq alist compressed) (while alist (setq comp-list (pop alist)) (setcdr comp-list (gnus-compress-sequence (nreverse (cdr comp-list))))) (princ compressed (current-buffer))) (insert "\n2\n") (write-file file) (when history-file (delete-file history-file)) t)))) ;; End of Oort Gnus v0.08 updates ;; No Gnus v0.3 - This release provides a mechanism for upgrading gnus ;; from previous versions. Therefore, the previous ;; hacks to handle a gnus-agent-expire-days that ;; specifies a list of values can be removed. (defun gnus-agent-unlist-expire-days (converting-to) (when (listp gnus-agent-expire-days) (let (buffer) (unwind-protect (save-window-excursion (setq buffer (gnus-get-buffer-create " *Gnus agent upgrade*")) (set-buffer buffer) (erase-buffer) (insert "The definition of gnus-agent-expire-days has been changed.\nYou currently have it set to the list:\n ") (gnus-pp gnus-agent-expire-days) (insert "\nIn order to use version '" converting-to "' of gnus, you will need to set\n") (insert "gnus-agent-expire-days to an integer. If you still wish to set different\n") (insert "expiration days to individual groups, you must instead set the\n") (insert "'agent-days-until-old group and/or topic parameter.\n") (insert "\n") (insert "If you would like, gnus can iterate over every group comparing its name to the\n") (insert "regular expressions that you currently have in gnus-agent-expire-days. When\n") (insert "gnus finds a match, it will update that group's 'agent-days-until-old group\n") (insert "parameter to the value associated with the regular expression.\n") (insert "\n") (insert "Whether gnus assigns group parameters, or not, gnus will terminate with an\n") (insert "ERROR as soon as this function completes. The reason is that you must\n") (insert "manually edit your configuration to either not set gnus-agent-expire-days or\n") (insert "to set it to an integer before gnus can be used.\n") (insert "\n") (insert "Once you have successfully edited gnus-agent-expire-days, gnus will be able to\n") (insert "execute past this function.\n") (insert "\n") (insert "Should gnus use gnus-agent-expire-days to assign\n") (insert "agent-days-until-old parameters to individual groups? (Y/N)") (switch-to-buffer buffer) (beep) (beep) (let ((echo-keystrokes 0) c) (while (progn (setq c (read-char-exclusive)) (cond ((or (eq c ?y) (eq c ?Y)) (save-excursion (let ((groups (gnus-group-listed-groups))) (while groups (let* ((group (pop groups)) (days gnus-agent-expire-days) (day (catch 'found (while days (when (eq 0 (string-match (caar days) group)) (throw 'found (cadar days))) (setq days (cdr days))) nil))) (when day (gnus-group-set-parameter group 'agent-days-until-old day)))))) nil ) ((or (eq c ?n) (eq c ?N)) nil) (t t)))))) (kill-buffer buffer)) (error "Change gnus-agent-expire-days to an integer for gnus to start")))) ;; The gnus-agent-unlist-expire-days has its own conversion prompt. ;; Therefore, hide the default prompt. (gnus-convert-mark-converter-prompt 'gnus-agent-unlist-expire-days t) (defun gnus-agent-unhook-expire-days (converting-to) "Remove every lambda from gnus-group-prepare-hook that mention the symbol gnus-agent-do-once in their definition. This should NOT be necessary as gnus-agent.el no longer adds them. However, it is possible that the hook was persistently saved." (let ((h t)) ; iterate from bgn of hook (while h (let ((func (progn (when (eq h t) ;; init h to list of functions (setq h (cond ((listp gnus-group-prepare-hook) gnus-group-prepare-hook) ((boundp 'gnus-group-prepare-hook) (list gnus-group-prepare-hook))))) (pop h)))) (when (cond ((eq (type-of func) 'compiled-function) ;; Search def. of compiled function for gnus-agent-do-once string (let* (definition print-level print-length (standard-output (lambda (char) (setq definition (cons char definition))))) (princ func) ; populates definition with reversed list of characters (let* ((i (length definition)) (s (make-string i 0))) (while definition (aset s (setq i (1- i)) (pop definition))) (string-match "\\bgnus-agent-do-once\\b" s)))) ((listp func) (eq (cadr (nth 2 func)) 'gnus-agent-do-once) ; handles eval'd lambda )) (remove-hook 'gnus-group-prepare-hook func) ;; I don't what remove-hook is going to actually do to the ;; hook list so start over from the beginning. (setq h t)))))) ;; gnus-agent-unhook-expire-days is safe in that it does not modify ;; the .newsrc.eld file. (gnus-convert-mark-converter-prompt 'gnus-agent-unhook-expire-days t) (provide 'legacy-gnus-agent) ;; arch-tag: 845c7b8a-88f7-4468-b8d7-94e8fc72cf1a ;;; legacy-gnus-agent.el ends here gnus-5.11+v0.10.dfsg/lisp/gnus-fun.el0000644000175000017500000002276211004005110017316 0ustar tvainikatvainika;;; gnus-fun.el --- various frivolous extension functions to Gnus ;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; Keywords: news ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 3, or (at your option) ;; any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Commentary: ;;; Code: ;; For Emacs < 22.2. (eval-and-compile (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) (eval-when-compile (require 'cl)) (require 'mm-util) (require 'gnus-ems) (require 'gnus-util) (require 'gnus) (defvar gnus-face-properties-alist) (defcustom gnus-x-face-directory (expand-file-name "x-faces" gnus-directory) "*Directory where X-Face PBM files are stored." :version "22.1" :group 'gnus-fun :type 'directory) (defcustom gnus-convert-pbm-to-x-face-command "pbmtoxbm %s | compface" "Command for converting a PBM to an X-Face." :version "22.1" :group 'gnus-fun :type 'string) (defcustom gnus-convert-image-to-x-face-command "convert -scale 48x48! %s xbm:- | xbm2xface.pl" "Command for converting an image to an X-Face. The command must take a image filename (use \"%s\") as input. The output must be the Face header data on stdout in PNG format. By default it takes a GIF filename and output the X-Face header data on stdout." :version "22.1" :group 'gnus-fun :type '(choice (const :tag "giftopnm, netpbm (GIF input only)" "giftopnm %s | ppmnorm | pnmscale -width 48 -height 48 | ppmtopgm | pgmtopbm | pbmtoxbm | compface") (const :tag "convert" "convert -scale 48x48! %s xbm:- | xbm2xface.pl") (string))) (defcustom gnus-convert-image-to-face-command "convert -scale 48x48! %s -colors %d png:-" "Command for converting an image to a Face. The command must take an image filename (first format argument \"%s\") and the number of colors (second format argument: \"%d\") as input. The output must be the Face header data on stdout in PNG format." :version "22.1" :group 'gnus-fun :type '(choice (const :tag "djpeg, netpbm (JPG input only)" "djpeg %s | ppmnorm | pnmscale -width 48 -height 48 | ppmquant %d | pnmtopng") (const :tag "convert" "convert -scale 48x48! %s -colors %d png:-") (string))) (defun gnus-shell-command-to-string (command) "Like `shell-command-to-string' except not mingling ERROR." (with-output-to-string (call-process shell-file-name nil (list standard-output nil) nil shell-command-switch command))) (defun gnus-shell-command-on-region (start end command) "A simplified `shell-command-on-region'. Output to the current buffer, replace text, and don't mingle error." (call-process-region start end shell-file-name t (list (current-buffer) nil) nil shell-command-switch command)) ;;;###autoload (defun gnus-random-x-face () "Return X-Face header data chosen randomly from `gnus-x-face-directory'." (interactive) (when (file-exists-p gnus-x-face-directory) (let* ((files (directory-files gnus-x-face-directory t "\\.pbm$")) (file (nth (random (length files)) files))) (when file (gnus-shell-command-to-string (format gnus-convert-pbm-to-x-face-command (shell-quote-argument file))))))) (autoload 'message-goto-eoh "message" nil t) ;;;###autoload (defun gnus-insert-random-x-face-header () "Insert a random X-Face header from `gnus-x-face-directory'." (interactive) (let ((data (gnus-random-x-face))) (save-excursion (message-goto-eoh) (if data (insert "X-Face: " data) (message "No face returned by `gnus-random-x-face'. Does %s/*.pbm exist?" gnus-x-face-directory))))) ;;;###autoload (defun gnus-x-face-from-file (file) "Insert an X-Face header based on an image file. Depending on `gnus-convert-image-to-x-face-command' it may accept different input formats." (interactive "fImage file name: ") (when (file-exists-p file) (gnus-shell-command-to-string (format gnus-convert-image-to-x-face-command (shell-quote-argument (expand-file-name file)))))) ;;;###autoload (defun gnus-face-from-file (file) "Return a Face header based on an image file. Depending on `gnus-convert-image-to-face-command' it may accept different input formats." (interactive "fImage file name: ") (when (file-exists-p file) (let ((done nil) (attempt "") (quant 16)) (while (and (not done) (> quant 1)) (setq attempt (let ((coding-system-for-read 'binary)) (gnus-shell-command-to-string (format gnus-convert-image-to-face-command (shell-quote-argument (expand-file-name file)) quant)))) (if (> (length attempt) 726) (progn (setq quant (- quant (if (< quant 10) 1 2))) (gnus-message 9 "Length %d; trying quant %d" (length attempt) quant)) (setq done t))) (if done (mm-with-unibyte-buffer (insert attempt) (gnus-face-encode)) nil)))) (defun gnus-face-encode () (let ((step 72)) (base64-encode-region (point-min) (point-max)) (goto-char (point-min)) (while (search-forward "\n" nil t) (replace-match "")) (goto-char (point-min)) (while (> (- (point-max) (point)) step) (forward-char step) (insert "\n ") (setq step 76)) (buffer-string))) ;;;###autoload (defun gnus-convert-face-to-png (face) "Convert FACE (which is base64-encoded) to a PNG. The PNG is returned as a string." (mm-with-unibyte-buffer (insert face) (ignore-errors (base64-decode-region (point-min) (point-max))) (buffer-string))) ;;;###autoload (defun gnus-convert-png-to-face (file) "Convert FILE to a Face. FILE should be a PNG file that's 48x48 and smaller than or equal to 726 bytes." (mm-with-unibyte-buffer (insert-file-contents file) (when (> (buffer-size) 726) (error "The file is %d bytes long, which is too long" (buffer-size))) (gnus-face-encode))) (defface gnus-x-face '((t (:foreground "black" :background "white"))) "Face to show X-Face. The colors from this face are used as the foreground and background colors of the displayed X-Faces." :group 'gnus-article-headers) (declare-function article-narrow-to-head "gnus-art" ()) (declare-function gnus-article-goto-header "gnus-art" (header)) (declare-function gnus-add-image "gnus-art" (category image)) (declare-function gnus-add-wash-type "gnus-art" (type)) (defun gnus-display-x-face-in-from (data) "Display the X-Face DATA in the From header." (require 'gnus-art) (let (pbm) (when (or (gnus-image-type-available-p 'xface) (and (gnus-image-type-available-p 'pbm) (setq pbm (uncompface data)))) (save-excursion (save-restriction (article-narrow-to-head) (gnus-article-goto-header "from") (when (bobp) (insert "From: [no `from' set]\n") (forward-char -17)) (gnus-add-image 'xface (gnus-put-image (if (gnus-image-type-available-p 'xface) (apply 'gnus-create-image (concat "X-Face: " data) 'xface t (cdr (assq 'xface gnus-face-properties-alist))) (apply 'gnus-create-image pbm 'pbm t (cdr (assq 'pbm gnus-face-properties-alist)))) nil 'xface)) (gnus-add-wash-type 'xface)))))) (defun gnus-grab-cam-x-face () "Grab a picture off the camera and make it into an X-Face." (interactive) (shell-command "xawtv-remote snap ppm") (let ((file nil)) (while (null (setq file (directory-files "/tftpboot/sparky/tmp" t "snap.*ppm"))) (sleep-for 1)) (setq file (car file)) (with-temp-buffer (shell-command (format "pnmcut -left 110 -top 30 -width 144 -height 144 '%s' | ppmnorm 2>/dev/null | pnmscale -width 48 | ppmtopgm | pgmtopbm -threshold -value 0.92 | pbmtoxbm | compface" file) (current-buffer)) ;;(sleep-for 3) (delete-file file) (buffer-string)))) (defun gnus-grab-cam-face () "Grab a picture off the camera and make it into an X-Face." (interactive) (shell-command "xawtv-remote snap ppm") (let ((file nil) result) (while (null (setq file (directory-files "/tftpboot/sparky/tmp" t "snap.*ppm"))) (sleep-for 1)) (setq file (car file)) (shell-command (format "pnmcut -left 110 -top 30 -width 144 -height 144 '%s' | pnmscale -width 48 -height 48 | ppmtopgm > /tmp/gnus.face.ppm" file)) (let ((gnus-convert-image-to-face-command (format "cat '%%s' | ppmquant %%d | ppmchange %s | pnmtopng" (gnus-fun-ppm-change-string)))) (setq result (gnus-face-from-file "/tmp/gnus.face.ppm"))) (delete-file file) ;;(delete-file "/tmp/gnus.face.ppm") result)) (defun gnus-fun-ppm-change-string () (let* ((possibilites '("%02x0000" "00%02x00" "0000%02x" "%02x%02x00" "00%02x%02x" "%02x00%02x")) (format (concat "'#%02x%02x%02x' '#" (nth (random 6) possibilites) "'")) (values nil)) (dotimes (i 255) (push (format format i i i i i i) values)) (mapconcat 'identity values " "))) (provide 'gnus-fun) ;; arch-tag: 9d000a69-15cc-4491-9dc0-4627484f50c1 ;;; gnus-fun.el ends here gnus-5.11+v0.10.dfsg/lisp/md4.el0000644000175000017500000002053511004005111016235 0ustar tvainikatvainika;;; md4.el --- MD4 Message Digest Algorithm. ;; Copyright (C) 2001, 2004, 2007, 2008 Free Software Foundation, Inc. ;; Author: Taro Kawagishi ;; Keywords: MD4 ;; Version: 1.00 ;; Created: February 2001 ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 3, or (at your option) ;; any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Code: ;;; ;;; MD4 hash calculation (defvar md4-buffer (make-vector 4 '(0 . 0)) "work buffer of four 32-bit integers") (defun md4 (in n) "Returns the MD4 hash string of 16 bytes long for a string IN of N bytes long. N is required to handle strings containing character 0." (let (m (b (cons 0 (* n 8))) (i 0) (buf (make-string 128 0)) c4) ;; initial values (aset md4-buffer 0 '(26437 . 8961)) ;0x67452301 (aset md4-buffer 1 '(61389 . 43913)) ;0xefcdab89 (aset md4-buffer 2 '(39098 . 56574)) ;0x98badcfe (aset md4-buffer 3 '(4146 . 21622)) ;0x10325476 ;; process the string in 64 bits chunks (while (> n 64) (setq m (md4-copy64 (substring in 0 64))) (md4-64 m) (setq in (substring in 64)) (setq n (- n 64))) ;; process the rest of the string (length is now n <= 64) (setq i 0) (while (< i n) (aset buf i (aref in i)) (setq i (1+ i))) (aset buf n 128) ;0x80 (if (<= n 55) (progn (setq c4 (md4-pack-int32 b)) (aset buf 56 (aref c4 0)) (aset buf 57 (aref c4 1)) (aset buf 58 (aref c4 2)) (aset buf 59 (aref c4 3)) (setq m (md4-copy64 buf)) (md4-64 m)) ;; else (setq c4 (md4-pack-int32 b)) (aset buf 120 (aref c4 0)) (aset buf 121 (aref c4 1)) (aset buf 122 (aref c4 2)) (aset buf 123 (aref c4 3)) (setq m (md4-copy64 buf)) (md4-64 m) (setq m (md4-copy64 (substring buf 64))) (md4-64 m))) (concat (md4-pack-int32 (aref md4-buffer 0)) (md4-pack-int32 (aref md4-buffer 1)) (md4-pack-int32 (aref md4-buffer 2)) (md4-pack-int32 (aref md4-buffer 3)))) (defsubst md4-F (x y z) (logior (logand x y) (logand (lognot x) z))) (defsubst md4-G (x y z) (logior (logand x y) (logand x z) (logand y z))) (defsubst md4-H (x y z) (logxor x y z)) (defmacro md4-make-step (name func) `(defun ,name (a b c d xk s ac) (let* ((h1 (+ (car a) (,func (car b) (car c) (car d)) (car xk) (car ac))) (l1 (+ (cdr a) (,func (cdr b) (cdr c) (cdr d)) (cdr xk) (cdr ac))) (h2 (logand 65535 (+ h1 (lsh l1 -16)))) (l2 (logand 65535 l1)) ;; cyclic shift of 32 bits integer (h3 (logand 65535 (if (> s 15) (+ (lsh h2 (- s 32)) (lsh l2 (- s 16))) (+ (lsh h2 s) (lsh l2 (- s 16)))))) (l3 (logand 65535 (if (> s 15) (+ (lsh l2 (- s 32)) (lsh h2 (- s 16))) (+ (lsh l2 s) (lsh h2 (- s 16))))))) (cons h3 l3)))) (md4-make-step md4-round1 md4-F) (md4-make-step md4-round2 md4-G) (md4-make-step md4-round3 md4-H) (defsubst md4-add (x y) "Return 32-bit sum of 32-bit integers X and Y." (let ((h (+ (car x) (car y))) (l (+ (cdr x) (cdr y)))) (cons (logand 65535 (+ h (lsh l -16))) (logand 65535 l)))) (defsubst md4-and (x y) (cons (logand (car x) (car y)) (logand (cdr x) (cdr y)))) (defun md4-64 (m) "Calculate md4 of 64 bytes chunk M which is represented as 16 pairs of 32 bits integers. The resulting md4 value is placed in md4-buffer." (let ((a (aref md4-buffer 0)) (b (aref md4-buffer 1)) (c (aref md4-buffer 2)) (d (aref md4-buffer 3))) (setq a (md4-round1 a b c d (aref m 0) 3 '(0 . 0)) d (md4-round1 d a b c (aref m 1) 7 '(0 . 0)) c (md4-round1 c d a b (aref m 2) 11 '(0 . 0)) b (md4-round1 b c d a (aref m 3) 19 '(0 . 0)) a (md4-round1 a b c d (aref m 4) 3 '(0 . 0)) d (md4-round1 d a b c (aref m 5) 7 '(0 . 0)) c (md4-round1 c d a b (aref m 6) 11 '(0 . 0)) b (md4-round1 b c d a (aref m 7) 19 '(0 . 0)) a (md4-round1 a b c d (aref m 8) 3 '(0 . 0)) d (md4-round1 d a b c (aref m 9) 7 '(0 . 0)) c (md4-round1 c d a b (aref m 10) 11 '(0 . 0)) b (md4-round1 b c d a (aref m 11) 19 '(0 . 0)) a (md4-round1 a b c d (aref m 12) 3 '(0 . 0)) d (md4-round1 d a b c (aref m 13) 7 '(0 . 0)) c (md4-round1 c d a b (aref m 14) 11 '(0 . 0)) b (md4-round1 b c d a (aref m 15) 19 '(0 . 0)) a (md4-round2 a b c d (aref m 0) 3 '(23170 . 31129)) ;0x5A827999 d (md4-round2 d a b c (aref m 4) 5 '(23170 . 31129)) c (md4-round2 c d a b (aref m 8) 9 '(23170 . 31129)) b (md4-round2 b c d a (aref m 12) 13 '(23170 . 31129)) a (md4-round2 a b c d (aref m 1) 3 '(23170 . 31129)) d (md4-round2 d a b c (aref m 5) 5 '(23170 . 31129)) c (md4-round2 c d a b (aref m 9) 9 '(23170 . 31129)) b (md4-round2 b c d a (aref m 13) 13 '(23170 . 31129)) a (md4-round2 a b c d (aref m 2) 3 '(23170 . 31129)) d (md4-round2 d a b c (aref m 6) 5 '(23170 . 31129)) c (md4-round2 c d a b (aref m 10) 9 '(23170 . 31129)) b (md4-round2 b c d a (aref m 14) 13 '(23170 . 31129)) a (md4-round2 a b c d (aref m 3) 3 '(23170 . 31129)) d (md4-round2 d a b c (aref m 7) 5 '(23170 . 31129)) c (md4-round2 c d a b (aref m 11) 9 '(23170 . 31129)) b (md4-round2 b c d a (aref m 15) 13 '(23170 . 31129)) a (md4-round3 a b c d (aref m 0) 3 '(28377 . 60321)) ;0x6ED9EBA1 d (md4-round3 d a b c (aref m 8) 9 '(28377 . 60321)) c (md4-round3 c d a b (aref m 4) 11 '(28377 . 60321)) b (md4-round3 b c d a (aref m 12) 15 '(28377 . 60321)) a (md4-round3 a b c d (aref m 2) 3 '(28377 . 60321)) d (md4-round3 d a b c (aref m 10) 9 '(28377 . 60321)) c (md4-round3 c d a b (aref m 6) 11 '(28377 . 60321)) b (md4-round3 b c d a (aref m 14) 15 '(28377 . 60321)) a (md4-round3 a b c d (aref m 1) 3 '(28377 . 60321)) d (md4-round3 d a b c (aref m 9) 9 '(28377 . 60321)) c (md4-round3 c d a b (aref m 5) 11 '(28377 . 60321)) b (md4-round3 b c d a (aref m 13) 15 '(28377 . 60321)) a (md4-round3 a b c d (aref m 3) 3 '(28377 . 60321)) d (md4-round3 d a b c (aref m 11) 9 '(28377 . 60321)) c (md4-round3 c d a b (aref m 7) 11 '(28377 . 60321)) b (md4-round3 b c d a (aref m 15) 15 '(28377 . 60321))) (aset md4-buffer 0 (md4-add a (aref md4-buffer 0))) (aset md4-buffer 1 (md4-add b (aref md4-buffer 1))) (aset md4-buffer 2 (md4-add c (aref md4-buffer 2))) (aset md4-buffer 3 (md4-add d (aref md4-buffer 3))) )) (defun md4-copy64 (seq) "Unpack a 64 bytes string into 16 pairs of 32 bits integers." (let ((int32s (make-vector 16 0)) (i 0) j) (while (< i 16) (setq j (* i 4)) (aset int32s i (cons (+ (aref seq (+ j 2)) (lsh (aref seq (+ j 3)) 8)) (+ (aref seq j) (lsh (aref seq (1+ j)) 8)))) (setq i (1+ i))) int32s)) ;;; ;;; sub functions (defun md4-pack-int16 (int16) "Pack 16 bits integer in 2 bytes string as little endian." (let ((str (make-string 2 0))) (aset str 0 (logand int16 255)) (aset str 1 (lsh int16 -8)) str)) (defun md4-pack-int32 (int32) "Pack 32 bits integer in a 4 bytes string as little endian. A 32 bits integer is represented as a pair of two 16 bits integers (cons high low)." (let ((str (make-string 4 0)) (h (car int32)) (l (cdr int32))) (aset str 0 (logand l 255)) (aset str 1 (lsh l -8)) (aset str 2 (logand h 255)) (aset str 3 (lsh h -8)) str)) (defun md4-unpack-int16 (str) (if (eq 2 (length str)) (+ (lsh (aref str 1) 8) (aref str 0)) (error "%s is not 2 bytes long" str))) (defun md4-unpack-int32 (str) (if (eq 4 (length str)) (cons (+ (lsh (aref str 3) 8) (aref str 2)) (+ (lsh (aref str 1) 8) (aref str 0))) (error "%s is not 4 bytes long" str))) (provide 'md4) ;; arch-tag: 99d706fe-089b-42ea-9507-67ae41091e6e ;;; md4.el ends here gnus-5.11+v0.10.dfsg/lisp/nntp.el0000644000175000017500000023540311004005111016532 0ustar tvainikatvainika;;; nntp.el --- nntp access for Gnus ;; Copyright (C) 1987, 1988, 1989, 1990, 1992, 1993, ;; 1994, 1995, 1996, 1997, 1998, 2000, 2001, 2002, ;; 2003, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; Keywords: news ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published ;; by the Free Software Foundation; either version 3, or (at your ;; option) any later version. ;; GNU Emacs is distributed in the hope that it will be useful, but ;; WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the ;; Free Software Foundation, 51 Franklin Street, Fifth Floor, Boston, ;; MA 02110-1301, USA. ;;; Commentary: ;;; Code: (require 'nnheader) (require 'nnoo) (require 'gnus-util) (require 'gnus) (require 'gnus-group) ;; gnus-group-name-charset (nnoo-declare nntp) (eval-when-compile (require 'cl)) (defgroup nntp nil "NNTP access for Gnus." :group 'gnus) (defvoo nntp-address nil "Address of the physical nntp server.") (defvoo nntp-port-number "nntp" "Port number on the physical nntp server.") (defvoo nntp-server-opened-hook '(nntp-send-mode-reader) "*Hook used for sending commands to the server at startup. The default value is `nntp-send-mode-reader', which makes an innd server spawn an nnrpd server.") (defvoo nntp-authinfo-function 'nntp-send-authinfo "Function used to send AUTHINFO to the server. It is called with no parameters.") (defvoo nntp-server-action-alist '(("nntpd 1\\.5\\.11t" (remove-hook 'nntp-server-opened-hook 'nntp-send-mode-reader)) ("NNRP server Netscape" (setq nntp-server-list-active-group nil))) "Alist of regexps to match on server types and actions to be taken. For instance, if you want Gnus to beep every time you connect to innd, you could say something like: \(setq nntp-server-action-alist '((\"innd\" (ding)))) You probably don't want to do that, though.") (defvoo nntp-open-connection-function 'nntp-open-network-stream "*Function used for connecting to a remote system. It will be called with the buffer to output in as argument. Currently, five such functions are provided (please refer to their respective doc string for more information), three of them establishing direct connections to the nntp server, and two of them using an indirect host. Direct connections: - `nntp-open-network-stream' (the default), - `nntp-open-ssl-stream', - `nntp-open-tls-stream', - `nntp-open-netcat-stream'. - `nntp-open-telnet-stream'. Indirect connections: - `nntp-open-via-rlogin-and-netcat', - `nntp-open-via-rlogin-and-telnet', - `nntp-open-via-telnet-and-telnet'.") (defvoo nntp-never-echoes-commands nil "*Non-nil means the nntp server never echoes commands. It is reported that some nntps server doesn't echo commands. So, you may want to set this to non-nil in the method for such a server setting `nntp-open-connection-function' to `nntp-open-ssl-stream' for example. Note that the `nntp-open-connection-functions-never-echo-commands' variable overrides the nil value of this variable.") (defvoo nntp-open-connection-functions-never-echo-commands '(nntp-open-network-stream) "*List of functions that never echo commands. Add or set a function which you set to `nntp-open-connection-function' to this list if it does not echo commands. Note that a non-nil value of the `nntp-never-echoes-commands' variable overrides this variable.") (defvoo nntp-pre-command nil "*Pre-command to use with the various nntp-open-via-* methods. This is where you would put \"runsocks\" or stuff like that.") (defvoo nntp-telnet-command "telnet" "*Telnet command used to connect to the nntp server. This command is used by the methods `nntp-open-telnet-stream', `nntp-open-via-rlogin-and-telnet' and `nntp-open-via-telnet-and-telnet'.") (defvoo nntp-telnet-switches '("-8") "*Switches given to the telnet command `nntp-telnet-command'.") (defvoo nntp-end-of-line "\r\n" "*String to use on the end of lines when talking to the NNTP server. This is \"\\r\\n\" by default, but should be \"\\n\" when using an indirect connection method (nntp-open-via-*).") (defvoo nntp-via-rlogin-command "rsh" "*Rlogin command used to connect to an intermediate host. This command is used by the methods `nntp-open-via-rlogin-and-telnet' and `nntp-open-via-rlogin-and-netcat'. The default is \"rsh\", but \"ssh\" is a popular alternative.") (defvoo nntp-via-rlogin-command-switches nil "*Switches given to the rlogin command `nntp-via-rlogin-command'. If you use \"ssh\" for `nntp-via-rlogin-command', you may set this to \(\"-C\") in order to compress all data connections, otherwise set this to \(\"-t\" \"-e\" \"none\") or (\"-C\" \"-t\" \"-e\" \"none\") if the telnet command requires a pseudo-tty allocation on an intermediate host.") (defvoo nntp-via-telnet-command "telnet" "*Telnet command used to connect to an intermediate host. This command is used by the `nntp-open-via-telnet-and-telnet' method.") (defvoo nntp-via-telnet-switches '("-8") "*Switches given to the telnet command `nntp-via-telnet-command'.") (defvoo nntp-netcat-command "nc" "*Netcat command used to connect to the nntp server. This command is used by the `nntp-open-netcat-stream' and `nntp-open-via-rlogin-and-netcat' methods.") (defvoo nntp-netcat-switches nil "*Switches given to the netcat command `nntp-netcat-command'.") (defvoo nntp-via-user-name nil "*User name to log in on an intermediate host with. This variable is used by the various nntp-open-via-* methods.") (defvoo nntp-via-user-password nil "*Password to use to log in on an intermediate host with. This variable is used by the `nntp-open-via-telnet-and-telnet' method.") (defvoo nntp-via-address nil "*Address of an intermediate host to connect to. This variable is used by the various nntp-open-via-* methods.") (defvoo nntp-via-envuser nil "*Whether both telnet client and server support the ENVIRON option. If non-nil, there will be no prompt for a login name.") (defvoo nntp-via-shell-prompt "bash\\|\$ *\r?$\\|> *\r?" "*Regular expression to match the shell prompt on an intermediate host. This variable is used by the `nntp-open-via-telnet-and-telnet' method.") (defvoo nntp-large-newsgroup 50 "*The number of articles which indicates a large newsgroup. If the number of articles is greater than the value, verbose messages will be shown to indicate the current status.") (defvoo nntp-maximum-request 400 "*The maximum number of the requests sent to the NNTP server at one time. If Emacs hangs up while retrieving headers, set the variable to a lower value.") (defvoo nntp-nov-is-evil nil "*If non-nil, nntp will never attempt to use XOVER when talking to the server.") (defvoo nntp-xover-commands '("XOVER" "XOVERVIEW") "*List of strings that are used as commands to fetch NOV lines from a server. The strings are tried in turn until a positive response is gotten. If none of the commands are successful, nntp will just grab headers one by one.") (defvoo nntp-nov-gap 5 "*Maximum allowed gap between two articles. If the gap between two consecutive articles is bigger than this variable, split the XOVER request into two requests.") (defvoo nntp-xref-number-is-evil nil "*If non-nil, Gnus never trusts article numbers in the Xref header. Some news servers, e.g., ones running Diablo, run multiple engines having the same articles but article numbers are not kept synchronized between them. If you connect to such a server, set this to a non-nil value, and Gnus never uses article numbers (that appear in the Xref header and vary by which engine is chosen) to refer to articles.") (defvoo nntp-prepare-server-hook nil "*Hook run before a server is opened. If can be used to set up a server remotely, for instance. Say you have an account at the machine \"other.machine\". This machine has access to an NNTP server that you can't access locally. You could then use this hook to rsh to the remote machine and start a proxy NNTP server there that you can connect to. See also `nntp-open-connection-function'") (defvoo nntp-coding-system-for-read 'binary "*Coding system to read from NNTP.") (defvoo nntp-coding-system-for-write 'binary "*Coding system to write to NNTP.") ;; Marks (defvoo nntp-marks-is-evil nil "*If non-nil, Gnus will never generate and use marks file for nntp groups. See `nnml-marks-is-evil' for more information.") (defvoo nntp-marks-file-name ".marks") (defvoo nntp-marks nil) (defvar nntp-marks-modtime (gnus-make-hashtable)) (defcustom nntp-marks-directory (nnheader-concat gnus-directory "marks/") "*The directory where marks for nntp groups will be stored." :group 'nntp :type 'directory) (defcustom nntp-authinfo-file "~/.authinfo" ".netrc-like file that holds nntp authinfo passwords." :group 'nntp :type '(choice file (repeat :tag "Entries" :menu-tag "Inline" (list :format "%v" :value ("" ("login" . "") ("password" . "")) (string :tag "Host") (checklist :inline t (cons :format "%v" (const :format "" "login") (string :format "Login: %v")) (cons :format "%v" (const :format "" "password") (string :format "Password: %v"))))))) (defvoo nntp-connection-timeout nil "*Number of seconds to wait before an nntp connection times out. If this variable is nil, which is the default, no timers are set. NOTE: This variable is never seen to work in Emacs 20 and XEmacs 21.") (defvoo nntp-prepare-post-hook nil "*Hook run just before posting an article. It is supposed to be used to insert Cancel-Lock headers.") ;;; Internal variables. (defvar nntp-record-commands nil "*If non-nil, nntp will record all commands in the \"*nntp-log*\" buffer.") (defvar nntp-have-messaged nil) (defvar nntp-process-wait-for nil) (defvar nntp-process-to-buffer nil) (defvar nntp-process-callback nil) (defvar nntp-process-decode nil) (defvar nntp-process-start-point nil) (defvar nntp-inside-change-function nil) (defvoo nntp-last-command-time nil) (defvoo nntp-last-command nil) (defvoo nntp-authinfo-password nil) (defvoo nntp-authinfo-user nil) (defvoo nntp-authinfo-force nil) (defvar nntp-connection-list nil) (defvoo nntp-server-type nil) (defvoo nntp-connection-alist nil) (defvoo nntp-status-string "") (defconst nntp-version "nntp 5.0") (defvoo nntp-inhibit-erase nil) (defvoo nntp-inhibit-output nil) (defvoo nntp-server-xover 'try) (defvoo nntp-server-list-active-group 'try) (defvar nntp-async-needs-kluge (string-match "^GNU Emacs 20\\.3\\." (emacs-version)) "*When non-nil, nntp will poll asynchronous connections once a second. By default, this is turned on only for Emacs 20.3, which has a bug that breaks nntp's normal method of noticing asynchronous data.") (defvar nntp-async-timer nil) (defvar nntp-async-process-list nil) (defvar nntp-ssl-program "openssl s_client -quiet -ssl3 -connect %s:%p" "A string containing commands for SSL connections. Within a string, %s is replaced with the server address and %p with port number on server. The program should accept IMAP commands on stdin and return responses to stdout.") (defvar nntp-authinfo-rejected nil "A custom error condition used to report 'Authentication Rejected' errors. Condition handlers that match just this condition ensure that the nntp backend doesn't catch this error.") (put 'nntp-authinfo-rejected 'error-conditions '(error nntp-authinfo-rejected)) (put 'nntp-authinfo-rejected 'error-message "Authorization Rejected") ;;; Internal functions. (defsubst nntp-send-string (process string) "Send STRING to PROCESS." ;; We need to store the time to provide timeouts, and ;; to store the command so the we can replay the command ;; if the server gives us an AUTHINFO challenge. (setq nntp-last-command-time (current-time) nntp-last-command string) (when nntp-record-commands (nntp-record-command string)) (process-send-string process (concat string nntp-end-of-line)) (or (memq (process-status process) '(open run)) (nntp-report "Server closed connection"))) (defun nntp-record-command (string) "Record the command STRING." (with-current-buffer (get-buffer-create "*nntp-log*") (goto-char (point-max)) (let ((time (current-time))) (insert (format-time-string "%Y%m%dT%H%M%S" time) "." (format "%03d" (/ (nth 2 time) 1000)) " " nntp-address " " string "\n")))) (defun nntp-report (&rest args) "Report an error from the nntp backend. The first string in ARGS can be a format string. For some commands, the failed command may be retried once before actually displaying the error report." (when nntp-record-commands (nntp-record-command "*** CALLED nntp-report ***")) (nnheader-report 'nntp args) (apply 'error args)) (defun nntp-report-1 (&rest args) "Throws out to nntp-with-open-group-error so that the connection may be restored and the command retried." (when nntp-record-commands (nntp-record-command "*** CONNECTION LOST ***")) (throw 'nntp-with-open-group-error t)) (defmacro nntp-insert-buffer-substring (buffer &optional start end) "Copy string from unibyte buffer to multibyte current buffer." (if (featurep 'xemacs) `(insert-buffer-substring ,buffer ,start ,end) `(if enable-multibyte-characters (insert (with-current-buffer ,buffer (mm-string-to-multibyte ,(if (or start end) `(buffer-substring (or ,start (point-min)) (or ,end (point-max))) '(buffer-string))))) (insert-buffer-substring ,buffer ,start ,end)))) (defmacro nntp-copy-to-buffer (buffer start end) "Copy string from unibyte current buffer to multibyte buffer." (if (featurep 'xemacs) `(copy-to-buffer ,buffer ,start ,end) `(let ((string (buffer-substring ,start ,end))) (with-current-buffer ,buffer (erase-buffer) (insert (if enable-multibyte-characters (mm-string-to-multibyte string) string)) (goto-char (point-min)) nil)))) (defsubst nntp-wait-for (process wait-for buffer &optional decode discard) "Wait for WAIT-FOR to arrive from PROCESS." (with-current-buffer (process-buffer process) (goto-char (point-min)) (while (and (or (not (memq (char-after (point)) '(?2 ?3 ?4 ?5))) (looking-at "48[02]")) (memq (process-status process) '(open run))) (cond ((looking-at "480") (nntp-handle-authinfo process)) ((looking-at "482") (nnheader-report 'nntp (get 'nntp-authinfo-rejected 'error-message)) (signal 'nntp-authinfo-rejected nil)) ((looking-at "^.*\n") (delete-region (point) (progn (forward-line 1) (point))))) (nntp-accept-process-output process) (goto-char (point-min))) (prog1 (cond ((looking-at "[45]") (progn (nntp-snarf-error-message) nil)) ((not (memq (process-status process) '(open run))) (nntp-report "Server closed connection")) (t (goto-char (point-max)) (let ((limit (point-min)) response) (while (not (re-search-backward wait-for limit t)) (nntp-accept-process-output process) ;; We assume that whatever we wait for is less than 1000 ;; characters long. (setq limit (max (- (point-max) 1000) (point-min))) (goto-char (point-max))) (setq response (match-string 0)) (with-current-buffer nntp-server-buffer (setq nntp-process-response response))) (nntp-decode-text (not decode)) (unless discard (with-current-buffer buffer (goto-char (point-max)) (nntp-insert-buffer-substring (process-buffer process)) ;; Nix out "nntp reading...." message. (when nntp-have-messaged (setq nntp-have-messaged nil) (nnheader-message 5 "")))) t)) (unless discard (erase-buffer))))) (defun nntp-kill-buffer (buffer) (when (buffer-name buffer) (kill-buffer buffer) (nnheader-init-server-buffer))) (defun nntp-erase-buffer (buffer) "Erase contents of BUFFER." (with-current-buffer buffer (erase-buffer))) (defsubst nntp-find-connection (buffer) "Find the connection delivering to BUFFER." (let ((alist nntp-connection-alist) (buffer (if (stringp buffer) (get-buffer buffer) buffer)) process entry) (while (and alist (setq entry (pop alist))) (when (eq buffer (cadr entry)) (setq process (car entry) alist nil))) (when process (if (memq (process-status process) '(open run)) process (nntp-kill-buffer (process-buffer process)) (setq nntp-connection-alist (delq entry nntp-connection-alist)) nil)))) (defsubst nntp-find-connection-entry (buffer) "Return the entry for the connection to BUFFER." (assq (nntp-find-connection buffer) nntp-connection-alist)) (defun nntp-find-connection-buffer (buffer) "Return the process connection buffer tied to BUFFER." (let ((process (nntp-find-connection buffer))) (when process (process-buffer process)))) (defsubst nntp-retrieve-data (command address port buffer &optional wait-for callback decode) "Use COMMAND to retrieve data into BUFFER from PORT on ADDRESS." (let ((process (or (nntp-find-connection buffer) (nntp-open-connection buffer)))) (if process (progn (unless (or nntp-inhibit-erase nnheader-callback-function) (nntp-erase-buffer (process-buffer process))) (condition-case err (progn (when command (nntp-send-string process command)) (cond ((eq callback 'ignore) t) ((and callback wait-for) (nntp-async-wait process wait-for buffer decode callback) t) (wait-for (nntp-wait-for process wait-for buffer decode)) (t t))) (nntp-authinfo-rejected (signal 'nntp-authinfo-rejected (cdr err))) (error (nnheader-report 'nntp "Couldn't open connection to %s: %s" address err)) (quit (message "Quit retrieving data from nntp") (signal 'quit nil) nil))) (nnheader-report 'nntp "Couldn't open connection to %s" address)))) (defsubst nntp-send-command (wait-for &rest strings) "Send STRINGS to server and wait until WAIT-FOR returns." (when (and (not nnheader-callback-function) (not nntp-inhibit-output)) (nntp-erase-buffer nntp-server-buffer)) (let* ((command (mapconcat 'identity strings " ")) (process (nntp-find-connection nntp-server-buffer)) (buffer (and process (process-buffer process))) (pos (and buffer (with-current-buffer buffer (point))))) (if process (prog1 (nntp-retrieve-data command nntp-address nntp-port-number nntp-server-buffer wait-for nnheader-callback-function) ;; If nothing to wait for, still remove possibly echo'ed commands. ;; We don't have echoes if `nntp-never-echoes-commands' is non-nil ;; or the value of `nntp-open-connection-function' is in ;; `nntp-open-connection-functions-never-echo-commands', so we ;; skip this in that cases. (unless (or wait-for nntp-never-echoes-commands (memq nntp-open-connection-function nntp-open-connection-functions-never-echo-commands)) (nntp-accept-response) (with-current-buffer buffer (goto-char pos) (if (looking-at (regexp-quote command)) (delete-region pos (progn (forward-line 1) (point-at-bol))))))) (nnheader-report 'nntp "Couldn't open connection to %s." nntp-address)))) (defun nntp-send-command-nodelete (wait-for &rest strings) "Send STRINGS to server and wait until WAIT-FOR returns." (let* ((command (mapconcat 'identity strings " ")) (process (nntp-find-connection nntp-server-buffer)) (buffer (and process (process-buffer process))) (pos (and buffer (with-current-buffer buffer (point))))) (if process (prog1 (nntp-retrieve-data command nntp-address nntp-port-number nntp-server-buffer wait-for nnheader-callback-function) ;; If nothing to wait for, still remove possibly echo'ed commands (unless wait-for (nntp-accept-response) (with-current-buffer buffer (goto-char pos) (if (looking-at (regexp-quote command)) (delete-region pos (progn (forward-line 1) (point-at-bol))))))) (nnheader-report 'nntp "Couldn't open connection to %s." nntp-address)))) (defun nntp-send-command-and-decode (wait-for &rest strings) "Send STRINGS to server and wait until WAIT-FOR returns." (when (and (not nnheader-callback-function) (not nntp-inhibit-output)) (nntp-erase-buffer nntp-server-buffer)) (let* ((command (mapconcat 'identity strings " ")) (process (nntp-find-connection nntp-server-buffer)) (buffer (and process (process-buffer process))) (pos (and buffer (with-current-buffer buffer (point))))) (if process (prog1 (nntp-retrieve-data command nntp-address nntp-port-number nntp-server-buffer wait-for nnheader-callback-function t) ;; If nothing to wait for, still remove possibly echo'ed commands (unless wait-for (nntp-accept-response) (with-current-buffer buffer (goto-char pos) (if (looking-at (regexp-quote command)) (delete-region pos (progn (forward-line 1) (point-at-bol)))) ))) (nnheader-report 'nntp "Couldn't open connection to %s." nntp-address)))) (defun nntp-send-buffer (wait-for) "Send the current buffer to server and wait until WAIT-FOR returns." (when (and (not nnheader-callback-function) (not nntp-inhibit-output)) (nntp-erase-buffer (nntp-find-connection-buffer nntp-server-buffer))) (nntp-encode-text) ;; Make sure we did not forget to encode some of the content. (assert (save-excursion (goto-char (point-min)) (not (re-search-forward "[^\000-\377]" nil t)))) (mm-disable-multibyte) (process-send-region (nntp-find-connection nntp-server-buffer) (point-min) (point-max)) (nntp-retrieve-data nil nntp-address nntp-port-number nntp-server-buffer wait-for nnheader-callback-function)) ;;; Interface functions. (nnoo-define-basics nntp) (defsubst nntp-next-result-arrived-p () (cond ;; A result that starts with a 2xx code is terminated by ;; a line with only a "." on it. ((eq (char-after) ?2) (if (re-search-forward "\n\\.\r?\n" nil t) (progn ;; Some broken news servers add another dot at the end. ;; Protect against inflooping there. (while (looking-at "^\\.\r?\n") (forward-line 1)) t) nil)) ;; A result that starts with a 3xx or 4xx code is terminated ;; by a newline. ((looking-at "[34]") (if (search-forward "\n" nil t) t nil)) ;; No result here. (t nil))) (eval-when-compile (defvar nntp-with-open-group-internal nil) (defvar nntp-report-n nil)) (defun nntp-with-open-group-function (-group -server -connectionless -bodyfun) "Protect against servers that don't like clients that keep idle connections opens. The problem being that these servers may either close a connection or simply ignore any further requests on a connection. Closed connections are not detected until `accept-process-output' has updated the `process-status'. Dropped connections are not detected until the connection timeouts (which may be several minutes) or `nntp-connection-timeout' has expired. When these occur `nntp-with-open-group', opens a new connection then re-issues the NNTP command whose response triggered the error." (letf ((nntp-report-n (symbol-function 'nntp-report)) ((symbol-function 'nntp-report) (symbol-function 'nntp-report-1)) (nntp-with-open-group-internal nil)) (while (catch 'nntp-with-open-group-error ;; Open the connection to the server ;; NOTE: Existing connections are NOT tested. (nntp-possibly-change-group -group -server -connectionless) (let ((-timer (and nntp-connection-timeout (run-at-time nntp-connection-timeout nil (lambda () (let* ((-process (nntp-find-connection nntp-server-buffer)) (-buffer (and -process (process-buffer -process)))) ;; When I an able to identify the ;; connection to the server AND I've ;; received NO reponse for ;; nntp-connection-timeout seconds. (when (and -buffer (eq 0 (buffer-size -buffer))) ;; Close the connection. Take no ;; other action as the accept input ;; code will handle the closed ;; connection. (nntp-kill-buffer -buffer)))))))) (unwind-protect (setq nntp-with-open-group-internal (condition-case nil (funcall -bodyfun) (quit (unless debug-on-quit (nntp-close-server)) (signal 'quit nil)))) (when -timer (nnheader-cancel-timer -timer))) nil)) (setf (symbol-function 'nntp-report) nntp-report-n)) nntp-with-open-group-internal)) (defmacro nntp-with-open-group (group server &optional connectionless &rest forms) "Protect against servers that don't like clients that keep idle connections opens. The problem being that these servers may either close a connection or simply ignore any further requests on a connection. Closed connections are not detected until `accept-process-output' has updated the `process-status'. Dropped connections are not detected until the connection timeouts (which may be several minutes) or `nntp-connection-timeout' has expired. When these occur `nntp-with-open-group', opens a new connection then re-issues the NNTP command whose response triggered the error." (declare (indent 2) (debug (form form [&optional symbolp] def-body))) (when (and (listp connectionless) (not (eq connectionless nil))) (setq forms (cons connectionless forms) connectionless nil)) `(nntp-with-open-group-function ,group ,server ,connectionless (lambda () ,@forms))) (deffoo nntp-retrieve-headers (articles &optional group server fetch-old) "Retrieve the headers of ARTICLES." (nntp-with-open-group group server (with-current-buffer (nntp-find-connection-buffer nntp-server-buffer) (erase-buffer) (if (and (not gnus-nov-is-evil) (not nntp-nov-is-evil) (nntp-retrieve-headers-with-xover articles fetch-old)) ;; We successfully retrieved the headers via XOVER. 'nov ;; XOVER didn't work, so we do it the hard, slow and inefficient ;; way. (let ((number (length articles)) (articles articles) (count 0) (received 0) (last-point (point-min)) (buf (nntp-find-connection-buffer nntp-server-buffer)) (nntp-inhibit-erase t) article) ;; Send HEAD commands. (while (setq article (pop articles)) (nntp-send-command nil "HEAD" (if (numberp article) (int-to-string article) ;; `articles' is either a list of article numbers ;; or a list of article IDs. article)) (incf count) ;; Every 400 requests we have to read the stream in ;; order to avoid deadlocks. (when (or (null articles) ;All requests have been sent. (zerop (% count nntp-maximum-request))) (nntp-accept-response) (while (progn (set-buffer buf) (goto-char last-point) ;; Count replies. (while (nntp-next-result-arrived-p) (setq last-point (point)) (incf received)) (< received count)) ;; If number of headers is greater than 100, give ;; informative messages. (and (numberp nntp-large-newsgroup) (> number nntp-large-newsgroup) (zerop (% received 20)) (nnheader-message 6 "NNTP: Receiving headers... %d%%" (/ (* received 100) number))) (nntp-accept-response)))) (and (numberp nntp-large-newsgroup) (> number nntp-large-newsgroup) (nnheader-message 6 "NNTP: Receiving headers...done")) ;; Now all of replies are received. Fold continuation lines. (nnheader-fold-continuation-lines) ;; Remove all "\r"'s. (nnheader-strip-cr) (nntp-copy-to-buffer nntp-server-buffer (point-min) (point-max)) 'headers))))) (deffoo nntp-retrieve-groups (groups &optional server) "Retrieve group info on GROUPS." (nntp-with-open-group nil server (when (nntp-find-connection-buffer nntp-server-buffer) (catch 'done (save-excursion ;; Erase nntp-server-buffer before nntp-inhibit-erase. (nntp-erase-buffer nntp-server-buffer) (set-buffer (nntp-find-connection-buffer nntp-server-buffer)) ;; The first time this is run, this variable is `try'. So we ;; try. (when (eq nntp-server-list-active-group 'try) (nntp-try-list-active (car groups))) (erase-buffer) (let ((count 0) (groups groups) (received 0) (last-point (point-min)) (nntp-inhibit-erase t) (buf (nntp-find-connection-buffer nntp-server-buffer)) (command (if nntp-server-list-active-group "LIST ACTIVE" "GROUP"))) (while groups ;; Timeout may have killed the buffer. (unless (gnus-buffer-live-p buf) (nnheader-report 'nntp "Connection to %s is closed." server) (throw 'done nil)) ;; Send the command to the server. (nntp-send-command nil command (pop groups)) (incf count) ;; Every 400 requests we have to read the stream in ;; order to avoid deadlocks. (when (or (null groups) ;All requests have been sent. (zerop (% count nntp-maximum-request))) (nntp-accept-response) (while (and (gnus-buffer-live-p buf) (progn ;; Search `blue moon' in this file for the ;; reason why set-buffer here. (set-buffer buf) (goto-char last-point) ;; Count replies. (while (re-search-forward "^[0-9]" nil t) (incf received)) (setq last-point (point)) (< received count))) (nntp-accept-response)))) ;; Wait for the reply from the final command. (unless (gnus-buffer-live-p buf) (nnheader-report 'nntp "Connection to %s is closed." server) (throw 'done nil)) (set-buffer buf) (goto-char (point-max)) (re-search-backward "^[0-9]" nil t) (when (looking-at "^[23]") (while (and (gnus-buffer-live-p buf) (progn (set-buffer buf) (goto-char (point-max)) (if (not nntp-server-list-active-group) (not (re-search-backward "\r?\n" (- (point) 3) t)) (not (re-search-backward "^\\.\r?\n" (- (point) 4) t))))) (nntp-accept-response))) ;; Now all replies are received. We remove CRs. (unless (gnus-buffer-live-p buf) (nnheader-report 'nntp "Connection to %s is closed." server) (throw 'done nil)) (set-buffer buf) (goto-char (point-min)) (while (search-forward "\r" nil t) (replace-match "" t t)) (if (not nntp-server-list-active-group) (progn (nntp-copy-to-buffer nntp-server-buffer (point-min) (point-max)) 'group) ;; We have read active entries, so we just delete the ;; superfluous gunk. (goto-char (point-min)) (while (re-search-forward "^[.2-5]" nil t) (delete-region (match-beginning 0) (progn (forward-line 1) (point)))) (nntp-copy-to-buffer nntp-server-buffer (point-min) (point-max)) 'active))))))) (deffoo nntp-retrieve-articles (articles &optional group server) (nntp-with-open-group group server (save-excursion (let ((number (length articles)) (articles articles) (count 0) (received 0) (last-point (point-min)) (buf (nntp-find-connection-buffer nntp-server-buffer)) (nntp-inhibit-erase t) (map (apply 'vector articles)) (point 1) article) (set-buffer buf) (erase-buffer) ;; Send ARTICLE command. (while (setq article (pop articles)) (nntp-send-command nil "ARTICLE" (if (numberp article) (int-to-string article) ;; `articles' is either a list of article numbers ;; or a list of article IDs. article)) (incf count) ;; Every 400 requests we have to read the stream in ;; order to avoid deadlocks. (when (or (null articles) ;All requests have been sent. (zerop (% count nntp-maximum-request))) (nntp-accept-response) (while (progn (set-buffer buf) (goto-char last-point) ;; Count replies. (while (nntp-next-result-arrived-p) (aset map received (cons (aref map received) (point))) (setq last-point (point)) (incf received)) (< received count)) ;; If number of headers is greater than 100, give ;; informative messages. (and (numberp nntp-large-newsgroup) (> number nntp-large-newsgroup) (zerop (% received 20)) (nnheader-message 6 "NNTP: Receiving articles... %d%%" (/ (* received 100) number))) (nntp-accept-response)))) (and (numberp nntp-large-newsgroup) (> number nntp-large-newsgroup) (nnheader-message 6 "NNTP: Receiving articles...done")) ;; Now we have all the responses. We go through the results, ;; wash it and copy it over to the server buffer. (set-buffer nntp-server-buffer) (erase-buffer) (setq last-point (point-min)) (mapcar (lambda (entry) (narrow-to-region (setq point (goto-char (point-max))) (progn (nntp-insert-buffer-substring buf last-point (cdr entry)) (point-max))) (setq last-point (cdr entry)) (nntp-decode-text) (widen) (cons (car entry) point)) map))))) (defun nntp-try-list-active (group) (nntp-list-active-group group) (with-current-buffer nntp-server-buffer (goto-char (point-min)) (cond ((or (eobp) (looking-at "5[0-9]+")) (setq nntp-server-list-active-group nil)) (t (setq nntp-server-list-active-group t))))) (deffoo nntp-list-active-group (group &optional server) "Return the active info on GROUP (which can be a regexp)." (nntp-with-open-group nil server (nntp-send-command "^\\.*\r?\n" "LIST ACTIVE" group))) (deffoo nntp-request-group-articles (group &optional server) "Return the list of existing articles in GROUP." (nntp-with-open-group nil server (nntp-send-command "^\\.*\r?\n" "LISTGROUP" group))) (deffoo nntp-request-article (article &optional group server buffer command) (nntp-with-open-group group server (when (nntp-send-command-and-decode "\r?\n\\.\r?\n" "ARTICLE" (if (numberp article) (int-to-string article) article)) (if (and buffer (not (equal buffer nntp-server-buffer))) (with-current-buffer nntp-server-buffer (copy-to-buffer buffer (point-min) (point-max)) (nntp-find-group-and-number group)) (nntp-find-group-and-number group))))) (deffoo nntp-request-head (article &optional group server) (nntp-with-open-group group server (when (nntp-send-command "\r?\n\\.\r?\n" "HEAD" (if (numberp article) (int-to-string article) article)) (prog1 (nntp-find-group-and-number group) (nntp-decode-text))))) (deffoo nntp-request-body (article &optional group server) (nntp-with-open-group group server (nntp-send-command-and-decode "\r?\n\\.\r?\n" "BODY" (if (numberp article) (int-to-string article) article)))) (deffoo nntp-request-group (group &optional server dont-check) (nntp-with-open-group nil server (when (nntp-send-command "^[245].*\n" "GROUP" group) (let ((entry (nntp-find-connection-entry nntp-server-buffer))) (setcar (cddr entry) group))))) (deffoo nntp-close-group (group &optional server) t) (deffoo nntp-server-opened (&optional server) "Say whether a connection to SERVER has been opened." (and (nnoo-current-server-p 'nntp server) nntp-server-buffer (gnus-buffer-live-p nntp-server-buffer) (nntp-find-connection nntp-server-buffer))) (deffoo nntp-open-server (server &optional defs connectionless) (nnheader-init-server-buffer) (if (nntp-server-opened server) t (when (or (stringp (car defs)) (numberp (car defs))) (setq defs (cons (list 'nntp-port-number (car defs)) (cdr defs)))) (unless (assq 'nntp-address defs) (setq defs (append defs (list (list 'nntp-address server))))) (nnoo-change-server 'nntp server defs) (unless connectionless (or (nntp-find-connection nntp-server-buffer) (nntp-open-connection nntp-server-buffer))))) (deffoo nntp-close-server (&optional server) (nntp-possibly-change-group nil server t) (let ((process (nntp-find-connection nntp-server-buffer))) (while process (when (memq (process-status process) '(open run)) (ignore-errors (nntp-send-string process "QUIT") (unless (eq nntp-open-connection-function 'nntp-open-network-stream) ;; Ok, this is evil, but when using telnet and stuff ;; as the connection method, it's important that the ;; QUIT command actually is sent out before we kill ;; the process. (sleep-for 1)))) (nntp-kill-buffer (process-buffer process)) (setq process (car (pop nntp-connection-alist)))) (nnoo-close-server 'nntp))) (deffoo nntp-request-close () (let (process) (while (setq process (pop nntp-connection-list)) (when (memq (process-status process) '(open run)) (ignore-errors (nntp-send-string process "QUIT") (unless (eq nntp-open-connection-function 'nntp-open-network-stream) ;; Ok, this is evil, but when using telnet and stuff ;; as the connection method, it's important that the ;; QUIT command actually is sent out before we kill ;; the process. (sleep-for 1)))) (nntp-kill-buffer (process-buffer process))))) (deffoo nntp-request-list (&optional server) (nntp-with-open-group nil server (nntp-send-command-and-decode "\r?\n\\.\r?\n" "LIST"))) (deffoo nntp-request-list-newsgroups (&optional server) (nntp-with-open-group nil server (nntp-send-command "\r?\n\\.\r?\n" "LIST NEWSGROUPS"))) (deffoo nntp-request-newgroups (date &optional server) (nntp-with-open-group nil server (with-current-buffer nntp-server-buffer (let* ((time (date-to-time date)) (ls (- (cadr time) (nth 8 (decode-time time))))) (cond ((< ls 0) (setcar time (1- (car time))) (setcar (cdr time) (+ ls 65536))) ((>= ls 65536) (setcar time (1+ (car time))) (setcar (cdr time) (- ls 65536))) (t (setcar (cdr time) ls))) (prog1 (nntp-send-command "^\\.\r?\n" "NEWGROUPS" (format-time-string "%y%m%d %H%M%S" time) "GMT") (nntp-decode-text)))))) (deffoo nntp-request-post (&optional server) (nntp-with-open-group nil server (when (nntp-send-command "^[23].*\r?\n" "POST") (let ((response (with-current-buffer nntp-server-buffer nntp-process-response)) server-id) (when (and response (string-match "^[23].*\\(<[^\t\n @<>]+@[^\t\n @<>]+>\\)" response)) (setq server-id (match-string 1 response)) (narrow-to-region (goto-char (point-min)) (if (search-forward "\n\n" nil t) (1- (point)) (point-max))) (unless (mail-fetch-field "Message-ID") (goto-char (point-min)) (insert "Message-ID: " server-id "\n")) (widen)) (run-hooks 'nntp-prepare-post-hook) (nntp-send-buffer "^[23].*\n"))))) (deffoo nntp-request-type (group article) 'news) (deffoo nntp-asynchronous-p () t) (deffoo nntp-request-set-mark (group actions &optional server) (unless nntp-marks-is-evil (nntp-possibly-create-directory group server) (nntp-open-marks group server) (dolist (action actions) (let ((range (nth 0 action)) (what (nth 1 action)) (marks (nth 2 action))) (assert (or (eq what 'add) (eq what 'del)) nil "Unknown request-set-mark action: %s" what) (dolist (mark marks) (setq nntp-marks (gnus-update-alist-soft mark (funcall (if (eq what 'add) 'gnus-range-add 'gnus-remove-from-range) (cdr (assoc mark nntp-marks)) range) nntp-marks))))) (nntp-save-marks group server)) nil) (deffoo nntp-request-update-info (group info &optional server) (unless nntp-marks-is-evil (nntp-possibly-create-directory group server) (when (nntp-marks-changed-p group server) (nnheader-message 8 "Updating marks for %s..." group) (nntp-open-marks group server) ;; Update info using `nntp-marks'. (mapc (lambda (pred) (unless (memq (cdr pred) gnus-article-unpropagated-mark-lists) (gnus-info-set-marks info (gnus-update-alist-soft (cdr pred) (cdr (assq (cdr pred) nntp-marks)) (gnus-info-marks info)) t))) gnus-article-mark-lists) (let ((seen (cdr (assq 'read nntp-marks)))) (gnus-info-set-read info (if (and (integerp (car seen)) (null (cdr seen))) (list (cons (car seen) (car seen))) seen))) (nnheader-message 8 "Updating marks for %s...done" group))) nil) ;;; Hooky functions. (defun nntp-send-mode-reader () "Send the MODE READER command to the nntp server. This function is supposed to be called from `nntp-server-opened-hook'. It will make innd servers spawn an nnrpd process to allow actual article reading." (nntp-send-command "^.*\n" "MODE READER")) (defun nntp-send-authinfo (&optional send-if-force) "Send the AUTHINFO to the nntp server. It will look in the \"~/.authinfo\" file for matching entries. If nothing suitable is found there, it will prompt for a user name and a password. If SEND-IF-FORCE, only send authinfo to the server if the .authinfo file has the FORCE token." (let* ((list (netrc-parse nntp-authinfo-file)) (alist (netrc-machine list nntp-address "nntp")) (force (or (netrc-get alist "force") nntp-authinfo-force)) (user (or (netrc-get alist "login") nntp-authinfo-user)) (passwd (netrc-get alist "password"))) (when (or (not send-if-force) force) (unless user (setq user (read-string (format "NNTP (%s) user name: " nntp-address)) nntp-authinfo-user user)) (unless (member user '(nil "")) (nntp-send-command "^3.*\r?\n" "AUTHINFO USER" user) (when t ;???Should check if AUTHINFO succeeded (nntp-send-command "^2.*\r?\n" "AUTHINFO PASS" (or passwd nntp-authinfo-password (setq nntp-authinfo-password (read-passwd (format "NNTP (%s@%s) password: " user nntp-address)))))))))) (defun nntp-send-nosy-authinfo () "Send the AUTHINFO to the nntp server." (let ((user (read-string (format "NNTP (%s) user name: " nntp-address)))) (unless (member user '(nil "")) (nntp-send-command "^3.*\r?\n" "AUTHINFO USER" user) (when t ;???Should check if AUTHINFO succeeded (nntp-send-command "^2.*\r?\n" "AUTHINFO PASS" (read-passwd (format "NNTP (%s@%s) password: " user nntp-address))))))) (defun nntp-send-authinfo-from-file () "Send the AUTHINFO to the nntp server. The authinfo login name is taken from the user's login name and the password contained in '~/.nntp-authinfo'." (when (file-exists-p "~/.nntp-authinfo") (with-temp-buffer (insert-file-contents "~/.nntp-authinfo") (goto-char (point-min)) (nntp-send-command "^3.*\r?\n" "AUTHINFO USER" (user-login-name)) (nntp-send-command "^2.*\r?\n" "AUTHINFO PASS" (buffer-substring (point) (point-at-eol)))))) ;;; Internal functions. (defun nntp-handle-authinfo (process) "Take care of an authinfo response from the server." (let ((last nntp-last-command)) (funcall nntp-authinfo-function) ;; We have to re-send the function that was interrupted by ;; the authinfo request. (nntp-erase-buffer nntp-server-buffer) (nntp-send-string process last))) (defun nntp-make-process-buffer (buffer) "Create a new, fresh buffer usable for nntp process connections." (with-current-buffer (generate-new-buffer (format " *server %s %s %s*" nntp-address nntp-port-number (gnus-buffer-exists-p buffer))) (mm-disable-multibyte) (set (make-local-variable 'after-change-functions) nil) (set (make-local-variable 'nntp-process-wait-for) nil) (set (make-local-variable 'nntp-process-callback) nil) (set (make-local-variable 'nntp-process-to-buffer) nil) (set (make-local-variable 'nntp-process-start-point) nil) (set (make-local-variable 'nntp-process-decode) nil) (current-buffer))) (defun nntp-open-connection (buffer) "Open a connection to PORT on ADDRESS delivering output to BUFFER." (run-hooks 'nntp-prepare-server-hook) (let* ((pbuffer (nntp-make-process-buffer buffer)) (timer (and nntp-connection-timeout (run-at-time nntp-connection-timeout nil `(lambda () (nntp-kill-buffer ,pbuffer))))) (process (condition-case () (let ((coding-system-for-read nntp-coding-system-for-read) (coding-system-for-write nntp-coding-system-for-write)) (funcall nntp-open-connection-function pbuffer)) (error nil) (quit (message "Quit opening connection to %s" nntp-address) (nntp-kill-buffer pbuffer) (signal 'quit nil) nil)))) (when timer (nnheader-cancel-timer timer)) (unless process (nntp-kill-buffer pbuffer)) (when (and (buffer-name pbuffer) process) (gnus-set-process-query-on-exit-flag process nil) (if (and (nntp-wait-for process "^2.*\n" buffer nil t) (memq (process-status process) '(open run))) (prog1 (caar (push (list process buffer nil) nntp-connection-alist)) (push process nntp-connection-list) (with-current-buffer pbuffer (nntp-read-server-type) (erase-buffer) (set-buffer nntp-server-buffer) (let ((nnheader-callback-function nil)) (run-hooks 'nntp-server-opened-hook) (nntp-send-authinfo t)))) (nntp-kill-buffer (process-buffer process)) nil)))) (defun nntp-open-network-stream (buffer) (open-network-stream "nntpd" buffer nntp-address nntp-port-number)) (eval-and-compile (autoload 'format-spec "format-spec") (autoload 'format-spec-make "format-spec") (autoload 'open-tls-stream "tls")) (defun nntp-open-ssl-stream (buffer) (let* ((process-connection-type nil) (proc (start-process "nntpd" buffer shell-file-name shell-command-switch (format-spec nntp-ssl-program (format-spec-make ?s nntp-address ?p nntp-port-number))))) (gnus-set-process-query-on-exit-flag proc nil) (with-current-buffer buffer (let ((nntp-connection-alist (list proc buffer nil))) (nntp-wait-for-string "^\r*20[01]")) (beginning-of-line) (delete-region (point-min) (point)) proc))) (defun nntp-open-tls-stream (buffer) (let ((proc (open-tls-stream "nntpd" buffer nntp-address nntp-port-number))) (gnus-set-process-query-on-exit-flag proc nil) (with-current-buffer buffer (let ((nntp-connection-alist (list proc buffer nil))) (nntp-wait-for-string "^\r*20[01]")) (beginning-of-line) (delete-region (point-min) (point)) proc))) (defun nntp-read-server-type () "Find out what the name of the server we have connected to is." ;; Wait for the status string to arrive. (setq nntp-server-type (buffer-string)) (let ((case-fold-search t)) ;; Run server-specific commands. (dolist (entry nntp-server-action-alist) (when (string-match (car entry) nntp-server-type) (if (and (listp (cadr entry)) (not (eq 'lambda (caadr entry)))) (eval (cadr entry)) (funcall (cadr entry))))))) (defun nntp-async-wait (process wait-for buffer decode callback) (with-current-buffer (process-buffer process) (unless nntp-inside-change-function (erase-buffer)) (setq nntp-process-wait-for wait-for nntp-process-to-buffer buffer nntp-process-decode decode nntp-process-callback callback nntp-process-start-point (point-max)) (setq after-change-functions '(nntp-after-change-function)) (if nntp-async-needs-kluge (nntp-async-kluge process)))) (defun nntp-async-kluge (process) ;; emacs 20.3 bug: process output with encoding 'binary ;; doesn't trigger after-change-functions. (unless nntp-async-timer (setq nntp-async-timer (run-at-time 1 1 'nntp-async-timer-handler))) (add-to-list 'nntp-async-process-list process)) (defun nntp-async-timer-handler () (mapcar (lambda (proc) (if (memq (process-status proc) '(open run)) (nntp-async-trigger proc) (nntp-async-stop proc))) nntp-async-process-list)) (defun nntp-async-stop (proc) (setq nntp-async-process-list (delq proc nntp-async-process-list)) (when (and nntp-async-timer (not nntp-async-process-list)) (nnheader-cancel-timer nntp-async-timer) (setq nntp-async-timer nil))) (defun nntp-after-change-function (beg end len) (unwind-protect ;; we only care about insertions at eob (when (and (eq 0 len) (eq (point-max) end)) (save-match-data (let ((proc (get-buffer-process (current-buffer)))) (when proc (nntp-async-trigger proc))))) ;; any throw from after-change-functions will leave it ;; set to nil. so we reset it here, if necessary. (when quit-flag (setq after-change-functions '(nntp-after-change-function))))) (defun nntp-async-trigger (process) (with-current-buffer (process-buffer process) (when nntp-process-callback ;; do we have an error message? (goto-char nntp-process-start-point) (if (memq (following-char) '(?4 ?5)) ;; wants credentials? (if (looking-at "480") (nntp-handle-authinfo process) ;; report error message. (nntp-snarf-error-message) (nntp-do-callback nil)) ;; got what we expect? (goto-char (point-max)) (when (re-search-backward nntp-process-wait-for nntp-process-start-point t) (let ((response (match-string 0))) (with-current-buffer nntp-server-buffer (setq nntp-process-response response))) (nntp-async-stop process) ;; convert it. (when (gnus-buffer-exists-p nntp-process-to-buffer) (let ((buf (current-buffer)) (start nntp-process-start-point) (decode nntp-process-decode)) (with-current-buffer nntp-process-to-buffer (goto-char (point-max)) (save-restriction (narrow-to-region (point) (point)) (nntp-insert-buffer-substring buf start) (when decode (nntp-decode-text)))))) ;; report it. (goto-char (point-max)) (nntp-do-callback (buffer-name (get-buffer nntp-process-to-buffer)))))))) (defun nntp-do-callback (arg) (let ((callback nntp-process-callback) (nntp-inside-change-function t)) (setq nntp-process-callback nil) (funcall callback arg))) (defun nntp-snarf-error-message () "Save the error message in the current buffer." (let ((message (buffer-string))) (while (string-match "[\r\n]+" message) (setq message (replace-match " " t t message))) (nnheader-report 'nntp message) message)) (defun nntp-accept-process-output (process) "Wait for output from PROCESS and message some dots." (with-current-buffer (or (nntp-find-connection-buffer nntp-server-buffer) nntp-server-buffer) (let ((len (/ (buffer-size) 1024)) message-log-max) (unless (< len 10) (setq nntp-have-messaged t) (nnheader-message 7 "nntp read: %dk" len))) (prog1 (nnheader-accept-process-output process) ;; accept-process-output may update status of process to indicate ;; that the server has closed the connection. This MUST be ;; handled here as the buffer restored by the save-excursion may ;; be the process's former output buffer (i.e. now killed) (or (and process (memq (process-status process) '(open run))) (nntp-report "Server closed connection"))))) (defun nntp-accept-response () "Wait for output from the process that outputs to BUFFER." (nntp-accept-process-output (nntp-find-connection nntp-server-buffer))) (defun nntp-possibly-change-group (group server &optional connectionless) (let ((nnheader-callback-function nil)) (when server (or (nntp-server-opened server) (nntp-open-server server nil connectionless))) (unless connectionless (or (nntp-find-connection nntp-server-buffer) (nntp-open-connection nntp-server-buffer)))) (when group (let ((entry (nntp-find-connection-entry nntp-server-buffer))) (cond ((not entry) (nntp-report "Server closed connection")) ((not (equal group (caddr entry))) (with-current-buffer (process-buffer (car entry)) (erase-buffer) (nntp-send-command "^[245].*\n" "GROUP" group) (setcar (cddr entry) group) (erase-buffer) (nntp-erase-buffer nntp-server-buffer))))))) (defun nntp-decode-text (&optional cr-only) "Decode the text in the current buffer." (goto-char (point-min)) (while (search-forward "\r" nil t) (delete-char -1)) (unless cr-only ;; Remove trailing ".\n" end-of-transfer marker. (goto-char (point-max)) (forward-line -1) (when (looking-at ".\n") (delete-char 2)) ;; Delete status line. (goto-char (point-min)) (while (looking-at "[1-5][0-9][0-9] .*\n") ;; For some unknown reason, there is more than one status line. (delete-region (point) (progn (forward-line 1) (point)))) ;; Remove "." -> ".." encoding. (while (search-forward "\n.." nil t) (delete-char -1)))) (defun nntp-encode-text () "Encode the text in the current buffer." (save-excursion ;; Replace "." at beginning of line with "..". (goto-char (point-min)) (while (re-search-forward "^\\." nil t) (insert ".")) (goto-char (point-max)) ;; Insert newline at the end of the buffer. (unless (bolp) (insert "\n")) ;; Insert `.' at end of buffer (end of text mark). (goto-char (point-max)) (insert ".\n") (goto-char (point-min)) (while (not (eobp)) (end-of-line) (delete-char 1) (insert nntp-end-of-line)))) (defun nntp-retrieve-headers-with-xover (articles &optional fetch-old) (set-buffer nntp-server-buffer) (erase-buffer) (cond ;; This server does not talk NOV. ((not nntp-server-xover) nil) ;; We don't care about gaps. ((or (not nntp-nov-gap) fetch-old) (nntp-send-xover-command (if fetch-old (if (numberp fetch-old) (max 1 (- (car articles) fetch-old)) 1) (car articles)) (car (last articles)) 'wait) (goto-char (point-min)) (when (looking-at "[1-5][0-9][0-9] .*\n") (delete-region (point) (progn (forward-line 1) (point)))) (while (search-forward "\r" nil t) (replace-match "" t t)) (goto-char (point-max)) (forward-line -1) (when (looking-at "\\.") (delete-region (point) (progn (forward-line 1) (point))))) ;; We do it the hard way. For each gap, an XOVER command is sent ;; to the server. We do not wait for a reply from the server, we ;; just send them off as fast as we can. That means that we have ;; to count the number of responses we get back to find out when we ;; have gotten all we asked for. ((numberp nntp-nov-gap) (let ((count 0) (received 0) last-point in-process-buffer-p (buf nntp-server-buffer) (process-buffer (nntp-find-connection-buffer nntp-server-buffer)) first last status) ;; We have to check `nntp-server-xover'. If it gets set to nil, ;; that means that the server does not understand XOVER, but we ;; won't know that until we try. (while (and nntp-server-xover articles) (setq first (car articles)) ;; Search forward until we find a gap, or until we run out of ;; articles. (while (and (cdr articles) (< (- (nth 1 articles) (car articles)) nntp-nov-gap)) (setq articles (cdr articles))) (setq in-process-buffer-p (stringp nntp-server-xover)) (nntp-send-xover-command first (setq last (car articles))) (setq articles (cdr articles)) (when (and nntp-server-xover in-process-buffer-p) ;; Don't count tried request. (setq count (1+ count)) ;; Every 400 requests we have to read the stream in ;; order to avoid deadlocks. (when (or (null articles) ;All requests have been sent. (= 1 (% count nntp-maximum-request))) (nntp-accept-response) ;; On some Emacs versions the preceding function has a ;; tendency to change the buffer. Perhaps. It's quite ;; difficult to reproduce, because it only seems to happen ;; once in a blue moon. (set-buffer process-buffer) (while (progn (goto-char (or last-point (point-min))) ;; Count replies. (while (re-search-forward "^\\([0-9][0-9][0-9]\\) .*\n" nil t) (incf received) (setq status (match-string 1)) (if (string-match "^[45]" status) (setq status 'error) (setq status 'ok))) (setq last-point (point)) (or (< received count) (if (eq status 'error) nil ;; I haven't started reading the final response (progn (goto-char (point-max)) (forward-line -1) (not (looking-at "^\\.\r?\n")))))) ;; I haven't read the end of the final response (nntp-accept-response) (set-buffer process-buffer)))) ;; Some nntp servers seem to have an extension to the XOVER ;; extension. On these servers, requesting an article range ;; preceeding the active range does not return an error as ;; specified in the RFC. What we instead get is the NOV entry ;; for the first available article. Obviously, a client can ;; use that entry to avoid making unnecessary requests. The ;; only problem is for a client that assumes that the response ;; will always be within the requested ranage. For such a ;; client, we can get N copies of the same entry (one for each ;; XOVER command sent to the server). (when (<= count 1) (goto-char (point-min)) (when (re-search-forward "^[0-9][0-9][0-9] .*\n\\([0-9]+\\)" nil t) (let ((low-limit (string-to-number (buffer-substring (match-beginning 1) (match-end 1))))) (while (and articles (<= (car articles) low-limit)) (setq articles (cdr articles)))))) (set-buffer buf)) (when nntp-server-xover (when in-process-buffer-p (set-buffer buf) (goto-char (point-max)) (nntp-insert-buffer-substring process-buffer) (set-buffer process-buffer) (erase-buffer) (set-buffer buf)) ;; We remove any "." lines and status lines. (goto-char (point-min)) (while (search-forward "\r" nil t) (delete-char -1)) (goto-char (point-min)) (delete-matching-lines "^\\.$\\|^[1-5][0-9][0-9] ") t)))) nntp-server-xover) (defun nntp-send-xover-command (beg end &optional wait-for-reply) "Send the XOVER command to the server." (let ((range (format "%d-%d" beg end)) (nntp-inhibit-erase t)) (if (stringp nntp-server-xover) ;; If `nntp-server-xover' is a string, then we just send this ;; command. (if wait-for-reply (nntp-send-command-nodelete "\r?\n\\.\r?\n" nntp-server-xover range) ;; We do not wait for the reply. (nntp-send-command-nodelete nil nntp-server-xover range)) (let ((commands nntp-xover-commands)) ;; `nntp-xover-commands' is a list of possible XOVER commands. ;; We try them all until we get at positive response. (while (and commands (eq nntp-server-xover 'try)) (nntp-send-command-nodelete "\r?\n\\.\r?\n" (car commands) range) (with-current-buffer nntp-server-buffer (goto-char (point-min)) (and (looking-at "[23]") ; No error message. ;; We also have to look at the lines. Some buggy ;; servers give back simple lines with just the ;; article number. How... helpful. (progn (forward-line 1) ;; More text after number, or a dot. (looking-at "[0-9]+\t...\\|\\.\r?\n")) (setq nntp-server-xover (car commands)))) (setq commands (cdr commands))) ;; If none of the commands worked, we disable XOVER. (when (eq nntp-server-xover 'try) (nntp-erase-buffer nntp-server-buffer) (setq nntp-server-xover nil)) nntp-server-xover)))) (defun nntp-find-group-and-number (&optional group) (save-excursion (save-restriction ;; FIXME: This is REALLY FISHY: set-buffer after save-restriction?!? (set-buffer nntp-server-buffer) (narrow-to-region (goto-char (point-min)) (or (search-forward "\n\n" nil t) (point-max))) (goto-char (point-min)) ;; We first find the number by looking at the status line. (let ((number (and (looking-at "2[0-9][0-9] +\\([0-9]+\\) ") (string-to-number (buffer-substring (match-beginning 1) (match-end 1))))) newsgroups xref) (and number (zerop number) (setq number nil)) (if number ;; Then we find the group name. (setq group (cond ;; If there is only one group in the Newsgroups ;; header, then it seems quite likely that this ;; article comes from that group, I'd say. ((and (setq newsgroups (mail-fetch-field "newsgroups")) (not (string-match "," newsgroups))) newsgroups) ;; If there is more than one group in the ;; Newsgroups header, then the Xref header should ;; be filled out. We hazard a guess that the group ;; that has this article number in the Xref header ;; is the one we are looking for. This might very ;; well be wrong if this article happens to have ;; the same number in several groups, but that's ;; life. ((and (setq xref (mail-fetch-field "xref")) number (string-match (format "\\([^ :]+\\):%d" number) xref)) (match-string 1 xref)) (t ""))) (cond ((and (not nntp-xref-number-is-evil) (setq xref (mail-fetch-field "xref")) (string-match (if group (concat "\\(" (regexp-quote group) "\\):\\([0-9]+\\)") "\\([^ :]+\\):\\([0-9]+\\)") xref)) (setq group (match-string 1 xref) number (string-to-number (match-string 2 xref)))) ((and (setq newsgroups (mail-fetch-field "newsgroups")) (not (string-match "," newsgroups))) (setq group newsgroups)) (group) (t (setq group "")))) (when (string-match "\r" group) (setq group (substring group 0 (match-beginning 0)))) (cons group number))))) (defun nntp-wait-for-string (regexp) "Wait until string arrives in the buffer." (let ((buf (current-buffer)) proc) (goto-char (point-min)) (while (and (setq proc (get-buffer-process buf)) (memq (process-status proc) '(open run)) (not (re-search-forward regexp nil t))) (accept-process-output proc) (set-buffer buf) (goto-char (point-min))))) ;; ========================================================================== ;; Obsolete nntp-open-* connection methods -- drv ;; ========================================================================== (defvoo nntp-open-telnet-envuser nil "*If non-nil, telnet session (client and server both) will support the ENVIRON option and not prompt for login name.") (defvoo nntp-telnet-shell-prompt "bash\\|\$ *\r?$\\|> *\r?" "*Regular expression to match the shell prompt on the remote machine.") (defvoo nntp-rlogin-program "rsh" "*Program used to log in on remote machines. The default is \"rsh\", but \"ssh\" is a popular alternative.") (defvoo nntp-rlogin-parameters '("telnet" "-8" "${NNTPSERVER:=news}" "nntp") "*Parameters to `nntp-open-rlogin'. That function may be used as `nntp-open-connection-function'. In that case, this list will be used as the parameter list given to rsh.") (defvoo nntp-rlogin-user-name nil "*User name on remote system when using the rlogin connect method.") (defvoo nntp-telnet-parameters '("exec" "telnet" "-8" "${NNTPSERVER:=news}" "nntp") "*Parameters to `nntp-open-telnet'. That function may be used as `nntp-open-connection-function'. In that case, this list will be executed as a command after logging in via telnet.") (defvoo nntp-telnet-user-name nil "User name to log in via telnet with.") (defvoo nntp-telnet-passwd nil "Password to use to log in via telnet with.") (defun nntp-service-to-port (svc) (cond ((integerp svc) (number-to-string svc)) ((string-match "\\`[[:digit:]]\\'" svc) svc) (t (with-temp-buffer (ignore-errors (insert-file-contents "/etc/services")) (goto-char (point-min)) (if (re-search-forward (concat "^" (regexp-quote svc) "[ \t]+\\([[:digit:]]+\\)/tcp")) (match-string 1) svc))))) (defun nntp-open-telnet (buffer) (with-current-buffer buffer (erase-buffer) (let ((proc (apply 'start-process "nntpd" buffer nntp-telnet-command nntp-telnet-switches)) (case-fold-search t)) (when (memq (process-status proc) '(open run)) (nntp-wait-for-string "^r?telnet") (process-send-string proc "set escape \^X\n") (cond ((and nntp-open-telnet-envuser nntp-telnet-user-name) (process-send-string proc (concat "open " "-l" nntp-telnet-user-name nntp-address "\n"))) (t (process-send-string proc (concat "open " nntp-address "\n")))) (cond ((not nntp-open-telnet-envuser) (nntp-wait-for-string "^\r*.?login:") (process-send-string proc (concat (or nntp-telnet-user-name (setq nntp-telnet-user-name (read-string "login: "))) "\n")))) (nntp-wait-for-string "^\r*.?password:") (process-send-string proc (concat (or nntp-telnet-passwd (setq nntp-telnet-passwd (read-passwd "Password: "))) "\n")) (nntp-wait-for-string nntp-telnet-shell-prompt) (process-send-string proc (concat (mapconcat 'identity nntp-telnet-parameters " ") "\n")) (nntp-wait-for-string "^\r*20[01]") (beginning-of-line) (delete-region (point-min) (point)) (process-send-string proc "\^]") (nntp-wait-for-string "^r?telnet") (process-send-string proc "mode character\n") (accept-process-output proc 1) (sit-for 1) (goto-char (point-min)) (forward-line 1) (delete-region (point) (point-max))) proc))) (defun nntp-open-rlogin (buffer) "Open a connection to SERVER using rsh." (let ((proc (if nntp-rlogin-user-name (apply 'start-process "nntpd" buffer nntp-rlogin-program nntp-address "-l" nntp-rlogin-user-name nntp-rlogin-parameters) (apply 'start-process "nntpd" buffer nntp-rlogin-program nntp-address nntp-rlogin-parameters)))) (with-current-buffer buffer (nntp-wait-for-string "^\r*20[01]") (beginning-of-line) (delete-region (point-min) (point)) proc))) ;; ========================================================================== ;; Replacements for the nntp-open-* functions -- drv ;; ========================================================================== (defun nntp-open-telnet-stream (buffer) "Open a nntp connection by telnet'ing the news server. `nntp-open-netcat-stream' is recommended in place of this function because it is more reliable. Please refer to the following variables to customize the connection: - `nntp-pre-command', - `nntp-telnet-command', - `nntp-telnet-switches', - `nntp-address', - `nntp-port-number', - `nntp-end-of-line'." (let ((command `(,nntp-telnet-command ,@nntp-telnet-switches ,nntp-address ,(nntp-service-to-port nntp-port-number))) proc) (and nntp-pre-command (push nntp-pre-command command)) (setq proc (apply 'start-process "nntpd" buffer command)) (with-current-buffer buffer (nntp-wait-for-string "^\r*20[01]") (beginning-of-line) (delete-region (point-min) (point)) proc))) (defun nntp-open-via-rlogin-and-telnet (buffer) "Open a connection to an nntp server through an intermediate host. First rlogin to the remote host, and then telnet the real news server from there. `nntp-open-via-rlogin-and-netcat' is recommended in place of this function because it is more reliable. Please refer to the following variables to customize the connection: - `nntp-pre-command', - `nntp-via-rlogin-command', - `nntp-via-rlogin-command-switches', - `nntp-via-user-name', - `nntp-via-address', - `nntp-telnet-command', - `nntp-telnet-switches', - `nntp-address', - `nntp-port-number', - `nntp-end-of-line'." (let ((command `(,nntp-via-address ,nntp-telnet-command ,@nntp-telnet-switches)) proc) (when nntp-via-user-name (setq command `("-l" ,nntp-via-user-name ,@command))) (when nntp-via-rlogin-command-switches (setq command (append nntp-via-rlogin-command-switches command))) (push nntp-via-rlogin-command command) (and nntp-pre-command (push nntp-pre-command command)) (setq proc (apply 'start-process "nntpd" buffer command)) (with-current-buffer buffer (nntp-wait-for-string "^r?telnet") (process-send-string proc (concat "open " nntp-address " " (nntp-service-to-port nntp-port-number) "\n")) (nntp-wait-for-string "^\r*20[01]") (beginning-of-line) (delete-region (point-min) (point)) (process-send-string proc "\^]") (nntp-wait-for-string "^r?telnet") (process-send-string proc "mode character\n") (accept-process-output proc 1) (sit-for 1) (goto-char (point-min)) (forward-line 1) (delete-region (point) (point-max))) proc)) (defun nntp-open-via-rlogin-and-netcat (buffer) "Open a connection to an nntp server through an intermediate host. First rlogin to the remote host, and then connect to the real news server from there using the netcat command. Please refer to the following variables to customize the connection: - `nntp-pre-command', - `nntp-via-rlogin-command', - `nntp-via-rlogin-command-switches', - `nntp-via-user-name', - `nntp-via-address', - `nntp-netcat-command', - `nntp-netcat-switches', - `nntp-address', - `nntp-port-number'." (let ((command `(,@(when nntp-pre-command (list nntp-pre-command)) ,nntp-via-rlogin-command ,@nntp-via-rlogin-command-switches ,@(when nntp-via-user-name (list "-l" nntp-via-user-name)) ,nntp-via-address ,nntp-netcat-command ,@nntp-netcat-switches ,nntp-address ,(nntp-service-to-port nntp-port-number)))) ;; A non-nil connection type results in mightily odd behavior where ;; (process-send-string proc "\^M") ends up sending a "\n" to the ;; ssh process. --Stef ;; Also a nil connection allow ssh-askpass to work under X11. (let ((process-connection-type nil)) (apply 'start-process "nntpd" buffer command)))) (defun nntp-open-netcat-stream (buffer) "Open a connection to an nntp server through netcat. I.e. use the `nc' command rather than Emacs's builtin networking code. Please refer to the following variables to customize the connection: - `nntp-pre-command', - `nntp-netcat-command', - `nntp-netcat-switches', - `nntp-address', - `nntp-port-number'." (let ((command `(,nntp-netcat-command ,@nntp-netcat-switches ,nntp-address ,(nntp-service-to-port nntp-port-number)))) (and nntp-pre-command (push nntp-pre-command command)) (let ((process-connection-type nil)) ;See `nntp-open-via-rlogin-and-netcat'. (apply 'start-process "nntpd" buffer command)))) (defun nntp-open-via-telnet-and-telnet (buffer) "Open a connection to an nntp server through an intermediate host. First telnet the remote host, and then telnet the real news server from there. Please refer to the following variables to customize the connection: - `nntp-pre-command', - `nntp-via-telnet-command', - `nntp-via-telnet-switches', - `nntp-via-address', - `nntp-via-envuser', - `nntp-via-user-name', - `nntp-via-user-password', - `nntp-via-shell-prompt', - `nntp-telnet-command', - `nntp-telnet-switches', - `nntp-address', - `nntp-port-number', - `nntp-end-of-line'." (with-current-buffer buffer (erase-buffer) (let ((command `(,nntp-via-telnet-command ,@nntp-via-telnet-switches)) (case-fold-search t) proc) (and nntp-pre-command (push nntp-pre-command command)) (setq proc (apply 'start-process "nntpd" buffer command)) (when (memq (process-status proc) '(open run)) (nntp-wait-for-string "^r?telnet") (process-send-string proc "set escape \^X\n") (cond ((and nntp-via-envuser nntp-via-user-name) (process-send-string proc (concat "open " "-l" nntp-via-user-name nntp-via-address "\n"))) (t (process-send-string proc (concat "open " nntp-via-address "\n")))) (when (not nntp-via-envuser) (nntp-wait-for-string "^\r*.?login:") (process-send-string proc (concat (or nntp-via-user-name (setq nntp-via-user-name (read-string "login: "))) "\n"))) (nntp-wait-for-string "^\r*.?password:") (process-send-string proc (concat (or nntp-via-user-password (setq nntp-via-user-password (read-passwd "Password: "))) "\n")) (nntp-wait-for-string nntp-via-shell-prompt) (let ((real-telnet-command `("exec" ,nntp-telnet-command ,@nntp-telnet-switches ,nntp-address ,(nntp-service-to-port nntp-port-number)))) (process-send-string proc (concat (mapconcat 'identity real-telnet-command " ") "\n"))) (nntp-wait-for-string "^\r*20[01]") (beginning-of-line) (delete-region (point-min) (point)) (process-send-string proc "\^]") (nntp-wait-for-string "^r?telnet") (process-send-string proc "mode character\n") (accept-process-output proc 1) (sit-for 1) (goto-char (point-min)) (forward-line 1) (delete-region (point) (point-max))) proc))) ;; Marks handling (defun nntp-marks-directory (server) (expand-file-name server nntp-marks-directory)) (defvar nntp-server-to-method-cache nil "Alist of servers and select methods.") (defun nntp-group-pathname (server group &optional file) "Return an absolute file name of FILE for GROUP on SERVER." (let ((method (cdr (assoc server nntp-server-to-method-cache)))) (unless method (push (cons server (setq method (or (gnus-server-to-method server) (gnus-find-method-for-group group)))) nntp-server-to-method-cache)) (nnmail-group-pathname (mm-decode-coding-string group (inline (gnus-group-name-charset method group))) (nntp-marks-directory server) file))) (defun nntp-possibly-create-directory (group server) (let ((dir (nntp-group-pathname server group)) (file-name-coding-system nnmail-pathname-coding-system)) (unless (file-exists-p dir) (make-directory (directory-file-name dir) t) (nnheader-message 5 "Creating nntp marks directory %s" dir)))) (eval-and-compile (autoload 'time-less-p "time-date")) (defun nntp-marks-changed-p (group server) (let ((file (nntp-group-pathname server group nntp-marks-file-name)) (file-name-coding-system nnmail-pathname-coding-system)) (if (null (gnus-gethash file nntp-marks-modtime)) t ;; never looked at marks file, assume it has changed (time-less-p (gnus-gethash file nntp-marks-modtime) (nth 5 (file-attributes file)))))) (defun nntp-save-marks (group server) (let ((file-name-coding-system nnmail-pathname-coding-system) (file (nntp-group-pathname server group nntp-marks-file-name))) (condition-case err (progn (nntp-possibly-create-directory group server) (with-temp-file file (erase-buffer) (gnus-prin1 nntp-marks) (insert "\n")) (gnus-sethash file (nth 5 (file-attributes file)) nntp-marks-modtime)) (error (or (gnus-yes-or-no-p (format "Could not write to %s (%s). Continue? " file err)) (error "Cannot write to %s (%s)" file err)))))) (defun nntp-open-marks (group server) (let ((file (nntp-group-pathname server group nntp-marks-file-name)) (file-name-coding-system nnmail-pathname-coding-system)) (if (file-exists-p file) (condition-case err (with-temp-buffer (gnus-sethash file (nth 5 (file-attributes file)) nntp-marks-modtime) (nnheader-insert-file-contents file) (setq nntp-marks (read (current-buffer))) (dolist (el gnus-article-unpropagated-mark-lists) (setq nntp-marks (gnus-remassoc el nntp-marks)))) (error (or (gnus-yes-or-no-p (format "Error reading nntp marks file %s (%s). Continuing will use marks from .newsrc.eld. Continue? " file err)) (error "Cannot read nntp marks file %s (%s)" file err)))) ;; User didn't have a .marks file. Probably first time ;; user of the .marks stuff. Bootstrap it from .newsrc.eld. (let ((info (gnus-get-info (gnus-group-prefixed-name group (gnus-server-to-method (format "nntp:%s" server))))) (decoded-name (mm-decode-coding-string group (gnus-group-name-charset (gnus-server-to-method server) group)))) (nnheader-message 7 "Bootstrapping marks for %s..." decoded-name) (setq nntp-marks (gnus-info-marks info)) (push (cons 'read (gnus-info-read info)) nntp-marks) (dolist (el gnus-article-unpropagated-mark-lists) (setq nntp-marks (gnus-remassoc el nntp-marks))) (nntp-save-marks group server) (nnheader-message 7 "Bootstrapping marks for %s...done" decoded-name))))) (provide 'nntp) ;; arch-tag: 8655466a-b1b5-4929-9c45-7b1b2e767271 ;;; nntp.el ends here gnus-5.11+v0.10.dfsg/lisp/canlock.el0000644000175000017500000002130311004005110017154 0ustar tvainikatvainika;;; canlock.el --- functions for Cancel-Lock feature ;; Copyright (C) 1998, 1999, 2001, 2002, 2003, 2004, ;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc. ;; Author: Katsumi Yamaoka ;; Keywords: news, cancel-lock, hmac, sha1, rfc2104 ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 3, or (at your option) ;; any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Commentary: ;; Canlock is a library for generating and verifying Cancel-Lock and/or ;; Cancel-Key header in news articles. This is used to protect articles ;; from rogue cancel, supersede or replace attacks. The method is based ;; on draft-ietf-usefor-cancel-lock-01.txt which was released on November ;; 3rd 1998. For instance, you can add Cancel-Lock (and possibly Cancel- ;; Key) header in a news article by using a hook which will be evaluated ;; just before sending an article as follows: ;; ;; (add-hook '*e**a*e-header-hook 'canlock-insert-header t) ;; ;; Verifying Cancel-Lock is mainly a function of news servers, however, ;; you can verify your own article using the command `canlock-verify' in ;; the (raw) article buffer. You will be prompted for the password for ;; each time if the option `canlock-password' or `canlock-password-for- ;; verify' is nil. Note that setting these options is a bit unsafe. ;;; Code: (eval-when-compile (require 'cl)) (require 'sha1) (defvar mail-header-separator) (defgroup canlock nil "The Cancel-Lock feature." :group 'news) (defcustom canlock-password nil "Password to use when signing a Cancel-Lock or a Cancel-Key header." :type '(radio (const :format "Not specified " nil) (string :tag "Password")) :group 'canlock) (defcustom canlock-password-for-verify canlock-password "Password to use when verifying a Cancel-Lock or a Cancel-Key header." :type '(radio (const :format "Not specified " nil) (string :tag "Password")) :group 'canlock) (defcustom canlock-force-insert-header nil "If non-nil, insert a Cancel-Lock or a Cancel-Key header even if the buffer does not look like a news message." :type 'boolean :group 'canlock) (eval-when-compile (defmacro canlock-string-as-unibyte (string) "Return a unibyte string with the same individual bytes as STRING." (if (fboundp 'string-as-unibyte) (list 'string-as-unibyte string) string))) (defun canlock-sha1 (message) "Make a SHA-1 digest of MESSAGE as a unibyte string of length 20 bytes." (let (sha1-maximum-internal-length) (sha1 message nil nil 'binary))) (defun canlock-make-cancel-key (message-id password) "Make a Cancel-Key header." (when (> (length password) 20) (setq password (canlock-sha1 password))) (setq password (concat password (make-string (- 64 (length password)) 0))) (let ((ipad (mapconcat (lambda (byte) (char-to-string (logxor 54 byte))) password "")) (opad (mapconcat (lambda (byte) (char-to-string (logxor 92 byte))) password ""))) (base64-encode-string (canlock-sha1 (concat opad (canlock-sha1 (concat ipad (canlock-string-as-unibyte message-id)))))))) (defun canlock-narrow-to-header () "Narrow the buffer to the head of the message." (let (case-fold-search) (narrow-to-region (goto-char (point-min)) (goto-char (if (re-search-forward (format "^$\\|^%s$" (regexp-quote mail-header-separator)) nil t) (match-beginning 0) (point-max)))))) (defun canlock-delete-headers () "Delete Cancel-Key or Cancel-Lock headers in the narrowed buffer." (let ((case-fold-search t)) (goto-char (point-min)) (while (re-search-forward "^Cancel-\\(Key\\|Lock\\):" nil t) (delete-region (match-beginning 0) (if (re-search-forward "^[^\t ]" nil t) (goto-char (match-beginning 0)) (point-max)))))) (defun canlock-fetch-fields (&optional key) "Return a list of the values of Cancel-Lock header. If KEY is non-nil, look for a Cancel-Key header instead. The buffer is expected to be narrowed to just the headers of the message." (let ((field (mail-fetch-field (if key "Cancel-Key" "Cancel-Lock"))) fields rest (case-fold-search t)) (when field (setq fields (split-string field "[\t\n\r ,]+")) (while fields (when (string-match "^sha1:" (setq field (pop fields))) (push (substring field 5) rest))) (nreverse rest)))) (defun canlock-fetch-id-for-key () "Return a Message-ID in Cancel, Supersedes or Replaces header. The buffer is expected to be narrowed to just the headers of the message." (or (let ((cancel (mail-fetch-field "Control"))) (and cancel (string-match "^cancel[\t ]+\\(<[^\t\n @<>]+@[^\t\n @<>]+>\\)" cancel) (match-string 1 cancel))) (mail-fetch-field "Supersedes") (mail-fetch-field "Replaces"))) ;;;###autoload (defun canlock-insert-header (&optional id-for-key id-for-lock password) "Insert a Cancel-Key and/or a Cancel-Lock header if possible." (let (news control key-for-key key-for-lock) (save-excursion (save-restriction (canlock-narrow-to-header) (when (setq news (or canlock-force-insert-header (mail-fetch-field "Newsgroups"))) (unless id-for-key (setq id-for-key (canlock-fetch-id-for-key))) (if (and (setq control (mail-fetch-field "Control")) (string-match "^cancel[\t ]+<[^\t\n @<>]+@[^\t\n @<>]+>" control)) (setq id-for-lock nil) (unless id-for-lock (setq id-for-lock (mail-fetch-field "Message-ID")))) (canlock-delete-headers) (goto-char (point-max)))) (when news (if (not (or id-for-key id-for-lock)) (message "There are no Message-ID(s)") (unless password (setq password (or canlock-password (read-passwd "Password for Canlock: ")))) (if (or (not (stringp password)) (zerop (length password))) (message "Password for Canlock is bad") (setq key-for-key (when id-for-key (canlock-make-cancel-key id-for-key password)) key-for-lock (when id-for-lock (canlock-make-cancel-key id-for-lock password))) (if (not (or key-for-key key-for-lock)) (message "Couldn't insert Canlock header") (when key-for-key (insert "Cancel-Key: sha1:" key-for-key "\n")) (when key-for-lock (insert "Cancel-Lock: sha1:" (base64-encode-string (canlock-sha1 key-for-lock)) "\n"))))))))) ;;;###autoload (defun canlock-verify (&optional buffer) "Verify Cancel-Lock or Cancel-Key in BUFFER. If BUFFER is nil, the current buffer is assumed. Signal an error if it fails." (interactive) (let (keys locks errmsg id-for-key id-for-lock password key-for-key key-for-lock match) (save-excursion (when buffer (set-buffer buffer)) (save-restriction (widen) (canlock-narrow-to-header) (setq keys (canlock-fetch-fields 'key) locks (canlock-fetch-fields)) (if (not (or keys locks)) (setq errmsg "There are neither Cancel-Lock nor Cancel-Key headers") (setq id-for-key (canlock-fetch-id-for-key) id-for-lock (mail-fetch-field "Message-ID")) (or id-for-key id-for-lock (setq errmsg "There are no Message-ID(s)"))))) (if errmsg (error "%s" errmsg) (setq password (or canlock-password-for-verify (read-passwd "Password for Canlock: "))) (if (or (not (stringp password)) (zerop (length password))) (error "Password for Canlock is bad") (when keys (when id-for-key (setq key-for-key (canlock-make-cancel-key id-for-key password)) (while (and keys (not match)) (setq match (string-equal key-for-key (pop keys))))) (setq keys (if match "good" "bad"))) (setq match nil) (when locks (when id-for-lock (setq key-for-lock (base64-encode-string (canlock-sha1 (canlock-make-cancel-key id-for-lock password)))) (when (and locks (not match)) (setq match (string-equal key-for-lock (pop locks))))) (setq locks (if match "good" "bad"))) (prog1 (when (member "bad" (list keys locks)) "bad") (cond ((and keys locks) (message "Cancel-Key is %s, Cancel-Lock is %s" keys locks)) (locks (message "Cancel-Lock is %s" locks)) (keys (message "Cancel-Key is %s" keys)))))))) (provide 'canlock) ;; arch-tag: 033c4f09-b9f1-459d-bd0d-254430283f78 ;;; canlock.el ends here gnus-5.11+v0.10.dfsg/lisp/mm-encode.el0000644000175000017500000001757611004530025017437 0ustar tvainikatvainika;;; mm-encode.el --- Functions for encoding MIME things ;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, ;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; MORIOKA Tomohiko ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 3, or (at your option) ;; any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Commentary: ;;; Code: (eval-when-compile (require 'cl)) (require 'mail-parse) (require 'mailcap) (eval-and-compile (autoload 'mm-body-7-or-8 "mm-bodies") (autoload 'mm-long-lines-p "mm-bodies")) (defcustom mm-content-transfer-encoding-defaults '(("text/x-patch" 8bit) ("text/.*" qp-or-base64) ("message/rfc822" 8bit) ("application/emacs-lisp" qp-or-base64) ("application/x-emacs-lisp" qp-or-base64) ("application/x-patch" qp-or-base64) (".*" base64)) "Alist of regexps that match MIME types and their encodings. If the encoding is `qp-or-base64', then either quoted-printable or base64 will be used, depending on what is more efficient. `qp-or-base64' has another effect. It will fold long lines so that MIME parts may not be broken by MTA. So do `quoted-printable' and `base64'. Note: It affects body encoding only when a part is a raw forwarded message (which will be made by `gnus-summary-mail-forward' with the arg 2 for example) or is neither the text/* type nor the message/* type. Even though in those cases, you can use the `encoding' MML tag to specify encoding of non-ASCII MIME parts." :type '(repeat (list (regexp :tag "MIME type") (choice :tag "encoding" (const 7bit) (const 8bit) (const qp-or-base64) (const quoted-printable) (const base64)))) :group 'mime) (defvar mm-use-ultra-safe-encoding nil "If non-nil, use encodings aimed at Procrustean bed survival. This means that textual parts are encoded as quoted-printable if they contain lines longer than 76 characters or starting with \"From \" in the body. Non-7bit encodings (8bit, binary) are generally disallowed. This is to reduce the probability that a broken MTA or MDA changes the message. This variable should never be set directly, but bound before a call to `mml-generate-mime' or similar functions.") (defun mm-insert-rfc822-headers (charset encoding) "Insert text/plain headers with CHARSET and ENCODING." (insert "MIME-Version: 1.0\n") (insert "Content-Type: text/plain; charset=" (mail-quote-string (downcase (symbol-name charset))) "\n") (insert "Content-Transfer-Encoding: " (downcase (symbol-name encoding)) "\n")) (defun mm-insert-multipart-headers () "Insert multipart/mixed headers." (let ((boundary "=-=-=")) (insert "MIME-Version: 1.0\n") (insert "Content-Type: multipart/mixed; boundary=\"" boundary "\"\n") boundary)) (defun mm-default-file-encoding (file) "Return a default encoding for FILE." (if (not (string-match "\\.[^.]+$" file)) "application/octet-stream" (mailcap-extension-to-mime (match-string 0 file)))) (defun mm-safer-encoding (encoding &optional type) "Return an encoding similar to ENCODING but safer than it." (cond ((eq encoding '7bit) '7bit) ;; 7bit is considered safe. ((memq encoding '(8bit quoted-printable)) ;; According to RFC2046, 5.2.1, RFC822 Subtype, "quoted-printable" is not ;; a valid encoding for message/rfc822: ;; No encoding other than "7bit", "8bit", or "binary" is permitted for the ;; body of a "message/rfc822" entity. (if (string= type "message/rfc822") '8bit 'quoted-printable)) ;; The remaining encodings are binary and base64 (and perhaps some ;; non-standard ones), which are both turned into base64. (t (if (string= type "message/rfc822") 'binary 'base64)))) (defun mm-encode-content-transfer-encoding (encoding &optional type) "Encode the current buffer with ENCODING for MIME type TYPE. ENCODING can be: nil (do nothing); one of `quoted-printable', `base64'; `7bit', `8bit' or `binary' (all do nothing); a function to do the encoding." (cond ((eq encoding 'quoted-printable) ;; This used to try to make a multibyte buffer unibyte. That's ;; completely wrong, since you'd get QP-encoded emacs-mule. If ;; this gets run on multibyte text it's an error that needs ;; fixing, and the encoding function will signal an error. ;; Likewise base64 below. (quoted-printable-encode-region (point-min) (point-max) t)) ((eq encoding 'base64) (when (string-match "\\`text/" type) (goto-char (point-min)) (while (search-forward "\n" nil t) (replace-match "\r\n" t t))) (base64-encode-region (point-min) (point-max))) ((memq encoding '(7bit 8bit binary)) ;; Do nothing. ) ((null encoding) ;; Do nothing. ) ;; Fixme: Ignoring errors here looks bogus. ((functionp encoding) (ignore-errors (funcall encoding (point-min) (point-max)))) (t (error "Unknown encoding %s" encoding)))) (defun mm-encode-buffer (type) "Encode the buffer which contains data of MIME type TYPE. TYPE is a string or a list of the components. The encoding used is returned." (let* ((mime-type (if (stringp type) type (car type))) (encoding (or (and (listp type) (cadr (assq 'encoding type))) (mm-content-transfer-encoding mime-type))) (bits (mm-body-7-or-8))) ;; We force buffers that are 7bit to be unencoded, no matter ;; what the preferred encoding is. ;; Only if the buffers don't contain lone lines. (when (and (eq bits '7bit) (not (mm-long-lines-p 76))) (setq encoding bits)) (mm-encode-content-transfer-encoding encoding mime-type) encoding)) (defun mm-insert-headers (type encoding &optional file) "Insert headers for TYPE." (insert "Content-Type: " type) (when file (insert ";\n\tname=\"" (file-name-nondirectory file) "\"")) (insert "\n") (insert (format "Content-Transfer-Encoding: %s\n" encoding)) (insert "Content-Disposition: inline") (when file (insert ";\n\tfilename=\"" (file-name-nondirectory file) "\"")) (insert "\n") (insert "\n")) (defun mm-content-transfer-encoding (type) "Return a CTE suitable for TYPE to encode the current buffer." (let ((rules mm-content-transfer-encoding-defaults)) (catch 'found (while rules (when (string-match (caar rules) type) (throw 'found (let ((encoding (if (eq (cadr (car rules)) 'qp-or-base64) (mm-qp-or-base64) (cadr (car rules))))) (if mm-use-ultra-safe-encoding (mm-safer-encoding encoding type) encoding)))) (pop rules))))) (defun mm-qp-or-base64 () "Return the type with which to encode the buffer. This is either `base64' or `quoted-printable'." (if (equal mm-use-ultra-safe-encoding '(sign . "pgp")) ;; perhaps not always accurate? 'quoted-printable (save-excursion (let ((limit (min (point-max) (+ 2000 (point-min)))) (n8bit 0)) (goto-char (point-min)) (skip-chars-forward "\x20-\x7f\r\n\t" limit) (while (< (point) limit) (incf n8bit) (forward-char 1) (skip-chars-forward "\x20-\x7f\r\n\t" limit)) (if (or (< (* 6 n8bit) (- limit (point-min))) ;; Don't base64, say, a short line with a single ;; non-ASCII char when splitting parts by charset. (= n8bit 1)) 'quoted-printable 'base64))))) (provide 'mm-encode) ;; arch-tag: 7d01bba4-d469-4851-952b-dc863f84ed66 ;;; mm-encode.el ends here gnus-5.11+v0.10.dfsg/lisp/nnheaderxm.el0000644000175000017500000000230510765103167017724 0ustar tvainikatvainika;;; nnheaderxm.el --- making Gnus backends work under XEmacs ;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2003, 2008 ;; Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; Keywords: news ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 3, or (at your option) ;; any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Commentary: ;;; Code: (defalias 'nnheader-cancel-timer 'delete-itimer) (defalias 'nnheader-string-as-multibyte 'identity) (provide 'nnheaderxm) ;;; arch-tag: ee2b3387-d3ca-4de6-9b64-304d838706dd ;;; nnheaderxm.el ends here gnus-5.11+v0.10.dfsg/lisp/nnrss.el0000644000175000017500000011257411004005111016721 0ustar tvainikatvainika;;; nnrss.el --- interfacing with RSS ;; Copyright (C) 2001, 2002, 2003, 2004, 2005, ;; 2006, 2007, 2008 Free Software Foundation, Inc. ;; Author: Shenghuo Zhu ;; Keywords: RSS ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published ;; by the Free Software Foundation; either version 3, or (at your ;; option) any later version. ;; GNU Emacs is distributed in the hope that it will be useful, but ;; WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Commentary: ;;; Code: ;; For Emacs < 22.2. (eval-and-compile (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) (eval-when-compile (require 'cl)) (require 'gnus) (require 'nnoo) (require 'nnmail) (require 'message) (require 'mm-util) (require 'gnus-util) (require 'time-date) (require 'rfc2231) (require 'mm-url) (require 'rfc2047) (require 'mml) (eval-when-compile (ignore-errors (require 'xml))) (eval '(require 'xml)) (nnoo-declare nnrss) (defvoo nnrss-directory (nnheader-concat gnus-directory "rss/") "Where nnrss will save its files.") (defvoo nnrss-ignore-article-fields '(slash:comments) "*List of fields that should be ignored when comparing RSS articles. Some RSS feeds update article fields during their lives, e.g. to indicate the number of comments or the number of times the articles have been seen. However, if there is a difference between the local article and the distant one, the latter is considered to be new. To avoid this and discard some fields, set this variable to the list of fields to be ignored.") ;; (group max rss-url) (defvoo nnrss-server-data nil) ;; (num timestamp url subject author date extra) (defvoo nnrss-group-data nil) (defvoo nnrss-group-max 0) (defvoo nnrss-group-min 1) (defvoo nnrss-group nil) (defvoo nnrss-group-hashtb (make-hash-table :test 'equal)) (defvoo nnrss-status-string "") (defconst nnrss-version "nnrss 1.0") (defvar nnrss-group-alist '() "List of RSS addresses.") (defvar nnrss-use-local nil) (defvar nnrss-description-field 'X-Gnus-Description "Field name used for DESCRIPTION. To use the description in headers, put this name into `nnmail-extra-headers'.") (defvar nnrss-url-field 'X-Gnus-Url "Field name used for URL. To use the description in headers, put this name into `nnmail-extra-headers'.") (defvar nnrss-content-function nil "A function which is called in `nnrss-request-article'. The arguments are (ENTRY GROUP ARTICLE). ENTRY is the record of the current headline. GROUP is the group name. ARTICLE is the article number of the current headline.") (defvar nnrss-file-coding-system mm-universal-coding-system "*Coding system used when reading and writing files. If you run Gnus with various versions of Emacsen, the value of this variable should be the coding system that all those Emacsen support. Note that you have to regenerate all the nnrss groups if you change the value. Moreover, you should be patient even if you are made to read the same articles twice, that arises for the difference of the versions of xml.el.") (defvar nnrss-compatible-encoding-alist (delq nil (mapcar (lambda (elem) (if (and (mm-coding-system-p (car elem)) (mm-coding-system-p (cdr elem))) elem)) mm-charset-override-alist)) "Alist of encodings and those supersets. The cdr of each element is used to decode data if it is available when the car is what the data specify as the encoding. Or, the car is used for decoding when the cdr that the data specify is not available.") (defvar nnrss-wash-html-in-text-plain-parts nil "*Non-nil means render text in text/plain parts as HTML. The function specified by the `mm-text-html-renderer' variable will be used to render text. If it is nil, text will simply be folded.") (nnoo-define-basics nnrss) ;;; Interface functions (defsubst nnrss-format-string (string) (gnus-replace-in-string string " *\n *" " ")) (defun nnrss-decode-group-name (group) (if (and group (mm-coding-system-p 'utf-8)) (setq group (mm-decode-coding-string group 'utf-8)) group)) (deffoo nnrss-retrieve-headers (articles &optional group server fetch-old) (setq group (nnrss-decode-group-name group)) (nnrss-possibly-change-group group server) (let (e) (save-excursion (set-buffer nntp-server-buffer) (erase-buffer) (dolist (article articles) (if (setq e (assq article nnrss-group-data)) (insert (number-to-string (car e)) "\t" ;; number ;; subject (or (nth 3 e) "") "\t" ;; from (or (nth 4 e) "(nobody)") "\t" ;; date (or (nth 5 e) "") "\t" ;; id (format "<%d@%s.nnrss>" (car e) group) "\t" ;; refs "\t" ;; chars "-1" "\t" ;; lines "-1" "\t" ;; Xref "" "\t" (if (and (nth 6 e) (memq nnrss-description-field nnmail-extra-headers)) (concat (symbol-name nnrss-description-field) ": " (nnrss-format-string (nth 6 e)) "\t") "") (if (and (nth 2 e) (memq nnrss-url-field nnmail-extra-headers)) (concat (symbol-name nnrss-url-field) ": " (nnrss-format-string (nth 2 e)) "\t") "") "\n"))))) 'nov) (deffoo nnrss-request-group (group &optional server dont-check) (setq group (nnrss-decode-group-name group)) (nnheader-message 6 "nnrss: Requesting %s..." group) (nnrss-possibly-change-group group server) (prog1 (if dont-check t (nnrss-check-group group server) (nnheader-report 'nnrss "Opened group %s" group) (nnheader-insert "211 %d %d %d %s\n" nnrss-group-max nnrss-group-min nnrss-group-max (prin1-to-string group) t)) (nnheader-message 6 "nnrss: Requesting %s...done" group))) (deffoo nnrss-close-group (group &optional server) t) (defvar mm-text-html-renderer) (defvar mm-text-html-washer-alist) (deffoo nnrss-request-article (article &optional group server buffer) (setq group (nnrss-decode-group-name group)) (when (stringp article) (setq article (if (string-match "\\`<\\([0-9]+\\)@" article) (string-to-number (match-string 1 article)) 0))) (nnrss-possibly-change-group group server) (let ((e (assq article nnrss-group-data)) (nntp-server-buffer (or buffer nntp-server-buffer)) post err) (when e (with-current-buffer nntp-server-buffer (erase-buffer) (if group (insert "Newsgroups: " group "\n")) (if (nth 3 e) (insert "Subject: " (nth 3 e) "\n")) (if (nth 4 e) (insert "From: " (nth 4 e) "\n")) (if (nth 5 e) (insert "Date: " (nnrss-format-string (nth 5 e)) "\n")) (let ((header (buffer-string)) (text (nth 6 e)) (link (nth 2 e)) (enclosure (nth 7 e)) (comments (nth 8 e)) ;; Enable encoding of Newsgroups header in XEmacs. (default-enable-multibyte-characters t) (rfc2047-header-encoding-alist (if (mm-coding-system-p 'utf-8) (cons '("Newsgroups" . utf-8) rfc2047-header-encoding-alist) rfc2047-header-encoding-alist)) rfc2047-encode-encoded-words body fn) (when (or text link enclosure comments) (insert "\n") (insert "<#multipart type=alternative>\n" "<#part type=\"text/plain\">\n") (setq body (point)) (when text (insert text) (goto-char body) (if (and nnrss-wash-html-in-text-plain-parts (progn (require 'mm-view) (setq fn (or (cdr (assq mm-text-html-renderer mm-text-html-washer-alist)) mm-text-html-renderer)))) (progn (narrow-to-region body (point-max)) (if (functionp fn) (funcall fn) (apply (car fn) (cdr fn))) (widen) (goto-char body) (re-search-forward "[^\t\n ]" nil t) (beginning-of-line) (delete-region body (point)) (goto-char (point-max)) (skip-chars-backward "\t\n ") (end-of-line) (delete-region (point) (point-max)) (insert "\n")) (while (re-search-forward "\n+" nil t) (replace-match " ")) (goto-char body) ;; See `nnrss-check-group', which inserts "

    ". (when (search-forward "

    " nil t) (if (eobp) (replace-match "\n") (replace-match "\n\n"))) (unless (eobp) (let ((fill-column default-fill-column) (window (get-buffer-window nntp-server-buffer))) (when window (setq fill-column (max 1 (/ (* (window-width window) 7) 8)))) (fill-region (point) (point-max)) (goto-char (point-max)) ;; XEmacs version of `fill-region' inserts newline. (unless (bolp) (insert "\n"))))) (when (or link enclosure) (insert "\n"))) (when link (insert link "\n")) (when enclosure (insert (car enclosure) " " (nth 2 enclosure) " " (nth 3 enclosure) "\n")) (when comments (insert comments "\n")) (setq body (buffer-substring body (point))) (insert "<#/part>\n" "<#part type=\"text/html\">\n" "\n") (when text (insert text "\n")) (when link (insert "

    link

    \n")) (when enclosure (insert "

    " (cadr enclosure) " " (nth 2 enclosure) " " (nth 3 enclosure) "

    \n")) (when comments (insert "

    comments

    \n")) (insert "\n" "<#/part>\n" "<#/multipart>\n")) (condition-case nil (mml-to-mime) (error (erase-buffer) (insert header "Content-Type: text/plain; charset=gnus-decoded\n" "Content-Transfer-Encoding: 8bit\n\n" body) (nnheader-message 3 "Warning - there might be invalid characters")))) (goto-char (point-min)) (search-forward "\n\n") (forward-line -1) (insert (format "Message-ID: <%d@%s.nnrss>\n" (car e) (let ((rfc2047-encoding-type 'mime) rfc2047-encode-max-chars) (rfc2047-encode-string (gnus-replace-in-string group "[\t\n ]+" "_"))))) (when nnrss-content-function (funcall nnrss-content-function e group article)))) (cond (err (nnheader-report 'nnrss err)) ((not e) (nnheader-report 'nnrss "no such id: %d" article)) (t (nnheader-report 'nnrss "article %s retrieved" (car e)) ;; we return the article number. (cons nnrss-group (car e)))))) (deffoo nnrss-request-list (&optional server) (nnrss-possibly-change-group nil server) (nnrss-generate-active) t) (deffoo nnrss-open-server (server &optional defs connectionless) (nnrss-read-server-data server) (nnoo-change-server 'nnrss server defs) t) (deffoo nnrss-request-expire-articles (articles group &optional server force) (setq group (nnrss-decode-group-name group)) (nnrss-possibly-change-group group server) (let (e days not-expirable changed) (dolist (art articles) (if (and (setq e (assq art nnrss-group-data)) (nnmail-expired-article-p group (if (listp (setq days (nth 1 e))) days (days-to-time (- days (time-to-days '(0 0))))) force)) (setq nnrss-group-data (delq e nnrss-group-data) changed t) (push art not-expirable))) (if changed (nnrss-save-group-data group server)) not-expirable)) (deffoo nnrss-request-delete-group (group &optional force server) (setq group (nnrss-decode-group-name group)) (nnrss-possibly-change-group group server) (let (elem) ;; There may be two or more entries in `nnrss-group-alist' since ;; this function didn't delete them formerly. (while (setq elem (assoc group nnrss-group-alist)) (setq nnrss-group-alist (delq elem nnrss-group-alist)))) (setq nnrss-server-data (delq (assoc group nnrss-server-data) nnrss-server-data)) (nnrss-save-server-data server) (ignore-errors (let ((file-name-coding-system nnmail-pathname-coding-system)) (delete-file (nnrss-make-filename group server)))) t) (deffoo nnrss-request-list-newsgroups (&optional server) (nnrss-possibly-change-group nil server) (save-excursion (set-buffer nntp-server-buffer) (erase-buffer) (dolist (elem nnrss-group-alist) (if (third elem) (insert (car elem) "\t" (third elem) "\n")))) t) (nnoo-define-skeleton nnrss) ;;; Internal functions (eval-when-compile (defun xml-rpc-method-call (&rest args))) (defun nnrss-get-encoding () "Return an encoding attribute specified in the current xml contents. If `nnrss-compatible-encoding-alist' specifies the compatible encoding, it is used instead. If the xml contents doesn't specify the encoding, return `utf-8' which is the default encoding for xml if it is available, otherwise return nil." (goto-char (point-min)) (if (re-search-forward "<\\?[^>]*encoding=\\(?:\"\\([^\">]+\\)\"\\|'\\([^'>]+\\)'\\)" nil t) (let ((encoding (intern (downcase (or (match-string 1) (match-string 2)))))) (or (mm-coding-system-p (cdr (assq encoding nnrss-compatible-encoding-alist))) (mm-coding-system-p encoding) (mm-coding-system-p (car (rassq encoding nnrss-compatible-encoding-alist))))) (mm-coding-system-p 'utf-8))) (declare-function w3-parse-buffer "ext:w3-parse" (&optional buff)) (defun nnrss-fetch (url &optional local) "Fetch URL and put it in a the expected Lisp structure." (mm-with-unibyte-buffer ;;some CVS versions of url.el need this to close the connection quickly (let (cs xmlform htmlform) ;; bit o' work necessary for w3 pre-cvs and post-cvs (if local (let ((coding-system-for-read 'binary)) (insert-file-contents url)) ;; FIXME: shouldn't binding `coding-system-for-read' be moved ;; to `mm-url-insert'? (let ((coding-system-for-read 'binary)) (condition-case err (mm-url-insert url) (error (if (or debug-on-quit debug-on-error) (signal (car err) (cdr err)) (message "nnrss: Failed to fetch %s" url)))))) (nnheader-remove-cr-followed-by-lf) ;; Decode text according to the encoding attribute. (when (setq cs (nnrss-get-encoding)) (insert (prog1 (mm-decode-coding-string (buffer-string) cs) (erase-buffer) (mm-enable-multibyte)))) (goto-char (point-min)) ;; Because xml-parse-region can't deal with anything that isn't ;; xml and w3-parse-buffer can't deal with some xml, we have to ;; parse with xml-parse-region first and, if that fails, parse ;; with w3-parse-buffer. Yuck. Eventually, someone should find out ;; why w3-parse-buffer fails to parse some well-formed xml and ;; fix it. (condition-case err1 (setq xmlform (xml-parse-region (point-min) (point-max))) (error (condition-case err2 (setq htmlform (caddar (w3-parse-buffer (current-buffer)))) (error (message "\ nnrss: %s: Not valid XML %s and w3-parse doesn't work %s" url err1 err2))))) (if htmlform htmlform xmlform)))) (defun nnrss-possibly-change-group (&optional group server) (when (and server (not (nnrss-server-opened server))) (nnrss-open-server server)) (when (and group (not (equal group nnrss-group))) (nnrss-read-group-data group server) (setq nnrss-group group))) (defvar nnrss-extra-categories '(nnrss-snarf-moreover-categories)) (defun nnrss-generate-active () (when (y-or-n-p "Fetch extra categories? ") (mapc 'funcall nnrss-extra-categories)) (save-excursion (set-buffer nntp-server-buffer) (erase-buffer) (dolist (elem nnrss-group-alist) (insert (prin1-to-string (car elem)) " 0 1 y\n")) (dolist (elem nnrss-server-data) (unless (assoc (car elem) nnrss-group-alist) (insert (prin1-to-string (car elem)) " 0 1 y\n"))))) (eval-and-compile (autoload 'timezone-parse-date "timezone")) (defun nnrss-normalize-date (date) "Return a date string of DATE in the RFC822 style. This function handles the ISO 8601 date format described in , and also the RFC822 style which RSS 2.0 allows." (let (case-fold-search vector year month day time zone cts) (cond ((null date)) ;; RFC822 ((string-match " [0-9]+ " date) (setq vector (timezone-parse-date date) year (string-to-number (aref vector 0))) (when (>= year 1969) (setq month (string-to-number (aref vector 1)) day (string-to-number (aref vector 2))) (unless (>= (length (setq time (aref vector 3))) 3) (setq time "00:00:00")) (when (and (setq zone (aref vector 4)) (not (string-match "\\`[A-Z+-]" zone))) (setq zone nil)))) ;; ISO 8601 ((string-match (eval-when-compile (concat ;; 1. year "\\(199[0-9]\\|20[0-9][0-9]\\)" "\\(?:-" ;; 2. month "\\([01][0-9]\\)" "\\(?:-" ;; 3. day "\\([0-3][0-9]\\)" "\\)?\\)?\\(?:T" ;; 4. hh:mm "\\([012][0-9]:[0-5][0-9]\\)" "\\(?:" ;; 5. :ss "\\(:[0-5][0-9]\\)" "\\(?:\\.[0-9]+\\)?\\)?\\)?" ;; 6+7,8,9. zone "\\(?:\\(?:\\([+-][012][0-9]\\):\\([0-5][0-9]\\)\\)" "\\|\\([+-][012][0-9][0-5][0-9]\\)" "\\|\\(Z\\)\\)?")) date) (setq year (string-to-number (match-string 1 date)) month (string-to-number (or (match-string 2 date) "1")) day (string-to-number (or (match-string 3 date) "1")) time (if (match-beginning 5) (substring date (match-beginning 4) (match-end 5)) (concat (or (match-string 4 date) "00:00") ":00")) zone (cond ((match-beginning 6) (concat (match-string 6 date) (match-string 7 date))) ((match-beginning 9) ;; Z "+0000") (t ;; nil if zone is not provided. (match-string 8 date)))))) (if month (progn (setq cts (current-time-string (encode-time 0 0 0 day month year))) (format "%s, %02d %s %04d %s%s" (substring cts 0 3) day (substring cts 4 7) year time (if zone (concat " " zone) ""))) (message-make-date)))) ;;; data functions (defun nnrss-read-server-data (server) (setq nnrss-server-data nil) (let ((file (nnrss-make-filename "nnrss" server)) (file-name-coding-system nnmail-pathname-coding-system)) (when (file-exists-p file) ;; In Emacs 21.3 and earlier, `load' doesn't support non-ASCII ;; file names. So, we use `insert-file-contents' instead. (mm-with-multibyte-buffer (let ((coding-system-for-read nnrss-file-coding-system)) (insert-file-contents file) (eval-region (point-min) (point-max))))))) (defun nnrss-save-server-data (server) (gnus-make-directory nnrss-directory) (let ((coding-system-for-write nnrss-file-coding-system) (file-name-coding-system nnmail-pathname-coding-system)) (with-temp-file (nnrss-make-filename "nnrss" server) (insert (format ";; -*- coding: %s; -*-\n" nnrss-file-coding-system)) (gnus-prin1 `(setq nnrss-group-alist ',nnrss-group-alist)) (insert "\n") (gnus-prin1 `(setq nnrss-server-data ',nnrss-server-data))))) (defun nnrss-read-group-data (group server) (setq nnrss-group-data nil) (if (hash-table-p nnrss-group-hashtb) (clrhash nnrss-group-hashtb) (setq nnrss-group-hashtb (make-hash-table :test 'equal))) (let ((pair (assoc group nnrss-server-data))) (setq nnrss-group-max (or (cadr pair) 0)) (setq nnrss-group-min (+ nnrss-group-max 1))) (let ((file (nnrss-make-filename group server)) (file-name-coding-system nnmail-pathname-coding-system)) (when (file-exists-p file) ;; In Emacs 21.3 and earlier, `load' doesn't support non-ASCII ;; file names. So, we use `insert-file-contents' instead. (mm-with-multibyte-buffer (let ((coding-system-for-read nnrss-file-coding-system)) (insert-file-contents file) (eval-region (point-min) (point-max)))) (dolist (e nnrss-group-data) (puthash (nth 9 e) t nnrss-group-hashtb) (when (and (car e) (> nnrss-group-min (car e))) (setq nnrss-group-min (car e))) (when (and (car e) (< nnrss-group-max (car e))) (setq nnrss-group-max (car e))))))) (defun nnrss-save-group-data (group server) (gnus-make-directory nnrss-directory) (let ((coding-system-for-write nnrss-file-coding-system) (file-name-coding-system nnmail-pathname-coding-system)) (with-temp-file (nnrss-make-filename group server) (insert (format ";; -*- coding: %s; -*-\n" nnrss-file-coding-system)) (gnus-prin1 `(setq nnrss-group-data ',nnrss-group-data))))) (defun nnrss-make-filename (name server) (expand-file-name (nnrss-translate-file-chars (concat name (and server (not (equal server "")) "-") server ".el")) nnrss-directory)) (gnus-add-shutdown 'nnrss-close 'gnus) (defun nnrss-close () "Clear internal nnrss variables." (setq nnrss-group-data nil nnrss-server-data nil nnrss-group-hashtb nil nnrss-group-alist nil)) ;;; URL interface (defun nnrss-no-cache (url) "") (defun nnrss-insert-w3 (url) (mm-with-unibyte-current-buffer (condition-case err (mm-url-insert url) (error (if (or debug-on-quit debug-on-error) (signal (car err) (cdr err)) (message "nnrss: Failed to fetch %s" url)))))) (defun nnrss-decode-entities-string (string) (if string (mm-with-multibyte-buffer (insert string) (mm-url-decode-entities-nbsp) (buffer-string)))) (defalias 'nnrss-insert 'nnrss-insert-w3) (defun nnrss-mime-encode-string (string) (mm-with-multibyte-buffer (insert string) (mm-url-decode-entities-nbsp) (goto-char (point-min)) (while (re-search-forward "[\t\n ]+" nil t) (replace-match " ")) (goto-char (point-min)) (skip-chars-forward " ") (delete-region (point-min) (point)) (goto-char (point-max)) (skip-chars-forward " ") (delete-region (point) (point-max)) (let ((rfc2047-encoding-type 'mime) rfc2047-encode-max-chars) (rfc2047-encode-region (point-min) (point-max))) (goto-char (point-min)) (while (search-forward "\n" nil t) (delete-backward-char 1)) (buffer-string))) ;;; Snarf functions (defun nnrss-make-hash-index (item) (setq item (gnus-remove-if (lambda (field) (when (listp field) (memq (car field) nnrss-ignore-article-fields))) item)) (md5 (gnus-prin1-to-string item) nil nil nnrss-file-coding-system)) (defun nnrss-check-group (group server) (let (file xml subject url extra changed author date feed-subject enclosure comments rss-ns rdf-ns content-ns dc-ns hash-index) (if (and nnrss-use-local (file-exists-p (setq file (expand-file-name (nnrss-translate-file-chars (concat group ".xml")) nnrss-directory)))) (setq xml (nnrss-fetch file t)) (setq url (or (nth 2 (assoc group nnrss-server-data)) (second (assoc group nnrss-group-alist)))) (unless url (setq url (cdr (assoc 'href (nnrss-discover-feed (read-string (format "URL to search for %s: " group) "http://"))))) (let ((pair (assoc group nnrss-server-data))) (if pair (setcdr (cdr pair) (list url)) (push (list group nnrss-group-max url) nnrss-server-data))) (setq changed t)) (setq xml (nnrss-fetch url))) ;; See ;; http://feeds.archive.org/validator/docs/howto/declare_namespaces.html ;; for more RSS namespaces. (setq dc-ns (nnrss-get-namespace-prefix xml "http://purl.org/dc/elements/1.1/") rdf-ns (nnrss-get-namespace-prefix xml "http://www.w3.org/1999/02/22-rdf-syntax-ns#") rss-ns (nnrss-get-namespace-prefix xml "http://purl.org/rss/1.0/") content-ns (nnrss-get-namespace-prefix xml "http://purl.org/rss/1.0/modules/content/")) (dolist (item (nreverse (nnrss-find-el (intern (concat rss-ns "item")) xml))) (when (and (listp item) (string= (concat rss-ns "item") (car item)) (progn (setq hash-index (nnrss-make-hash-index item)) (not (gethash hash-index nnrss-group-hashtb)))) (setq subject (nnrss-node-text rss-ns 'title item)) (setq url (nnrss-decode-entities-string (nnrss-node-text rss-ns 'link (cddr item)))) (setq extra (or (nnrss-node-text content-ns 'encoded item) (nnrss-node-text rss-ns 'description item))) (if (setq feed-subject (nnrss-node-text dc-ns 'subject item)) (setq extra (concat feed-subject "

    " extra))) (setq author (or (nnrss-node-text rss-ns 'author item) (nnrss-node-text dc-ns 'creator item) (nnrss-node-text dc-ns 'contributor item))) (setq date (nnrss-normalize-date (or (nnrss-node-text dc-ns 'date item) (nnrss-node-text rss-ns 'pubDate item)))) (setq comments (nnrss-node-text rss-ns 'comments item)) (when (setq enclosure (cadr (assq (intern (concat rss-ns "enclosure")) item))) (let ((url (cdr (assq 'url enclosure))) (len (cdr (assq 'length enclosure))) (type (cdr (assq 'type enclosure))) (name)) (setq len (if (and len (integerp (setq len (string-to-number len)))) ;; actually already in `ls-lisp-format-file-size' but ;; probably not worth to require it for one function (do ((size (/ len 1.0) (/ size 1024.0)) (post-fixes (list "" "k" "M" "G" "T" "P" "E") (cdr post-fixes))) ((< size 1024) (format "%.1f%s" size (car post-fixes)))) "0")) (setq url (or url "")) (setq name (if (string-match "/\\([^/]*\\)$" url) (match-string 1 url) "file")) (setq type (or type "")) (setq enclosure (list url name len type)))) (push (list (incf nnrss-group-max) (current-time) url (and subject (nnrss-mime-encode-string subject)) (and author (nnrss-mime-encode-string author)) date (and extra (nnrss-decode-entities-string extra)) enclosure comments hash-index) nnrss-group-data) (puthash hash-index t nnrss-group-hashtb) (setq changed t)) (setq extra nil)) (when changed (nnrss-save-group-data group server) (let ((pair (assoc group nnrss-server-data))) (if pair (setcar (cdr pair) nnrss-group-max) (push (list group nnrss-group-max) nnrss-server-data))) (nnrss-save-server-data server)))) (declare-function gnus-group-make-rss-group "gnus-group" (&optional url)) (defun nnrss-opml-import (opml-file) "OPML subscriptions import. Read the file and attempt to subscribe to each Feed in the file." (interactive "fImport file: ") (mapc (lambda (node) (let ((xmlurl (cdr (assq 'xmlUrl (cadr node))))) (when (and xmlurl (not (string-match "\\`[\t ]*\\'" xmlurl)) (prog1 (y-or-n-p (format "Subscribe to %s " xmlurl)) (message ""))) (condition-case err (progn (gnus-group-make-rss-group xmlurl) (forward-line 1)) (error (message "Failed to subscribe to %s (%s); type any key to continue: " xmlurl (error-message-string err)) (let ((echo-keystrokes 0)) (read-char))))))) (nnrss-find-el 'outline (mm-with-multibyte-buffer (insert-file-contents opml-file) (xml-parse-region (point-min) (point-max)))))) (defun nnrss-opml-export () "OPML subscription export. Export subscriptions to a buffer in OPML Format." (interactive) (with-current-buffer (get-buffer-create "*OPML Export*") (mm-set-buffer-file-coding-system 'utf-8) (insert "\n" "\n" "\n" " \n" " mySubscriptions\n" " " (format-time-string "%a, %d %b %Y %T %z") "\n" " " user-mail-address "\n" " " (user-full-name) "\n" " \n" " \n") (dolist (sub nnrss-group-alist) (insert " \n")) (insert " \n" "\n")) (pop-to-buffer "*OPML Export*") (when (fboundp 'sgml-mode) (sgml-mode))) (defun nnrss-generate-download-script () "Generate a download script in the current buffer. It is useful when `(setq nnrss-use-local t)'." (interactive) (insert "#!/bin/sh\n") (insert "WGET=wget\n") (insert "RSSDIR='" (expand-file-name nnrss-directory) "'\n") (dolist (elem nnrss-server-data) (let ((url (or (nth 2 elem) (second (assoc (car elem) nnrss-group-alist))))) (insert "$WGET -q -O \"$RSSDIR\"/'" (nnrss-translate-file-chars (concat (car elem) ".xml")) "' '" url "'\n")))) (defun nnrss-translate-file-chars (name) (let ((nnheader-file-name-translation-alist (append nnheader-file-name-translation-alist '((?' . ?_))))) (nnheader-translate-file-chars name))) (defvar nnrss-moreover-url "http://w.moreover.com/categories/category_list_rss.html" "The url of moreover.com categories.") (defun nnrss-snarf-moreover-categories () "Snarf RSS links from moreover.com." (interactive) (let (category name url changed) (with-temp-buffer (nnrss-insert nnrss-moreover-url) (goto-char (point-min)) (while (re-search-forward "\\| elements that are links to RSS from the parsed data." (delq nil (mapcar (lambda (el) (if (nnrss-rsslink-p el) el)) (nnrss-find-el 'link data)))) (defun nnrss-extract-hrefs (data) "Recursively extract hrefs from a page's source. DATA should be the output of `xml-parse-region' or `w3-parse-buffer'." (mapcar (lambda (ahref) (cdr (assoc 'href (cadr ahref)))) (nnrss-find-el 'a data))) (defmacro nnrss-match-macro (base-uri item onsite-list offsite-list) `(cond ((or (string-match (concat "^" ,base-uri) ,item) (not (string-match "://" ,item))) (setq ,onsite-list (append ,onsite-list (list ,item)))) (t (setq ,offsite-list (append ,offsite-list (list ,item)))))) (defun nnrss-order-hrefs (base-uri hrefs) "Given a list of hrefs, sort them using the following priorities: 1. links ending in .rss 2. links ending in .rdf 3. links ending in .xml 4. links containing the above 5. offsite links BASE-URI is used to determine the location of the links and whether they are `offsite' or `onsite'." (let (rss-onsite-end rdf-onsite-end xml-onsite-end rss-onsite-in rdf-onsite-in xml-onsite-in rss-offsite-end rdf-offsite-end xml-offsite-end rss-offsite-in rdf-offsite-in xml-offsite-in) (dolist (href hrefs) (cond ((null href)) ((string-match "\\.rss$" href) (nnrss-match-macro base-uri href rss-onsite-end rss-offsite-end)) ((string-match "\\.rdf$" href) (nnrss-match-macro base-uri href rdf-onsite-end rdf-offsite-end)) ((string-match "\\.xml$" href) (nnrss-match-macro base-uri href xml-onsite-end xml-offsite-end)) ((string-match "rss" href) (nnrss-match-macro base-uri href rss-onsite-in rss-offsite-in)) ((string-match "rdf" href) (nnrss-match-macro base-uri href rdf-onsite-in rdf-offsite-in)) ((string-match "xml" href) (nnrss-match-macro base-uri href xml-onsite-in xml-offsite-in)))) (append rss-onsite-end rdf-onsite-end xml-onsite-end rss-onsite-in rdf-onsite-in xml-onsite-in rss-offsite-end rdf-offsite-end xml-offsite-end rss-offsite-in rdf-offsite-in xml-offsite-in))) (defun nnrss-discover-feed (url) "Given a page, find an RSS feed using Mark Pilgrim's `ultra-liberal rss locator' (http://diveintomark.org/2002/08/15.html)." (let ((parsed-page (nnrss-fetch url))) ;; 1. if this url is the rss, use it. (if (nnrss-rss-p parsed-page) (let ((rss-ns (nnrss-get-namespace-prefix parsed-page "http://purl.org/rss/1.0/"))) (nnrss-rss-title-description rss-ns parsed-page url)) ;; 2. look for the (length urllist) 1)) (cdar urllist) (let ((completion-ignore-case t) (selection (mapcar (lambda (listinfo) (cons (cdr (assoc "sitename" listinfo)) (string-to-number (cdr (assoc "feedid" listinfo))))) feedinfo))) (cdr (assoc (completing-read "Multiple feeds found. Select one: " selection nil t) urllist))))))))) (defun nnrss-rss-p (data) "Test if DATA is an RSS feed. Simply ensures that the first element is rss or rdf." (or (eq (caar data) 'rss) (eq (caar data) 'rdf:RDF))) (defun nnrss-rss-title-description (rss-namespace data url) "Return the title of an RSS feed." (if (nnrss-rss-p data) (let ((description (intern (concat rss-namespace "description"))) (title (intern (concat rss-namespace "title"))) (channel (nnrss-find-el (intern (concat rss-namespace "channel")) data))) (list (cons 'description (caddr (nth 0 (nnrss-find-el description channel)))) (cons 'title (caddr (nth 0 (nnrss-find-el title channel)))) (cons 'href url))))) (defun nnrss-get-namespace-prefix (el uri) "Given EL (containing a parsed element) and URI (containing a string that gives the URI for which you want to retrieve the namespace prefix), return the prefix." (let* ((prefix (car (rassoc uri (cadar el)))) (nslist (if prefix (split-string (symbol-name prefix) ":"))) (ns (cond ((eq (length nslist) 1) ; no prefix given "") ((eq (length nslist) 2) ; extract prefix (cadr nslist))))) (if (and ns (not (string= ns ""))) (concat ns ":") ns))) (provide 'nnrss) ;; arch-tag: 12910c07-0cdf-44fb-8d2c-416ded64c267 ;;; nnrss.el ends here gnus-5.11+v0.10.dfsg/lisp/nnmbox.el0000644000175000017500000005732611004005111017062 0ustar tvainikatvainika;;; nnmbox.el --- mail mbox access for Gnus ;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, ;; 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; Masanobu UMEDA ;; Keywords: news, mail ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 3, or (at your option) ;; any later version. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Commentary: ;; For an overview of what the interface functions do, please see the ;; Gnus sources. ;;; Code: (require 'nnheader) (require 'message) (require 'nnmail) (require 'nnoo) (require 'gnus-range) (eval-when-compile (require 'cl)) (nnoo-declare nnmbox) (defvoo nnmbox-mbox-file (expand-file-name "~/mbox") "The name of the mail box file in the user's home directory.") (defvoo nnmbox-active-file (expand-file-name "~/.mbox-active") "The name of the active file for the mail box.") (defvoo nnmbox-get-new-mail t "If non-nil, nnmbox will check the incoming mail file and split the mail.") (defvoo nnmbox-prepare-save-mail-hook nil "Hook run narrowed to an article before saving.") (defconst nnmbox-version "nnmbox 1.0" "nnmbox version.") (defvoo nnmbox-current-group nil "Current nnmbox news group directory.") (defvar nnmbox-mbox-buffer nil) (defvoo nnmbox-status-string "") (defvoo nnmbox-group-alist nil) (defvoo nnmbox-active-timestamp nil) (defvoo nnmbox-file-coding-system mm-binary-coding-system) (defvoo nnmbox-file-coding-system-for-write nil) (defvoo nnmbox-active-file-coding-system mm-binary-coding-system) (defvoo nnmbox-active-file-coding-system-for-write nil) (defvar nnmbox-group-building-active-articles nil) (defvar nnmbox-group-active-articles nil) ;;; Interface functions (nnoo-define-basics nnmbox) (deffoo nnmbox-retrieve-headers (sequence &optional newsgroup server fetch-old) (save-excursion (set-buffer nntp-server-buffer) (erase-buffer) (let ((number (length sequence)) (count 0) article start stop) (nnmbox-possibly-change-newsgroup newsgroup server) (while sequence (setq article (car sequence)) (set-buffer nnmbox-mbox-buffer) (when (nnmbox-find-article article) (setq start (save-excursion (re-search-backward (concat "^" message-unix-mail-delimiter) nil t) (point))) (search-forward "\n\n" nil t) (setq stop (1- (point))) (set-buffer nntp-server-buffer) (insert (format "221 %d Article retrieved.\n" article)) (insert-buffer-substring nnmbox-mbox-buffer start stop) (goto-char (point-max)) (insert ".\n")) (setq sequence (cdr sequence)) (setq count (1+ count)) (and (numberp nnmail-large-newsgroup) (> number nnmail-large-newsgroup) (zerop (% count 20)) (nnheader-message 5 "nnmbox: Receiving headers... %d%%" (/ (* count 100) number)))) (and (numberp nnmail-large-newsgroup) (> number nnmail-large-newsgroup) (nnheader-message 5 "nnmbox: Receiving headers...done")) (set-buffer nntp-server-buffer) (nnheader-fold-continuation-lines) 'headers))) (deffoo nnmbox-open-server (server &optional defs) (nnoo-change-server 'nnmbox server defs) (nnmbox-create-mbox) (cond ((not (file-exists-p nnmbox-mbox-file)) (nnmbox-close-server) (nnheader-report 'nnmbox "No such file: %s" nnmbox-mbox-file)) ((file-directory-p nnmbox-mbox-file) (nnmbox-close-server) (nnheader-report 'nnmbox "Not a regular file: %s" nnmbox-mbox-file)) (t (nnheader-report 'nnmbox "Opened server %s using mbox %s" server nnmbox-mbox-file) t))) (deffoo nnmbox-close-server (&optional server) (when (and nnmbox-mbox-buffer (buffer-name nnmbox-mbox-buffer)) (kill-buffer nnmbox-mbox-buffer)) (nnoo-close-server 'nnmbox server) t) (deffoo nnmbox-server-opened (&optional server) (and (nnoo-current-server-p 'nnmbox server) nnmbox-mbox-buffer (buffer-name nnmbox-mbox-buffer) nntp-server-buffer (buffer-name nntp-server-buffer))) (deffoo nnmbox-request-article (article &optional newsgroup server buffer) (nnmbox-possibly-change-newsgroup newsgroup server) (save-excursion (set-buffer nnmbox-mbox-buffer) (when (nnmbox-find-article article) (let (start stop) (re-search-backward (concat "^" message-unix-mail-delimiter) nil t) (setq start (point)) (forward-line 1) (setq stop (if (re-search-forward (concat "^" message-unix-mail-delimiter) nil 'move) (match-beginning 0) (point))) (let ((nntp-server-buffer (or buffer nntp-server-buffer))) (set-buffer nntp-server-buffer) (erase-buffer) (insert-buffer-substring nnmbox-mbox-buffer start stop) (goto-char (point-min)) (while (looking-at "From ") (delete-char 5) (insert "X-From-Line: ") (forward-line 1)) (if (numberp article) (cons nnmbox-current-group article) (nnmbox-article-group-number nil))))))) (deffoo nnmbox-request-group (group &optional server dont-check) (nnmbox-possibly-change-newsgroup nil server) (let ((active (cadr (assoc group nnmbox-group-alist)))) (cond ((or (null active) (null (nnmbox-possibly-change-newsgroup group server))) (nnheader-report 'nnmbox "No such group: %s" group)) (dont-check (nnheader-report 'nnmbox "Selected group %s" group) (nnheader-insert "")) (t (nnheader-report 'nnmbox "Selected group %s" group) (nnheader-insert "211 %d %d %d %s\n" (1+ (- (cdr active) (car active))) (car active) (cdr active) group))))) (defun nnmbox-save-buffer () (let ((coding-system-for-write (or nnmbox-file-coding-system-for-write nnmbox-file-coding-system))) (save-buffer))) (defun nnmbox-save-active (group-alist active-file) (let ((nnmail-active-file-coding-system (or nnmbox-active-file-coding-system-for-write nnmbox-active-file-coding-system))) (nnmail-save-active group-alist active-file))) (deffoo nnmbox-request-scan (&optional group server) (nnmbox-possibly-change-newsgroup group server) (nnmbox-read-mbox) (nnmail-get-new-mail 'nnmbox (lambda () (save-excursion (set-buffer nnmbox-mbox-buffer) (nnmbox-save-buffer))) (file-name-directory nnmbox-mbox-file) group (lambda () (save-excursion (let ((in-buf (current-buffer))) (set-buffer nnmbox-mbox-buffer) (goto-char (point-max)) (insert-buffer-substring in-buf))) (nnmbox-save-active nnmbox-group-alist nnmbox-active-file)))) (deffoo nnmbox-close-group (group &optional server) t) (deffoo nnmbox-request-create-group (group &optional server args) (nnmail-activate 'nnmbox) (unless (assoc group nnmbox-group-alist) (push (list group (cons 1 0)) nnmbox-group-alist) (nnmbox-save-active nnmbox-group-alist nnmbox-active-file)) t) (deffoo nnmbox-request-list (&optional server) (save-excursion (let ((nnmail-file-coding-system nnmbox-active-file-coding-system)) (nnmail-find-file nnmbox-active-file)) (setq nnmbox-group-alist (nnmail-get-active)) t)) (deffoo nnmbox-request-newgroups (date &optional server) (nnmbox-request-list server)) (deffoo nnmbox-request-list-newsgroups (&optional server) (nnheader-report 'nnmbox "LIST NEWSGROUPS is not implemented.")) (deffoo nnmbox-request-expire-articles (articles newsgroup &optional server force) (nnmbox-possibly-change-newsgroup newsgroup server) (let* ((is-old t) rest) (nnmail-activate 'nnmbox) (save-excursion (set-buffer nnmbox-mbox-buffer) (while (and articles is-old) (when (nnmbox-find-article (car articles)) (if (setq is-old (nnmail-expired-article-p newsgroup (buffer-substring (point) (progn (end-of-line) (point))) force)) (progn (unless (eq nnmail-expiry-target 'delete) (with-temp-buffer (nnmbox-request-article (car articles) newsgroup server (current-buffer)) (let ((nnml-current-directory nil)) (nnmail-expiry-target-group nnmail-expiry-target newsgroup))) (nnmbox-possibly-change-newsgroup newsgroup server)) (nnheader-message 5 "Deleting article %d in %s..." (car articles) newsgroup) (nnmbox-delete-mail)) (push (car articles) rest))) (setq articles (cdr articles))) (nnmbox-save-buffer) ;; Find the lowest active article in this group. (let ((active (nth 1 (assoc newsgroup nnmbox-group-alist)))) (while (and (not (nnmbox-find-article (car active))) (<= (car active) (cdr active))) (setcar active (1+ (car active))))) (nnmbox-save-active nnmbox-group-alist nnmbox-active-file) (nconc rest articles)))) (deffoo nnmbox-request-move-article (article group server accept-form &optional last move-is-internal) (let ((buf (get-buffer-create " *nnmbox move*")) result) (and (nnmbox-request-article article group server) (save-excursion (set-buffer buf) (erase-buffer) (insert-buffer-substring nntp-server-buffer) (goto-char (point-min)) (while (re-search-forward "^X-Gnus-Newsgroup:" (save-excursion (search-forward "\n\n" nil t) (point)) t) (gnus-delete-line)) (setq result (eval accept-form)) (kill-buffer buf) result) (save-excursion (nnmbox-possibly-change-newsgroup group server) (set-buffer nnmbox-mbox-buffer) (when (nnmbox-find-article article) (nnmbox-delete-mail)) (and last (nnmbox-save-buffer)))) result)) (deffoo nnmbox-request-accept-article (group &optional server last) (nnmbox-possibly-change-newsgroup group server) (nnmail-check-syntax) (let ((buf (current-buffer)) result cont) (and (nnmail-activate 'nnmbox) (with-temp-buffer (insert-buffer-substring buf) (goto-char (point-min)) (cond (;; The From line may have been quoted by movemail. (looking-at (concat ">" message-unix-mail-delimiter)) (delete-char 1) (forward-line 1)) ((looking-at "X-From-Line: ") (replace-match "From ") (forward-line 1)) (t (insert "From nobody " (current-time-string) "\n"))) (narrow-to-region (point) (if (search-forward "\n\n" nil 'move) (1- (point)) (point))) (while (re-search-backward "^X-Gnus-Newsgroup: " nil t) (delete-region (point) (progn (forward-line 1) (point)))) (when nnmail-cache-accepted-message-ids (nnmail-cache-insert (message-fetch-field "message-id") group (message-fetch-field "subject") (message-fetch-field "from"))) (widen) (setq result (if (stringp group) (list (cons group (nnmbox-active-number group))) (nnmail-article-group 'nnmbox-active-number))) (prog1 (if (and (null result) (yes-or-no-p "Moved to `junk' group; delete article? ")) (setq result 'junk) (setq result (car (nnmbox-save-mail result)))) (setq cont (buffer-string)))) (with-current-buffer nnmbox-mbox-buffer (goto-char (point-max)) (insert cont) (when last (when nnmail-cache-accepted-message-ids (nnmail-cache-close)) (nnmbox-save-active nnmbox-group-alist nnmbox-active-file) (nnmbox-save-buffer)))) result)) (deffoo nnmbox-request-replace-article (article group buffer) (nnmbox-possibly-change-newsgroup group) (save-excursion (set-buffer nnmbox-mbox-buffer) (if (not (nnmbox-find-article article)) nil (nnmbox-delete-mail t t) (insert (with-temp-buffer (insert-buffer-substring buffer) (goto-char (point-min)) (when (looking-at "X-From-Line:") (delete-region (point) (progn (forward-line 1) (point)))) (while (re-search-forward (concat "^" message-unix-mail-delimiter) nil t) (goto-char (match-beginning 0)) (insert ">")) (goto-char (point-max)) (unless (bolp) (insert "\n")) (buffer-string))) (nnmbox-save-buffer) t))) (deffoo nnmbox-request-delete-group (group &optional force server) (nnmbox-possibly-change-newsgroup group server) ;; Delete all articles in GROUP. (if (not force) () ; Don't delete the articles. (save-excursion (set-buffer nnmbox-mbox-buffer) (goto-char (point-min)) ;; Delete all articles in this group. (let ((ident (concat "\nX-Gnus-Newsgroup: " nnmbox-current-group ":")) found) (while (search-forward ident nil t) (setq found t) (nnmbox-delete-mail)) (when found (nnmbox-save-buffer))))) ;; Remove the group from all structures. (setq nnmbox-group-alist (delq (assoc group nnmbox-group-alist) nnmbox-group-alist) nnmbox-current-group nil) ;; Save the active file. (nnmbox-save-active nnmbox-group-alist nnmbox-active-file) t) (deffoo nnmbox-request-rename-group (group new-name &optional server) (nnmbox-possibly-change-newsgroup group server) (save-excursion (set-buffer nnmbox-mbox-buffer) (goto-char (point-min)) (let ((ident (concat "\nX-Gnus-Newsgroup: " nnmbox-current-group ":")) (new-ident (concat "\nX-Gnus-Newsgroup: " new-name ":")) found) (while (search-forward ident nil t) (replace-match new-ident t t) (setq found t)) (when found (nnmbox-save-buffer)))) (let ((entry (assoc group nnmbox-group-active-articles))) (when entry (setcar entry new-name))) (let ((entry (assoc group nnmbox-group-alist))) (when entry (setcar entry new-name)) (setq nnmbox-current-group nil) ;; Save the new group alist. (nnmbox-save-active nnmbox-group-alist nnmbox-active-file) t)) ;;; Internal functions. ;; If FORCE, delete article no matter how many X-Gnus-Newsgroup ;; headers there are. If LEAVE-DELIM, don't delete the Unix mbox ;; delimiter line. (defun nnmbox-delete-mail (&optional force leave-delim) ;; Delete the current X-Gnus-Newsgroup line. ;; First delete record of active article, unless the article is being ;; replaced, indicated by FORCE being non-nil. (if (not force) (nnmbox-record-deleted-article (nnmbox-article-group-number t))) (or force (gnus-delete-line)) ;; Beginning of the article. (save-excursion (save-restriction (narrow-to-region (prog2 (re-search-backward (concat "^" message-unix-mail-delimiter) nil t) (if leave-delim (progn (forward-line 1) (point)) (match-beginning 0)) (forward-line 1)) (or (and (re-search-forward (concat "^" message-unix-mail-delimiter) nil t) (match-beginning 0)) (point-max))) (goto-char (point-min)) ;; Only delete the article if no other group owns it as well. (when (or force (not (re-search-forward "^X-Gnus-Newsgroup: " nil t)) (search-backward "\n\n" nil t)) (delete-region (point-min) (point-max)))))) (defun nnmbox-possibly-change-newsgroup (newsgroup &optional server) (when (and server (not (nnmbox-server-opened server))) (nnmbox-open-server server)) (when (or (not nnmbox-mbox-buffer) (not (buffer-name nnmbox-mbox-buffer))) (nnmbox-read-mbox)) (when (not nnmbox-group-alist) (nnmail-activate 'nnmbox)) (if newsgroup (when (assoc newsgroup nnmbox-group-alist) (setq nnmbox-current-group newsgroup)) t)) (defun nnmbox-article-string (article) (if (numberp article) (concat "\nX-Gnus-Newsgroup: " nnmbox-current-group ":" (int-to-string article) " ") (concat "\nMessage-ID: " article))) (defun nnmbox-article-group-number (this-line) (save-excursion (if this-line (beginning-of-line) (goto-char (point-min))) (when (re-search-forward "^X-Gnus-Newsgroup: +\\([^:]+\\):\\([0-9]+\\) " nil t) (cons (buffer-substring (match-beginning 1) (match-end 1)) (string-to-number (buffer-substring (match-beginning 2) (match-end 2))))))) (defun nnmbox-in-header-p (pos) "Return non-nil if POS is in the header of an article." (save-excursion (goto-char pos) (re-search-backward (concat "^" message-unix-mail-delimiter) nil t) (search-forward "\n\n" nil t) (< pos (point)))) (defun nnmbox-find-article (article) "Leaves point on the relevant X-Gnus-Newsgroup line if found." ;; Check that article is in the active range first, to avoid an ;; expensive exhaustive search if it isn't. (if (and (numberp article) (not (nnmbox-is-article-active-p article))) nil (let ((art-string (nnmbox-article-string article)) (found nil)) ;; There is the possibility that the X-Gnus-Newsgroup line appears ;; in the body of an article (for instance, if an article has been ;; forwarded from someone using Gnus as their mailer), so check ;; that the line is actually part of the article header. (or (and (search-forward art-string nil t) (nnmbox-in-header-p (point))) (progn (goto-char (point-min)) (while (and (not found) (search-forward art-string nil t)) (setq found (nnmbox-in-header-p (point)))) found))))) (defun nnmbox-record-active-article (group-art) (let* ((group (car group-art)) (article (cdr group-art)) (entry (or (assoc group nnmbox-group-active-articles) (progn (push (list group) nnmbox-group-active-articles) (car nnmbox-group-active-articles))))) ;; add article to index, either by building complete list ;; in reverse order, or as a list of ranges. (if (not nnmbox-group-building-active-articles) (setcdr entry (gnus-add-to-range (cdr entry) (list article))) (when (memq article (cdr entry)) (switch-to-buffer nnmbox-mbox-buffer) (error "Article %s:%d already exists!" group article)) (when (and (cadr entry) (< article (cadr entry))) (switch-to-buffer nnmbox-mbox-buffer) (error "Article %s:%d out of order" group article)) (setcdr entry (cons article (cdr entry)))))) (defun nnmbox-record-deleted-article (group-art) (let* ((group (car group-art)) (article (cdr group-art)) (entry (or (assoc group nnmbox-group-active-articles) (progn (push (list group) nnmbox-group-active-articles) (car nnmbox-group-active-articles))))) ;; remove article from index (setcdr entry (gnus-remove-from-range (cdr entry) (list article))))) (defun nnmbox-is-article-active-p (article) (gnus-member-of-range article (cdr (assoc nnmbox-current-group nnmbox-group-active-articles)))) (defun nnmbox-save-mail (group-art) "Called narrowed to an article." (let ((delim (concat "^" message-unix-mail-delimiter))) (goto-char (point-min)) ;; This might come from somewhere else. (if (looking-at delim) (forward-line 1) (insert "From nobody " (current-time-string) "\n")) ;; Quote all "From " lines in the article. (while (re-search-forward delim nil t) (goto-char (match-beginning 0)) (insert ">"))) (goto-char (point-max)) (unless (bolp) (insert "\n")) (nnmail-insert-lines) (nnmail-insert-xref group-art) (nnmbox-insert-newsgroup-line group-art) (let ((alist group-art)) (while alist (nnmbox-record-active-article (car alist)) (setq alist (cdr alist)))) (run-hooks 'nnmail-prepare-save-mail-hook) (run-hooks 'nnmbox-prepare-save-mail-hook) group-art) (defun nnmbox-insert-newsgroup-line (group-art) (save-excursion (goto-char (point-min)) (when (search-forward "\n\n" nil t) (forward-char -1) (while group-art (insert (format "X-Gnus-Newsgroup: %s:%d %s\n" (caar group-art) (cdar group-art) (current-time-string))) (setq group-art (cdr group-art)))) t)) (defun nnmbox-active-number (group) ;; Find the next article number in GROUP. (let ((active (cadr (assoc group nnmbox-group-alist)))) (if active (setcdr active (1+ (cdr active))) ;; This group is new, so we create a new entry for it. ;; This might be a bit naughty... creating groups on the drop of ;; a hat, but I don't know... (push (list group (setq active (cons 1 1))) nnmbox-group-alist)) (cdr active))) (defun nnmbox-create-mbox () (when (not (file-exists-p nnmbox-mbox-file)) (let ((nnmail-file-coding-system (or nnmbox-file-coding-system-for-write nnmbox-file-coding-system)) (dir (file-name-directory nnmbox-mbox-file))) (and dir (gnus-make-directory dir)) (nnmail-write-region (point-min) (point-min) nnmbox-mbox-file t 'nomesg)))) (defun nnmbox-read-mbox () (nnmail-activate 'nnmbox) (nnmbox-create-mbox) (if (and nnmbox-mbox-buffer (buffer-name nnmbox-mbox-buffer) (save-excursion (set-buffer nnmbox-mbox-buffer) (= (buffer-size) (nnheader-file-size nnmbox-mbox-file)))) () (save-excursion (let ((delim (concat "^" message-unix-mail-delimiter)) (alist nnmbox-group-alist) (nnmbox-group-building-active-articles t) start end end-header number) (set-buffer (setq nnmbox-mbox-buffer (let ((nnheader-file-coding-system nnmbox-file-coding-system)) (nnheader-find-file-noselect nnmbox-mbox-file t t)))) (mm-enable-multibyte) (buffer-disable-undo) ;; Go through the group alist and compare against the mbox file. (while alist (goto-char (point-max)) (when (and (re-search-backward (format "^X-Gnus-Newsgroup: %s:\\([0-9]+\\) " (caar alist)) nil t) (> (setq number (string-to-number (buffer-substring (match-beginning 1) (match-end 1)))) (cdadar alist))) (setcdr (cadar alist) number)) (setq alist (cdr alist))) ;; Examine all articles for our private X-Gnus-Newsgroup ;; headers. This is done primarily as a consistency check, but ;; it is convenient for building an index of the articles ;; present, to avoid costly searches for missing articles ;; (eg. when expiring articles). (goto-char (point-min)) (setq nnmbox-group-active-articles nil) (while (re-search-forward delim nil t) (setq start (match-beginning 0)) (save-excursion (search-forward "\n\n" nil t) (setq end-header (point)) (setq end (or (and (re-search-forward delim nil t) (match-beginning 0)) (point-max)))) (if (search-forward "\nX-Gnus-Newsgroup: " end-header t) ;; Build a list of articles in each group, remembering ;; that each article may be in more than one group. (progn (nnmbox-record-active-article (nnmbox-article-group-number t)) (while (search-forward "\nX-Gnus-Newsgroup: " end-header t) (nnmbox-record-active-article (nnmbox-article-group-number t)))) ;; The article is either new, or for some other reason ;; hasn't got our private headers, so add them now. The ;; only situation I've encountered when the X-Gnus-Newsgroup ;; header is missing is if the article contains a forwarded ;; message which does contain that header line (earlier ;; versions of Gnus didn't restrict their search to the ;; headers). In this case, there is an Xref line which ;; provides the relevant information to construct the ;; missing header(s). (save-excursion (save-restriction (narrow-to-region start end) (if (re-search-forward "\nXref: [^ ]+" end-header t) ;; generate headers from Xref: (let (alist) (while (re-search-forward " \\([^:]+\\):\\([0-9]+\\)" end-header t) (push (cons (match-string 1) (string-to-number (match-string 2))) alist)) (nnmbox-insert-newsgroup-line alist)) ;; this is really a new article (nnmbox-save-mail (nnmail-article-group 'nnmbox-active-number)))))) (goto-char end)) ;; put article lists in order (setq alist nnmbox-group-active-articles) (while alist (setcdr (car alist) (gnus-compress-sequence (nreverse (cdar alist)))) (setq alist (cdr alist))))))) (provide 'nnmbox) ;; arch-tag: 611dd95f-be37-413a-b3ae-8b059ba93659 ;;; nnmbox.el ends here gnus-5.11+v0.10.dfsg/lisp/nnwarchive.el0000644000175000017500000005500111004005111017711 0ustar tvainikatvainika;;; nnwarchive.el --- interfacing with web archives ;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, ;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc. ;; Author: Shenghuo Zhu ;; Keywords: news egroups mail-archive ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published ;; by the Free Software Foundation; either version 3, or (at your ;; option) any later version. ;; GNU Emacs is distributed in the hope that it will be useful, but ;; WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Commentary: ;; Note: You need to have `url' (w3 0.46) or greater version ;; installed for some functions of this backend to work. ;; Todo: ;; 1. To support more web archives. ;; 2. Generalize webmail to other MHonArc archive. ;;; Code: (eval-when-compile (require 'cl)) (require 'nnoo) (require 'message) (require 'gnus-util) (require 'gnus) (require 'gnus-bcklg) (require 'nnmail) (require 'mm-util) (require 'mm-url) (nnoo-declare nnwarchive) (defvar nnwarchive-type-definition '((egroups (address . "www.egroups.com") (open-url "http://www.egroups.com/login.cgi?&login_email=%s&login_password=%s" nnwarchive-login nnwarchive-passwd) (list-url "http://www.egroups.com/mygroups") (list-dissect . nnwarchive-egroups-list) (list-groups . nnwarchive-egroups-list-groups) (xover-url "http://www.egroups.com/messages/%s/%d" group aux) (xover-last-url "http://www.egroups.com/messages/%s/" group) (xover-page-size . 13) (xover-dissect . nnwarchive-egroups-xover) (article-url "http://www.egroups.com/message/%s/%d?source=1" group article) (article-dissect . nnwarchive-egroups-article) (authentication . t) (article-offset . 0) (xover-files . nnwarchive-egroups-xover-files)) (mail-archive (address . "www.mail-archive.com") (open-url) (list-url "http://www.mail-archive.com/lists.html") (list-dissect . nnwarchive-mail-archive-list) (list-groups . nnwarchive-mail-archive-list-groups) (xover-url "http://www.mail-archive.com/%s/mail%d.html" group aux) (xover-last-url "http://www.mail-archive.com/%s/maillist.html" group) (xover-page-size) (xover-dissect . nnwarchive-mail-archive-xover) (article-url "http://www.mail-archive.com/%s/msg%05d.html" group article1) (article-dissect . nnwarchive-mail-archive-article) (xover-files . nnwarchive-mail-archive-xover-files) (authentication) (article-offset . 1)))) (defvar nnwarchive-default-type 'egroups) (defvoo nnwarchive-directory (nnheader-concat gnus-directory "warchive/") "Where nnwarchive will save its files.") (defvoo nnwarchive-type nil "The type of nnwarchive.") (defvoo nnwarchive-address "" "The address of nnwarchive.") (defvoo nnwarchive-login nil "Your login name for the group.") (defvoo nnwarchive-passwd nil "Your password for the group.") (defvoo nnwarchive-groups nil) (defvoo nnwarchive-headers-cache nil) (defvoo nnwarchive-authentication nil) (defvoo nnwarchive-nov-is-evil nil) (defconst nnwarchive-version "nnwarchive 1.0") ;;; Internal variables (defvoo nnwarchive-open-url nil) (defvoo nnwarchive-open-dissect nil) (defvoo nnwarchive-list-url nil) (defvoo nnwarchive-list-dissect nil) (defvoo nnwarchive-list-groups nil) (defvoo nnwarchive-xover-files nil) (defvoo nnwarchive-xover-url nil) (defvoo nnwarchive-xover-last-url nil) (defvoo nnwarchive-xover-dissect nil) (defvoo nnwarchive-xover-page-size nil) (defvoo nnwarchive-article-url nil) (defvoo nnwarchive-article-dissect nil) (defvoo nnwarchive-xover-files nil) (defvoo nnwarchive-article-offset 0) (defvoo nnwarchive-buffer nil) (defvoo nnwarchive-keep-backlog 300) (defvar nnwarchive-backlog-articles nil) (defvar nnwarchive-backlog-hashtb nil) (defvoo nnwarchive-headers nil) ;;; Interface functions (nnoo-define-basics nnwarchive) (defun nnwarchive-set-default (type) (let ((defs (cdr (assq type nnwarchive-type-definition))) def) (dolist (def defs) (set (intern (concat "nnwarchive-" (symbol-name (car def)))) (cdr def))))) (defmacro nnwarchive-backlog (&rest form) `(let ((gnus-keep-backlog nnwarchive-keep-backlog) (gnus-backlog-buffer (format " *nnwarchive backlog %s*" nnwarchive-address)) (gnus-backlog-articles nnwarchive-backlog-articles) (gnus-backlog-hashtb nnwarchive-backlog-hashtb)) (unwind-protect (progn ,@form) (setq nnwarchive-backlog-articles gnus-backlog-articles nnwarchive-backlog-hashtb gnus-backlog-hashtb)))) (put 'nnwarchive-backlog 'lisp-indent-function 0) (put 'nnwarchive-backlog 'edebug-form-spec '(form body)) (defun nnwarchive-backlog-enter-article (group number buffer) (nnwarchive-backlog (gnus-backlog-enter-article group number buffer))) (defun nnwarchive-get-article (article &optional group server buffer) (if (numberp article) (if (nnwarchive-backlog (gnus-backlog-request-article group article (or buffer nntp-server-buffer))) (cons group article) (let (contents) (save-excursion (set-buffer nnwarchive-buffer) (goto-char (point-min)) (let ((article1 (- article nnwarchive-article-offset))) (nnwarchive-url nnwarchive-article-url)) (setq contents (funcall nnwarchive-article-dissect group article))) (when contents (save-excursion (set-buffer (or buffer nntp-server-buffer)) (erase-buffer) (insert contents) (nnwarchive-backlog-enter-article group article (current-buffer)) (nnheader-report 'nnwarchive "Fetched article %s" article) (cons group article))))) nil)) (deffoo nnwarchive-retrieve-headers (articles &optional group server fetch-old) (nnwarchive-possibly-change-server group server) (if (or gnus-nov-is-evil nnwarchive-nov-is-evil) (with-temp-buffer (with-current-buffer nntp-server-buffer (erase-buffer)) (let ((buf (current-buffer)) b e) (dolist (art articles) (nnwarchive-get-article art group server buf) (setq b (goto-char (point-min))) (if (search-forward "\n\n" nil t) (forward-char -1) (goto-char (point-max))) (setq e (point)) (with-current-buffer nntp-server-buffer (insert (format "221 %d Article retrieved.\n" art)) (insert-buffer-substring buf b e) (insert ".\n")))) 'headers) (setq nnwarchive-headers (cdr (assoc group nnwarchive-headers-cache))) (save-excursion (set-buffer nnwarchive-buffer) (erase-buffer) (funcall nnwarchive-xover-files group articles)) (save-excursion (set-buffer nntp-server-buffer) (erase-buffer) (let (header) (dolist (art articles) (if (setq header (assq art nnwarchive-headers)) (nnheader-insert-nov (cdr header)))))) (let ((elem (assoc group nnwarchive-headers-cache))) (if elem (setcdr elem nnwarchive-headers) (push (cons group nnwarchive-headers) nnwarchive-headers-cache))) 'nov)) (deffoo nnwarchive-request-group (group &optional server dont-check) (nnwarchive-possibly-change-server nil server) (when (and (not dont-check) nnwarchive-list-groups) (funcall nnwarchive-list-groups (list group)) (nnwarchive-write-groups)) (let ((elem (assoc group nnwarchive-groups))) (cond ((not elem) (nnheader-report 'nnwarchive "Group does not exist")) (t (nnheader-report 'nnwarchive "Opened group %s" group) (nnheader-insert "211 %d %d %d %s\n" (or (cadr elem) 0) 1 (or (cadr elem) 0) (prin1-to-string group)) t)))) (deffoo nnwarchive-request-article (article &optional group server buffer) (nnwarchive-possibly-change-server group server) (nnwarchive-get-article article group server buffer)) (deffoo nnwarchive-close-server (&optional server) (when (and (nnwarchive-server-opened server) (gnus-buffer-live-p nnwarchive-buffer)) (save-excursion (set-buffer nnwarchive-buffer) (kill-buffer nnwarchive-buffer))) (nnwarchive-backlog (gnus-backlog-shutdown)) (nnoo-close-server 'nnwarchive server)) (deffoo nnwarchive-request-list (&optional server) (nnwarchive-possibly-change-server nil server) (save-excursion (set-buffer nnwarchive-buffer) (erase-buffer) (if nnwarchive-list-url (nnwarchive-url nnwarchive-list-url)) (if nnwarchive-list-dissect (funcall nnwarchive-list-dissect)) (nnwarchive-write-groups) (nnwarchive-generate-active)) t) (deffoo nnwarchive-open-server (server &optional defs connectionless) (nnoo-change-server 'nnwarchive server defs) (nnwarchive-init server) (when nnwarchive-authentication (setq nnwarchive-login (or nnwarchive-login (read-string (format "Login at %s: " server) user-mail-address))) (setq nnwarchive-passwd (or nnwarchive-passwd (read-passwd (format "Password for %s at %s: " nnwarchive-login server))))) (unless nnwarchive-groups (nnwarchive-read-groups)) (save-excursion (set-buffer nnwarchive-buffer) (erase-buffer) (if nnwarchive-open-url (nnwarchive-url nnwarchive-open-url)) (if nnwarchive-open-dissect (funcall nnwarchive-open-dissect))) t) (nnoo-define-skeleton nnwarchive) ;;; Internal functions (defun nnwarchive-possibly-change-server (&optional group server) (nnwarchive-init server) (when (and server (not (nnwarchive-server-opened server))) (nnwarchive-open-server server))) (defun nnwarchive-read-groups () (let ((file (expand-file-name (concat "groups-" nnwarchive-address) nnwarchive-directory))) (when (file-exists-p file) (with-temp-buffer (insert-file-contents file) (goto-char (point-min)) (setq nnwarchive-groups (read (current-buffer))))))) (defun nnwarchive-write-groups () (with-temp-file (expand-file-name (concat "groups-" nnwarchive-address) nnwarchive-directory) (prin1 nnwarchive-groups (current-buffer)))) (defun nnwarchive-init (server) "Initialize buffers and such." (let ((type (intern server)) (defs nnwarchive-type-definition) def) (cond ((equal server "") (setq type nnwarchive-default-type)) ((assq type nnwarchive-type-definition) t) (t (setq type nil) (while (setq def (pop defs)) (when (equal (cdr (assq 'address (cdr def))) server) (setq defs nil) (setq type (car def)))) (unless type (error "Undefined server %s" server)))) (setq nnwarchive-type type)) (unless (file-exists-p nnwarchive-directory) (gnus-make-directory nnwarchive-directory)) (unless (gnus-buffer-live-p nnwarchive-buffer) (setq nnwarchive-buffer (save-excursion (nnheader-set-temp-buffer (format " *nnwarchive %s %s*" nnwarchive-type server))))) (nnwarchive-set-default nnwarchive-type)) (defun nnwarchive-eval (expr) (cond ((consp expr) (cons (nnwarchive-eval (car expr)) (nnwarchive-eval (cdr expr)))) ((symbolp expr) (eval expr)) (t expr))) (defun nnwarchive-url (xurl) (mm-with-unibyte-current-buffer (let ((url-confirmation-func 'identity) ;; Some hacks. (url-cookie-multiple-line nil)) (cond ((eq (car xurl) 'post) (pop xurl) (mm-url-fetch-form (car xurl) (nnwarchive-eval (cdr xurl)))) (t (mm-url-insert (apply 'format (nnwarchive-eval xurl)))))))) (defun nnwarchive-generate-active () (save-excursion (set-buffer nntp-server-buffer) (erase-buffer) (dolist (elem nnwarchive-groups) (insert (prin1-to-string (car elem)) " " (number-to-string (or (cadr elem) 0)) " 1 y\n")))) (defun nnwarchive-paged (articles) (let (art narts next) (while (setq art (pop articles)) (when (and (>= art (or next 0)) (not (assq art nnwarchive-headers))) (push art narts) (setq next (+ art nnwarchive-xover-page-size)))) narts)) ;; egroups (defun nnwarchive-egroups-list-groups (groups) (save-excursion (let (articles) (set-buffer nnwarchive-buffer) (dolist (group groups) (erase-buffer) (nnwarchive-url nnwarchive-xover-last-url) (goto-char (point-min)) (when (re-search-forward "of \\([0-9]+\\)[ \t\n\r]*" nil t) (setq articles (string-to-number (match-string 1)))) (let ((elem (assoc group nnwarchive-groups))) (if elem (setcar (cdr elem) articles) (push (list group articles "") nnwarchive-groups))) (setq nnwarchive-headers (cdr (assoc group nnwarchive-headers-cache))) (nnwarchive-egroups-xover group) (let ((elem (assoc group nnwarchive-headers-cache))) (if elem (setcdr elem nnwarchive-headers) (push (cons group nnwarchive-headers) nnwarchive-headers-cache))))))) (defun nnwarchive-egroups-list () (let ((case-fold-search t) group description elem articles) (goto-char (point-min)) (while (re-search-forward "href=\"/group/\\([^/\"\> ]+\\)" nil t) (setq group (match-string 1) description (match-string 2)) (if (setq elem (assoc group nnwarchive-groups)) (setcar (cdr elem) 0) (push (list group articles description) nnwarchive-groups)))) t) (defun nnwarchive-egroups-xover (group) (let (article subject from date) (goto-char (point-min)) (while (re-search-forward "]+>\\([^<]+\\)<" nil t) (setq group (match-string 1) article (string-to-number (match-string 2)) subject (match-string 3)) (forward-line 1) (unless (assq article nnwarchive-headers) (if (looking-at "]+>]+>\\([^<]+\\)    ") (setq from (match-string 1))) (forward-line 1) (if (looking-at "]+>]+>\\([^<]+\\)") (setq date (identity (match-string 1)))) (push (cons article (make-full-mail-header article (mm-url-decode-entities-string subject) (mm-url-decode-entities-string from) date (concat "<" group "%" (number-to-string article) "@egroup.com>") "" 0 0 "")) nnwarchive-headers)))) nnwarchive-headers) (defun nnwarchive-egroups-article (group articles) (goto-char (point-min)) (if (search-forward "
    " nil t)
      (delete-region (point-min) (point)))
  (goto-char (point-max))
  (if (search-backward "
    " nil t) (delete-region (point) (point-max))) (goto-char (point-min)) (while (re-search-forward "]+>\\([^<]+\\)    " nil t) (replace-match "\\1")) (mm-url-decode-entities) (buffer-string)) (defun nnwarchive-egroups-xover-files (group articles) (let (aux auxs) (setq auxs (nnwarchive-paged (sort articles '<))) (while (setq aux (pop auxs)) (goto-char (point-max)) (nnwarchive-url nnwarchive-xover-url)) (if nnwarchive-xover-dissect (nnwarchive-egroups-xover group)))) ;; mail-archive (defun nnwarchive-mail-archive-list-groups (groups) (save-excursion (let (articles) (set-buffer nnwarchive-buffer) (dolist (group groups) (erase-buffer) (nnwarchive-url nnwarchive-xover-last-url) (goto-char (point-min)) (when (re-search-forward "msg\\([0-9]+\\)\\.html" nil t) (setq articles (1+ (string-to-number (match-string 1))))) (let ((elem (assoc group nnwarchive-groups))) (if elem (setcar (cdr elem) articles) (push (list group articles "") nnwarchive-groups))) (setq nnwarchive-headers (cdr (assoc group nnwarchive-headers-cache))) (nnwarchive-mail-archive-xover group) (let ((elem (assoc group nnwarchive-headers-cache))) (if elem (setcdr elem nnwarchive-headers) (push (cons group nnwarchive-headers) nnwarchive-headers-cache))))))) (defun nnwarchive-mail-archive-list () (let ((case-fold-search t) group description elem articles) (goto-char (point-min)) (while (re-search-forward "\\([^>]+\\)<" nil t) (setq group (match-string 1) description (match-string 2)) (forward-line 1) (setq articles 0) (if (setq elem (assoc group nnwarchive-groups)) (setcar (cdr elem) articles) (push (list group articles description) nnwarchive-groups)))) t) (defun nnwarchive-mail-archive-xover (group) (let (article subject from date) (goto-char (point-min)) (while (re-search-forward "]*HREF=\"msg\\([0-9]+\\)\\.html[^>]+>\\([^<]+\\)<" nil t) (setq article (1+ (string-to-number (match-string 1))) subject (match-string 2)) (forward-line 1) (unless (assq article nnwarchive-headers) (if (looking-at "