CVS update by fenk packages/xemacs-packages/vm NEWS example.vm
packages/xemacs-packages/vm Makefile-kj README.bytecompile
xemacs-cvs at xemacs.org
xemacs-cvs at xemacs.org
Wed Apr 9 17:04:41 EDT 2008
User: fenk
Date: 08/04/09 23:04:32
Added: packages/xemacs-packages/vm NEWS example.vm
packages/xemacs-packages/vm/lisp tapestry.el vm-avirtual.el
vm-biff.el vm-crypto.el vm-delete.el vm-digest.el
vm-edit.el vm-folder.el vm-grepmail.el vm-imap.el
vm-license.el vm-macro.el vm-mark.el vm-menu.el
vm-message-history.el vm-message.el vm-mime.el
vm-minibuf.el vm-misc.el vm-motion.el vm-mouse.el
vm-page.el vm-pcrisis.el vm-pgg.el vm-pine.el
vm-pop.el vm-ps-print.el vm-reply.el vm-rfaddons.el
vm-save.el vm-search.el vm-serial.el vm-sort.el
vm-startup.el vm-summary-faces.el vm-summary.el
vm-thread.el vm-toolbar.el vm-undo.el vm-user.el
vm-vars.el vm-vcard.el vm-version.el vm-virtual.el
vm-window.el vm.el
packages/xemacs-packages/vm/pixmaps autofile-dn.xpm
autofile-up.xpm compose-dn.xpm compose-up.xpm
delete-dn.xpm delete-up.xpm file-dn.xpm file-up.xpm
followup-dn.xpm followup-up.xpm forward-dn.xpm
forward-up.xpm getmail-dn.xpm getmail-up.xpm
help-dn.xpm help-up.xpm mime-dn.xpm mime-up.xpm
mime-xx.xpm next-dn.xpm next-up.xpm previous-dn.xpm
previous-up.xpm print-dn.xpm print-up.xpm
quit-dn.xpm quit-up.xpm recover-dn.xpm
recover-up.xpm reply-dn.xpm reply-up.xpm
undelete-dn.xpm undelete-up.xpm visit-dn.xpm
visit-up.xpm
packages/xemacs-packages/vm/pixmaps/gtk autofile-dn.xpm
autofile-up.xpm compose-dn.xpm compose-up.xpm
delete-dn.xpm delete-up.xpm file-dn.xpm file-up.xpm
followup-dn.xpm followup-up.xpm forward-dn.xpm
forward-up.xpm getmail-dn.xpm getmail-up.xpm
help-dn.xpm help-up.xpm mime-dn.xpm mime-up.xpm
mime-xx.xpm next-dn.xpm next-up.xpm previous-dn.xpm
previous-up.xpm print-dn.xpm print-up.xpm
quit-dn.xpm quit-up.xpm recover-dn.xpm
recover-up.xpm reply-dn.xpm reply-up.xpm
undelete-dn.xpm undelete-up.xpm visit-dn.xpm
visit-up.xpm
packages/xemacs-packages/vm/pixmaps/mime application.xpm
audio.xpm image.xpm message.xpm multipart.xpm
text.xpm video.xpm
Removed: packages/xemacs-packages/vm Makefile-kj README.bytecompile
make-autoloads tapestry.el vm-byteopts.el
vm-crypto.el vm-delete.el vm-digest.el
vm-easymenu.el vm-edit.el vm-folder.el vm-imap.el
vm-license.el vm-macro.el vm-mark.el vm-menu.el
vm-message.el vm-mime.el vm-minibuf.el vm-misc.el
vm-motion.el vm-mouse.el vm-page.el vm-pop.el
vm-reply.el vm-save.el vm-search.el vm-sort.el
vm-startup.el vm-summary.el vm-thread.el
vm-toolbar.el vm-undo.el vm-user.el vm-vars.el
vm-version.el vm-virtual.el vm-window.el vm.texinfo
packages/xemacs-packages/vm/etc audio_stamp-colorful.xpm
audio_stamp-simple.xpm autofile-dn.xbm
autofile-dn.xpm autofile-up.xbm autofile-up.xpm
autofile-xx.xbm compose-dn.xbm compose-dn.xpm
compose-up.xbm compose-up.xpm compose-xx.xbm
delete-dn.xbm delete-dn.xpm delete-up.xbm
delete-up.xpm delete-xx.xbm document-colorful.xpm
document-simple.xpm file-dn.xbm file-dn.xpm
file-up.xbm file-up.xpm file-xx.xbm
film-colorful.xpm film-simple.xpm gear-colorful.xpm
gear-simple.xpm getmail-dn.xbm getmail-dn.xpm
getmail-up.xbm getmail-up.xpm getmail-xx.xbm
help-dn.xbm help-dn.xpm help-up.xbm help-up.xpm
help-xx.xbm message-colorful.xpm message-simple.xpm
mime-colorful-dn.xpm mime-colorful-up.xpm
mime-colorful-xx.xpm mime-dn.xbm mime-simple-dn.xpm
mime-simple-up.xpm mime-simple-xx.xpm mime-up.xbm
mime-xx.xbm mona_stamp-colorful.xpm
mona_stamp-simple.xpm next-dn.xbm next-dn.xpm
next-up.xbm next-up.xpm next-xx.xbm previous-dn.xbm
previous-dn.xpm previous-up.xbm previous-up.xpm
previous-xx.xbm print-dn.xbm print-dn.xpm
print-up.xbm print-up.xpm print-xx.xbm quit-dn.xbm
quit-dn.xpm quit-up.xbm quit-up.xpm quit-xx.xbm
recover-dn.xbm recover-dn.xpm recover-up.xbm
recover-up.xpm recover-xx.xbm reply-dn.xbm
reply-dn.xpm reply-up.xbm reply-up.xpm reply-xx.xbm
stuffed_box-colorful.xpm stuffed_box-simple.xpm
undelete-dn.xbm undelete-dn.xpm undelete-up.xbm
undelete-up.xpm undelete-xx.xbm visit-dn.xbm
visit-dn.xpm visit-up.xbm visit-up.xpm visit-xx.xbm
Log:
Synced vm package with VM 8.0.x.
It will get some more changes before releasing 8.0.10.
There are tons of warnings as we do not use the old Makefile anymore.
Also there are much more dependencies to other packages now.
Revision Changes Path
1.75 +20 -39 XEmacs/packages/xemacs-packages/vm/Makefile
Index: Makefile
===================================================================
RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/vm/Makefile,v
retrieving revision 1.74
retrieving revision 1.75
diff -u -p -r1.74 -r1.75
--- Makefile 2007/10/13 21:40:37 1.74
+++ Makefile 2008/04/09 21:00:02 1.75
@@ -17,54 +17,35 @@
# the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
# Boston, MA 02111-1307, USA.
-VERSION = 7.26
-AUTHOR_VERSION = 7.19
-MAINTAINER = Kyle Jones <kyle_jones at wonderworks.com>
+VERSION = 8.0
+AUTHOR_VERSION = 8.0.10-devo
+MAINTAINER = Robert Widhopf-Fenk <hack at robf.de>
PACKAGE = vm
PKG_TYPE = regular
-REQUIRES = mail-lib xemacs-base
+REQUIRES = vm xemacs-base mail-lib gnus pgg ecrypto eterm sh-script net-utils ps-print os-utils bbdb fsf-compat
CATEGORY = standard
# vm-version.elc needs to be first in this list, because load time
# code needs the Emacs/XEmacs MULE/no-MULE feature stuff.
-ELCS = vm-version.elc vm-message.elc vm-misc.elc tapestry.elc \
- vm-delete.elc vm-digest.elc vm-easymenu.elc vm-edit.elc \
- vm-folder.elc vm-imap.elc vm-license.elc vm-macro.elc \
- vm-mark.elc vm-menu.elc vm-mime.elc vm-minibuf.elc \
- vm-motion.elc vm-mouse.elc vm-page.elc vm-pop.elc vm-reply.elc \
- vm-save.elc vm-search.elc vm-sort.elc vm-startup.elc \
- vm-summary.elc vm-thread.elc vm-toolbar.elc vm-undo.elc \
- vm-user.elc vm-vars.elc vm-virtual.elc vm-window.elc \
- vm-crypto.elc
-
-EXTRA_SOURCES = vm.el vm.elc vm-autoload.el vm-autoload.elc Makefile-kj \
- README.bytecompile
-
-PRELOADS =-l vm-byteopts.el -l vm-version.el -l vm-message.el \
- -l vm-macro.el -l vm-vars.el
+DONTCOMPILE = lisp/vm-build.el \
+ lisp/_pkg.el lisp/auto-autoloads.el lisp/custom-load.el
-DOCS_TEXINFO_EXTENSION = t
-STANDARD_DOCS = t
+ELCS = $(patsubst %.el,%.elc,$(filter-out $(DONTCOMPILE),$(wildcard lisp/*.el)))
-DATA_FILES = $(shell echo etc/*.x??)
-DATA_DEST = $(PACKAGE)
+EXTRA_SOURCES = NEWS $(DONTCOMPILE)
-EARLY_GENERATED_LISP += vm.el vm-autoload.el
+EXPLICIT_DOCS = $(wildcard info/*.texi)
+DATA_FILES = $(shell echo pixmaps/*.xpm) $(shell echo pixmaps/mime/*.xpm)
+DATA_DEST = pixmaps
+
+AUTOLOAD_PATH = lisp
+
+PRELOADS = -l vm-version.el -l vm-message.el \
+ -l vm-macro.el -l vm-vars.el -l vm-misc.el
+
include ../../XEmacs.rules
+
+lisp/vm-revno.el: .bzr/branch/last-revision
+ ./release.sh version-info
-vm.el:
- @echo "building vm.elc (with all modules set to autoload)..."
- @echo "(defun vm-its-such-a-cruel-world ()" > vm.el
- @echo " (require 'vm-version)" >> vm.el
- @echo " (require 'vm-startup)" >> vm.el
- @echo " (require 'vm-vars)" >> vm.el
- @echo " (require 'vm-autoload))" >> vm.el
- @echo "(vm-its-such-a-cruel-world)" >> vm.el
- @echo "(fmakunbound 'vm-its-such-a-cruel-world)" >> vm.el
-
-vm-autoload.el: $(ELCS:.elc=.el)
- @echo scanning sources to build autoload definitions...
- $(BOOT_XEMACS) -l ./make-autoloads -f print-autoloads \
- $(ELCS:.elc=.el) >> vm-autoload.el
- @echo "(provide 'vm-autoload)" >> vm-autoload.el
1.8 +118 -64 XEmacs/packages/xemacs-packages/vm/README
Index: README
===================================================================
RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/vm/README,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -p -r1.7 -r1.8
--- README 2003/09/03 00:43:45 1.7
+++ README 2008/04/09 21:00:03 1.8
@@ -1,66 +1,120 @@
-How to setup VM:
+VM was written by Kyle Jones! Hail Kyle! The last release from Kyle was 7.19.
-0) Look at the Makefile and review the values of EMACS, INFODIR,
- LISPDIR, BINDIR and PIXMAPDIR. If they are not right for your
- system, change them.
-
-1) Your build options:
- `make' to build a usable VM.
- `make vm.info' to build the Info online help document.
- 'make utils' to compile the external Quoted-Printable and
- BASE64 encoders and decoders.
- `make all' to make everything.
- If there are byte compiler warnings, ignore them. They
- probably can't be avoided with code that is run on multipe
- Emacs versions.
-
-2) Put all the .elc files into a Lisp directory that is in your
- Emacs load-path. If you've already set LISPDIR to this
- directory, just `make install'.
-
-3) If you're using XEmacs or Emacs 21 and you want toolbar
- support, make a directory called `vm' in the XEmacs `etc'
- directory. Copy the files in pixmaps directory into the
- directory you just created. VM will look for the pixmaps
- there by default.
-
- Alternately you can put the pixmap files in any directory you
- want or just leave them where they are. Be sure to point the
- variables vm-toolbar-pixmap-directory and vm-image-directory at
- the direrctory where you put the files. That is
-
- (setq vm-toolbar-pixmap-directory "/path/to/pixmaps")
- (setq vm-image-directory "/path/to/pixmaps")
-
- in your .emacs or .vm file. If you've set PIXMAPDIR, 'make
- install' will copy the files to that directory.
-
-4) If you built the Info document, copy the file vm.info* files
- into the Emacs' info. ('make install' will do this for you if
- you've set INFODIR). You may need to edit the "dir" file in
- that directory and add a menu entry for VM. It should look
- like this:
-
-* VM:: (vm) A mail reader.
-
-5) Put these lines in your .emacs file if they aren't there
- already:
-
- (autoload 'vm "vm" "Start VM on your primary inbox." t)
- (autoload 'vm-other-frame "vm" "Like `vm' but starts in another frame." t)
- (autoload 'vm-visit-folder "vm" "Start VM on an arbitrary folder." t)
- (autoload 'vm-visit-virtual-folder "vm" "Visit a VM virtual folder." t)
- (autoload 'vm-mode "vm" "Run VM major mode on a buffer" t)
- (autoload 'vm-mail "vm" "Send a mail message using VM." t)
- (autoload 'vm-submit-bug-report "vm" "Send a bug report about VM." t)
-
-You're now ready to use VM. C-h i should start up the Emacs Info
-system and if you've installed the Info document properly you can
-use the online documentation to teach yourself how to use VM.
-
-Please use M-x vm-submit-bug-report to report bugs. The bug report
-will be sent to bug-vm at uunet.uu.net and be gatewayed from there to
-gnu.emacs.vm.bug.
+VM's home page up to version 7.19 on the World Wide Web is at
+http://www.wonderworks.com/vm and the FAQ is still hosted there.
-VM's home page on the World Wide Web is at http://www.wonderworks.com/vm .
-You can get the latest version of VM from there.
+This VM is based on my (Robert Widhopf-Fenk) patches against VM 7.19.
+
+The persons who have contributed to this version of VM are:
+
+ * Aidan Kehoe
+ * Glenn ???
+ * Jens Gustedt
+ * John J Foerch
+ * Kevin Rogers
+ * Kyle Jones
+ * Rob Hodges
+ * Robert Marshall
+ * Robert P. Goldman
+ * Robert Widhopf-Fenk
+
+Please mail me a note, if I have forgotten someone or accidently put you on
+the list.
+
+Read INSTALL and follow the instructions to compile and setup VM.
+
+*******************************************************************************
+BUGS
+
+If you have any problems or meet a bug it is best to discuss them on the USENET
+groups gnu.emacs.vm.bugs or gnu.emacs.vm.info! Also search the groups before
+posting as there might have been some discussion and a fix before.
+
+Report any problems or bugs otherwise they cannot be fixed!
+
+Please provide the version number of VM and Emacs and how to reproduce the
+problem.
+
+Personally I am an follower of the XEmacs church and thus some things may not
+work with GNU Emacs, nevertheless I test VM also on GNU Emacs from time to
+time and I am happy to merge you fixes.
+
+*******************************************************************************
+Homepage
+
+The new homepage of VM is at http://www.nongnu.org/viewmail/ hosted by
+Savannah. There is a bugtracker and other stuff, but I prefer the news
+groups!
+
+*******************************************************************************
+Wiki
+
+The Wiki at http://www.emacswiki.org/cgi-bin/wiki?id=CategoryViewMail is
+best suited to conserve code snippets, cooking guides or feature requests.
+
+*******************************************************************************
+BZR (http://bazaar-vcs.org/)
+
+I maintain my changes with BZR now, since CVS and SVN suck and TLA/BAZ do as well.
+
+If you want to send me changes or start hacking on your own you may want to
+branch from my repository at http://www.robf.de/Hacking/bazaar/vm-repo.
+
+# create your own branch from the trunk
+bzr get http://www.robf.de/Hacking/bazaar/vm-repo/vm-trunk
+# get updates
+bzr pull
+# start hacking
+xemacs vm-pgg.el
+# commit your changes
+bzr commit
+# Generate a bundle of your changes for merging
+bzr bundle-revisions --output=xy-changes.diff
+# Attach the bundle to a mail (rather than doing cut&paste) and send
+# it to hack at robf.de with a descriptive subject.
+
+*******************************************************************************
+COMMENTS
+
+The documentation of my changes is incomplete and the changes may even cause
+new problems or bugs.
+
+This VM provides the following hacks & enhancements and other stuff not
+listed here, as I am quite lazy in writing docs. ;c)
+
+Additional extensions for VM written by myself:
+- vm-pine.el for draft handling and other Pine inspired functions.
+- vm-ps-print.el for nice ps-printing functions
+- vm-rfaddons.el adds various add-ons to VM
+- vm-grepmail a grepmail interface for VM
+- vm-avirtual.el brings additional virtual folder selectors and functions
+ for spam tagging
+- vm-biff.el is a xbiff within VM, notifying you of new mail
+- vm-serial.el templates for mails, personalized serial mails
+- vm-summary-faces.el face base on virtual selectors
+
+Additional extensions for VM from other people:
+- vm-pcrisis.el by Rob Hodges for people with personal crisis which need
+ to rewrite headers automatically.
+- vcard.el by Noah Friedman <friedman at splode.com> for
+ vm-vcard.el displaying vcards within VM.
+
+Changes of the VM core (incomplete):
+- make-autoloads: enhanced output & ignore links
+- vm-mime.el:
+ * vm-pine patch for attachment handling of continued message drafts
+ * mime button displaying file name of attachment
+ * write mime filter
+ * qp-decoding of disposition parameters like filename etc.
+- vm-mouse.el: handling of email-addresses like "mailto:" URLs
+- vm-page.el: vm-energize-urls is interactive now, this allows you to easily
+ check URLs in a message you are currently composing.
+- vm-reply.el:
+ * Proper setting of subject & references when replying to multiple
+ messages.
+ * Filtering of MIME types when yanking a message. Now only those
+ types listed in `vm-included-mime-types-list' are yanked and you
+ will have no attachment mess any more!
+- vm-startup.el: vm-mail takes now a subject argument
+- vm-vars.el: two new variables for customization (see vm-reply)
+ * vm-included-mime-types-list
1.6 +11 -1 XEmacs/packages/xemacs-packages/vm/package-info.in
Index: package-info.in
===================================================================
RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/vm/package-info.in,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -p -r1.5 -r1.6
--- package-info.in 2002/01/01 14:38:59 1.5
+++ package-info.in 2008/04/09 21:00:04 1.6
@@ -13,7 +13,17 @@
filename FILENAME
md5sum MD5SUM
size SIZE
- provides (tapestry vm-byteopts vm-delete vm-digest vm-easymenu vm-edit vm-folder vm-imap vm-license vm-macro vm-mark vm-menu vm-message vm-mime vm-minibuf vm-misc vm-motion vm-mouse vm-page vm-pop vm-reply vm-save vm-search vm-sort vm-startup vm-summary vm-thread vm-toolbar vm-undo vm-user vm-vars vm vm-version vm-virtual vm-window)
+ provides (tapestry vm-autoload vm-avirtual vm-biff vm-build vm-crypto
+ vm-delete vm-digest vm-edit vm vm-folder vm-grepmail
+ vm-imap vm-license vm-macro vm-mark vm-menu vm-message
+ vm-message-history vm-mime vm-minibuf vm-misc vm-motion
+ vm-mouse vm-page vm-pcrisis vm-pgg vm-pine vm-pop
+ vm-ps-print vm-reply vm-rfaddons vm-save vm-search
+ vm-serial vm-sort vm-startup vm-summary vm-summary-faces
+ vm-thread vm-toolbar vm-undo vm-user vm-vars vm-vcard
+ vm-version vm-virtual vm-window)
requires (REQUIRES)
type regular
))
+
+
1.1 XEmacs/packages/xemacs-packages/vm/NEWS
Index: NEWS
===================================================================
VM 8.0.10
NOTES:
* This is the first version of VM 8.* to be also released as a XEmacs
package.
IMPROVEMENTS:
* `vm-message-history.el' now uses a buffer similar to the summary for
browsing the history. The buffer replaces the summary buffer when
present. Duplicate history entries will be removed.
BUGFIXES:
* Rewrote `vm-message-history.el' to also work for XEmacs.
* Leading lines of a yanked message were accidently taken as headers and
got removed if `vm-reply-include-presentation' was t.
* Fixed encoding of headers for trailing 8 bit characters. (Thanks to
Lutz Euler for the patch)
* Decode (QP-)encoded clear text before decrypting it.
VM 8.0.9
BUGFIXES:
* Added documentation to `vm-mime-external-content-types-alist' that no
extra single quotes should be used around %f as the file name is already
quoted for the shell. (Thanks to Martin Schwenke)
* Fixed version number generation in release script. It was broken for
8.0.8, i.e. it was showing 8.0.x-xemacs-542 instead. Now also other
branch related information is stored in the file vm-revno.el.
VM 8.0.8
IMPROVEMENTS:
* Reactivated "Allow defadvice on function `vm' by recursing on session
start". It should work correctly now.
* Added interactive `vm-pipe-message-to-command-discard-output' and
the non-interactive `vm-pipe-message-to-command-to-string' for using
it in own functions.
* Added `vm-pipe-messages-to-command*' for bulk piping messages to a
single command, i.e. like saving to a pipe. This is substantially
faster than `vm-pipe-message-to-command*' which call the command on
each message separately. You may want to use it to feed spamassasin.
* Modified key bindings for piping messages, i.e. "|" is a prefix key
now. Type it twice to get the old pipe command, "|d" will call the
discard the output, just display some infos in the mode line. "|s"
will call `vm-pipe-messages-to-command' and "|n" will also call it
but discard the output.
* Removed vm-easymenu.el and use easymenu.el instead.
* In `vm-save-message-preview', ask the user if the output file already
exists instead of silently overwriting it.
BUGFIXES:
* Moved [Undo] to Dispose menu and [Emacs] to Help menu as these do not
work in Emacs 22 anymore when on the menu bar.
* Fixed intermixing of signature and quoted text in reply if
`vm-reply-include-presentation' is t. (Thanks to Roland Winkler for
debugging and reporting)
* Fixed yanking of presentation from wrong folder when folder is virtual.
(Thanks to Roland Winkler for reporting)
* Redistributed flag not displayed in presentation buffer mode line.
https://bugzilla.redhat.com/show_bug.cgi?id=428248 (Thanks to Jonathan
Underwood for the fix)
* `vm-submit-bug-report' gets the variables dynamically now and thus does
not miss new ones or references old ones anymore.
* Correctly determine the real folder when postponing compositions started
from a virtual folder. (Thanks to Uday S. Reddy for reporting and
debugging)
* Avoid crash when `vm-mouse-set-mouse-track-highlight' is not called
within a summary buffer or without a valid message pointer.
* Do not disable modes which do not exist. (Thanks to Uday S. Reddy for
reporting)
VM 8.0.7
BUGFIXES:
* Disable only those minor modes listed in the variable
`vm-disable-modes-before-encoding' before encoding a
composition. (Thanks to Alley for reporting and debugging)
* Removed recursion from function `vm' added by 8.0.6, as it
causes startup troubles.
* Removed extra newline before attachment buttons. (Thanks to Alley for
reporting)
* Removed wrongly used calls to `interactive-p'. (Thanks to Alley for
reporting and debugging)
VM 8.0.6
IMPROVEMENTS:
* Rewrote INSTALL to be more consistent and more understandable.
* Allow defadvice on function `vm' by recursing on session start. (Thanks
to Blueman for the code)
BUGFIXES:
* Ignore empty reply-to in `vm-ignored-reply-to'.
* Quoted the variable `vm-summary-format' in a doc string.
* Fixed typos in the docstring of `vm-mail-send-and-exit'.
* Disable all minor modes before encoding a composition. This results in
faster encoding when font-lock was enabled and avoids problems when
parts of a MIME object button get expanded due to an abbrev and thus the
extent/overlay gets split into two separate parts causing an encoding
error.
* Avoid duplicate mime buttons during decoding. (Thanks to Alley for
reporting)
* Mask 8 bit chars by 0xff in `vm-mime-qp-encode-region' to avoid crash
for those with all higher order bits set (negative ones?) (Thanks to
Blueman for the fix.)
VM 8.0.5
BUGFIXES:
* Fixed bug caused by fixing `vm-drop-buffer-name-chars' in 8.0.4. There
is a 20-40% chance to create a new bug when fixing one. Regression
tests would be nice, but we do not have any for VM ;-/
VM 8.0.4
IMPROVEMENTS:
* Require cl.el at compile-time only. (Thanks to John J. Foerch)
* Quiet compiler warning about old style backquotes. (Thanks to John
J. Foerch)
BUGFIXES:
* Correctly call custom-add-load. (Thanks to John J. Foerch and
Jonathan.underwood)
* Fixed building of vm-cus-load.el for Emacs 21.
* Use the old default for `vm-primary-inbox', i.e. "~/INBOX".
* Honor a t in `vm-drop-buffer-name-chars' as documented.
VM 8.0.3
IMPROVEMENTS:
* Unified `vm-continue-what-message', i.e. first check for composition
buffers, if none exist then for saved drafts. Also added new variable
`vm-zero-drafts-start-compose'.
BUGFIXES:
* Fixed building of autoloads for GNU Emacs.
* Docfixes for vm-pine.el (Thanks to Stephen Eglen).
* Resurrected `vm-add-reply-subject-prefix' which was lost by the commit
of revno 91.
* Search for BZR only if bzrdir exists and use locate-file only when
defined.
* Use vm-mime-8bit-composition-charset as a fallback also for MULE Emacs.
* Fixed defcustom of vm-keep-crash-boxes and vm-spool-files.
* Fixed the section headers of the NEWS file.
VM 8.0.2
IMPROVEMENTS:
* Added --with-pixmapdir to configure the location of the pixmaps.
* DESTDIR-Patch (Ulrich Mueller).
BUGFIXES:
* Avoid overflow of `buffer-undo-list' when inserting or encoding
big attachments.
* defcustom of `vm-mime-all-attachments-directory' should list nil.
* Honor pre VM 8.0.0 values of `vm-folder-directory' and
`vm-primary-inbox'. This should eliminate problems with users which
never changed the defaults.
* Use "cygwin-mount" to fix paths when available.
* Activate summary faces only when requested by vm-enable-addons.
* Fixed defcustom of `vm-enable-addons' and added documentation.
* "make install" creates $(bindir) now.
* Separate paths (e.g. otherdirs) only by semicolons to avoid problems on
Win32.
* Handle paths with spaces correctly.
* Install also pixmaps for GTK enabled Emacs.
* Just use the first subject when replying/forwarding to a set of
messages. This avoids long filenames for saved composition buffers.
* Ensure we are compiling with an emacs version >= 21.
* Encode headers regexp and case-fold-search corrected. (Ulrich Mueller)
* vm-summary-faces-mode does not leak extents anymore.
VM 8.0.1
NOTES:
In order to get more features from vm-rfaddons set the variable
`vm-enable-addons' in your ~/.vm.
BUGFIXES:
* A saner default for vm-shrunken-header-face.
* Added documentation on vm-shrunken-headers-face and
vm-shrunken-headers-keymap.
* Added a new custom group `vm-faces' for faces.
* Added autoload token for vm-user-agent.
* Use INSTALL_PROGRAM instead of INSTALL_DATA for programs.
* Do not set vm-folder-directory if there is ~/INBOX. If VM does not get
mail after upgrading from 7.19 it is probably due to the new default for
vm-folder-directory, which was nil before.
* Revised the bindings and enabled features to a hopefully less
controversial setting.
VM 8.0.0
NOTES:
VM is now in my hands and I will do my best to keep it alive!
,--------------------------------------------------------------------------
| From: Kyle Jones <kyle_jones at wonderworks.com>
| To: Robert Widhopf-Fenk <hack at robf.de>
| Date: Wed, 21 Feb 2007 13:11:32 -0800
| Subject: Handing over VM?
|
| Robert Widhopf-Fenk writes:
| > Hi Kyle,
| >
| > I have been maintaining VM "unofficially" for the last few
| > years and now I want to become the official maintainer of
| > VM.
| >
| > Do I get your OK?
|
| Yes. Obviously I've moved on, though I've been slow to admit it
| to myself. Good luck.
`--------------------------------------------------------------------------
* My (robf) VM extensions are now activated by default, where it makes
sense to me.
* Releases are numbered now MAJOR.MINOR.PATCHLEVEL, where MAJOR is
increased when fundamental changes occur, MINOR for new features and
PATCHLEVEL for bugfix releases.
* New cleaner source tree layout.
* Better built system based on configure. Autoloads are generated only
for those functions marked with the autoload token now, which are mainly
interactive function. Thus, loading occurs only on demand and startup
should be faster.
BUGFIXES:
* All bugs reported to gnu.emacs.vm.bugs, gnu.emacs.vm.info and directly
to me are fixed either by the patches posted by others or me.
* If there are any missing autoloads, please report them and add a
(require 'vm-SOURCE) to your ~/.vm!
* Probably added numerous new bugs.
IMPROVEMENTS: compared to 7.19 (not vmrf)
* A new icon set based on vm-small-pixmaps.tgz which was floating around.
This one should fit by height to the one used in XEmacs and Emacs 22,
but it is slightly larger than those used in Emacs 21. If you see the
old icons, the please set the variables `vm-image-directory' and
`vm-toolbar-pixmap-directory' to nil in your ~/.vm!
* vm-mime-type-converter-alist now also works when replying to messages,
i.e. for text/html one can use lynx or w3m for the conversion.
(setq vm-mime-type-converter-alist
'(("text/html" "text/plain" "lynx -force_html -dump /dev/stdin")))
* Postponing (draft handling) of compositions and continuing of drafts, in
fact any messages also those from other people. (Info node: Sending
Messages)
* New mail header insertion functions for return-receipts, mail-priority
and FCC.
* More virtual folder selectors and replacements of other functions based
on selectors. (Info node: Virtual Folders)
* vm-serial.el provides message templates for composition and
personalizes mass emails. (Info node: TODO)
* vm-biff.el for popups with a list of new messages.
* vm-rfaddons.el has various stuff, look at the source if you are curious
or miss some VM feature, as it might already be there!
;;; Local Variables: ***
;;; mode:text ***
;;; End: ***
1.1 XEmacs/packages/xemacs-packages/vm/example.vm
Index: example.vm
===================================================================
;;; .vm --- Example ~/.vm
;;;
;;; -*- emacs-lisp -*-
;;;
;;; Copyright (C) 2007 Robert Widhopf-Fenk
;;;
;;; This program 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 1, or (at your option)
;;; any later version.
;;;
;;; This program 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; if not, write to the Free Software
;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
;;;
;;; You may use this file as a starting point for setting up and customizing
;;; VM to your own needs.
;;*****************************************************************************
;; Make VM your default mail agent in Emacs
(setq mail-user-agent 'vm-user-agent)
;;*****************************************************************************
;; Folders and spool files, this is where your mail comes from.
;; vm-spool-files is a list of lists, each sublist should be of the form
;; (INBOX SPOOLNAME CRASHBOX)
(setq vm-spool-files
(list
;; You can drop mail to the same inbox from different spool files.
(list vm-primary-inbox "/var/spool/mail/username1" vm-crash-box)
(list vm-primary-inbox "/var/spool/mail/username2" vm-crash-box)
;; Another spool file
(list "spam" (expand-file-name "~spam/drop")
(concat vm-folder-directory "spam.crash"))
;; POP
(list "gmail.pop" "pop:pop.google.com:110:pass:YourEmailAddress:*"
(concat vm-folder-directory "gmail.pop.crash"))
;; POP-SSL
(list "gmail.pop" "pop-ssl:pop.google.com:995:pass:YourEmailAddress:*"
(concat vm-folder-directory "gmail.pop.crash"))
;; IMAP
(list "gmail.imap" "imap:imap.google.com:143:inbox:login:YourEmailAddress:*"
(concat vm-folder-directory "gmail.imap.crash"))
))
;;*****************************************************************************
;; Summary
;; See the recipients for emails you sent instead of yourself.
(setq vm-summary-uninteresting-senders
(regexp-opt '("@robf.de" "Robert Widhopf-Fenk")))
;; Change the summary format by setting `vm-summary-format'.
;; Run "M-x vm-fix-my-summary!!! RET" to fix existing summaries.
;;*****************************************************************************
;; Viewing messages
;;
;; HTML messages can be converted to text or the w3 resp. w3m Emacs viewers
;; can be used for displaying.
(setq vm-mime-type-converter-alist
'(("text/html" "text/plain" "lynx -force_html -dump /dev/stdin")
("message/delivery-status" "text/plain")
("application/zip" "text/plain" "listzip")
("application/x-zip-compressed" "text/plain" "zipinfo /dev/stdin")
("application/x-www-form-urlencoded" "text/plain")
("message/disposition-notification" "text/plain")
("application/mac-binhex40" "application/octet-stream" "hexbin -s"))
;; Set up w3m (you should check if it exists)
(require 'vm-w3m)
(setq vm-included-mime-types-list
'("text/plain" "text/html" "text/enriched" "message/rfc822"))
;;*****************************************************************************
;; Composing email
(setq mail-default-headers "From: Robert Widhopf-Fenk <hack at robf.de>\n")
(vmpc-my-identities "me at company1.nil" "me at home.nil" "me at alterego.nil")
(require 'vm-pcrisis)
;;*****************************************************************************
;; A hook function to setup mail-composing buffers
(defun robf-vm-mail-mode-hook ()
"Robert Widhopf-Fenks `vm-mail-mode-hook'."
(interactive)
(when (string-match "received" (buffer-name))
(make-local-variable 'vm-confirm-quit)
(setq vm-confirm-quit t))
(setq fill-column 60
comment-start "> "
indent-line-function 'indent-relative-maybe)
;; mark lines longer than `fill-column' chars red
(add-to-list 'mail-font-lock-keywords
(list (concat "^" (make-string fill-column ?.)
"\\(.+$\\)")
'(1 font-lock-warning-face t)))
(ispell-change-dictionary "deutsch8")
(font-lock-mode 1)
(turn-on-auto-fill)
(turn-on-filladapt-mode)
(flyspell-mode 1)
; (enriched-mode 1)
; (auto-capitalize-mode)
; (vm-mail-subject-prefix-cleanup)
)
(add-hook 'vm-mail-mode-hook 'robf-vm-mail-mode-hook)
;; Do you like boxquotes?
(require 'boxquote)
(defun boxquote-region-and-edit-title (s e)
(interactive "r")
(boxquote-region s e)
(call-interactively 'boxquote-title))
;;*****************************************************************************
;; Sending email via SMTP.
;;
;; This is not done by VM, by by separate packages. The standard package is
;; smtpmail.el and it should come with your Emacs. If you have more than one
;; email address and have to send them using different SMTP servers, the you
;; might want to take a look at esmtpmail.el a fork from smtpmail.el targeted
;; to deal with personal crisis support.
(require 'esmtpmail)
(setq send-mail-function 'esmtpmail-send-it
esmtpmail-default-smtp-server "smtp.someprovider.com"
;; trace buffers help debugging problems
esmtpmail-debug-info t)
;; Select the SMTP server based on the From: header, i.e. the email address of
;; the author. There are also other authentication methods, see the docs.
(setq esmtpmail-send-it-by-alist
(list
'("YourEmaiAddress1" "SMTPSERVER1"
(vm-pop-login "pop:SMTPSERVER1:110:pass:YourEmailAddress:*"))
'("YourEmaiAddress2" "SMTPSERVER2"
(vm-after-pop "pop:SMTPSERVER2:110:pass:YourEmailAddress:*"))))
;;*****************************************************************************
;; Feed mail to a local queue if you are offline
(require 'feedmail)
(setq send-mail-function 'vm-mail-send-or-feed-it
feedmail-enable-queue t
feedmail-ask-before-queue nil
feedmail-buffer-eating-function 'feedmail-buffer-to-smtpmail
feedmail-queue-directory (expand-file-name "~/Mail/QUEUE"))
(define-key vm-mode-map "Qr" 'feedmail-run-the-queue)
(define-key vm-mode-map "Qc" 'vm-smtp-server-online-p)
(define-key vm-mode-map "Qw" 'feedmail-queue-reminder-medium)
(setq auto-mode-alist (cons '("\\.fqm$" . mail-mode) auto-mode-alist))
;; Check the queue on startup
(when (and (> (car (feedmail-look-at-queue-directory
feedmail-queue-directory)) 0))
(feedmail-queue-reminder-medium)
(sit-for 2)
(if (y-or-n-p "Send messages now? ")
(feedmail-run-the-queue)))
;;*****************************************************************************
;; BBDB - the address book for Emacs
(require 'bbdb)
(require 'bbdb-autoloads)
(bbdb-initialize 'vm 'sendmail)
(bbdb-insinuate-vm)
;; create records for people you reply to
(add-hook 'vm-reply-hook 'bbdb-force-record-create)
;;*****************************************************************************
;; Now change some keyboard bindings
(define-key vm-mode-map [(meta up)] 'vm-previous-unread-message)
(define-key vm-mode-map [(meta down)] 'vm-next-unread-message)
(define-key vm-mode-map "\C- " 'vm-scroll-backward)
(define-key vm-mode-map " " 'vm-scroll-forward)
(define-key vm-mode-map "c" 'vm-continue-what-message-other-frame)
(define-key vm-mode-map "C" 'vm-continue-postponed-message)
(define-key vm-mode-map "R" 'vm-reply-other-frame)
(define-key vm-mode-map "r" 'vm-reply-include-text-other-frame)
(define-key vm-mode-map "\C-R" 'vm-followup-other-frame)
(define-key vm-mode-map "\C-r" 'vm-followup-include-text-other-frame)
(define-key vm-mode-map "f" 'vm-forward-message-other-frame)
(define-key vm-mode-map "m" 'vm-toggle-mark)
(define-key vm-mode-map "d" 'vm-delete-message-action)
(define-key vm-mode-map "s" 'vm-virtual-save-message)
(define-key vm-mode-map "w" 'vm-save-message-preview)
(define-key vm-mode-map "lr" 'vm-delete-message-labels)
(define-key vm-mode-map "li" 'rf-vm-label-toggle-important)
(define-key vm-mode-map "ls" 'rf-vm-label-toggle-spam)
(define-key vm-mode-map "W" 'vm-save-message-sans-headers)
(define-key vm-mode-map "W" (make-sparse-keymap))
(define-key vm-mode-map "WW" 'vm-apply-window-configuration)
(define-key vm-mode-map "WS" 'vm-save-window-configuration)
(define-key vm-mode-map "WD" 'vm-delete-window-configuration)
(define-key vm-mode-map "W?" 'vm-window-help)
(define-key vm-mode-map "x" 'vm-expunge-folder)
(define-key vm-mode-map "X" 'vm-expunge-pop-messages)
(define-key vm-mode-map "#" nil)
(define-key vm-mode-map "/" 'bbdb)
(define-key vm-mode-map [(control return)] 'vm-edit-init-file)
(define-key vm-mode-map "S" 'vm-save-everything)
(define-key vm-mode-map "\C-a" 'vm-mime-auto-save-all-attachments)
(define-key vm-mode-map "VO" 'vm-virtual-omit-message)
(define-key vm-mode-map "VU" 'vm-virtual-update-folders)
(define-key vm-mode-map [(control s)] 'isearch-forward)
(define-key vm-mode-map "o" 'vm-switch-to-folder)
(define-key vm-summary-mode-map [(control up)] 'previous-line)
(define-key vm-summary-mode-map [(control down)] 'next-line)
(define-key vm-summary-mode-map [(control s)] 'vm-isearch-forward)
(define-key vm-mail-mode-map [tab] 'indent-relative)
(define-key vm-mail-mode-map [(control tab)] 'mail-interactive-insert-alias)
(define-key vm-mail-mode-map [return] 'newline-and-indent)
(define-key vm-mail-mode-map "\C-c\C-i" 'vm-serial-yank-mail)
(define-key vm-mail-mode-map "\C-c\C-o" 'vm-serial-expand-tokens)
(define-key vm-mail-mode-map [(control c) (control I)] 'vm-serial-insert-token)
(define-key vm-mail-mode-map [(control meta delete)] 'kill-this-buffer)
(define-key vm-mail-mode-map "\C-c\C-c" 'vm-mail-mode-comment-region)
(define-key vm-mail-mode-map "\C-c\C-d" 'vm-mail-mode-elide-reply-region)
(define-key vm-mail-mode-map "\C-c\C-k" 'vm-mail-mode-citation-clean-up)
(define-key vm-mail-mode-map "\C-c\C-a" 'vm-mime-attach-file)
(define-key vm-mail-mode-map "\C-c\C-b" 'boxquote-region-and-edit-title)
;;; Local Variables: ***
;;; mode:emacs-lisp ***
;;; End: ***
;;; .vm ends here
1.1 XEmacs/packages/xemacs-packages/vm/lisp/tapestry.el
Index: tapestry.el
===================================================================
;;; tapestry.el --- Tools to configure your GNU Emacs windows
;;
;; Copyright (C) 1991, 1993, 1994, 1995, 1997 Kyle E. Jones
;;
;; This program 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 2 of the License, or
;; (at your option) any later version.
;;
;; This program 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; if not, write to the Free Software Foundation, Inc.,
;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
;;; Code:
(defvar tapestry-version "1.09")
;; Pass state information between the tapestry-set-window-map
;; and tapestry-set-buffer-map stages. UGH. The reason for this
;; is explained in tapestry-set-buffer-map.
(defvar tapestry-windows-changed nil)
;;;###autoload
(defun tapestry (&optional frame-list)
"Returns a list containing complete information about the current
configuration of Emacs frames, windows, buffers and cursor
positions. Call the function set-tapestry with the list that this function
returns to restore the configuration.
Optional first arg FRAME-LIST should be a list of frames; only
configuration information about these frames will be returned.
The configuration information is returned in a form that can be saved and
restored across multiple Emacs sessions."
(let ((frames (or frame-list (tapestry-frame-list)))
(frame-map (tapestry-frame-map))
(sf (tapestry-selected-frame))
(other-maps nil))
(unwind-protect
(while frames
(tapestry-select-frame (car frames))
(setq other-maps (cons (list (tapestry-window-map)
(tapestry-buffer-map)
(tapestry-position-map))
other-maps)
frames (cdr frames)))
(tapestry-select-frame sf))
(list frame-map other-maps)))
;;;###autoload
(defun set-tapestry (map &optional n root-window-edges)
"Restore the frame/window/buffer configuration described by MAP,
which should be a list previously returned by a call to
tapestry.
Optional second arg N causes frame reconfiguration to be skipped
and the windows of the current frame will configured according to
the window map of the Nth frame in MAP.
Optional third arg ROOT-WINDOW-EDGES non-nil should be a list
containing the edges of a window in the current frame. This list
should be in the same form as returned by the `window-edges'
function. The window configuration from MAP will be restored in
this window. If no window with these exact edges exists, a
window that lies entirely within the edge coordinates will be
expanded until the edge coordinates match or the window bounded by
ROOT-WINDOW-EDGES is entirely contained within the expanded
window. If no window entirely within the ROOT-WINDOW-EDGES edge
coordinates can be found, the window with the greatest overlap of
ROOT-WINDOW-EDGES will be used."
(let ((sf (tapestry-selected-frame))
(tapestry-windows-changed nil)
frame-list frame-map other-maps other-map)
(setq frame-map (nth 0 map)
other-maps (nth 1 map))
(if (and root-window-edges (null n))
(setq n 1))
(if n
(let (first-window)
(setq other-map (nth (1- n) other-maps))
(if (null other-map)
(error "No such map, %d" n))
(setq first-window
(tapestry-set-window-map (nth 0 other-map) root-window-edges))
(tapestry-set-buffer-map (nth 1 other-map) first-window)
(tapestry-set-position-map (nth 2 other-map) first-window))
(tapestry-set-frame-map frame-map)
;; frame list is reversed relative to the map order because
;; created frames are added to the head of the list instead
;; of the tail.
(setq frame-list (nreverse (tapestry-frame-list)))
(unwind-protect
(while other-maps
(tapestry-select-frame (car frame-list))
(tapestry-set-window-map (nth 0 (car other-maps)))
(tapestry-set-buffer-map (nth 1 (car other-maps)))
(tapestry-set-position-map (nth 2 (car other-maps)))
(setq other-maps (cdr other-maps)
frame-list (cdr frame-list)))
(and (tapestry-frame-live-p sf) (tapestry-select-frame sf))))))
(defun tapestry-frame-map ()
(let ((map (mapcar 'tapestry-frame-parameters (tapestry-frame-list)))
list cell frame-list)
(setq list map
frame-list (tapestry-frame-list))
(while list
(setq cell (assq 'minibuffer (car list)))
(if (and cell (windowp (cdr cell)))
(if (eq (tapestry-window-frame (cdr cell)) (car frame-list))
(setcdr cell t)
(setcdr cell 'none)))
(setq list (cdr list)
frame-list (cdr frame-list)))
map ))
(defun tapestry-set-frame-map (map)
;; some parameters can only be set only at frame creation time.
;; so all existing frames must die.
(let ((doomed-frames (tapestry-frame-list)))
(while map
(tapestry-make-frame (car map))
(setq map (cdr map)))
(while doomed-frames
(tapestry-delete-frame (car doomed-frames))
(setq doomed-frames (cdr doomed-frames)))))
(defun tapestry-window-map ()
(let (maps map0 map1 map0-edges map1-edges x-unchanged y-unchanged)
(setq maps (mapcar 'tapestry-window-edges (tapestry-window-list)))
(while (cdr maps)
(setq map0 maps)
(while (cdr map0)
(setq map1 (cdr map0)
map0-edges (tapestry-find-window-map-edges (car map0))
map1-edges (tapestry-find-window-map-edges (car map1))
x-unchanged (and (= (car map0-edges) (car map1-edges))
(= (nth 2 map0-edges) (nth 2 map1-edges)))
y-unchanged (and (= (nth 1 map0-edges) (nth 1 map1-edges))
(= (nth 3 map0-edges) (nth 3 map1-edges))))
(cond ((and (not x-unchanged) (not y-unchanged))
(setq map0 (cdr map0)))
((or (and x-unchanged (eq (car (car map0)) '-))
(and y-unchanged (eq (car (car map0)) '|)))
(nconc (car map0) (list (car map1)))
(setcdr map0 (cdr map1)))
(t
(setcar map0 (list (if x-unchanged '- '|)
(car map0)
(car map1)))
(setcdr map0 (cdr map1))))))
(car maps)))
(defun tapestry-set-window-map (map &optional root-window-edges)
(let ((map-width (tapestry-compute-map-width map))
(map-height (tapestry-compute-map-height map))
(root-window nil))
(if root-window-edges
(let (w-list w-edges w-area
exact-w inside-w overlap-w max-overlap overlap)
(while (null root-window)
(setq exact-w nil
inside-w nil
overlap-w nil
max-overlap -1
w-list (tapestry-window-list))
(while w-list
(setq w-edges (tapestry-window-edges (car w-list))
w-area (tapestry-window-area w-edges))
(if (equal w-edges root-window-edges)
(setq exact-w (car w-list)
w-list nil)
(setq overlap (tapestry-window-overlap w-edges
root-window-edges)
overlap (if overlap (tapestry-window-area overlap) 0)
w-area (tapestry-window-area w-edges))
(if (< max-overlap overlap)
(setq max-overlap overlap
overlap-w (car w-list)))
;; set inside-w each time we find a window inside
;; the root window edges. FSF Emacs gives space
;; to the window above or to the left if there is
;; such a window. therefore we want to find the
;; inside window that is bottom-most or right-most so that
;; when we delete it, its space will be given to
;; what will be the root window.
(if (= w-area overlap)
(setq inside-w (car w-list)))
(setq w-list (cdr w-list))))
(cond (exact-w (setq root-window exact-w))
(inside-w
;; how could a window be inside the root window
;; edges and there only be one window? a
;; multi-line minibuffer, that's how!
(if (not (one-window-p t))
(delete-window inside-w)))
(t (setq root-window overlap-w))))
(tapestry-apply-window-map map map-width map-height root-window)
(setq tapestry-windows-changed t)
root-window )
(if (tapestry-windows-match-map map map-width map-height)
(tapestry-first-window)
(if (fboundp 'frame-reduce-to-one-window)
(frame-reduce-to-one-window (selected-frame))
;; `delete-other-windows' may cause the window point to move
;; as it tries to minimize redisplay
(delete-other-windows))
(setq root-window (selected-window))
(tapestry-apply-window-map map map-width map-height root-window)
(setq tapestry-windows-changed t)
root-window ))))
(defun tapestry-buffer-map ()
(let ((w-list (tapestry-window-list))
b list)
(while w-list
(setq b (window-buffer (car w-list))
list (cons (list (buffer-file-name b)
(buffer-name b))
list)
w-list (cdr w-list)))
(nreverse list)))
;; This version of tapestry-set-buffer-map unconditionally set
;; the window buffer. This confused XEmacs 19.14's scroll-up
;; function when scrolling VM presentation buffers.
;; end-of-buffer was never signaled after a scroll. You can
;; duplicate this by creating a buffer that can be displayed
;; fully in the current window and then run
;;
;; (progn
;; (set-window-buffer (selected-window) (current-buffer))
;; (scroll-up nil))
;;;;;;;;;;;
;;(defun tapestry-set-buffer-map (buffer-map &optional first-window)
;; (let ((w-list (tapestry-window-list first-window)) wb)
;; (while (and w-list buffer-map)
;; (setq wb (car buffer-map))
;; (set-window-buffer
;; (car w-list)
;; (if (car wb)
;; (or (get-file-buffer (car wb))
;; (find-file-noselect (car wb)))
;; (get-buffer-create (nth 1 wb))))
;; (setq w-list (cdr w-list)
;; buffer-map (cdr buffer-map)))))
(defun tapestry-set-buffer-map (buffer-map &optional first-window)
(let ((w-list (tapestry-window-list first-window))
current-wb proposed-wb cell)
(while (and w-list buffer-map)
(setq cell (car buffer-map)
proposed-wb (if (car cell)
(or (get-file-buffer (car cell))
(find-file-noselect (car cell)))
(get-buffer-create (nth 1 cell)))
current-wb (window-buffer (car w-list)))
;; Setting the window buffer to the same value it already
;; has seems to confuse XEmacs' scroll-up function. But
;; _not_ setting it after windows torn down seem to cause
;; window point to sometimes drift away from point at
;; redisplay time. The solution (hopefully!) is to track
;; when windows have been rearranged and unconditionally do
;; the set-window-buffer, otherwise do it only if the
;; window buffer and the proposed window buffer differ.
(if (or tapestry-windows-changed (not (eq proposed-wb current-wb)))
(set-window-buffer (car w-list) proposed-wb))
(setq w-list (cdr w-list)
buffer-map (cdr buffer-map)))))
(defun tapestry-position-map ()
(let ((sw (selected-window))
(w-list (tapestry-window-list))
list)
(while w-list
(setq list (cons (list (window-start (car w-list))
(window-point (car w-list))
(window-hscroll (car w-list))
(eq (car w-list) sw))
list)
w-list (cdr w-list)))
(nreverse list)))
(defun tapestry-set-position-map (position-map &optional first-window)
(let ((w-list (tapestry-window-list first-window))
(osw (selected-window))
sw p)
(while (and w-list position-map)
(setq p (car position-map))
(and (car p) (set-window-start (car w-list) (car p)))
(and (nth 1 p) (set-window-point (car w-list) (nth 1 p)))
(and (nth 2 p) (set-window-hscroll (car w-list) (nth 2 p)))
(and (nth 3 p) (setq sw (car w-list)))
;; move this buffer up in the buffer-list
(select-window (car w-list))
(setq w-list (cdr w-list)
position-map (cdr position-map)))
(select-window (or sw osw))))
(defun tapestry-apply-window-map (map map-width map-height current-window
&optional
root-window-width
root-window-height)
(let ((window-min-height 1)
(window-min-width 1)
horizontal)
(if (null root-window-width)
(setq root-window-height (window-height current-window)
root-window-width (window-width current-window)))
(while map
(cond
((numberp (car map)) (setq map nil))
((eq (car map) '-) (setq horizontal nil))
((eq (car map) '|) (setq horizontal t))
(t
(if (cdr map)
(split-window
current-window
(if horizontal
(/ (* (tapestry-compute-map-width (car map))
root-window-width)
map-width)
(/ (* (tapestry-compute-map-height (car map))
root-window-height)
map-height))
horizontal))
(if (not (numberp (car (car map))))
(setq current-window
(tapestry-apply-window-map (car map)
map-width map-height
current-window
root-window-width
root-window-height)))
(and (cdr map) (setq current-window (next-window current-window 0)))))
(setq map (cdr map)))
current-window ))
(defun tapestry-windows-match-map (map
&optional
map-width map-height
window-map
window-map-width
window-map-height)
(or map-width
(setq map-width (tapestry-compute-map-width map)
map-height (tapestry-compute-map-height map)))
(or window-map
(setq window-map (tapestry-window-map)
window-map-height (tapestry-compute-map-height window-map)
window-map-width (tapestry-compute-map-width window-map)))
(let ((result t))
(cond ((numberp (car map))
(and (numberp (car window-map))
(= (/ (* (nth 0 map) window-map-width)
map-width)
(nth 0 window-map))
(= (/ (* (nth 1 map) window-map-height)
map-height)
(nth 1 window-map))
(= (/ (* (nth 2 map) window-map-width)
map-width)
(nth 2 window-map))
(= (/ (* (nth 3 map) window-map-height)
map-height)
(nth 3 window-map))))
((eq (car map) '-)
(if (not (eq (car window-map) '-))
nil
(setq map (cdr map)
window-map (cdr window-map))
(while (and result map window-map)
(setq result (tapestry-windows-match-map (car map)
map-width
map-height
(car window-map)
window-map-width
window-map-height)
map (cdr map)
window-map (cdr window-map)))
(and result (null map) (null window-map))))
((eq (car map) '|)
(if (not (eq (car window-map) '|))
nil
(setq map (cdr map)
window-map (cdr window-map))
(while (and result map window-map)
(setq result (tapestry-windows-match-map (car map)
map-width
map-height
(car window-map)
window-map-width
window-map-height)
map (cdr map)
window-map (cdr window-map)))
(and result (null map) (null window-map)))))))
(defun tapestry-find-window-map-edges (map)
(let (nw-edges se-edges)
(setq nw-edges map)
(while (and (consp nw-edges) (not (numberp (car nw-edges))))
(setq nw-edges (car (cdr nw-edges))))
(setq se-edges map)
(while (and (consp se-edges) (not (numberp (car se-edges))))
(while (cdr se-edges)
(setq se-edges (cdr se-edges)))
(setq se-edges (car se-edges)))
(if (eq nw-edges se-edges)
nw-edges
(setq nw-edges (copy-sequence nw-edges))
(setcdr (nthcdr 1 nw-edges) (nthcdr 2 se-edges))
nw-edges )))
(defun tapestry-compute-map-width (map)
(let ((edges (tapestry-find-window-map-edges map)))
(- (nth 2 edges) (car edges))))
(defun tapestry-compute-map-height (map)
(let ((edges (tapestry-find-window-map-edges map)))
(- (nth 3 edges) (nth 1 edges))))
;; delq is to memq as delassq is to assq
(defun tapestry-delassq (elt list)
(let ((prev nil)
(curr list))
(while curr
(if (eq elt (car (car curr)))
(if (null prev)
(setq list (cdr list) curr list)
(setcdr prev (cdr curr))
(setq curr (cdr curr)))
(setq prev curr curr (cdr curr))))
list ))
;;;###autoload
(defun tapestry-remove-frame-parameters (map params)
(let (frame-map)
(while params
(setq frame-map (nth 0 map))
(while frame-map
(setcar frame-map (tapestry-delassq (car params) (car frame-map)))
(setq frame-map (cdr frame-map)))
(setq params (cdr params)))))
;;;###autoload
(defun tapestry-nullify-tapestry-elements (map &optional buf-file-name buf-name
window-start window-point
window-hscroll selected-window)
(let (p)
(setq map (nth 1 map))
(while map
(setq p (nth 1 (car map)))
(while p
(and buf-file-name (setcar (car p) nil))
(and buf-name (setcar (cdr (car p)) nil))
(setq p (cdr p)))
(setq p (nth 2 (car map)))
(while p
(and window-start (setcar (car p) nil))
(and window-point (setcar (cdr (car p)) nil))
(and window-hscroll (setcar (nthcdr 2 (car p)) nil))
(and selected-window (setcar (nthcdr 3 (car p)) nil))
(setq p (cdr p)))
(setq map (cdr map)))))
;;;###autoload
(defun tapestry-replace-tapestry-element (map what function)
(let (mapi mapj p old new)
(cond ((eq what 'buffer-file-name)
(setq mapi 1 mapj 0))
((eq what 'buffer-name)
(setq mapi 1 mapj 1))
((eq what 'window-start)
(setq mapi 2 mapj 0))
((eq what 'window-point)
(setq mapi 2 mapj 1))
((eq what 'window-hscroll)
(setq mapi 2 mapj 2))
((eq what 'selected-window)
(setq mapi 2 mapj 3)))
(setq map (nth 1 map))
(while map
(setq p (nth mapi (car map)))
(while p
(setq old (nth mapj (car p))
new (funcall function old))
(if (not (equal old new))
(setcar (nthcdr mapj (car p)) new))
(setq p (cdr p)))
(setq map (cdr map)))))
(defun tapestry-window-list (&optional first-window)
(let* ((first-window (or first-window (tapestry-first-window)))
(windows (cons first-window nil))
(current-cons windows)
(w (next-window first-window 'nomini)))
(while (not (eq w first-window))
(setq current-cons (setcdr current-cons (cons w nil)))
(setq w (next-window w 'nomini)))
windows ))
(defun tapestry-first-window ()
(if (eq (tapestry-selected-frame)
(tapestry-window-frame (minibuffer-window)))
(next-window (minibuffer-window))
(let ((w (selected-window))
(top (or (cdr (assq 'menu-bar-lines (tapestry-frame-parameters))) 0))
edges)
(while (or (not (= 0 (car (setq edges (tapestry-window-edges w)))))
;; >= instead of = because in FSF Emacs 19.2x
;; (whenever the Lucid menubar code was added) the
;; menu-bar-lines frame parameter == 1 when the
;; Lucid menubar is enabled even though the
;; menubar doesn't steal the first line from the
;; window.
(not (>= top (nth 1 edges))))
(setq w (next-window w 'nomini)))
w )))
(defun tapestry-window-area (edges)
(* (- (nth 3 edges) (nth 1 edges))
(- (nth 2 edges) (nth 0 edges))))
(defun tapestry-window-overlap (e0 e1)
(let (top left bottom right)
(cond ((and (<= (nth 0 e0) (nth 0 e1)) (< (nth 0 e1) (nth 2 e0)))
(setq left (nth 0 e1)))
((and (<= (nth 0 e1) (nth 0 e0)) (< (nth 0 e0) (nth 2 e1)))
(setq left (nth 0 e0))))
(cond ((and (< (nth 0 e0) (nth 2 e1)) (<= (nth 2 e1) (nth 2 e0)))
(setq right (nth 2 e1)))
((and (< (nth 0 e1) (nth 2 e0)) (<= (nth 2 e0) (nth 2 e1)))
(setq right (nth 2 e0))))
(cond ((and (<= (nth 1 e0) (nth 1 e1)) (< (nth 1 e1) (nth 3 e0)))
(setq top (nth 1 e1)))
((and (<= (nth 1 e1) (nth 1 e0)) (< (nth 1 e0) (nth 3 e1)))
(setq top (nth 1 e0))))
(cond ((and (< (nth 1 e0) (nth 3 e1)) (<= (nth 3 e1) (nth 3 e0)))
(setq bottom (nth 3 e1)))
((and (< (nth 1 e1) (nth 3 e0)) (<= (nth 3 e0) (nth 3 e1)))
(setq bottom (nth 3 e0))))
(and left top right bottom (list left top right bottom))))
(defun tapestry-window-edges (&optional window)
(if (and (fboundp 'window-pixel-edges)
(fboundp 'face-width)
(fboundp 'face-height))
(let ((edges (window-pixel-edges window))
tmp)
(setq tmp edges)
(setcar tmp (/ (car tmp) (face-width 'default)))
(setq tmp (cdr tmp))
(setcar tmp (/ (car tmp) (face-height 'default)))
(setq tmp (cdr tmp))
(setcar tmp (/ (car tmp) (face-width 'default)))
(setq tmp (cdr tmp))
(setcar tmp (/ (car tmp) (face-height 'default)))
edges )
(window-edges window)))
;; We call these functions instead of calling the Emacs 19 frame
;; functions directly to let this package work with v18 Emacs.
(defun tapestry-frame-list ()
(if (fboundp 'frame-list)
(frame-list)
(list nil)))
(defun tapestry-frame-parameters (&optional f)
(if (fboundp 'frame-parameters)
(frame-parameters f)
nil ))
(defun tapestry-window-frame (w)
(if (fboundp 'window-frame)
(window-frame w)
nil ))
(defun tapestry-modify-frame-parameters (f alist)
(if (fboundp 'modify-frame-parameters)
(modify-frame-parameters f alist)
nil ))
(defun tapestry-select-frame (f)
(if (fboundp 'select-frame)
(select-frame f)
nil ))
(defun tapestry-selected-frame ()
(if (fboundp 'selected-frame)
(selected-frame)
nil ))
(defun tapestry-next-frame (&optional f all)
(if (fboundp 'next-frame)
(next-frame f all)
nil ))
(defun tapestry-make-frame (&optional alist)
(if (fboundp 'make-frame)
(make-frame alist)
nil ))
(defun tapestry-delete-frame (&optional f)
(if (fboundp 'delete-frame)
(delete-frame f)
nil ))
(defun tapestry-frame-live-p (f)
(if (fboundp 'frame-live-p)
(frame-live-p f)
t ))
(provide 'tapestry)
;;; tapestry.el ends here
1.1 XEmacs/packages/xemacs-packages/vm/lisp/vm-avirtual.el
Index: vm-avirtual.el
===================================================================
;;; vm-avirtual.el --- additional functions for virtual folder selectors
;;
;; Copyright (C) 2000-2006 Robert Widhopf-Fenk
;;
;; Author: Robert Widhopf-Fenk
;; Status: Tested with XEmacs 21.4.19 & VM 7.19
;; Keywords: VM, virtual folders
;; X-URL: http://www.robf.de/Hacking/elisp
;; Version: $Id: vm-avirtual.el,v 1.1 2008/04/09 21:01:46 fenk Exp $
;; This program 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 2 of the License, or
;; (at your option) any later version.
;;
;; This program 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; if not, write to the Free Software Foundation, Inc.,
;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
;;; Commentary:
;;
;; Virtual folders are one of the greatest features offered by VM, however
;; sometimes I do not want do visit a virtual folder in order to do something
;; on messages. E.g. I have a virtual folder selector for spam messages and I
;; want VM to mark those messages matching the selector for deletion when
;; retrieving new messages. This can be done with a trick described in
;; the VM-FAQ, however this created two new buffers polluting my buffer space.
;; So this package provides a function `vm-auto-delete-messages' for this
;; purpose without drawbacks.
;;
;; Then after I realized I was maintaining three different variables for
;; actually the same things. They were `vm-auto-folder-alist' for automatic
;; selection of folders when saving messages, `vm-virtual-folder-alist' for my
;; loved virtual folders and `vmpc-conditions' in order to solve the handling
;; of my different email-addresses.
;;
;; This was kind of annoying, since virtual folder selector offer the best
;; way of specifying conditions, but they only work on messages within
;; folders and not on messages which are currently composed. So I decided to
;; extent virtual folder selectors also to message composing, although not
;; all of the selectors are meaning full for `mail-mode'.
;;
;; I wrote functions which can replace (*) the existing ones and others that
;; add new (+) functionality. Finally I came up with the following ones:
;; * vm-virtual-auto-archive-messages
;; * vm-virtual-save-message
;; * vmpc-check-virtual-selector
;; + vm-virtual-auto-delete-messages
;; + vm-virtual-auto-delete-message
;; + vm-virtual-omit-message
;; + vm-virtual-update-folders
;; + vm-virtual-apply-function
;; and the following variables
;; vm-virtual-check-case-fold-search
;; vm-virtual-auto-delete-message-selector
;; vm-virtual-auto-folder-alist
;; vm-virtual-message
;; and a couple of new selectors
;; mail-mode if in mail-mode evals its `argument' else `nil'
;; vm-mode if in vm-mode evals its `arg' else `nil'
;; eval evaluates its `arg' (write own complex selectors)
;; older-than returns `t' is a message is older than `arg' days
;;
;; So by using theses new features I can maintain just one selector for
;; e.g. my private email-address and get the right folder for saving messages,
;; visiting the corresponding virtual folders, auto archiving, setting the FCC
;; header and setting up `vmpc-conditions'. Do you know a mailer than can
;; beet this?
;;
;; My default selector for spam messages:
;;
;; ("spam" ("received")
;; (vm-mode
;; (and (new) (undeleted)
;; (or
;; ;; kill all those where all authors/recipients
;; ;; are unknown to my BBDB, i.e. messages from
;; ;; strangers which are not directed to me!
;; ;; (c't 12/2001)
;; (not (in-bbdb))
;; ;; authors that I do not know
;; (and (not (in-bbdb authors))
;; (or
;; ;; with bad content
;; (spam-word)
;; ;; they hide ID codes by long subjects
;; (subject " ")
;; ;; HTML only messages
;; (header "^Content-Type: text/html")
;; ;; for 8bit encoding "chinese" spam
;; (header "[¡-ÿ][¡-ÿ][¡-ÿ][¡-ÿ]")
;; ;; for qp-encoding "chinese" spam
;; (header "=[A-F][0-9A-F]=[A-F][0-9A-F]=[A-F][0-9A-F]=[A-F][0-9A-F]=[A-F][0-9A-F]")
;; ))))))
;;
;;; Feel free to sent me any comments or bug reports.
;;
;;; Code:
(require 'vm-virtual)
(defgroup vm nil
"VM"
:group 'mail)
(defgroup vm-avirtual nil
"VM additional virtual folder selectors and functions."
:group 'vm)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(eval-when-compile
(require 'cl))
(eval-and-compile
(require 'advice)
(require 'regexp-opt)
(require 'vm-version)
(require 'vm-message)
(require 'vm-macro)
(require 'vm-vars)
(require 'time-date)
(let ((feature-list '(bbdb bbdb-autoloads bbdb-com)))
(while feature-list
(condition-case nil
(require (car feature-list))
(error
(if (load (format "%s\n" (car feature-list)) t)
(message "Library %s loaded!" (car feature-list))
(message "Could not load feature %S. Related functions may not work correctly!" (car feature-list))
(beep 1))))
(setq feature-list (cdr feature-list)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defvar vm-mail-virtual-selector-function-alist
'(;; standard selectors
(and . vm-mail-vs-and)
(or . vm-mail-vs-or)
(not . vm-mail-vs-not)
(any . vm-mail-vs-any)
(header . vm-mail-vs-header)
(text . vm-mail-vs-text)
(header-or-text . vm-mail-vs-header-or-text)
(recipient . vm-mail-vs-recipient)
(author . vm-mail-vs-author)
(author-or-recipient . vm-mail-vs-author-or-recipient)
(subject . vm-mail-vs-subject)
(sortable-subject . vm-mail-vs-sortable-subject)
(more-chars-than . vm-mail-vs-more-chars-than)
(less-chars-than . vm-mail-vs-less-chars-than)
(more-lines-than . vm-mail-vs-more-lines-than)
(less-lines-than . vm-mail-vs-less-lines-than)
(replied . vm-mail-vs-replied)
(answered . vm-mail-vs-answered)
(forwarded . vm-mail-vs-forwarded)
(redistributed . vm-mail-vs-redistributed)
(unreplied . vm-mail-vs-unreplied)
(unanswered . vm-mail-vs-unanswered)
(unforwarded . vm-mail-vs-unforwarded)
(unredistributed . vm-mail-vs-unredistributed)
;; unknown selectors which return always nil
(new . vm-mail-vs-unknown)
(unread . vm-mail-vs-unknown)
(read . vm-mail-vs-unknown)
(unseen . vm-mail-vs-unknown)
(recent . vm-mail-vs-unknown)
(deleted . vm-mail-vs-unknown)
(filed . vm-mail-vs-unknown)
(written . vm-mail-vs-unknown)
(edited . vm-mail-vs-unknown)
(marked . vm-mail-vs-unknown)
(undeleted . vm-mail-vs-unknown)
(unfiled . vm-mail-vs-unknown)
(unwritten . vm-mail-vs-unknown)
(unedited . vm-mail-vs-unknown)
(unmarked . vm-mail-vs-unknown)
(virtual-folder-member . vm-mail-vs-unknown)
(label . vm-mail-vs-unknown)
(sent-before . vm-mail-vs-unknown)
(sent-after . vm-mail-vs-unknown)
;; new selectors
(mail-mode . vm-mail-vs-mail-mode)
(vm-mode . vm-vs-vm-mode)
(eval . vm-mail-vs-eval)
(older-than . vm-mail-vs-older-than)
(in-bbdb . vm-mail-vs-in-bbdb)
))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun vm-avirtual-add-selectors (selectors)
(let ((alist 'vm-virtual-selector-function-alist)
(sup-alist 'vm-supported-interactive-virtual-selectors)
sel)
(while selectors
(setq sel (car selectors))
(add-to-list alist (cons sel (intern (format "vm-vs-%s" sel))))
(add-to-list sup-alist (list (format "%s" sel)))
(setq selectors (cdr selectors)))))
(vm-avirtual-add-selectors
'(mail-mode
vm-mode
eval
older-than
outgoing
selected
in-bbdb
uninteresting-senders
spam-word
folder-name
attachment
spam-level
spam-score))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; we redefine the basic selectors for some extra features ...
(defcustom vm-virtual-check-case-fold-search t
"Wheater to use case-fold-search or not when applying virtual selectors.
I was really missing this!"
:type 'boolean
:group 'vm-avirtual)
(defcustom vm-virtual-check-diagnostics nil
"When set to nil we will display messages on matching selectors."
:type 'boolean
:group 'vm-avirtual)
(defvar vm-virtual-check-level 0)
(defun vm-vs-or (m &rest selectors)
(let ((case-fold-search vm-virtual-check-case-fold-search)
(vm-virtual-check-level (+ 2 vm-virtual-check-level))
(result nil) selector arglist function)
(while selectors
(setq selector (car (car selectors))
function (cdr (assq selector vm-virtual-selector-function-alist)))
(setq arglist (cdr (car selectors))
arglist (cdr (car selectors))
result (apply function m arglist)
selectors (if result nil (cdr selectors)))
(if vm-virtual-check-diagnostics
(princ (format "%sor: %s (%S%s)\n"
(make-string vm-virtual-check-level ? )
(if result t nil) selector
(if arglist (format " %S" arglist) "")))))
result))
(defun vm-vs-and (m &rest selectors)
(let ((vm-virtual-check-level (+ 2 vm-virtual-check-level))
(result t) selector arglist function)
(while selectors
(setq selector (car (car selectors))
function (cdr (assq selector vm-virtual-selector-function-alist)))
(if (null function)
(error "Invalid selector"))
(setq arglist (cdr (car selectors))
result (apply function m arglist)
selectors (if (null result) nil (cdr selectors)))
(if vm-virtual-check-diagnostics
(princ (format "%sand: %s (%S%s)\n"
(make-string vm-virtual-check-level ? )
(if result t nil) selector
(if arglist (format " %S" arglist) "")))))
result))
(defun vm-vs-not (m arg)
(let ((vm-virtual-check-level (+ 2 vm-virtual-check-level))
(selector (car arg))
(arglist (cdr arg))
result)
(setq result
(apply (cdr (assq selector vm-virtual-selector-function-alist))
m arglist))
(if vm-virtual-check-diagnostics
(princ (format "%snot: %s for (%S%s)\n"
(make-string vm-virtual-check-level ? )
(if result t nil) selector
(if arglist (format " %S" arglist) ""))))
(not result)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;###autoload
(defun vm-avirtual-check-for-missing-selectors (&optional arg)
"Check if there are selectors missing for either vm-mode or mail-mode."
(interactive "P")
(let ((a (if arg vm-mail-virtual-selector-function-alist
vm-virtual-selector-function-alist))
(b (mapcar (lambda (s) (car s))
(if arg vm-virtual-selector-function-alist
vm-mail-virtual-selector-function-alist)))
l)
(while a
(if (not (memq (caar a) b))
(setq l (concat (format "%s" (caar a)) ", " l)))
(setq a (cdr a)))
(if l
(message "Selectors %s are missing!" l)
(message "No selectors are missing!"))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; new virtual folder selectors
(defvar vm-virtual-message nil
"Set to the VM message vector when doing a `vm-vs-eval'.")
(defcustom vm-vs-attachment-regexp "^Content-Disposition: attachment"
"Regexp used to detect attachments in an message."
:group 'vm-avirtual
:type 'regexp)
(defun vm-vs-attachment (m)
(vm-vs-text m vm-vs-attachment-regexp))
(defun vm-vs-folder-name (m regexp)
(setq m (vm-real-message-of m))
(string-match regexp (buffer-name (marker-buffer (vm-start-of m)))))
(defun vm-vs-eval (&rest selectors)
(let ((vm-virtual-message (car selectors)))
(eval (cadr selectors))))
(defun vm-vs-vm-mode (&rest selectors)
(if (not (equal major-mode 'mail-mode))
(apply 'vm-vs-or selectors)
nil))
(defun vm-vs-older-than (m arg)
(let ((date (vm-get-header-contents m "Date:")))
(if date
(> (days-between (current-time-string) date) arg))))
(defun vm-vs-outgoing (m)
(and vm-summary-uninteresting-senders
(or (string-match vm-summary-uninteresting-senders (vm-su-full-name m))
(string-match vm-summary-uninteresting-senders (vm-su-from m)))))
(defun vm-vs-selected (m)
(save-excursion
(vm-select-folder-buffer)
(eq m (car vm-message-pointer))))
(defun vm-vs-uninteresting-senders (m)
(string-match vm-summary-uninteresting-senders
(vm-get-header-contents m "From:")))
(defun vm-vs-in-bbdb (m &optional address-class only-first)
"check if one of the email addresses from the mail is known."
(let (bbdb-user-mail-names)
(let* ((bbdb-get-only-first-address-p only-first)
(bbdb-user-mail-names nil)
(bbdb-get-addresses-headers
(if address-class
(or (list (assoc address-class bbdb-get-addresses-headers))
(error "no such address class"))
bbdb-get-addresses-headers))
(addresses (bbdb-get-addresses nil nil
'bbdb/vm-get-header-content
(vm-real-message-of m)))
(done nil)
addr)
(while (and (not done) addresses)
(setq addr (caddar addresses)
addresses (cdr addresses))
(let ((name (car addr))
(net (cadr addr)))
(setq done (or (bbdb-search-simple nil net)
(bbdb-search-simple name nil)))))
done)))
(defun vm-mail-vs-in-bbdb (&optional address-class only-first)
"check if one of the email addresses from the mail is known."
(let (bbdb-user-mail-names)
(let* ((bbdb-get-only-first-address-p only-first)
(bbdb-user-mail-names nil)
(bbdb-get-addresses-headers
(if address-class
(or (list (assoc address-class bbdb-get-addresses-headers))
(error "no such address class"))
bbdb-get-addresses-headers))
(addresses (bbdb-get-addresses nil nil
'vm-mail-mode-get-header-contents))
(done nil)
addr)
(while (and (not done) addresses)
(setq addr (caddar addresses)
addresses (cdr addresses))
(let ((name (car addr))
(net (cadr addr)))
(setq done (or (bbdb-search-simple nil net)
(bbdb-search-simple name nil)))))
done)))
(defvar vm-spam-words nil
"A list of words often contained in spam messages.")
(defvar vm-spam-words-regexp nil
"A regexp matching those words in `vm-spam-words'.")
(defcustom vm-spam-words-file
(expand-file-name "~/.spam-words")
"A file storing a list of words contained in spam messages."
:group 'vm-avirtual
:type 'file)
(defun vm-vs-spam-word (m &optional selector)
(if (and (not vm-spam-words)
vm-spam-words-file
(file-readable-p vm-spam-words-file)
(not (get-file-buffer vm-spam-words-file)))
(save-excursion
(set-buffer (find-file-noselect vm-spam-words-file))
(goto-char (point-min))
(while (re-search-forward "^\\s-*\\([^#;].*\\)\\s-*$" (point-max) t)
(setq vm-spam-words (cons (match-string 1) vm-spam-words)))
(setq vm-spam-words-regexp (regexp-opt vm-spam-words))))
(if (and m vm-spam-words-regexp)
(let ((case-fold-search t))
(cond ((eq selector 'header)
(vm-vs-header m vm-spam-words-regexp))
((eq selector 'header-or-text)
(vm-vs-header-or-text m vm-spam-words-regexp))
(t
(vm-vs-text m vm-spam-words-regexp))))))
;;;###autoload
(defun vm-add-spam-word (word)
"Add a new word to the list of spam words."
(interactive (list (if (region-active-p)
(buffer-substring (point) (mark))
(read-string "Spam word: "))))
(save-excursion
(when (not (member word vm-spam-words))
(if (get-file-buffer vm-spam-words-file)
(set-buffer (get-file-buffer vm-spam-words-file))
(set-buffer (find-file-noselect vm-spam-words-file)))
(goto-char (point-max))
;; if the last character is no newline, then append one!
(if (and (not (= (point) (point-min)))
(save-excursion
(backward-char 1)
(not (looking-at "\n"))))
(insert "\n"))
(insert word)
(save-buffer)
(setq vm-spam-words (cons word vm-spam-words))
(setq vm-spam-words-regexp (regexp-opt vm-spam-words)))))
;;;###autoload
(defun vm-spam-words-rebuild ()
"Discharge the internal cached data about spam words."
(interactive)
(setq vm-spam-words nil
vm-spam-words-regexp nil)
(if (get-file-buffer vm-spam-words-file)
(kill-buffer (get-file-buffer vm-spam-words-file)))
(vm-vs-spam-word nil)
(message "%d spam words are installed!" (length vm-spam-words)))
(defcustom vm-vs-spam-score-headers
'(("X-Spam-Score:" "[-+]?[0-9]*\\.?[0-9]+" string-to-number)
("X-Spam-Status:" "[-+]?[0-9]*\\.?[0-9]+" string-to-number)
("X-Spam-Level:" "\\*+" length))
"A list of headers to look for spam scores."
:group 'vm-avirtual
:type '(repeat (list (string :tag "Header regexp")
(regexp :tag "Regexp matching the score")
(function :tag "Function converting the score to a number"))))
(defun vm-vs-spam-score (m min &optional max)
"True when the spam score is >= MIN and optionally <= MAX.
The headers that will be checked are those listed in `vm-vs-spam-score-headers'."
(let ((spam-headers vm-vs-spam-score-headers)
it-is-spam)
(while spam-headers
(let* ((spam-selector (car spam-headers))
(score (vm-get-header-contents m (car spam-selector))))
(when (and score (string-match (nth 1 spam-selector) score))
(setq score (funcall (nth 2 spam-selector) (match-string 0 score)))
(if (and (<= min score) (if max (<= score max) t))
(setq it-is-spam t spam-headers nil))))
(setq spam-headers (cdr spam-headers)))
it-is-spam))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; new mail virtual folder selectors
(defun vm-mail-vs-eval (&rest selectors)
(eval (cadr selectors)))
(defun vm-mail-vs-mail-mode (&rest selectors)
(if (equal major-mode 'mail-mode)
(apply 'vm-mail-vs-or selectors)
nil))
(defalias 'vm-vs-mail-mode 'vm-mail-vs-mail-mode)
(defun vm-mail-vs-or (&rest selectors)
(let ((result nil) selector arglist
(case-fold-search vm-virtual-check-case-fold-search))
(while selectors
(setq selector (car (car selectors))
arglist (cdr (car selectors))
result (apply (cdr (assq selector
vm-mail-virtual-selector-function-alist))
arglist)
selectors (if result nil (cdr selectors)))
(if vm-virtual-check-diagnostics
(princ (format "%sor: %s (%S%s)\n"
(make-string vm-virtual-check-level ? )
(if result t nil) selector
(if arglist (format " %S" arglist) "")))))
result))
(defun vm-mail-vs-and (&rest selectors)
(let ((result t) selector arglist)
(while selectors
(setq selector (car (car selectors))
arglist (cdr (car selectors))
result (apply (cdr (assq selector
vm-mail-virtual-selector-function-alist))
arglist)
selectors (if (null result) nil (cdr selectors)))
(if vm-virtual-check-diagnostics
(princ (format "%sand: %s (%S%s)\n"
(make-string vm-virtual-check-level ? )
(if result t nil) selector
(if arglist (format " %S" arglist) "")))))
result))
(defun vm-mail-vs-not (arg)
(let ((selector (car arg))
(arglist (cdr arg))
result)
(setq result (apply (cdr (assq selector vm-mail-virtual-selector-function-alist))
arglist))
(if vm-virtual-check-diagnostics
(princ (format "%snot: %s for (%S%s)\n"
(make-string vm-virtual-check-level ? )
(if result t nil) selector
(if arglist (format " %S" arglist) ""))))
(not result)))
;; return just nil for those selectors not known for mail-mode
(defun vm-mail-vs-unknown (&optional arg)
nil)
(defun vm-mail-vs-any ()
t)
(defun vm-mail-vs-author (arg)
(let ((val (vm-mail-mode-get-header-contents "Sender\\|From:")))
(and val (string-match arg val))))
(defun vm-mail-vs-recipient (arg)
(let (val)
(or
(and (setq val (vm-mail-mode-get-header-contents "\\(Resent-\\)?To:"))
(string-match arg val))
(and (setq val (vm-mail-mode-get-header-contents "\\(Resent-\\)?CC:"))
(string-match arg val))
(and (setq val (vm-mail-mode-get-header-contents "\\(Resent-\\)?BCC:"))
(string-match arg val)))))
(defun vm-mail-vs-author-or-recipient (arg)
(or (vm-mail-vs-author arg)
(vm-mail-vs-recipient arg)))
(defun vm-mail-vs-subject (arg)
(let ((val (vm-mail-mode-get-header-contents "Subject:")))
(and val (string-match arg val))))
(defun vm-mail-vs-sortable-subject (arg)
(let ((case-fold-search t)
(subject (vm-mail-mode-get-header-contents "Subject:")))
(when subject
(if (and vm-subject-ignored-prefix
(string-match vm-subject-ignored-prefix subject)
(zerop (match-beginning 0)))
(setq subject (substring subject (match-end 0))))
(if (and vm-subject-ignored-suffix
(string-match vm-subject-ignored-suffix subject)
(= (match-end 0) (length subject)))
(setq subject (substring subject 0 (match-beginning 0))))
(setq subject (vm-with-string-as-temp-buffer
subject
(function vm-collapse-whitespace)))
(if (and vm-subject-significant-chars
(natnump vm-subject-significant-chars)
(< vm-subject-significant-chars (length subject)))
(setq subject
(substring subject 0 vm-subject-significant-chars)))
(string-match arg subject))))
(defun vm-mail-vs-header (arg)
(save-excursion
(let ((start (point-min)) end)
(goto-char start)
(search-forward (concat "\n" mail-header-separator "\n"))
(setq end (match-beginning 0))
(goto-char start)
(re-search-forward arg end t))))
(defun vm-mail-vs-text (arg)
(save-excursion
(goto-char (point-min))
(search-forward (concat "\n" mail-header-separator "\n"))
(re-search-forward arg (point-max) t)))
(defun vm-mail-vs-header-or-text (arg)
(save-excursion
(goto-char (point-min))
(re-search-forward arg (point-max) t)))
(defun vm-mail-vs-more-chars-than (arg)
(> (- (point-max) (point-min) (length mail-header-separator) 2) arg))
(defun vm-mail-vs-less-chars-than (arg)
(< (- (point-max) (point-min) (length mail-header-separator) 2) arg))
(defun vm-mail-vs-more-lines-than (arg)
(> (- (count-lines (point-min) (point-max)) 1) arg))
(defun vm-mail-vs-less-lines-than (arg)
(< (- (count-lines (point-min) (point-max)) 1) arg))
(defun vm-mail-vs-replied ()
vm-reply-list)
(fset 'vm-mail-vs-answered 'vm-mail-vs-replied)
(defun vm-mail-vs-forwarded ()
vm-forward-list)
(defun vm-mail-vs-redistributed ()
(vm-mail-mode-get-header-contents "Resent-[^:]+:"))
(defun vm-mail-vs-unreplied ()
(not (vm-mail-vs-forwarded )))
(fset 'vm-mail-vs-unanswered 'vm-mail-vs-unreplied)
(defun vm-mail-vs-unforwarded ()
(not (vm-mail-vs-forwarded )))
(defun vm-mail-vs-unredistributed ()
(not (vm-mail-vs-redistributed )))
(defun vm-mail-vs-older-than (arg)
(let* ((date (vm-mail-mode-get-header-contents "Date:"))
(days (and date (days-between (current-time-string) date))))
(and days (> days arg))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun vm-virtual-get-selector-member (folder-name folder-list)
(let (match )
(while folder-list
(if (string-match (car folder-list) folder-name)
(setq folder-list nil
match t))
(setq folder-list (cdr folder-list)))
match))
;;;###autoload
(defun vm-virtual-get-selector (vfolder &optional valid-folder-list)
"Return the selector of virtual folder VFOLDER for VALID-FOLDER-LIST."
(interactive
(list (vm-read-string "Virtual folder: " vm-virtual-folder-alist)
(if (equal major-mode 'mail-mode) nil
(list (save-excursion (vm-select-folder-buffer)
(buffer-name))))))
(let ((sels (assoc vfolder vm-virtual-folder-alist))
selector folder-name)
(setq sels (and sels (cadr sels)))
(when sels
(if (not valid-folder-list)
(setq selector (append (cdr sels) selector))
(setq folder-name valid-folder-list)
(while folder-name
(if (vm-virtual-get-selector-member (car folder-name) (car sels))
(setq selector (append (cdr sels) selector)))
(setq folder-name (cdr folder-name)))))
selector))
;;;###autoload
(defun vm-virtual-check-selector (selector &optional msg virtual)
"Return t if SELECTOR matches the message MSG.
If VIRTUAL is true we check the current message and not the real one."
(if msg
(if virtual
(apply 'vm-vs-or msg selector)
(save-excursion
(set-buffer (vm-buffer-of (vm-real-message-of msg)))
(apply 'vm-vs-or msg selector)))
(if (eq major-mode 'mail-mode)
(apply 'vm-mail-vs-or selector))))
;;;###autoload
(defun vm-virtual-check-selector-interactive (selector &optional diagnostics)
"Return t if SELECTOR matches the current message.
Called with an prefix argument we display more diagnostics about the selector
evaluation. Information is displayed in the order of evaluation and indented
according to the level of recursion. The displayed information is has the
format:
FATHER-SELECTOR: RESULT CHILD-SELECTOR"
(interactive
(list (vm-read-string "Virtual folder: " vm-virtual-folder-alist)
current-prefix-arg))
(save-excursion
(vm-select-folder-buffer)
(vm-error-if-folder-empty)
(vm-follow-summary-cursor)
(let ((msg (car vm-message-pointer))
(virtual (eq major-mode 'vm-virtual-mode))
(vm-virtual-check-diagnostics (or vm-virtual-check-diagnostics
diagnostics)))
(with-output-to-temp-buffer "*VM virtual-folder-check*"
(save-excursion
(set-buffer "*VM virtual-folder-check*")
(toggle-truncate-lines t))
(princ (format "Checking %S on <%s> from %s\n\n" selector
(vm-su-subject msg) (vm-su-from msg)))
(princ (format "\nThe virtual folder selector `%s' is %s!\n"
selector
(if (vm-virtual-check-selector
(vm-virtual-get-selector selector)
msg virtual)
"true"
"false")))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defvar vmpc-current-state nil)
;;;###autoload
(defun vmpc-virtual-check-selector (selector &optional folder-list)
"Checks SELECTOR based on the state of vmpc on the original or current."
(setq selector (vm-virtual-get-selector selector folder-list))
(if (null selector)
(error "no virtual folder %s!!" selector))
(cond ((or (eq vmpc-current-state 'reply)
(eq vmpc-current-state 'forward)
(eq vmpc-current-state 'resend))
(vm-virtual-check-selector selector (car vm-message-pointer)))
((eq vmpc-current-state 'automorph)
(vm-virtual-check-selector selector))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;###autoload
(defun vm-virtual-apply-function (count &optional selector function)
"Apply a FUNCTION to the next COUNT messages matching SELECTOR."
(interactive "p")
(when (interactive-p)
(vm-follow-summary-cursor)
(setq selector (vm-virtual-get-selector
(vm-read-string "Virtual folder: "
vm-virtual-folder-alist))
function (key-or-menu-binding (read-key-sequence "VM command: "))))
(vm-select-folder-buffer)
(vm-check-for-killed-summary)
(vm-error-if-folder-empty)
(let ((mlist (vm-select-marked-or-prefixed-messages (or count 1)))
(count 0))
(while mlist
(if (vm-virtual-check-selector selector (car mlist))
(progn (funcall function (car mlist))
(vm-increment count)))
(setq mlist (cdr mlist)))
count))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;###autoload
(defun vm-virtual-update-folders (&optional count message-list)
"Updates all virtual folders.
E.g. when creating a folder of all marked messages one can call this
function in order to add newly marked messages to the virtual folder
without recreating it."
(interactive "p")
(vm-select-folder-buffer)
(let ((new-messages (or message-list
(vm-select-marked-or-prefixed-messages count)))
b-list)
(setq new-messages (copy-sequence new-messages))
(if (and new-messages vm-virtual-buffers)
(save-excursion
(setq b-list vm-virtual-buffers)
(while b-list
;; buffer might be dead
(if (buffer-name (car b-list))
(let (tail-cons)
(set-buffer (car b-list))
(setq tail-cons (vm-last vm-message-list))
(vm-build-virtual-message-list new-messages)
(if (or (null tail-cons) (cdr tail-cons))
(progn
(setq vm-ml-sort-keys nil)
(if vm-thread-obarray
(vm-build-threads (cdr tail-cons)))
(vm-set-summary-redo-start-point
(or (cdr tail-cons) vm-message-list))
(vm-set-numbering-redo-start-point
(or (cdr tail-cons) vm-message-list))
(if (null vm-message-pointer)
(progn (setq vm-message-pointer vm-message-list
vm-need-summary-pointer-update t)
(if vm-message-pointer
(vm-preview-current-message))))
(setq vm-messages-needing-summary-update new-messages
vm-need-summary-pointer-update t)
(vm-update-summary-and-mode-line)
(if vm-summary-show-threads
(vm-sort-messages "thread"))))))
(setq b-list (cdr b-list)))))
new-messages))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;###autoload
(defun vm-virtual-omit-message (&optional count message-list)
"Omits a meassage from a virtual folder.
IMHO allowing it for real folders makes no sense. One rather should create a
virtual folder of all messages."
(interactive "p")
(vm-select-folder-buffer)
(if (not (eq major-mode 'vm-virtual-mode))
(error "This is no virtual folder."))
(let ((old-messages (or message-list
(vm-select-marked-or-prefixed-messages count)))
prev curr
(mp vm-message-list))
(while mp
(if (not (member (car mp) old-messages))
nil
(setq prev (vm-reverse-link-of (car mp))
curr (or (cdr prev) vm-message-list))
(vm-set-numbering-redo-start-point (or prev t))
(vm-set-summary-redo-start-point (or prev t))
(if (eq vm-message-pointer curr)
(setq vm-system-state nil
vm-message-pointer (or prev (cdr curr))))
(if (eq vm-last-message-pointer curr)
(setq vm-last-message-pointer nil))
(if (null prev)
(progn
(setq vm-message-list (cdr vm-message-list))
(and (cdr curr)
(vm-set-reverse-link-of (car (cdr curr)) nil)))
(setcdr prev (cdr curr))
(and (cdr curr)
(vm-set-reverse-link-of (car (cdr curr)) prev))))
(setq mp (cdr mp)))
(vm-update-summary-and-mode-line)
(if vm-summary-show-threads
(vm-sort-messages "thread"))
old-messages))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defcustom vm-virtual-auto-delete-message-selector "spam"
"*Name of virtual folder selector used for automatically deleting a message.
Actually they are only marked for deletion."
:group 'vm-avirtual
:type 'string)
(defcustom vm-virtual-auto-delete-message-folder nil
"*When set to a folder name we save affected messages there."
:group 'vm-avirtual
:type '(choice (file :tag "VM folder" "spam")
(const :tag "Disabled" nil)))
(defcustom vm-virtual-auto-delete-message-expunge nil
"*When true we expunge the affected right after marking and saving them."
:group 'vm-avirtual
:type 'boolean)
;;;###autoload
(defun vm-virtual-auto-delete-message (&optional count selector)
"*Mark messages matching a virtual folder selector for deletion.
The virtual folder selector can be configured by the variable
`vm-virtual-auto-delete-message-selector'.
This function does not visit the virtual folder, but checks only the current
message, therefore it is much faster and not so disturbing like the method
described in the VM-FAQ.
In order to automatically mark spam for deletion use the function
`vm-virtual-auto-delete-messages'. See its documentation on how to hook it
into VM!"
(interactive "p")
(setq selector (or selector
(vm-virtual-get-selector
vm-virtual-auto-delete-message-selector)))
(let (spammlist)
(setq count (vm-virtual-apply-function
count
selector
(function (lambda (msg)
(setq spammlist (cons msg spammlist))
(vm-set-labels
msg
(list
vm-virtual-auto-delete-message-selector))
(vm-set-deleted-flag msg t)
(vm-mark-for-summary-update msg t)))))
(when spammlist
(setq spammlist (reverse spammlist))
;; save them
(if vm-virtual-auto-delete-message-folder
(let ((vm-arrived-messages-hook nil)
(vm-arrived-message-hook nil)
(mlist spammlist))
(while mlist
(let ((vm-message-pointer mlist))
(vm-save-message vm-virtual-auto-delete-message-folder))
(setq mlist (cdr mlist)))))
;; expunge them
(if vm-virtual-auto-delete-message-expunge
(vm-expunge-folder t t spammlist)))
(vm-display nil nil '(vm-delete-message vm-delete-message-backward)
(list this-command))
(vm-update-summary-and-mode-line)
(message "%s message%s %s!"
(if (> count 0) count "No")
(if (= 1 count) "" "s")
(concat
(if vm-virtual-auto-delete-message-folder
(format "saved to %s and "
vm-virtual-auto-delete-message-folder)
"")
(if vm-virtual-auto-delete-message-expunge
"expunged right away"
"marked for deletion")))))
;;;###autoload
(defun vm-virtual-auto-delete-messages ()
"*Mark all messages from the current upto the last for (spam-)deletion.
Add this to `vm-arrived-messages-hook'!
See the function `vm-virtual-auto-delete-message' for details.
(add-hook 'vm-arrived-messages-hook 'vm-virtual-auto-delete-messages)
"
(interactive)
(if (interactive-p)
(vm-follow-summary-cursor))
(vm-select-folder-buffer)
(vm-check-for-killed-summary)
(vm-virtual-auto-delete-message (length vm-message-pointer)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;###autoload
(defcustom vm-virtual-auto-folder-alist nil
"*Non-nil value should be an alist that VM will use to choose a default
folder name when messages are saved. The alist should be of the form
((VIRTUAL-FOLDER-NAME . FOLDER-NAME)
...)
where VIRTUAL-FOLDER-NAME is a string, and FOLDER-NAME
is a string or an s-expression that evaluates to a string.
This allows you to extend `vm-virtual-auto-select-folder' to generate
a folder name. Your function may use `folder' to get the currently choosen
folder name and `mp' (a vm-pessage-pointer) to access the message.
Example:
(setq vm-virtual-auto-folder-alist
'((\"spam\" (concat folder \"-\"
(format-time-string \"%y%m\" (current-time))))))
This will return \"spam-0008\" as a folder name for messages matching the
virtual folder selector of the virtual folder \"spam\" during August in year
2000."
:type 'sexp
:group 'vm-avirtual)
;;;###autoload
(defun vm-virtual-auto-select-folder (&optional m avfolder-alist
valid-folder-list
not-to-history)
"Return the first matching virtual folder.
This can be seen as an more powerful replacement of `vm-auto-select-folder'
and it is used by `vm-virtual-save-message'. It might also be applied to
messages which are composed in order to find the right FCC."
(when (not m)
(setq m (car vm-message-pointer)
avfolder-alist vm-virtual-folder-alist
valid-folder-list (cond ((eq major-mode 'mail-mode)
nil)
((eq major-mode 'vm-mode)
(save-excursion
(vm-select-folder-buffer)
(list (buffer-name))))
((eq major-mode 'vm-virtual-mode)
(list (buffer-name
(vm-buffer-of
(vm-real-message-of m))))))))
(let ((vfolders avfolder-alist)
selector folder-list)
(when t;(and m (aref m 0) (aref (aref m 0) 0)
; (marker-buffer (aref (aref m 0) 0)))
(while vfolders
(setq selector (vm-virtual-get-selector (caar vfolders)
valid-folder-list))
(when (and selector (vm-virtual-check-selector selector m))
(setq folder-list (append (list (caar vfolders)) folder-list))
(if not-to-history
(setq vfolders nil)))
(setq vfolders (cdr vfolders)))
(setq folder-list (reverse folder-list))
(setq folder-list
(mapcar (lambda (f)
(let ((rf (assoc f vm-virtual-auto-folder-alist)))
(if rf
(eval (cadr rf))
f)))
folder-list))
(when (and (not not-to-history) folder-list)
(let ((fl (cdr folder-list)) f)
(while fl
(setq f (abbreviate-file-name
(expand-file-name (car fl) vm-folder-directory) t)
vm-folder-history (delete f vm-folder-history)
vm-folder-history (nconc (list f) vm-folder-history)
fl (cdr fl)))))
(car folder-list))))
;;;###autoload
(defvar vm-sort-compare-auto-folder-cache nil)
(add-to-list 'vm-supported-sort-keys "auto-folder")
(defun vm-sort-compare-auto-folder (m1 m2)
(let* ((folder-list (list (buffer-name)))
s1 s2)
(if (setq s1 (assoc m1 vm-sort-compare-auto-folder-cache))
(setq s1 (cdr s1))
(setq s1 (vm-virtual-auto-select-folder
m1 vm-virtual-folder-alist folder-list))
(add-to-list 'vm-sort-compare-auto-folder-cache (cons m1 s1)))
(if (setq s2 (assoc m2 vm-sort-compare-auto-folder-cache))
(setq s2 (cdr s2))
(setq s2 (vm-virtual-auto-select-folder
m2 vm-virtual-folder-alist folder-list))
(add-to-list 'vm-sort-compare-auto-folder-cache (cons m2 s2)))
(cond ((or (and (null s1) s2)
(and s1 s2 (string-lessp s1 s2)))
t)
((or (and (null s1) (null s2))
(and s1 s2 (string-equal s1 s2)))
'=)
(t nil))))
;;;###autoload
(defun vm-sort-insert-auto-folder-names ()
(interactive)
(if (interactive-p)
(vm-sort-messages "auto-folder"))
(save-excursion
(vm-select-folder-buffer)
;; remove old descriptions
(save-excursion
(set-buffer vm-summary-buffer)
(goto-char (point-min))
(let ((buffer-read-only nil)
(s (point-min))
(p (point-min)))
(while (setq p (next-single-property-change p 'vm-auto-folder))
(if (get-text-property (1+ p) 'vm-auto-folder)
(setq s p)
(delete-region s p))
(setq p (1+ p)))))
;; add new descriptions
(let ((ml vm-message-list)
(oldf "")
m f)
(while ml
(setq m (car ml)
f (cdr (assoc m vm-sort-compare-auto-folder-cache)))
(when (not (equal oldf f))
(setq m (vm-su-start-of m))
(save-excursion
(set-buffer (marker-buffer m))
(let ((buffer-read-only nil))
(goto-char m)
(insert (format "%s\n" (or f "no default folder")))
(put-text-property m (point) 'vm-auto-folder t)
(put-text-property m (point) 'face 'blue)
;; fix messages summary mark
(set-marker m (point))))
(setq oldf f))
(setq ml (cdr ml))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;###autoload
(defun vm-virtual-save-message (&optional folder count)
"Save the current message to a mail folder.
Like `vm-save-message' but the default folder it guessed by
`vm-virtual-auto-select-folder'."
(interactive
(list
;; protect value of last-command
(let ((last-command last-command)
(this-command this-command))
(vm-follow-summary-cursor)
(let ((default (save-excursion
(vm-select-folder-buffer)
(vm-check-for-killed-summary)
(vm-error-if-folder-empty)
(or (vm-virtual-auto-select-folder)
vm-last-save-folder)))
(dir (or vm-folder-directory default-directory)))
(cond ((and default
(let ((default-directory dir))
(file-directory-p default)))
(vm-read-file-name "Save in folder: "
dir nil nil default 'vm-folder-history))
(default
(vm-read-file-name
(format "Save in folder: (default %s) " default)
dir default nil nil 'vm-folder-history))
(t
(vm-read-file-name "Save in folder: " dir nil)))))
(prefix-numeric-value current-prefix-arg)))
(vm-save-message folder count))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;###autoload
(defun vm-virtual-auto-archive-messages (&optional prompt)
"With a prefix ARG ask user before saving."
(interactive "P")
(vm-select-folder-buffer)
(vm-check-for-killed-summary)
(vm-error-if-folder-empty)
(vm-error-if-folder-read-only)
(message "Archiving...")
(let ((auto-folder)
(folder-list (list (buffer-name)))
(archived 0))
(unwind-protect
;; Need separate (let ...) so vm-message-pointer can
;; revert back in time for
;; (vm-update-summary-and-mode-line).
;; vm-last-save-folder is tucked away here since archives
;; shouldn't affect its value.
(let ((vm-message-pointer
(if (eq last-command 'vm-next-command-uses-marks)
(vm-select-marked-or-prefixed-messages 0)
vm-message-list))
(done nil)
stop-point
(vm-last-save-folder vm-last-save-folder)
(vm-move-after-deleting nil))
;; mark the place where we should stop. otherwise if any
;; messages in this folder are archived to this folder
;; we would file messages into this folder forever.
(setq stop-point (vm-last vm-message-pointer))
(while (not done)
(and (not (vm-filed-flag (car vm-message-pointer)))
;; don't archive deleted messages
(not (vm-deleted-flag (car vm-message-pointer)))
(setq auto-folder
(vm-virtual-auto-select-folder (car vm-message-pointer)
vm-virtual-folder-alist
folder-list))
;; Don't let user archive into the same folder
;; that they are visiting.
(not (eq (vm-get-file-buffer auto-folder)
(current-buffer)))
(or (null prompt)
(y-or-n-p
(format "Save message %s in folder %s? "
(vm-number-of (car vm-message-pointer))
auto-folder)))
(let ((vm-delete-after-saving vm-delete-after-archiving))
(vm-save-message auto-folder)
(vm-increment archived)
(message "%d archived, still working..." archived)))
(setq done (eq vm-message-pointer stop-point)
vm-message-pointer (cdr vm-message-pointer))))
;; fix mode line
(intern (buffer-name) vm-buffers-needing-display-update)
(vm-update-summary-and-mode-line))
(if (zerop archived)
(message "No messages were archived")
(message "%d message%s archived"
archived (if (= 1 archived) "" "s")))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;###autoload
(defun vm-virtual-make-folder-persistent ()
"Save all mails of current virtual folder to the real folder with the same
name."
(interactive)
(save-excursion
(vm-select-folder-buffer)
(if (eq major-mode 'vm-virtual-mode)
(let ((file (substring (buffer-name) 1 -1)))
(vm-goto-message 0)
(vm-save-message file (length vm-message-list))
(message "Saved virtual folder in file \"%s\"" file))
(error "This is no virtual folder!"))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(provide 'vm-avirtual)
;;; vm-rfaddons.el ends here
1.1 XEmacs/packages/xemacs-packages/vm/lisp/vm-biff.el
Index: vm-biff.el
===================================================================
;;; vm-biff.el --- a xlbiff like tool for VM
;;
;; Copyright (C) 2001 Robert Fenk
;;
;; Author: Robert Fenk
;; Status: Tested with XEmacs 21.4.15 & VM 7.18
;; Keywords: VM helpers
;; X-URL: http://www.robf.de/Hacking/elisp
;; Version: $Id: vm-biff.el,v 1.1 2008/04/09 21:01:47 fenk Exp $
;; This program 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 2 of the License, or
;; (at your option) any later version.
;;
;; This program 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; if not, write to the Free Software Foundation, Inc.,
;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
;;; Commentary:
;;
;; Put this file into your load path and add the following line to your .vm
;; file
;;
;; (require 'vm-biff)
;;
;; Try: M-x customize-group vm-biff RET
;;
;; You should set `vm-auto-get-newmail', since otherwise this package
;; does not make any sense! If getting mail is slow, use fetchmail to
;; retrieve it to a local file and uses that file as VM spool file!
;;
(eval-when-compile
(require 'cl))
(when vm-xemacs-p
(require 'overlay))
(defgroup vm nil
"VM"
:group 'mail)
(defgroup vm-biff nil
"The VM biff lib"
:group 'vm)
(defcustom vm-biff-position 'center
"*Position of the popup-frame."
:group 'vm-biff
:type '(choice (const :tag "center the popup frame" center)
(list :tag "Position of the top-left corner."
:value (1 1)
(integer :tag "X")
(integer :tag "Y"))))
(defcustom vm-biff-width 120
"*Width of the popup-frame."
:group 'vm-biff
:type 'integer)
(defcustom vm-biff-max-height 10
"*Maximum hight of the popup window."
:group 'vm-biff
:type 'integer)
(defcustom vm-biff-body-peek 50
"*Maximum number of chractes to peek into the body of a message."
:group 'vm-biff
:type 'integer)
(defcustom vm-biff-focus-popup nil
"*t if popup window should get the focus after an update."
:group 'vm-biff
:type 'boolean)
(defcustom vm-biff-auto-remove nil
"*Number of seconds after the popup window is automatically removed."
:group 'vm-biff
:type '(choice (integer :tag "Number of seconds" 10)
(const :tag "Disable remove" nil)))
(defcustom vm-biff-summary-format nil
"*Like `vm-summary-format' but for popup buffers."
:group 'vm-biff
:type '(choice (string :tag "Summary format")
(const :tag "Disable own format" nil)))
(defcustom vm-biff-selector '(and (new)
(not (deleted))
(not (outgoing)))
"*virtual folder selector matching messages to display in the pop-up."
:group 'vm-biff
:type 'sexp)
(defcustom vm-biff-place-frame-function 'vm-biff-place-frame
"*Function that sets the popup frame position and size."
:group 'vm-biff
:type 'function)
(defcustom vm-biff-select-hook nil
"*List of hook functions to be run when selection a message."
:group 'vm-biff
:type '(repeat (function)))
(defcustom vm-biff-select-frame-hook nil
"*List of hook functions to be run when selection a message.
You may want to add `vm-biff-fvwm-focus-vm-folder-frame'.
"
:group 'vm-biff
:type '(repeat (function)))
(defcustom vm-biff-folder-list nil
"*List of folders to generate a popup for.
The default is all spool files listed in `vm-spool-files'.
Testing is done by string-matching it against the current buffer-file-name.
Another form is an alist of elements (FODERNAME SELECTOR),
where SELECTOR is a virtual folder selector matching the
messges which should be displayed. See `vm-biff-selector'
for an example and `vm-virtual-folder-alist' on how virtual
folder selectors work."
:group 'vm-biff
:type '(repeat (string)))
(defvar vm-biff-keymap nil
"Keymap for vm-biff popup buffers.")
(when (not vm-biff-keymap)
(setq vm-biff-keymap (make-sparse-keymap "VM Biff"))
(define-key vm-biff-keymap "q" 'vm-biff-delete-popup)
(define-key vm-biff-keymap " " 'vm-biff-delete-popup)
(define-key vm-biff-keymap [(space)] 'vm-biff-delete-popup)
(define-key vm-biff-keymap [(button1)] 'vm-biff-delete-popup)
(define-key vm-biff-keymap [(mouse-1)] 'vm-biff-delete-popup)
(define-key vm-biff-keymap [(return)] 'vm-biff-select-message)
(define-key vm-biff-keymap [(button2)] 'vm-biff-select-message-mouse)
(define-key vm-biff-keymap [(mouse-2)] 'vm-biff-select-message-mouse))
(defun vm-summary-function-V (msg)
(let ((body-start (vm-text-of msg))
(body-end (vm-end-of msg))
peek)
(if (< vm-biff-body-peek (- body-end body-start))
(setq body-end (+ vm-biff-body-peek body-start)))
(save-excursion
(save-restriction
(set-buffer (vm-buffer-of msg))
(widen)
(goto-char body-end)
(re-search-forward "$" (point-max) t)
(setq peek (vm-decode-mime-encoded-words-in-string
(buffer-substring body-start (point))))
(let ((pos 0))
(if (string-match "^\n+" peek pos)
(setq peek (replace-match "" t t peek)))
(while (setq pos (string-match "\n\n+" peek pos))
(setq peek (replace-match "\n" t t peek)))
(setq pos 0)
(while (setq pos (string-match "\n" peek pos))
(setq peek (replace-match "\n\t" t t peek)
pos (+ 2 pos))))
(setq peek (concat "\t" peek))
(put-text-property 0 (length peek) 'face 'bold peek)
peek))))
(defun vm-biff-place-frame (&optional f)
"Centers the frame and limits it to `vm-biff-max-height' lines."
(let ((f (or f (selected-frame)))
(height (1+ (count-lines (point-min) (point-max)))))
(if (> height vm-biff-max-height)
(setq height vm-biff-max-height))
(set-frame-size f vm-biff-width height)
(if (eq 'center vm-biff-position)
(set-frame-position
f
(/ (- (x-display-pixel-width) (frame-pixel-width f)) 2)
(/ (- (x-display-pixel-height) (frame-pixel-height f)) 2))
(apply 'set-frame-position f vm-biff-position))))
(defconst vm-biff-frame-properties
'(;; common properties
(name . "New Mail")
(unsplittable . t)
(minibuffer . nil)
(user-position . t)
(menubar-visible-p . nil)
(default-toolbar-visible-p . nil)
; (has-modeline-p . nil)
(top . 1)
(left . 1)
;; Xemacs properties
(initially-unmapped . t)
(modeline-shadow-thickness . 0)
(vertical-scrollbar . nil)
;; GNU Emacs properties
(vertical-scroll-bars . nil)
(menu-bar-lines . 0)
(tool-bar-lines . 0)
(visibility . nil)
)
"Default properties for popup frame.")
(defvar vm-biff-message-pointer nil)
(defvar vm-biff-folder-buffer nil)
(defvar vm-biff-message-number nil)
(defvar vm-biff-folder-frame nil)
(defvar vm-biff--folder-window nil)
(defun vm-biff-x-p ()
(if vm-xemacs-p
(memq (console-type) '(x mswindows))
t))
(defun vm-biff-get-buffer-window (buf)
(if vm-xemacs-p
(get-buffer-window buf (vm-biff-x-p) (frame-device))
(get-buffer-window buf (vm-biff-x-p))))
(defun vm-biff-find-folder-window (msg)
(let ((buf (vm-buffer-of msg)))
(save-excursion
(set-buffer buf)
(or (vm-biff-get-buffer-window buf)
(and vm-presentation-buffer
(vm-biff-get-buffer-window vm-presentation-buffer))
(and vm-summary-buffer
(vm-biff-get-buffer-window vm-summary-buffer))))))
(defun vm-biff-find-folder-frame (msg)
(let ((ff (vm-biff-find-folder-window msg)))
(if ff (window-frame ff))))
;;;###autoload
(defun vm-biff-select-message ()
"Put focus on the folder frame and select the appropiate message."
(interactive)
(let* ((vm-biff-message-pointer
(or (get-text-property (point) 'vm-message-pointer)
vm-biff-message-pointer))
(msg (car vm-biff-message-pointer))
(vm-biff-message-number (vm-number-of msg))
(vm-biff-folder-buffer (vm-buffer-of msg))
(vm-biff-folder-window (vm-biff-find-folder-window msg))
vm-biff-folder-frame)
(if vm-biff-folder-window
(setq vm-biff-folder-frame (window-frame vm-biff-folder-window)))
(setq vm-biff-message-pointer nil)
(vm-biff-delete-popup)
(cond ((and vm-biff-folder-frame (vm-biff-x-p))
(select-frame vm-biff-folder-frame)
(focus-frame vm-biff-folder-frame)
(raise-frame vm-biff-folder-frame)
(run-hooks 'vm-biff-select-frame-hook)
(select-window vm-biff-folder-window))
(vm-biff-folder-window
(select-window vm-biff-folder-window))
(t
(bury-buffer)
(switch-to-buffer vm-biff-folder-buffer)))
(sit-for 0)
(if vm-biff-message-number
(vm-goto-message (string-to-number (vm-number-of msg))))
(run-hooks 'vm-biff-select-hook)))
;;;###autoload
(defun vm-biff-select-message-mouse (event)
(interactive "e")
(mouse-set-point event)
(vm-biff-select-message))
(defcustom vm-biff-FvwmCommand-path "/usr/bin/FvwmCommand"
"Full qualified path to FvwmCommand."
:group 'vm-biff
:type 'file)
;;;###autoload
(defun vm-biff-fvwm-focus-vm-folder-frame ()
"Jumps to the frame containing the folder for the selected message.
1) Your Emacs frame needs to have the folder name in its title, see the
variable `frame-title-format' on how to set this up.
2) You need to define the FVWM2 function SelectWindow and start the
FvwmCommandS module. Therefore, you will need the following lines
in your .fvwm2rc file.
AddToFunc InitFunction
+ I Module FvwmCommandS
AddToFunc RestartFunction
+ I Module FvwmCommandS
AddToFunc SelectWindow
+ I Next ($0) Iconify false
+ I Next ($0) Raise
+ I Next ($0) WarpToWindow 10p 10p
"
(interactive)
(let ((p (start-process "FvwmCommand"
" *FvwmCommand*"
vm-biff-FvwmCommand-path
"-c")))
(process-send-string p (concat "SelectWindow *"
(buffer-name vm-biff-folder-buffer)
"*\n"))
(process-send-eof p)))
;;;###autoload
(defun vm-biff-delete-popup (&optional wf)
(interactive)
(if (vm-biff-x-p)
(delete-frame wf)
(if (not (one-window-p))
(delete-window wf)))
(sit-for 0))
(defun vm-biff-timer-delete-popup (wf)
(if (featurep 'itimer)
(delete-itimer current-itimer))
(vm-biff-delete-popup wf))
(defvar vm-biff-message-pointer nil)
(make-variable-buffer-local 'vm-biff-message-pointer)
;;;###autoload
(defun vm-biff-popup (&optional force)
"Scan the current VM folder for new messages and popup a summary frame."
(interactive (list current-prefix-arg))
(save-excursion
(vm-select-folder-buffer)
(when (not vm-biff-folder-list)
(setq vm-biff-folder-list
(if (stringp (car vm-spool-files))
(list (expand-file-name
vm-primary-inbox
vm-folder-directory))
(mapcar (lambda (f)
(expand-file-name
(car f)
vm-folder-directory))
vm-spool-files))))
(let* ((mp vm-message-pointer)
(folder (buffer-name))
(do-mouse-track
(and vm-mouse-track-summary
(vm-mouse-support-possible-p)))
(buf (get-buffer-create
(concat " *new messages in VM folder: " folder "*")))
selector msg new-messages wf)
(let ((fl vm-biff-folder-list))
(while fl
(if (stringp (car fl))
(if (string-match (car fl) (or (buffer-file-name)
(buffer-name)))
(setq selector (list vm-biff-selector) fl nil))
(if (string-match (caar fl) (