Mercurial > emacs
changeset 110090:9f2296908370
merge trunk
| author | Kenichi Handa <handa@m17n.org> |
|---|---|
| date | Wed, 01 Sep 2010 09:55:43 +0900 |
| parents | b0de94d21a73 (current diff) e4e62433ed67 (diff) |
| children | 0dcf6ddbe02b |
| files | lisp/gnus/gnus-soup.el lisp/gnus/nnsoup.el lisp/gnus/nnultimate.el lisp/gnus/nnwarchive.el |
| diffstat | 22 files changed, 403 insertions(+), 3427 deletions(-) [+] |
line wrap: on
line diff
--- a/doc/misc/ChangeLog Tue Aug 31 04:22:49 2010 +0000 +++ b/doc/misc/ChangeLog Wed Sep 01 09:55:43 2010 +0900 @@ -1,3 +1,9 @@ +2010-08-31 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * gnus.texi (HTML): Document gnus-blocked-images. + + * message.texi (Wide Reply): Document message-prune-recipient-rules. + 2010-08-30 Lars Magne Ingebrigtsen <larsi@gnus.org> * gnus.texi (Summary Mail Commands): Note that only the addresses from
--- a/doc/misc/gnus.texi Tue Aug 31 04:22:49 2010 +0000 +++ b/doc/misc/gnus.texi Wed Sep 01 09:55:43 2010 +0900 @@ -632,7 +632,7 @@ * Getting Mail:: Reading your personal mail with Gnus. * Browsing the Web:: Getting messages from a plethora of Web sources. * IMAP:: Using Gnus as a @acronym{IMAP} client. -* Other Sources:: Reading directories, files, SOUP packets. +* Other Sources:: Reading directories, files. * Combined Groups:: Combining groups into one group. * Email Based Diary:: Using mails to manage diary events in Gnus. * Gnus Unplugged:: Reading news and mail offline. @@ -695,8 +695,6 @@ * Archiving Mail:: * Web Searches:: Creating groups from articles that match a string. -* Ultimate:: The Ultimate Bulletin Board systems. -* Web Archive:: Reading mailing list archived on web. * RSS:: Reading RDF site summary. * Customizing W3:: Doing stuff to Emacs/W3 from Gnus. @@ -714,19 +712,12 @@ * Directory Groups:: You can read a directory as if it was a newsgroup. * Anything Groups:: Dired? Who needs dired? * Document Groups:: Single files can be the basis of a group. -* SOUP:: Reading @sc{soup} packets ``offline''. * Mail-To-News Gateways:: Posting articles via mail-to-news gateways. Document Groups * Document Server Internals:: How to add your own document types. -SOUP - -* SOUP Commands:: Commands for creating and sending @sc{soup} packets -* SOUP Groups:: A back end for reading @sc{soup} packets. -* SOUP Replies:: How to enable @code{nnsoup} to take over mail and news. - Combined Groups * Virtual Groups:: Combining articles from many groups. @@ -6850,10 +6841,6 @@ @vindex gnus-canceled-mark Canceled article (@code{gnus-canceled-mark}) -@item F -@vindex gnus-souped-mark -@sc{soup}ed article (@code{gnus-souped-mark}). @xref{SOUP}. - @item Q @vindex gnus-sparse-mark Sparsely reffed article (@code{gnus-sparse-mark}). @xref{Customizing @@ -7824,7 +7811,7 @@ intended for those non-news newsgroups where the back end has to fetch quite a lot to present the summary buffer, and where it's impossible to go back to parents of articles. This is mostly the case in the -web-based groups, like the @code{nnultimate} groups. +web-based groups. If you don't use those, then it's safe to leave this as the default @code{nil}. If you want to use this variable, it should be a regexp @@ -12501,10 +12488,22 @@ If set to @code{gnus-article-html}, Gnus will use the built-in method, that's based on @code{curl} and @code{w3m}. +@item gnus-blocked-images +@vindex gnus-blocked-images +Images that have @acronym{URL}s that match this regexp won't be +fetched and displayed. For instance, do block all @acronym{URL}s that +have the string ``ads'' in them, do the following: + +@lisp +(setq gnus-blocked-images "ads") +@end lisp + +The default is to block all external images. + @item gnus-html-cache-directory @vindex gnus-html-cache-directory Gnus will download and cache images according to how -@code{mm-w3m-safe-url-regexp} is set. These images will be stored in +@code{gnus-blocked-images} is set. These images will be stored in this directory. @item gnus-html-cache-size @@ -13734,7 +13733,7 @@ * Getting Mail:: Reading your personal mail with Gnus. * Browsing the Web:: Getting messages from a plethora of Web sources. * IMAP:: Using Gnus as a @acronym{IMAP} client. -* Other Sources:: Reading directories, files, SOUP packets. +* Other Sources:: Reading directories, files. * Combined Groups:: Combining groups into one group. * Email Based Diary:: Using mails to manage diary events in Gnus. * Gnus Unplugged:: Reading news and mail offline. @@ -17395,8 +17394,6 @@ @menu * Archiving Mail:: * Web Searches:: Creating groups from articles that match a string. -* Ultimate:: The Ultimate Bulletin Board systems. -* Web Archive:: Reading mailing list archived on web. * RSS:: Reading RDF site summary. * Customizing W3:: Doing stuff to Emacs/W3 from Gnus. @end menu @@ -17539,71 +17536,6 @@ @end table -@node Ultimate -@subsection Ultimate -@cindex nnultimate -@cindex Ultimate Bulletin Board - -@uref{http://www.ultimatebb.com/, The Ultimate Bulletin Board} is -probably the most popular Web bulletin board system used. It has a -quite regular and nice interface, and it's possible to get the -information Gnus needs to keep groups updated. - -The easiest way to get started with @code{nnultimate} is to say -something like the following in the group buffer: @kbd{B nnultimate RET -http://www.tcj.com/messboard/ubbcgi/ RET}. (Substitute the @acronym{URL} -(not including @samp{Ultimate.cgi} or the like at the end) for a forum -you're interested in; there's quite a list of them on the Ultimate web -site.) Then subscribe to the groups you're interested in from the -server buffer, and read them from the group buffer. - -The following @code{nnultimate} variables can be altered: - -@table @code -@item nnultimate-directory -@vindex nnultimate-directory -The directory where @code{nnultimate} stores its files. The default is@* -@file{~/News/ultimate/}. -@end table - - -@node Web Archive -@subsection Web Archive -@cindex nnwarchive -@cindex Web Archive - -Some mailing lists only have archives on Web servers, such as -@uref{http://www.egroups.com/} and -@uref{http://www.mail-archive.com/}. It has a quite regular and nice -interface, and it's possible to get the information Gnus needs to keep -groups updated. - -@findex gnus-group-make-warchive-group -The easiest way to get started with @code{nnwarchive} is to say -something like the following in the group buffer: @kbd{M-x -gnus-group-make-warchive-group RET @var{an_egroup} RET egroups RET -www.egroups.com RET @var{your@@email.address} RET}. (Substitute the -@var{an_egroup} with the mailing list you subscribed, the -@var{your@@email.address} with your email address.), or to browse the -back end by @kbd{B nnwarchive RET mail-archive RET}. - -The following @code{nnwarchive} variables can be altered: - -@table @code -@item nnwarchive-directory -@vindex nnwarchive-directory -The directory where @code{nnwarchive} stores its files. The default is@* -@file{~/News/warchive/}. - -@item nnwarchive-login -@vindex nnwarchive-login -The account name on the web server. - -@item nnwarchive-passwd -@vindex nnwarchive-passwd -The password for your account on the web server. -@end table - @node RSS @subsection RSS @cindex nnrss @@ -18540,7 +18472,6 @@ * Directory Groups:: You can read a directory as if it was a newsgroup. * Anything Groups:: Dired? Who needs dired? * Document Groups:: Single files can be the basis of a group. -* SOUP:: Reading @sc{soup} packets ``offline''. * Mail-To-News Gateways:: Posting articles via mail-to-news gateways. @end menu @@ -18908,289 +18839,6 @@ means low probability with @samp{0} being the lowest valid number. -@node SOUP -@subsection SOUP -@cindex SOUP -@cindex offline - -In the PC world people often talk about ``offline'' newsreaders. These -are thingies that are combined reader/news transport monstrosities. -With built-in modem programs. Yecchh! - -Of course, us Unix Weenie types of human beans use things like -@code{uucp} and, like, @code{nntpd} and set up proper news and mail -transport things like Ghod intended. And then we just use normal -newsreaders. - -However, it can sometimes be convenient to do something that's a bit -easier on the brain if you have a very slow modem, and you're not really -that interested in doing things properly. - -A file format called @sc{soup} has been developed for transporting news -and mail from servers to home machines and back again. It can be a bit -fiddly. - -First some terminology: - -@table @dfn - -@item server -This is the machine that is connected to the outside world and where you -get news and/or mail from. - -@item home machine -This is the machine that you want to do the actual reading and responding -on. It is typically not connected to the rest of the world in any way. - -@item packet -Something that contains messages and/or commands. There are two kinds -of packets: - -@table @dfn -@item message packets -These are packets made at the server, and typically contain lots of -messages for you to read. These are called @file{SoupoutX.tgz} by -default, where @var{x} is a number. - -@item response packets -These are packets made at the home machine, and typically contains -replies that you've written. These are called @file{SoupinX.tgz} by -default, where @var{x} is a number. - -@end table - -@end table - - -@enumerate - -@item -You log in on the server and create a @sc{soup} packet. You can either -use a dedicated @sc{soup} thingie (like the @code{awk} program), or you -can use Gnus to create the packet with its @sc{soup} commands (@kbd{O -s} and/or @kbd{G s b}; and then @kbd{G s p}) (@pxref{SOUP Commands}). - -@item -You transfer the packet home. Rail, boat, car or modem will do fine. - -@item -You put the packet in your home directory. - -@item -You fire up Gnus on your home machine using the @code{nnsoup} back end as -the native or secondary server. - -@item -You read articles and mail and answer and followup to the things you -want (@pxref{SOUP Replies}). - -@item -You do the @kbd{G s r} command to pack these replies into a @sc{soup} -packet. - -@item -You transfer this packet to the server. - -@item -You use Gnus to mail this packet out with the @kbd{G s s} command. - -@item -You then repeat until you die. - -@end enumerate - -So you basically have a bipartite system---you use @code{nnsoup} for -reading and Gnus for packing/sending these @sc{soup} packets. - -@menu -* SOUP Commands:: Commands for creating and sending @sc{soup} packets -* SOUP Groups:: A back end for reading @sc{soup} packets. -* SOUP Replies:: How to enable @code{nnsoup} to take over mail and news. -@end menu - - -@node SOUP Commands -@subsubsection SOUP Commands - -These are commands for creating and manipulating @sc{soup} packets. - -@table @kbd -@item G s b -@kindex G s b (Group) -@findex gnus-group-brew-soup -Pack all unread articles in the current group -(@code{gnus-group-brew-soup}). This command understands the -process/prefix convention. - -@item G s w -@kindex G s w (Group) -@findex gnus-soup-save-areas -Save all @sc{soup} data files (@code{gnus-soup-save-areas}). - -@item G s s -@kindex G s s (Group) -@findex gnus-soup-send-replies -Send all replies from the replies packet -(@code{gnus-soup-send-replies}). - -@item G s p -@kindex G s p (Group) -@findex gnus-soup-pack-packet -Pack all files into a @sc{soup} packet (@code{gnus-soup-pack-packet}). - -@item G s r -@kindex G s r (Group) -@findex nnsoup-pack-replies -Pack all replies into a replies packet (@code{nnsoup-pack-replies}). - -@item O s -@kindex O s (Summary) -@findex gnus-soup-add-article -This summary-mode command adds the current article to a @sc{soup} packet -(@code{gnus-soup-add-article}). It understands the process/prefix -convention (@pxref{Process/Prefix}). - -@end table - - -There are a few variables to customize where Gnus will put all these -thingies: - -@table @code - -@item gnus-soup-directory -@vindex gnus-soup-directory -Directory where Gnus will save intermediate files while composing -@sc{soup} packets. The default is @file{~/SoupBrew/}. - -@item gnus-soup-replies-directory -@vindex gnus-soup-replies-directory -This is what Gnus will use as a temporary directory while sending our -reply packets. @file{~/SoupBrew/SoupReplies/} is the default. - -@item gnus-soup-prefix-file -@vindex gnus-soup-prefix-file -Name of the file where Gnus stores the last used prefix. The default is -@samp{gnus-prefix}. - -@item gnus-soup-packer -@vindex gnus-soup-packer -A format string command for packing a @sc{soup} packet. The default is -@samp{tar cf - %s | gzip > $HOME/Soupout%d.tgz}. - -@item gnus-soup-unpacker -@vindex gnus-soup-unpacker -Format string command for unpacking a @sc{soup} packet. The default is -@samp{gunzip -c %s | tar xvf -}. - -@item gnus-soup-packet-directory -@vindex gnus-soup-packet-directory -Where Gnus will look for reply packets. The default is @file{~/}. - -@item gnus-soup-packet-regexp -@vindex gnus-soup-packet-regexp -Regular expression matching @sc{soup} reply packets in -@code{gnus-soup-packet-directory}. - -@end table - - -@node SOUP Groups -@subsubsection SOUP Groups -@cindex nnsoup - -@code{nnsoup} is the back end for reading @sc{soup} packets. It will -read incoming packets, unpack them, and put them in a directory where -you can read them at leisure. - -These are the variables you can use to customize its behavior: - -@table @code - -@item nnsoup-tmp-directory -@vindex nnsoup-tmp-directory -When @code{nnsoup} unpacks a @sc{soup} packet, it does it in this -directory. (@file{/tmp/} by default.) - -@item nnsoup-directory -@vindex nnsoup-directory -@code{nnsoup} then moves each message and index file to this directory. -The default is @file{~/SOUP/}. - -@item nnsoup-replies-directory -@vindex nnsoup-replies-directory -All replies will be stored in this directory before being packed into a -reply packet. The default is @file{~/SOUP/replies/}. - -@item nnsoup-replies-format-type -@vindex nnsoup-replies-format-type -The @sc{soup} format of the replies packets. The default is @samp{?n} -(rnews), and I don't think you should touch that variable. I probably -shouldn't even have documented it. Drats! Too late! - -@item nnsoup-replies-index-type -@vindex nnsoup-replies-index-type -The index type of the replies packet. The default is @samp{?n}, which -means ``none''. Don't fiddle with this one either! - -@item nnsoup-active-file -@vindex nnsoup-active-file -Where @code{nnsoup} stores lots of information. This is not an ``active -file'' in the @code{nntp} sense; it's an Emacs Lisp file. If you lose -this file or mess it up in any way, you're dead. The default is -@file{~/SOUP/active}. - -@item nnsoup-packer -@vindex nnsoup-packer -Format string command for packing a reply @sc{soup} packet. The default -is @samp{tar cf - %s | gzip > $HOME/Soupin%d.tgz}. - -@item nnsoup-unpacker -@vindex nnsoup-unpacker -Format string command for unpacking incoming @sc{soup} packets. The -default is @samp{gunzip -c %s | tar xvf -}. - -@item nnsoup-packet-directory -@vindex nnsoup-packet-directory -Where @code{nnsoup} will look for incoming packets. The default is -@file{~/}. - -@item nnsoup-packet-regexp -@vindex nnsoup-packet-regexp -Regular expression matching incoming @sc{soup} packets. The default is -@samp{Soupout}. - -@item nnsoup-always-save -@vindex nnsoup-always-save -If non-@code{nil}, save the replies buffer after each posted message. - -@end table - - -@node SOUP Replies -@subsubsection SOUP Replies - -Just using @code{nnsoup} won't mean that your postings and mailings end -up in @sc{soup} reply packets automagically. You have to work a bit -more for that to happen. - -@findex nnsoup-set-variables -The @code{nnsoup-set-variables} command will set the appropriate -variables to ensure that all your followups and replies end up in the -@sc{soup} system. - -In specific, this is what it does: - -@lisp -(setq message-send-news-function 'nnsoup-request-post) -(setq message-send-mail-function 'nnsoup-request-mail) -@end lisp - -And that's it, really. If you only want news to go into the @sc{soup} -system you just use the first line. If you only want mail to be -@sc{soup}ed you use the second. - - @node Mail-To-News Gateways @subsection Mail-To-News Gateways @cindex mail-to-news gateways @@ -27915,8 +27563,7 @@ else (@pxref{Document Groups}). @item -Gnus has a new back end (@code{nnsoup}) to create/read SOUP packets -(@pxref{SOUP}). +Gnus has a new back end (@code{nnsoup}) to create/read SOUP packets. @item The Gnus cache is much faster. @@ -29477,10 +29124,9 @@ As the variables for the other back ends, there are @code{nndiary-nov-is-evil}, @code{nndir-nov-is-evil}, @code{nnfolder-nov-is-evil}, @code{nnimap-nov-is-evil}, -@code{nnml-nov-is-evil}, @code{nnspool-nov-is-evil}, and -@code{nnwarchive-nov-is-evil}. Note that a non-@code{nil} value for -@code{gnus-nov-is-evil} overrides all those variables.@footnote{Although -the back ends @code{nnkiboze}, @code{nnultimate}, and +@code{nnml-nov-is-evil}, and @code{nnspool-nov-is-evil}. Note that a +non-@code{nil} value for @code{gnus-nov-is-evil} overrides all those +variables.@footnote{Although the back ends @code{nnkiboze}, and @code{nnwfm} don't have their own nn*-nov-is-evil.} @end table
--- a/doc/misc/message.texi Tue Aug 31 04:22:49 2010 +0000 +++ b/doc/misc/message.texi Wed Sep 01 09:55:43 2010 +0900 @@ -182,6 +182,37 @@ expression (or list of regular expressions) will be removed from the @code{Cc} header. A value of @code{nil} means exclude your name only. +@vindex message-prune-recipient-rules +@code{message-prune-recipient-rules} is used to prune the addresses +used when doing a wide reply. It's meant to be used to remove +duplicate addresses and the like. It's a list of lists, where the +first element is a regexp to match the address to trigger the rule, +and the second is a regexp that will be expanded based on the first, +to match addresses to be pruned. + +It's complicated to explain, but it's easy to use. + +For instance, if you get an email from @samp{foo@@example.org}, but +@samp{foo@@zot.example.org} is also in the @code{Cc} list, then your +wide reply will go out to both these addresses, since they are unique. + +To avoid this, do something like the following: + +@lisp +(setq message-prune-recipient-rules + '(("^\\([^@@]+\\)@@\\(.*\\)" "\\1@@.*[.]\\2"))) +@end lisp + +If, for instance, you want all wide replies that involve messages from +@samp{cvs@@example.org} to go to that address, and nowhere else (i.e., +remove all other recipients if @samp{cvs@@example.org} is in the +recipient list: + +@lisp +(setq message-prune-recipient-rules + '(("cvs@@example.org" "."))) +@end lisp + @vindex message-wide-reply-confirm-recipients If @code{message-wide-reply-confirm-recipients} is non-@code{nil} you will be asked to confirm that you want to reply to multiple
--- a/lisp/ChangeLog Tue Aug 31 04:22:49 2010 +0000 +++ b/lisp/ChangeLog Wed Sep 01 09:55:43 2010 +0900 @@ -1,3 +1,27 @@ +2010-08-31 Masatake YAMATO <yamato@redhat.com> + + * textmodes/nroff-mode.el (nroff-view): New command. + (nroff-mode-map): Bind it to C-c C-c. + +2010-08-31 Stefan Monnier <monnier@iro.umontreal.ca> + + * emacs-lisp/smie.el (smie-down-list): New command. + + Remove old indentation and navigation code on octave-mode. + * progmodes/octave-mod.el (octave-mode-map): Remap down-list to + smie-down-list rather than add a binding for octave-down-block. + (octave-mark-block, octave-blink-matching-block-open): + Rely on forward-sexp-function. + (octave-fill-paragraph): Don't narrow, so you can use + indent-according-to-mode. + (octave-block-begin-regexp, octave-block-begin-or-end-regexp): Remove. + (octave-in-block-p, octave-re-search-forward-kw) + (octave-re-search-backward-kw, octave-indent-calculate) + (octave-end-as-array-index-p, octave-block-end-offset) + (octave-scan-blocks, octave-forward-block, octave-backward-block) + (octave-down-block, octave-backward-up-block, octave-up-block) + (octave-before-magic-comment-p, octave-indent-line): Remove. + 2010-08-31 Chong Yidong <cyd@stupidchicken.com> * emacs-lisp/package.el (package--read-archive-file): Just use @@ -12,15 +36,15 @@ package-menu-package-list and package-menu-package-sort-key. (package-menu--version-predicate): Fix version calculation. (package-menu-sort-by-column): Don't select the window. - (package--list-packages): Create the *Packages* buffer. Set - package-menu-package-list-key. + (package--list-packages): Create the *Packages* buffer. + Set package-menu-package-list-key. (list-packages): Sorting by status is now the default. (package-buffer-info): Use match-string-no-properties. (define-package): Add a &rest argument for future proofing, but don't use it yet. (package-install-from-buffer, package-install-buffer-internal): - Merged into a single function, package-install-from-buffer. - (package-install-file): Caller changed. + Merge into a single function, package-install-from-buffer. + (package-install-file): Change caller. * finder.el: Load finder-inf using `require'. (finder-list-matches): Sorting by status is now the default.
--- a/lisp/emacs-lisp/smie.el Tue Aug 31 04:22:49 2010 +0000 +++ b/lisp/emacs-lisp/smie.el Wed Sep 01 09:55:43 2010 +0900 @@ -560,6 +560,42 @@ (indent-according-to-mode) (reindent-then-newline-and-indent)))) +(defun smie-down-list (&optional arg) + "Move forward down one level paren-like blocks. Like `down-list'. +With argument ARG, do this that many times. +A negative argument means move backward but still go down a level. +This command assumes point is not in a string or comment." + (interactive "p") + (let ((start (point)) + (inc (if (< arg 0) -1 1)) + (offset (if (< arg 0) 1 0)) + (next-token (if (< arg 0) + smie-backward-token-function + smie-forward-token-function))) + (while (/= arg 0) + (setq arg (- arg inc)) + (while + (let* ((pos (point)) + (token (funcall next-token)) + (levels (assoc token smie-op-levels))) + (cond + ((zerop (length token)) + (if (if (< inc 0) (looking-back "\\s(\\|\\s)" (1- (point))) + (looking-at "\\s(\\|\\s)")) + ;; Go back to `start' in case of an error. This presumes + ;; none of the token we've found until now include a ( or ). + (progn (goto-char start) (down-list inc) nil) + (forward-sexp inc) + (/= (point) pos))) + ((and levels (null (nth (+ 1 offset) levels))) nil) + ((and levels (null (nth (- 2 offset) levels))) + (let ((end (point))) + (goto-char start) + (signal 'scan-error + (list "Containing expression ends prematurely" + pos end)))) + (t))))))) + ;;; The indentation engine. (defcustom smie-indent-basic 4
--- a/lisp/gnus/ChangeLog Tue Aug 31 04:22:49 2010 +0000 +++ b/lisp/gnus/ChangeLog Wed Sep 01 09:55:43 2010 +0900 @@ -1,5 +1,43 @@ +2010-08-31 Julien Danjou <julien@danjou.info> (tiny change) + + * nnimap.el (nnimap-request-newgroups): Use nnimap-request-list-method + instead of lsub directly. + +2010-08-31 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * nnwarchive.el: Removed. + + * gnus-soup.el: Removed. + + * nnsoup.el: Removed. + + * nnultimate.el: Removed. + + * gnus-html.el (gnus-blocked-images): New variable. + + * message.el (message-prune-recipients): New function. + (message-prune-recipient-rules): New variable. + + * gnus-cite.el (gnus-article-natural-long-line-p): New function to + guess whether a long line is natural text or not. + + * gnus-html.el (gnus-html-schedule-image-fetching): Use + gnus-process-plist and friends for compatibility. + +2010-08-31 Stefan Monnier <monnier@iro.umontreal.ca> + + * gnus-html.el: Require packages that define macros used in this file. + (gnus-article-mouse-face): Declare to silence byte-compiler. + (gnus-html-curl-sentinel): Use with-current-buffer, inhibit-read-only, and + process-get. + (gnus-html-put-image): Use plist-get to avoid getf. + (gnus-html-prefetch-images): Use with-current-buffer. + 2010-08-31 Katsumi Yamaoka <yamaoka@jpl.org> + * gnus-ems.el: Provide compatibility functions for + gnus-set-process-plist. + * gnus-sum.el (gnus-summary-stop-at-end-of-message) * gnus.el (gnus-valid-select-methods) * message.el (message-send-mail-partially-limit) @@ -10,6 +48,9 @@ 2010-08-31 Lars Magne Ingebrigtsen <larsi@gnus.org> * gnus-html.el: require mm-url. + (gnus-html-wash-tags): Clarify the code a bit by renaming the variable + with the url to `url'. + (gnus-html-wash-tags): Support cid: URLs/images. 2010-08-30 Lars Magne Ingebrigtsen <larsi@gnus.org>
--- a/lisp/gnus/gnus-cite.el Tue Aug 31 04:22:49 2010 +0000 +++ b/lisp/gnus/gnus-cite.el Wed Sep 01 09:55:43 2010 +0900 @@ -552,6 +552,24 @@ gnus-cite-loose-attribution-alist nil gnus-cite-article nil))))) +(defun gnus-article-natural-long-line-p () + "Return true if the current line is long, and it's natural text." + (save-excursion + (beginning-of-line) + (and + ;; The line is long. + (> (- (line-end-position) (line-beginning-position)) + (frame-width)) + ;; It doesn't start with spaces. + (not (looking-at " ")) + ;; Not cited text. + (let ((line-number (1+ (count-lines (point-min) (point)))) + citep) + (dolist (elem gnus-cite-prefix-alist) + (when (member line-number (cdr elem)) + (setq citep t))) + (not citep))))) + (defun gnus-article-hide-citation (&optional arg force) "Toggle hiding of all cited text except attribution lines. See the documentation for `gnus-article-highlight-citation'.
--- a/lisp/gnus/gnus-ems.el Tue Aug 31 04:22:49 2010 +0000 +++ b/lisp/gnus/gnus-ems.el Wed Sep 01 09:55:43 2010 +0900 @@ -276,7 +276,7 @@ (defun gnus-put-image (glyph &optional string category) (let ((point (point))) - (insert-image glyph (or string " ")) + (insert-image glyph (or string "*")) (put-text-property point (point) 'gnus-image-category category) (unless string (put-text-property (1- (point)) (point) @@ -305,6 +305,27 @@ (setq start end end nil)))))) +(if (fboundp 'set-process-plist) + (progn + (defalias 'gnus-set-process-plist 'set-process-plist) + (defalias 'gnus-process-plist 'process-plist)) + (defun gnus-set-process-plist (process plist) + "Replace the plist of PROCESS with PLIST. Returns PLIST." + (put 'gnus-process-plist process plist)) + (defun gnus-process-plist (process) + "Return the plist of PROCESS." + ;; Remove those of dead processes from `gnus-process-plist' + ;; to prevent it from growing. + (let ((plist (symbol-plist 'gnus-process-plist)) + proc) + (while (setq proc (car plist)) + (if (and (processp proc) + (memq (process-status proc) '(open run))) + (setq plist (cddr plist)) + (setcar plist (caddr plist)) + (setcdr plist (or (cdddr plist) '(nil)))))) + (get 'gnus-process-plist process))) + (provide 'gnus-ems) ;; arch-tag: e7360b45-14b5-4171-aa39-69a44aed3cdb
--- a/lisp/gnus/gnus-group.el Tue Aug 31 04:22:49 2010 +0000 +++ b/lisp/gnus/gnus-group.el Wed Sep 01 09:55:43 2010 +0900 @@ -680,13 +680,6 @@ "\177" gnus-group-delete-group [delete] gnus-group-delete-group) -(gnus-define-keys (gnus-group-soup-map "s" gnus-group-group-map) - "b" gnus-group-brew-soup - "w" gnus-soup-save-areas - "s" gnus-soup-send-replies - "p" gnus-soup-pack-packet - "r" nnsoup-pack-replies) - (gnus-define-keys (gnus-group-sort-map "S" gnus-group-group-map) "s" gnus-group-sort-groups "a" gnus-group-sort-groups-by-alphabet @@ -972,13 +965,6 @@ (easy-menu-define gnus-group-misc-menu gnus-group-mode-map "" `("Gnus" - ("SOUP" - ["Pack replies" nnsoup-pack-replies (fboundp 'nnsoup-request-group)] - ["Send replies" gnus-soup-send-replies - (fboundp 'gnus-soup-pack-packet)] - ["Pack packet" gnus-soup-pack-packet (fboundp 'gnus-soup-pack-packet)] - ["Save areas" gnus-soup-save-areas (fboundp 'gnus-soup-pack-packet)] - ["Brew SOUP" gnus-group-brew-soup (fboundp 'gnus-soup-pack-packet)]) ["Send a mail" gnus-group-mail t] ["Send a message (mail or news)" gnus-group-post-news t] ["Create a local message" gnus-group-news t] @@ -3097,42 +3083,6 @@ (nnrss-save-server-data nil)) (error "No feeds found for %s" url)))) -(defvar nnwarchive-type-definition) -(defvar gnus-group-warchive-type-history nil) -(defvar gnus-group-warchive-login-history nil) -(defvar gnus-group-warchive-address-history nil) - -(defun gnus-group-make-warchive-group () - "Create a nnwarchive group." - (interactive) - (require 'nnwarchive) - (let* ((group (gnus-read-group "Group name: ")) - (default-type (or (car gnus-group-warchive-type-history) - (symbol-name (caar nnwarchive-type-definition)))) - (type - (gnus-string-or - (completing-read - (format "Warchive type (default %s): " default-type) - (mapcar (lambda (elem) (list (symbol-name (car elem)))) - nnwarchive-type-definition) - nil t nil 'gnus-group-warchive-type-history) - default-type)) - (address (read-string "Warchive address: " - nil 'gnus-group-warchive-address-history)) - (default-login (or (car gnus-group-warchive-login-history) - user-mail-address)) - (login - (gnus-string-or - (read-string - (format "Warchive login (default %s): " user-mail-address) - default-login 'gnus-group-warchive-login-history) - user-mail-address)) - (method - `(nnwarchive ,address - (nnwarchive-type ,(intern type)) - (nnwarchive-login ,login)))) - (gnus-group-make-group group method))) - (defun gnus-group-make-archive-group (&optional all) "Create the (ding) Gnus archive group of the most recent articles. Given a prefix, create a full group."
--- a/lisp/gnus/gnus-html.el Tue Aug 31 04:22:49 2010 +0000 +++ b/lisp/gnus/gnus-html.el Wed Sep 01 09:55:43 2010 +0900 @@ -28,6 +28,8 @@ ;;; Code: +(eval-when-compile (require 'cl)) +(eval-when-compile (require 'mm-decode)) (require 'mm-url) (defcustom gnus-html-cache-directory (nnheader-concat gnus-directory "html-cache/") @@ -45,6 +47,11 @@ :group 'gnus-art :type 'integer) +(defcustom gnus-blocked-images "." + "Images that have URLs matching this regexp will be blocked." + :group 'gnus-art + :type 'regexp) + ;;;###autoload (defun gnus-article-html (handle) (let ((article-buffer (current-buffer))) @@ -71,8 +78,10 @@ "-T" "text/html")))) (gnus-html-wash-tags)))) +(defvar gnus-article-mouse-face) + (defun gnus-html-wash-tags () - (let (tag parameters string start end images) + (let (tag parameters string start end images url) (mm-url-decode-entities) (goto-char (point-min)) (while (re-search-forward "<\\([^ />]+\\)\\([^>]*\\)>" nil t) @@ -89,31 +98,46 @@ ;; Fetch and insert a picture. ((equal tag "img_alt") (when (string-match "src=\"\\([^\"]+\\)" parameters) - (setq parameters (match-string 1 parameters)) - (when (or (null mm-w3m-safe-url-regexp) - (string-match mm-w3m-safe-url-regexp parameters)) - (let ((file (gnus-html-image-id parameters))) - (if (file-exists-p file) - ;; It's already cached, so just insert it. - (when (gnus-html-put-image file (point)) - ;; Delete the ALT text. - (delete-region start end)) - ;; We don't have it, so schedule it for fetching - ;; asynchronously. - (push (list parameters - (set-marker (make-marker) start) - (point-marker)) - images)))))) + (setq url (match-string 1 parameters)) + (if (string-match "^cid:\\(.*\\)" url) + ;; URLs with cid: have their content stashed in other + ;; parts of the MIME structure, so just insert them + ;; immediately. + (let ((handle (mm-get-content-id + (setq url (match-string 1 url)))) + image) + (when handle + (mm-with-part handle + (setq image (gnus-create-image (buffer-string) + nil t)))) + (when image + (delete-region start end) + (gnus-put-image image))) + ;; Normal, external URL. + (when (or (null gnus-blocked-images) + (not (string-match gnus-blocked-images url))) + (let ((file (gnus-html-image-id url))) + (if (file-exists-p file) + ;; It's already cached, so just insert it. + (when (gnus-html-put-image file (point)) + ;; Delete the ALT text. + (delete-region start end)) + ;; We don't have it, so schedule it for fetching + ;; asynchronously. + (push (list url + (set-marker (make-marker) start) + (point-marker)) + images))))))) ;; Add a link. ((equal tag "a") (when (string-match "href=\"\\([^\"]+\\)" parameters) - (setq parameters (match-string 1 parameters)) + (setq url (match-string 1 parameters)) (gnus-article-add-button start end - 'browse-url parameters - parameters) + 'browse-url url + url) (let ((overlay (gnus-make-overlay start end))) (gnus-overlay-put overlay 'evaporate t) - (gnus-overlay-put overlay 'gnus-button-url parameters) + (gnus-overlay-put overlay 'gnus-button-url url) (when gnus-article-mouse-face (gnus-overlay-put overlay 'mouse-face gnus-article-mouse-face))))) ;; Whatever. Just ignore the tag. @@ -139,27 +163,26 @@ url))) (process-kill-without-query process) (set-process-sentinel process 'gnus-html-curl-sentinel) - (set-process-plist process (list 'images images - 'buffer buffer)))) + (gnus-set-process-plist process (list 'images images + 'buffer buffer)))) (defun gnus-html-image-id (url) (expand-file-name (sha1 url) gnus-html-cache-directory)) (defun gnus-html-curl-sentinel (process event) (when (string-match "finished" event) - (let* ((images (getf (process-plist process) 'images)) - (buffer (getf (process-plist process) 'buffer)) + (let* ((images (process-get process 'images)) + (buffer (process-get process 'buffer)) (spec (pop images)) (file (gnus-html-image-id (car spec)))) (when (and (buffer-live-p buffer) ;; If the position of the marker is 1, then that - ;; means that the text is was in has been deleted; + ;; means that the text it was in has been deleted; ;; i.e., that the user has selected a different ;; article before the image arrived. - (not (= (marker-position (cadr spec)) 1))) - (save-excursion - (set-buffer buffer) - (let ((buffer-read-only nil)) + (not (= (marker-position (cadr spec)) (point-min)))) + (with-current-buffer buffer + (let ((inhibit-read-only t)) (when (gnus-html-put-image file (cadr spec)) (delete-region (1+ (cadr spec)) (caddr spec)))))) (when images @@ -175,7 +198,7 @@ ;; Kludge to avoid displaying 30x30 gif images, which ;; seems to be a signal of a broken image. (not (and (listp image) - (eq (getf (cdr image) :type) 'gif) + (eq (plist-get (cdr image) :type) 'gif) (= (car (image-size image t)) 30) (= (cdr (image-size image t)) 30)))) (progn @@ -206,16 +229,15 @@ ;;;###autoload (defun gnus-html-prefetch-images (summary) - (let (safe-url-regexp urls) + (let (blocked-images urls) (when (buffer-live-p summary) - (save-excursion - (set-buffer summary) - (setq safe-url-regexp mm-w3m-safe-url-regexp)) + (with-current-buffer summary + (setq blocked-images gnus-blocked-images)) (save-match-data (while (re-search-forward "<img.*src=[\"']\\([^\"']+\\)" nil t) (let ((url (match-string 1))) - (when (or (null safe-url-regexp) - (string-match safe-url-regexp url)) + (when (or (null blocked-images) + (not (string-match blocked-images url))) (unless (file-exists-p (gnus-html-image-id url)) (push url urls) (push (gnus-html-image-id url) urls)
--- a/lisp/gnus/gnus-soup.el Tue Aug 31 04:22:49 2010 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,611 +0,0 @@ -;;; gnus-soup.el --- SOUP packet writing support for Gnus - -;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, -;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. - -;; Author: Per Abrahamsen <abraham@iesd.auc.dk> -;; Lars Magne Ingebrigtsen <larsi@gnus.org> -;; Keywords: news, mail - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. - -;;; Commentary: - -;;; Code: - -(eval-when-compile (require 'cl)) - -(require 'gnus) -(require 'gnus-art) -(require 'message) -(require 'gnus-start) -(require 'gnus-range) - -(defgroup gnus-soup nil - "SOUP packet writing support for Gnus." - :group 'gnus) - -;;; User Variables: - -(defcustom gnus-soup-directory (nnheader-concat gnus-home-directory "SoupBrew/") - "Directory containing an unpacked SOUP packet." - :version "22.1" ;; Gnus 5.10.9 - :type 'directory - :group 'gnus-soup) - -(defcustom gnus-soup-replies-directory - (nnheader-concat gnus-soup-directory "SoupReplies/") - "Directory where Gnus will do processing of replies." - :version "22.1" ;; Gnus 5.10.9 - :type 'directory - :group 'gnus-soup) - -(defcustom gnus-soup-prefix-file "gnus-prefix" - "Name of the file where Gnus stores the last used prefix." - :version "22.1" ;; Gnus 5.10.9 - :type 'file - :group 'gnus-soup) - -(defcustom gnus-soup-packer "tar cf - %s | gzip > $HOME/Soupout%d.tgz" - "Format string command for packing a SOUP packet. -The SOUP files will be inserted where the %s is in the string. -This string MUST contain both %s and %d. The file number will be -inserted where %d appears." - :version "22.1" ;; Gnus 5.10.9 - :type 'string - :group 'gnus-soup) - -(defcustom gnus-soup-unpacker "gunzip -c %s | tar xvf -" - "Format string command for unpacking a SOUP packet. -The SOUP packet file name will be inserted at the %s." - :version "22.1" ;; Gnus 5.10.9 - :type 'string - :group 'gnus-soup) - -(defcustom gnus-soup-packet-directory gnus-home-directory - "Where gnus-soup will look for REPLIES packets." - :version "22.1" ;; Gnus 5.10.9 - :type 'directory - :group 'gnus-soup) - -(defcustom gnus-soup-packet-regexp "Soupin" - "Regular expression matching SOUP REPLIES packets in `gnus-soup-packet-directory'." - :version "22.1" ;; Gnus 5.10.9 - :type 'regexp - :group 'gnus-soup) - -(defcustom gnus-soup-ignored-headers "^Xref:" - "Regexp to match headers to be removed when brewing SOUP packets." - :version "22.1" ;; Gnus 5.10.9 - :type 'regexp - :group 'gnus-soup) - -;;; Internal Variables: - -(defvar gnus-soup-encoding-type ?u - "*Soup encoding type. -`u' is USENET news format, `m' is Unix mbox format, and `M' is MMDF mailbox -format.") - -(defvar gnus-soup-index-type ?c - "*Soup index type. -`n' means no index file and `c' means standard Cnews overview -format.") - -(defvar gnus-soup-areas nil) -(defvar gnus-soup-last-prefix nil) -(defvar gnus-soup-prev-prefix nil) -(defvar gnus-soup-buffers nil) - -;;; Access macros: - -(defmacro gnus-soup-area-prefix (area) - `(aref ,area 0)) -(defmacro gnus-soup-set-area-prefix (area prefix) - `(aset ,area 0 ,prefix)) -(defmacro gnus-soup-area-name (area) - `(aref ,area 1)) -(defmacro gnus-soup-area-encoding (area) - `(aref ,area 2)) -(defmacro gnus-soup-area-description (area) - `(aref ,area 3)) -(defmacro gnus-soup-area-number (area) - `(aref ,area 4)) -(defmacro gnus-soup-area-set-number (area value) - `(aset ,area 4 ,value)) - -(defmacro gnus-soup-encoding-format (encoding) - `(aref ,encoding 0)) -(defmacro gnus-soup-encoding-index (encoding) - `(aref ,encoding 1)) -(defmacro gnus-soup-encoding-kind (encoding) - `(aref ,encoding 2)) - -(defmacro gnus-soup-reply-prefix (reply) - `(aref ,reply 0)) -(defmacro gnus-soup-reply-kind (reply) - `(aref ,reply 1)) -(defmacro gnus-soup-reply-encoding (reply) - `(aref ,reply 2)) - -;;; Commands: - -(defun gnus-soup-send-replies () - "Unpack and send all replies in the reply packet." - (interactive) - (let ((packets (directory-files - gnus-soup-packet-directory t gnus-soup-packet-regexp))) - (while packets - (when (gnus-soup-send-packet (car packets)) - (delete-file (car packets))) - (setq packets (cdr packets))))) - -(defun gnus-soup-add-article (n) - "Add the current article to SOUP packet. -If N is a positive number, add the N next articles. -If N is a negative number, add the N previous articles. -If N is nil and any articles have been marked with the process mark, -move those articles instead." - (interactive "P") - (let* ((articles (gnus-summary-work-articles n)) - (tmp-buf (gnus-get-buffer-create "*soup work*")) - (area (gnus-soup-area gnus-newsgroup-name)) - (prefix (gnus-soup-area-prefix area)) - headers) - (buffer-disable-undo tmp-buf) - (save-excursion - (while articles - ;; Put the article in a buffer. - (set-buffer tmp-buf) - (when (gnus-request-article-this-buffer - (car articles) gnus-newsgroup-name) - (setq headers (nnheader-parse-head t)) - (save-restriction - (message-narrow-to-head) - (message-remove-header gnus-soup-ignored-headers t)) - (gnus-soup-store gnus-soup-directory prefix headers - gnus-soup-encoding-type - gnus-soup-index-type) - (gnus-soup-area-set-number - area (1+ (or (gnus-soup-area-number area) 0))) - ;; Mark article as read. - (set-buffer gnus-summary-buffer) - (gnus-summary-mark-as-read (car articles) gnus-souped-mark)) - (gnus-summary-remove-process-mark (car articles)) - (setq articles (cdr articles))) - (kill-buffer tmp-buf)) - (gnus-soup-save-areas) - (gnus-set-mode-line 'summary))) - -(defun gnus-soup-pack-packet () - "Make a SOUP packet from the SOUP areas." - (interactive) - (gnus-soup-read-areas) - (if (file-exists-p gnus-soup-directory) - (if (directory-files gnus-soup-directory nil "\\.MSG$") - (gnus-soup-pack gnus-soup-directory gnus-soup-packer) - (message "No files to pack.")) - (message "No such directory: %s" gnus-soup-directory))) - -(defun gnus-group-brew-soup (n) - "Make a soup packet from the current group. -Uses the process/prefix convention." - (interactive "P") - (let ((groups (gnus-group-process-prefix n))) - (while groups - (gnus-group-remove-mark (car groups)) - (gnus-soup-group-brew (car groups) t) - (setq groups (cdr groups))) - (gnus-soup-save-areas))) - -(defun gnus-brew-soup (&optional level) - "Go through all groups on LEVEL or less and make a soup packet." - (interactive "P") - (let ((level (or level gnus-level-subscribed)) - (newsrc (cdr gnus-newsrc-alist))) - (while newsrc - (when (<= (nth 1 (car newsrc)) level) - (gnus-soup-group-brew (caar newsrc) t)) - (setq newsrc (cdr newsrc))) - (gnus-soup-save-areas))) - -;;;###autoload -(defun gnus-batch-brew-soup () - "Brew a SOUP packet from groups mention on the command line. -Will use the remaining command line arguments as regular expressions -for matching on group names. - -For instance, if you want to brew on all the nnml groups, as well as -groups with \"emacs\" in the name, you could say something like: - -$ emacs -batch -f gnus-batch-brew-soup ^nnml \".*emacs.*\" - -Note -- this function hasn't been implemented yet." - (interactive) - nil) - -;;; Internal Functions: - -;; Store the current buffer. -(defun gnus-soup-store (directory prefix headers format index) - ;; Create the directory, if needed. - (gnus-make-directory directory) - (let* ((msg-buf (nnheader-find-file-noselect - (concat directory prefix ".MSG"))) - (idx-buf (if (= index ?n) - nil - (nnheader-find-file-noselect - (concat directory prefix ".IDX")))) - (article-buf (current-buffer)) - from head-line beg type) - (setq gnus-soup-buffers (cons msg-buf (delq msg-buf gnus-soup-buffers))) - (buffer-disable-undo msg-buf) - (when idx-buf - (push idx-buf gnus-soup-buffers) - (buffer-disable-undo idx-buf)) - (save-excursion - ;; Make sure the last char in the buffer is a newline. - (goto-char (point-max)) - (unless (= (current-column) 0) - (insert "\n")) - ;; Find the "from". - (goto-char (point-min)) - (setq from - (gnus-mail-strip-quoted-names - (or (mail-fetch-field "from") - (mail-fetch-field "really-from") - (mail-fetch-field "sender")))) - (goto-char (point-min)) - ;; Depending on what encoding is supposed to be used, we make - ;; a soup header. - (setq head-line - (cond - ((or (= gnus-soup-encoding-type ?u) - (= gnus-soup-encoding-type ?n)) ;;Gnus back compatibility. - (format "#! rnews %d\n" (buffer-size))) - ((= gnus-soup-encoding-type ?m) - (while (search-forward "\nFrom " nil t) - (replace-match "\n>From " t t)) - (concat "From " (or from "unknown") - " " (current-time-string) "\n")) - ((= gnus-soup-encoding-type ?M) - "\^a\^a\^a\^a\n") - (t (error "Unsupported type: %c" gnus-soup-encoding-type)))) - ;; Insert the soup header and the article in the MSG buf. - (set-buffer msg-buf) - (goto-char (point-max)) - (insert head-line) - (setq beg (point)) - (insert-buffer-substring article-buf) - ;; Insert the index in the IDX buf. - (cond ((= index ?c) - (set-buffer idx-buf) - (gnus-soup-insert-idx beg headers)) - ((/= index ?n) - (error "Unknown index type: %c" type))) - ;; Return the MSG buf. - msg-buf))) - -(defun gnus-soup-group-brew (group &optional not-all) - "Enter GROUP and add all articles to a SOUP package. -If NOT-ALL, don't pack ticked articles." - (let ((gnus-expert-user t) - (gnus-large-newsgroup nil) - (entry (gnus-group-entry group))) - (when (or (null entry) - (eq (car entry) t) - (and (car entry) - (> (car entry) 0)) - (and (not not-all) - (gnus-range-length (cdr (assq 'tick (gnus-info-marks - (nth 2 entry))))))) - (when (gnus-summary-read-group group nil t) - (setq gnus-newsgroup-processable - (reverse - (if (not not-all) - (append gnus-newsgroup-marked gnus-newsgroup-unreads) - gnus-newsgroup-unreads))) - (gnus-soup-add-article nil) - (gnus-summary-exit))))) - -(defun gnus-soup-insert-idx (offset header) - ;; [number subject from date id references chars lines xref] - (goto-char (point-max)) - (insert - (format "%d\t%s\t%s\t%s\t%s\t%s\t%d\t%s\t\t\n" - offset - (or (mail-header-subject header) "(none)") - (or (mail-header-from header) "(nobody)") - (or (mail-header-date header) "") - (or (mail-header-id header) - (concat "soup-dummy-id-" - (mapconcat - (lambda (time) (int-to-string time)) - (current-time) "-"))) - (or (mail-header-references header) "") - (or (mail-header-chars header) 0) - (or (mail-header-lines header) "0")))) - -(defun gnus-soup-save-areas () - "Write all SOUP buffers." - (interactive) - (gnus-soup-write-areas) - (save-excursion - (let (buf) - (while gnus-soup-buffers - (setq buf (car gnus-soup-buffers) - gnus-soup-buffers (cdr gnus-soup-buffers)) - (if (not (buffer-name buf)) - () - (set-buffer buf) - (when (buffer-modified-p) - (save-buffer)) - (kill-buffer (current-buffer))))) - (gnus-soup-write-prefixes))) - -(defun gnus-soup-write-prefixes () - (let ((prefixes gnus-soup-last-prefix) - prefix) - (save-excursion - (gnus-set-work-buffer) - (while (setq prefix (pop prefixes)) - (erase-buffer) - (insert (format "(setq gnus-soup-prev-prefix %d)\n" (cdr prefix))) - (let ((coding-system-for-write mm-text-coding-system)) - (gnus-write-buffer (concat (car prefix) gnus-soup-prefix-file))))))) - -(defun gnus-soup-pack (dir packer) - (let* ((files (mapconcat 'identity - '("AREAS" "*.MSG" "*.IDX" "INFO" - "LIST" "REPLIES" "COMMANDS" "ERRORS") - " ")) - (packer (if (< (string-match "%s" packer) - (string-match "%d" packer)) - (format packer files - (string-to-number (gnus-soup-unique-prefix dir))) - (format packer - (string-to-number (gnus-soup-unique-prefix dir)) - files))) - (dir (expand-file-name dir))) - (gnus-make-directory dir) - (setq gnus-soup-areas nil) - (gnus-message 4 "Packing %s..." packer) - (if (eq 0 (call-process shell-file-name - nil nil nil shell-command-switch - (concat "cd " dir " ; " packer))) - (progn - (call-process shell-file-name nil nil nil shell-command-switch - (concat "cd " dir " ; rm " files)) - (gnus-message 4 "Packing...done" packer)) - (error "Couldn't pack packet")))) - -(defun gnus-soup-parse-areas (file) - "Parse soup area file FILE. -The result is a of vectors, each containing one entry from the AREA file. -The vector contain five strings, - [prefix name encoding description number] -though the two last may be nil if they are missing." - (let (areas) - (when (file-exists-p file) - (save-excursion - (set-buffer (nnheader-find-file-noselect file 'force)) - (buffer-disable-undo) - (goto-char (point-min)) - (while (not (eobp)) - (push (vector (gnus-soup-field) - (gnus-soup-field) - (gnus-soup-field) - (and (eq (preceding-char) ?\t) - (gnus-soup-field)) - (and (eq (preceding-char) ?\t) - (string-to-number (gnus-soup-field)))) - areas) - (when (eq (preceding-char) ?\t) - (beginning-of-line 2))) - (kill-buffer (current-buffer)))) - areas)) - -(defun gnus-soup-parse-replies (file) - "Parse soup REPLIES file FILE. -The result is a of vectors, each containing one entry from the REPLIES -file. The vector contain three strings, [prefix name encoding]." - (let (replies) - (save-excursion - (set-buffer (nnheader-find-file-noselect file)) - (buffer-disable-undo) - (goto-char (point-min)) - (while (not (eobp)) - (push (vector (gnus-soup-field) (gnus-soup-field) - (gnus-soup-field)) - replies) - (when (eq (preceding-char) ?\t) - (beginning-of-line 2))) - (kill-buffer (current-buffer))) - replies)) - -(defun gnus-soup-field () - (prog1 - (buffer-substring (point) (progn (skip-chars-forward "^\t\n") (point))) - (forward-char 1))) - -(defun gnus-soup-read-areas () - (or gnus-soup-areas - (setq gnus-soup-areas - (gnus-soup-parse-areas (concat gnus-soup-directory "AREAS"))))) - -(defun gnus-soup-write-areas () - "Write the AREAS file." - (interactive) - (when gnus-soup-areas - (with-temp-file (concat gnus-soup-directory "AREAS") - (let ((areas gnus-soup-areas) - area) - (while (setq area (pop areas)) - (insert - (format - "%s\t%s\t%s%s\n" - (gnus-soup-area-prefix area) - (gnus-soup-area-name area) - (gnus-soup-area-encoding area) - (if (or (gnus-soup-area-description area) - (gnus-soup-area-number area)) - (concat "\t" (or (gnus-soup-area-description - area) "") - (if (gnus-soup-area-number area) - (concat "\t" (int-to-string - (gnus-soup-area-number area))) - "")) "")))))))) - -(defun gnus-soup-write-replies (dir areas) - "Write a REPLIES file in DIR containing AREAS." - (with-temp-file (concat dir "REPLIES") - (let (area) - (while (setq area (pop areas)) - (insert (format "%s\t%s\t%s\n" - (gnus-soup-reply-prefix area) - (gnus-soup-reply-kind area) - (gnus-soup-reply-encoding area))))))) - -(defun gnus-soup-area (group) - (gnus-soup-read-areas) - (let ((areas gnus-soup-areas) - (real-group (gnus-group-real-name group)) - area result) - (while areas - (setq area (car areas) - areas (cdr areas)) - (when (equal (gnus-soup-area-name area) real-group) - (setq result area))) - (unless result - (setq result - (vector (gnus-soup-unique-prefix) - real-group - (format "%c%c%c" - gnus-soup-encoding-type - gnus-soup-index-type - (if (gnus-member-of-valid 'mail group) ?m ?n)) - nil nil) - gnus-soup-areas (cons result gnus-soup-areas))) - result)) - -(defun gnus-soup-unique-prefix (&optional dir) - (let* ((dir (file-name-as-directory (or dir gnus-soup-directory))) - (entry (assoc dir gnus-soup-last-prefix)) - gnus-soup-prev-prefix) - (if entry - () - (when (file-exists-p (concat dir gnus-soup-prefix-file)) - (ignore-errors - (load (concat dir gnus-soup-prefix-file) nil t t))) - (push (setq entry (cons dir (or gnus-soup-prev-prefix 0))) - gnus-soup-last-prefix)) - (setcdr entry (1+ (cdr entry))) - (gnus-soup-write-prefixes) - (int-to-string (cdr entry)))) - -(defun gnus-soup-unpack-packet (dir unpacker packet) - "Unpack PACKET into DIR using UNPACKER. -Return whether the unpacking was successful." - (gnus-make-directory dir) - (gnus-message 4 "Unpacking: %s" (format unpacker packet)) - (prog1 - (eq 0 (call-process - shell-file-name nil nil nil shell-command-switch - (format "cd %s ; %s" (expand-file-name dir) - (format unpacker packet)))) - (gnus-message 4 "Unpacking...done"))) - -(defun gnus-soup-send-packet (packet) - (gnus-soup-unpack-packet - gnus-soup-replies-directory gnus-soup-unpacker packet) - (let ((replies (gnus-soup-parse-replies - (concat gnus-soup-replies-directory "REPLIES")))) - (save-excursion - (while replies - (let* ((msg-file (concat gnus-soup-replies-directory - (gnus-soup-reply-prefix (car replies)) - ".MSG")) - (msg-buf (and (file-exists-p msg-file) - (nnheader-find-file-noselect msg-file))) - (tmp-buf (gnus-get-buffer-create " *soup send*")) - beg end) - (cond - ((and (/= (gnus-soup-encoding-format - (gnus-soup-reply-encoding (car replies))) - ?u) - (/= (gnus-soup-encoding-format - (gnus-soup-reply-encoding (car replies))) - ?n)) ;; Gnus back compatibility. - (error "Unsupported encoding")) - ((null msg-buf) - t) - (t - (buffer-disable-undo msg-buf) - (set-buffer msg-buf) - (goto-char (point-min)) - (while (not (eobp)) - (unless (looking-at "#! *rnews +\\([0-9]+\\)") - (error "Bad header")) - (forward-line 1) - (setq beg (point) - end (+ (point) (string-to-number - (buffer-substring - (match-beginning 1) (match-end 1))))) - (switch-to-buffer tmp-buf) - (erase-buffer) - (mm-disable-multibyte) - (insert-buffer-substring msg-buf beg end) - (cond - ((string= (gnus-soup-reply-kind (car replies)) "news") - (gnus-message 5 "Sending news message to %s..." - (mail-fetch-field "newsgroups")) - (sit-for 1) - (let ((message-syntax-checks - 'dont-check-for-anything-just-trust-me) - (method (if (functionp message-post-method) - (funcall message-post-method) - message-post-method)) - result) - (run-hooks 'message-send-news-hook) - (gnus-open-server method) - (message "Sending news via %s..." - (gnus-server-string method)) - (unless (let ((mail-header-separator "")) - (gnus-request-post method)) - (message "Couldn't send message via news: %s" - (nnheader-get-report (car method)))))) - ((string= (gnus-soup-reply-kind (car replies)) "mail") - (gnus-message 5 "Sending mail to %s..." - (mail-fetch-field "to")) - (sit-for 1) - (let ((mail-header-separator "")) - (funcall (or message-send-mail-real-function - message-send-mail-function)))) - (t - (error "Unknown reply kind"))) - (set-buffer msg-buf) - (goto-char end)) - (delete-file (buffer-file-name)) - (kill-buffer msg-buf) - (kill-buffer tmp-buf) - (gnus-message 4 "Sent packet")))) - (setq replies (cdr replies))) - t))) - -(provide 'gnus-soup) - -;; arch-tag: eddfa69d-13e8-4aea-84ef-62a526ef185c -;;; gnus-soup.el ends here
--- a/lisp/gnus/gnus-sum.el Tue Aug 31 04:22:49 2010 +0000 +++ b/lisp/gnus/gnus-sum.el Wed Sep 01 09:55:43 2010 +0900 @@ -538,11 +538,6 @@ :group 'gnus-summary-marks :type 'character) -(defcustom gnus-souped-mark ?F - "*Mark used for souped articles." - :group 'gnus-summary-marks - :type 'character) - (defcustom gnus-kill-file-mark ?X "*Mark used for articles killed by kill files." :group 'gnus-summary-marks @@ -666,7 +661,7 @@ (defcustom gnus-auto-expirable-marks (list gnus-killed-mark gnus-del-mark gnus-catchup-mark gnus-low-score-mark gnus-ancient-mark gnus-read-mark - gnus-souped-mark gnus-duplicate-mark) + gnus-duplicate-mark) "*The list of marks converted into expiration if a group is auto-expirable." :version "21.1" :group 'gnus-summary @@ -1258,7 +1253,7 @@ "Whether Gnus should parse all headers made available to it. This is mostly relevant for slow back ends where the user may wish to widen the summary buffer to include all headers -that were fetched. Say, for nnultimate groups." +that were fetched." :version "22.1" :group 'gnus-summary :type '(choice boolean regexp)) @@ -2180,8 +2175,7 @@ "h" gnus-summary-save-article-folder "v" gnus-summary-save-article-vm "p" gnus-summary-pipe-output - "P" gnus-summary-muttprint - "s" gnus-soup-add-article) + "P" gnus-summary-muttprint) (gnus-define-keys (gnus-summary-mime-map "K" gnus-summary-mode-map) "b" gnus-summary-display-buttonized @@ -2445,7 +2439,6 @@ ["Save in RMAIL mbox..." gnus-summary-save-article-rmail t] ["Save body in file..." gnus-summary-save-article-body-file t] ["Pipe through a filter..." gnus-summary-pipe-output t] - ["Add to SOUP packet" gnus-soup-add-article t] ["Print with Muttprint..." gnus-summary-muttprint t] ["Print" gnus-summary-print-article ,@(if (featurep 'xemacs) '(t) @@ -8305,7 +8298,7 @@ gnus-killed-mark gnus-spam-mark gnus-kill-file-mark gnus-low-score-mark gnus-expirable-mark gnus-canceled-mark gnus-catchup-mark gnus-sparse-mark - gnus-duplicate-mark gnus-souped-mark) + gnus-duplicate-mark) 'reverse))) (defun gnus-summary-limit-to-headers (match &optional reverse)
--- a/lisp/gnus/gnus.el Tue Aug 31 04:22:49 2010 +0000 +++ b/lisp/gnus/gnus.el Wed Sep 01 09:55:43 2010 +0900 @@ -1741,15 +1741,12 @@ ("nndoc" none address prompt-address) ("nnbabyl" mail address respool) ("nnkiboze" post virtual) - ("nnsoup" post-mail address) ("nndraft" post-mail) ("nnfolder" mail respool address) ("nngateway" post-mail address prompt-address physical-address) ("nnweb" none) - ("nnultimate" none) ("nnrss" none) ("nnwfm" none) - ("nnwarchive" none) ("nnlistserv" none) ("nnagent" post-mail) ("nnimap" post-mail address prompt-address physical-address) @@ -2892,10 +2889,6 @@ ("rmailsum" rmail-update-summary) ("gnus-audio" :interactive t gnus-audio-play) ("gnus-xmas" gnus-xmas-splash) - ("gnus-soup" :interactive t - gnus-group-brew-soup gnus-brew-soup gnus-soup-add-article - gnus-soup-send-replies gnus-soup-save-areas gnus-soup-pack-packet) - ("nnsoup" nnsoup-pack-replies) ("score-mode" :interactive t gnus-score-mode) ("gnus-mh" gnus-summary-save-article-folder gnus-Folder-save-name gnus-folder-save-name)
--- a/lisp/gnus/message.el Tue Aug 31 04:22:49 2010 +0000 +++ b/lisp/gnus/message.el Wed Sep 01 09:55:43 2010 +0900 @@ -249,6 +249,14 @@ :link '(custom-manual "(message)Message Headers") :type '(repeat sexp)) +(defcustom message-prune-recipient-rules nil + "Rules for how to prune the list of recipients when doing wide replies. +This is a list of regexps and regexp matches." + :group 'message-mail + :group 'message-headers + :link '(custom-manual "(message)Wide Reply") + :type '(repeat regexp)) + (defcustom message-deletable-headers '(Message-ID Date Lines) "Headers to be deleted if they already exist and were generated by message previously." :group 'message-headers @@ -6551,7 +6559,7 @@ (defun message-get-reply-headers (wide &optional to-address address-headers) (let (follow-to mct never-mct to cc author mft recipients extra) - ;; Find all relevant headers we need. + ;; Find all relevant headers we need. (save-restriction (message-narrow-to-headers-or-head) ;; Gmane renames "To". Look at "Original-To", too, if it is present in @@ -6677,6 +6685,8 @@ (if recip (setq recipients (delq recip recipients)))))))) + (setq recipients (message-prune-recipients recipients)) + ;; Build the header alist. Allow the user to be asked whether ;; or not to reply to all recipients in a wide reply. (setq follow-to (list (cons 'To (cdr (pop recipients))))) @@ -6690,6 +6700,22 @@ (push (cons 'Cc recipients) follow-to))) follow-to)) +(defun message-prune-recipients (recipients) + (dolist (rule message-prune-recipient-rules) + (let ((match (car rule)) + dup-match + address) + (dolist (recipient recipients) + (setq address (car recipient)) + (when (string-match match address) + (setq dup-match (replace-match (cadr rule) nil nil address)) + (dolist (recipient recipients) + ;; Don't delete the address that triggered this. + (when (and (not (eq address (car recipient))) + (string-match dup-match (car recipient))) + (setq recipients (delq recipient recipients)))))))) + recipients) + (defcustom message-simplify-subject-functions '(message-strip-list-identifiers message-strip-subject-re
--- a/lisp/gnus/nnimap.el Tue Aug 31 04:22:49 2010 +0000 +++ b/lisp/gnus/nnimap.el Wed Sep 01 09:55:43 2010 +0900 @@ -1499,8 +1499,8 @@ (nnimap-before-find-minmax-bugworkaround) (dolist (pattern (nnimap-pattern-to-list-arguments nnimap-list-pattern)) - (dolist (mbx (imap-mailbox-lsub (cdr pattern) (car pattern) nil - nnimap-server-buffer)) + (dolist (mbx (funcall nnimap-request-list-method (cdr pattern) (car pattern) nil + nnimap-server-buffer)) (or (catch 'found (dolist (mailbox (imap-mailbox-get 'list-flags mbx nnimap-server-buffer))
--- a/lisp/gnus/nnsoup.el Tue Aug 31 04:22:49 2010 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,812 +0,0 @@ -;;; nnsoup.el --- SOUP access for Gnus - -;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, -;; 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. - -;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> -;; Masanobu UMEDA <umerin@flab.flab.fujitsu.junet> -;; Keywords: news, mail - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. - -;;; Commentary: - -;;; Code: - -(require 'nnheader) -(require 'nnmail) -(require 'gnus-soup) -(require 'gnus-msg) -(require 'nnoo) -(eval-when-compile (require 'cl)) - -(nnoo-declare nnsoup) - -(defvoo nnsoup-directory (nnheader-concat gnus-home-directory "SOUP/") - "*SOUP packet directory.") - -(defvoo nnsoup-tmp-directory - (cond ((fboundp 'temp-directory) (temp-directory)) - ((boundp 'temporary-file-directory) temporary-file-directory) - ("/tmp/")) - "*Where nnsoup will store temporary files.") - -(defvoo nnsoup-replies-directory (expand-file-name "replies/" nnsoup-directory) - "*Directory where outgoing packets will be composed.") - -(defvoo nnsoup-replies-format-type ?u ;; u is USENET news format. - "*Format of the replies packages.") - -(defvoo nnsoup-replies-index-type ?n - "*Index type of the replies packages.") - -(defvoo nnsoup-active-file (expand-file-name "active" nnsoup-directory) - "Active file.") - -(defvoo nnsoup-packer (concat "tar cf - %s | gzip > " - (expand-file-name gnus-home-directory) - "Soupin%d.tgz") - "Format string command for packing a SOUP packet. -The SOUP files will be inserted where the %s is in the string. -This string MUST contain both %s and %d. The file number will be -inserted where %d appears.") - -(defvoo nnsoup-unpacker "gunzip -c %s | tar xvf -" - "*Format string command for unpacking a SOUP packet. -The SOUP packet file name will be inserted at the %s.") - -(defvoo nnsoup-packet-directory gnus-home-directory - "*Where nnsoup will look for incoming packets.") - -(defvoo nnsoup-packet-regexp "Soupout" - "*Regular expression matching SOUP packets in `nnsoup-packet-directory'.") - -(defvoo nnsoup-always-save t - "If non-nil commit the reply buffer on each message send. -This is necessary if using message mode outside Gnus with nnsoup as a -backend for the messages.") - - - -(defconst nnsoup-version "nnsoup 0.0" - "nnsoup version.") - -(defvoo nnsoup-status-string "") -(defvoo nnsoup-group-alist nil) -(defvoo nnsoup-current-prefix 0) -(defvoo nnsoup-replies-list nil) -(defvoo nnsoup-buffers nil) -(defvoo nnsoup-current-group nil) -(defvoo nnsoup-group-alist-touched nil) -(defvoo nnsoup-article-alist nil) - - -;;; Interface functions. - -(nnoo-define-basics nnsoup) - -(deffoo nnsoup-retrieve-headers (sequence &optional group server fetch-old) - (nnsoup-possibly-change-group group) - (save-excursion - (set-buffer nntp-server-buffer) - (erase-buffer) - (let ((areas (cddr (assoc nnsoup-current-group nnsoup-group-alist))) - (articles sequence) - (use-nov t) - useful-areas this-area-seq msg-buf) - (if (stringp (car sequence)) - ;; We don't support fetching by Message-ID. - 'headers - ;; We go through all the areas and find which files the - ;; articles in SEQUENCE come from. - (while (and areas sequence) - ;; Peel off areas that are below sequence. - (while (and areas (< (cdar (car areas)) (car sequence))) - (setq areas (cdr areas))) - (when areas - ;; This is a useful area. - (push (car areas) useful-areas) - (setq this-area-seq nil) - ;; We take note whether this MSG has a corresponding IDX - ;; for later use. - (when (or (= (gnus-soup-encoding-index - (gnus-soup-area-encoding (nth 1 (car areas)))) ?n) - (not (file-exists-p - (nnsoup-file - (gnus-soup-area-prefix (nth 1 (car areas))))))) - (setq use-nov nil)) - ;; We assign the portion of `sequence' that is relevant to - ;; this MSG packet to this packet. - (while (and sequence (<= (car sequence) (cdar (car areas)))) - (push (car sequence) this-area-seq) - (setq sequence (cdr sequence))) - (setcar useful-areas (cons (nreverse this-area-seq) - (car useful-areas))))) - - ;; We now have a list of article numbers and corresponding - ;; areas. - (setq useful-areas (nreverse useful-areas)) - - ;; Two different approaches depending on whether all the MSG - ;; files have corresponding IDX files. If they all do, we - ;; simply return the relevant IDX files and let Gnus sort out - ;; what lines are relevant. If some of the IDX files are - ;; missing, we must return HEADs for all the articles. - (if use-nov - ;; We have IDX files for all areas. - (progn - (while useful-areas - (goto-char (point-max)) - (let ((b (point)) - (number (car (nth 1 (car useful-areas)))) - (index-buffer (nnsoup-index-buffer - (gnus-soup-area-prefix - (nth 2 (car useful-areas)))))) - (when index-buffer - (insert-buffer-substring index-buffer) - (goto-char b) - ;; We have to remove the index number entries and - ;; insert article numbers instead. - (while (looking-at "[0-9]+") - (replace-match (int-to-string number) t t) - (incf number) - (forward-line 1)))) - (setq useful-areas (cdr useful-areas))) - 'nov) - ;; We insert HEADs. - (while useful-areas - (setq articles (caar useful-areas) - useful-areas (cdr useful-areas)) - (while articles - (when (setq msg-buf - (nnsoup-narrow-to-article - (car articles) (cdar useful-areas) 'head)) - (goto-char (point-max)) - (insert (format "221 %d Article retrieved.\n" (car articles))) - (insert-buffer-substring msg-buf) - (goto-char (point-max)) - (insert ".\n")) - (setq articles (cdr articles)))) - - (nnheader-fold-continuation-lines) - 'headers))))) - -(deffoo nnsoup-open-server (server &optional defs) - (nnoo-change-server 'nnsoup server defs) - (when (not (file-exists-p nnsoup-directory)) - (condition-case () - (make-directory nnsoup-directory t) - (error t))) - (cond - ((not (file-exists-p nnsoup-directory)) - (nnsoup-close-server) - (nnheader-report 'nnsoup "Couldn't create directory: %s" nnsoup-directory)) - ((not (file-directory-p (file-truename nnsoup-directory))) - (nnsoup-close-server) - (nnheader-report 'nnsoup "Not a directory: %s" nnsoup-directory)) - (t - (nnsoup-read-active-file) - (nnheader-report 'nnsoup "Opened server %s using directory %s" - server nnsoup-directory) - t))) - -(deffoo nnsoup-request-close () - (nnsoup-write-active-file) - (nnsoup-write-replies) - (gnus-soup-save-areas) - ;; Kill all nnsoup buffers. - (let (buffer) - (while nnsoup-buffers - (setq buffer (cdr (pop nnsoup-buffers))) - (and buffer - (buffer-name buffer) - (kill-buffer buffer)))) - (setq nnsoup-group-alist nil - nnsoup-group-alist-touched nil - nnsoup-current-group nil - nnsoup-replies-list nil) - (nnoo-close-server 'nnoo) - t) - -(deffoo nnsoup-request-article (id &optional newsgroup server buffer) - (nnsoup-possibly-change-group newsgroup) - (let (buf) - (save-excursion - (set-buffer (or buffer nntp-server-buffer)) - (erase-buffer) - (when (and (not (stringp id)) - (setq buf (nnsoup-narrow-to-article id))) - (insert-buffer-substring buf) - t)))) - -(deffoo nnsoup-request-group (group &optional server dont-check) - (nnsoup-possibly-change-group group) - (if dont-check - t - (let ((active (cadr (assoc group nnsoup-group-alist)))) - (if (not active) - (nnheader-report 'nnsoup "No such group: %s" group) - (nnheader-insert - "211 %d %d %d %s\n" - (max (1+ (- (cdr active) (car active))) 0) - (car active) (cdr active) group))))) - -(deffoo nnsoup-request-type (group &optional article) - (nnsoup-possibly-change-group group) - ;; Try to guess the type based on the first article in the group. - (when (not article) - (setq article - (cdar (car (cddr (assoc group nnsoup-group-alist)))))) - (if (not article) - 'unknown - (let ((kind (gnus-soup-encoding-kind - (gnus-soup-area-encoding - (nth 1 (nnsoup-article-to-area - article nnsoup-current-group)))))) - (cond ((= kind ?m) 'mail) - ((= kind ?n) 'news) - (t 'unknown))))) - -(deffoo nnsoup-close-group (group &optional server) - ;; Kill all nnsoup buffers. - (let ((buffers nnsoup-buffers) - elem) - (while buffers - (when (equal (car (setq elem (pop buffers))) group) - (setq nnsoup-buffers (delq elem nnsoup-buffers)) - (and (cdr elem) (buffer-name (cdr elem)) - (kill-buffer (cdr elem)))))) - t) - -(deffoo nnsoup-request-list (&optional server) - (save-excursion - (set-buffer nntp-server-buffer) - (erase-buffer) - (unless nnsoup-group-alist - (nnsoup-read-active-file)) - (let ((alist nnsoup-group-alist) - (standard-output (current-buffer)) - entry) - (while (setq entry (pop alist)) - (insert (car entry) " ") - (princ (cdadr entry)) - (insert " ") - (princ (caadr entry)) - (insert " y\n")) - t))) - -(deffoo nnsoup-request-scan (group &optional server) - (nnsoup-unpack-packets)) - -(deffoo nnsoup-request-newgroups (date &optional server) - (nnsoup-request-list)) - -(deffoo nnsoup-request-list-newsgroups (&optional server) - nil) - -(deffoo nnsoup-request-post (&optional server) - (nnsoup-store-reply "news") - t) - -(deffoo nnsoup-request-mail (&optional server) - (nnsoup-store-reply "mail") - t) - -(deffoo nnsoup-request-expire-articles (articles group &optional server force) - (nnsoup-possibly-change-group group) - (let* ((total-infolist (assoc group nnsoup-group-alist)) - (active (cadr total-infolist)) - (infolist (cddr total-infolist)) - info range-list mod-time prefix) - (while infolist - (setq info (pop infolist) - range-list (gnus-uncompress-range (car info)) - prefix (gnus-soup-area-prefix (nth 1 info))) - (when;; All the articles in this file are marked for expiry. - (and (or (setq mod-time (nth 5 (file-attributes - (nnsoup-file prefix)))) - (setq mod-time (nth 5 (file-attributes - (nnsoup-file prefix t))))) - (gnus-sublist-p articles range-list) - ;; This file is old enough. - (nnmail-expired-article-p group mod-time force)) - ;; Ok, we delete this file. - (when (ignore-errors - (nnheader-message - 5 "Deleting %s in group %s..." (nnsoup-file prefix) - group) - (when (file-exists-p (nnsoup-file prefix)) - (delete-file (nnsoup-file prefix))) - (nnheader-message - 5 "Deleting %s in group %s..." (nnsoup-file prefix t) - group) - (when (file-exists-p (nnsoup-file prefix t)) - (delete-file (nnsoup-file prefix t))) - t) - (setcdr (cdr total-infolist) (delq info (cddr total-infolist))) - (setq articles (gnus-sorted-difference articles range-list)))) - (when (not mod-time) - (setcdr (cdr total-infolist) (delq info (cddr total-infolist))))) - (if (cddr total-infolist) - (setcar active (caaadr (cdr total-infolist))) - (setcar active (1+ (cdr active)))) - (nnsoup-write-active-file t) - ;; Return the articles that weren't expired. - articles)) - - -;;; Internal functions - -(defun nnsoup-possibly-change-group (group &optional force) - (when (and group - (not (equal nnsoup-current-group group))) - (setq nnsoup-article-alist nil) - (setq nnsoup-current-group group)) - t) - -(defun nnsoup-read-active-file () - (setq nnsoup-group-alist nil) - (when (file-exists-p nnsoup-active-file) - (ignore-errors - (load nnsoup-active-file t t t)) - ;; Be backwards compatible. - (when (and nnsoup-group-alist - (not (atom (caadar nnsoup-group-alist)))) - (let ((alist nnsoup-group-alist) - entry e min max) - (while (setq e (cdr (setq entry (pop alist)))) - (setq min (caaar e)) - (setq max (cdar (car (last e)))) - (setcdr entry (cons (cons min max) (cdr entry))))) - (setq nnsoup-group-alist-touched t)) - nnsoup-group-alist)) - -(defun nnsoup-write-active-file (&optional force) - (when (and nnsoup-group-alist - (or force - nnsoup-group-alist-touched)) - (setq nnsoup-group-alist-touched nil) - (with-temp-file nnsoup-active-file - (gnus-prin1 `(setq nnsoup-group-alist ',nnsoup-group-alist)) - (insert "\n") - (gnus-prin1 `(setq nnsoup-current-prefix ,nnsoup-current-prefix)) - (insert "\n")))) - -(defun nnsoup-next-prefix () - "Return the next free prefix." - (let (prefix) - (while (or (file-exists-p - (nnsoup-file (setq prefix (int-to-string - nnsoup-current-prefix)))) - (file-exists-p (nnsoup-file prefix t))) - (incf nnsoup-current-prefix)) - (incf nnsoup-current-prefix) - prefix)) - -(defun nnsoup-file-name (dir file) - "Return the full name of FILE (in any case) in DIR." - (let* ((case-fold-search t) - (files (directory-files dir t)) - (regexp (concat (regexp-quote file) "$"))) - (car (delq nil - (mapcar - (lambda (file) - (if (string-match regexp file) - file - nil)) - files))))) - -(defun nnsoup-read-areas () - (let ((areas-file (nnsoup-file-name nnsoup-tmp-directory "areas"))) - (when areas-file - (save-excursion - (set-buffer nntp-server-buffer) - (let ((areas (gnus-soup-parse-areas areas-file)) - entry number area lnum cur-prefix file) - ;; Go through all areas in the new AREAS file. - (while (setq area (pop areas)) - ;; Change the name to the permanent name and move the files. - (setq cur-prefix (nnsoup-next-prefix)) - (nnheader-message 5 "Incorporating file %s..." cur-prefix) - (when (file-exists-p - (setq file - (expand-file-name - (concat (gnus-soup-area-prefix area) ".IDX") - nnsoup-tmp-directory))) - (rename-file file (nnsoup-file cur-prefix))) - (when (file-exists-p - (setq file (expand-file-name - (concat (gnus-soup-area-prefix area) ".MSG") - nnsoup-tmp-directory))) - (rename-file file (nnsoup-file cur-prefix t)) - (gnus-soup-set-area-prefix area cur-prefix) - ;; Find the number of new articles in this area. - (setq number (nnsoup-number-of-articles area)) - (if (not (setq entry (assoc (gnus-soup-area-name area) - nnsoup-group-alist))) - ;; If this is a new area (group), we just add this info to - ;; the group alist. - (push (list (gnus-soup-area-name area) - (cons 1 number) - (list (cons 1 number) area)) - nnsoup-group-alist) - ;; There are already articles in this group, so we add this - ;; info to the end of the entry. - (nconc entry (list (list (cons (1+ (setq lnum (cdadr entry))) - (+ lnum number)) - area))) - (setcdr (cadr entry) (+ lnum number)))))) - (nnsoup-write-active-file t) - (delete-file areas-file))))) - -(defun nnsoup-number-of-articles (area) - (save-excursion - (cond - ;; If the number is in the area info, we just return it. - ((gnus-soup-area-number area) - (gnus-soup-area-number area)) - ;; If there is an index file, we just count the lines. - ((/= (gnus-soup-encoding-index (gnus-soup-area-encoding area)) ?n) - (set-buffer (nnsoup-index-buffer (gnus-soup-area-prefix area))) - (count-lines (point-min) (point-max))) - ;; We do it the hard way - re-searching through the message - ;; buffer. - (t - (set-buffer (nnsoup-message-buffer (gnus-soup-area-prefix area))) - (unless (assoc (gnus-soup-area-prefix area) nnsoup-article-alist) - (nnsoup-dissect-buffer area)) - (length (cdr (assoc (gnus-soup-area-prefix area) - nnsoup-article-alist))))))) - -(defun nnsoup-dissect-buffer (area) - (let ((mbox-delim (concat "^" message-unix-mail-delimiter)) - (format (gnus-soup-encoding-format (gnus-soup-area-encoding area))) - (i 0) - alist len) - (goto-char (point-min)) - (cond - ;; rnews batch format - ((or (= format ?u) - (= format ?n)) ;; Gnus back compatibility. - (while (looking-at "^#! *rnews \\(+[0-9]+\\) *$") - (forward-line 1) - (push (list - (incf i) (point) - (progn - (forward-char (string-to-number (match-string 1))) - (point))) - alist))) - ;; Unix mbox format - ((= format ?m) - (while (looking-at mbox-delim) - (forward-line 1) - (push (list - (incf i) (point) - (progn - (if (re-search-forward mbox-delim nil t) - (beginning-of-line) - (goto-char (point-max))) - (point))) - alist))) - ;; MMDF format - ((= format ?M) - (while (looking-at "\^A\^A\^A\^A\n") - (forward-line 1) - (push (list - (incf i) (point) - (progn - (if (search-forward "\n\^A\^A\^A\^A\n" nil t) - (beginning-of-line) - (goto-char (point-max))) - (point))) - alist))) - ;; Binary format - ((or (= format ?B) (= format ?b)) - (while (not (eobp)) - (setq len (+ (* (char-after (point)) (expt 2.0 24)) - (* (char-after (+ (point) 1)) (expt 2 16)) - (* (char-after (+ (point) 2)) (expt 2 8)) - (char-after (+ (point) 3)))) - (push (list - (incf i) (+ (point) 4) - (progn - (forward-char (floor (+ len 4))) - (point))) - alist))) - (t - (error "Unknown format: %c" format))) - (push (cons (gnus-soup-area-prefix area) alist) nnsoup-article-alist))) - -(defun nnsoup-index-buffer (prefix &optional message) - (let* ((file (concat prefix (if message ".MSG" ".IDX"))) - (buffer-name (concat " *nnsoup " file "*"))) - (or (get-buffer buffer-name) ; File already loaded. - (when (file-exists-p (expand-file-name file nnsoup-directory)) - (save-excursion ; Load the file. - (set-buffer (get-buffer-create buffer-name)) - (buffer-disable-undo) - (push (cons nnsoup-current-group (current-buffer)) nnsoup-buffers) - (nnheader-insert-file-contents - (expand-file-name file nnsoup-directory)) - (current-buffer)))))) - -(defun nnsoup-file (prefix &optional message) - (expand-file-name - (concat prefix (if message ".MSG" ".IDX")) - nnsoup-directory)) - -(defun nnsoup-message-buffer (prefix) - (nnsoup-index-buffer prefix 'msg)) - -(defun nnsoup-unpack-packets () - "Unpack all packets in `nnsoup-packet-directory'." - (let ((packets (directory-files - nnsoup-packet-directory t nnsoup-packet-regexp))) - (dolist (packet packets) - (nnheader-message 5 "nnsoup: unpacking %s..." packet) - (if (not (gnus-soup-unpack-packet - nnsoup-tmp-directory nnsoup-unpacker packet)) - (nnheader-message 5 "Couldn't unpack %s" packet) - (delete-file packet) - (nnsoup-read-areas) - (nnheader-message 5 "Unpacking...done"))))) - -(defun nnsoup-narrow-to-article (article &optional area head) - (let* ((area (or area (nnsoup-article-to-area article nnsoup-current-group))) - (prefix (and area (gnus-soup-area-prefix (nth 1 area)))) - (msg-buf (and prefix (nnsoup-index-buffer prefix 'msg))) - beg end) - (when area - (save-excursion - (cond - ;; There is no MSG file. - ((null msg-buf) - nil) - ;; We use the index file to find out where the article - ;; begins and ends. - ((and (= (gnus-soup-encoding-index - (gnus-soup-area-encoding (nth 1 area))) - ?c) - (file-exists-p (nnsoup-file prefix))) - (set-buffer (nnsoup-index-buffer prefix)) - (widen) - (goto-char (point-min)) - (forward-line (- article (caar area))) - (setq beg (read (current-buffer))) - (forward-line 1) - (if (looking-at "[0-9]+") - (progn - (setq end (read (current-buffer))) - (set-buffer msg-buf) - (widen) - (let ((format (gnus-soup-encoding-format - (gnus-soup-area-encoding (nth 1 area))))) - (goto-char end) - (when (or (= format ?u) (= format ?n) (= format ?m)) - (setq end (progn (forward-line -1) (point)))))) - (set-buffer msg-buf)) - (widen) - (narrow-to-region beg (or end (point-max)))) - (t - (set-buffer msg-buf) - (widen) - (unless (assoc (gnus-soup-area-prefix (nth 1 area)) - nnsoup-article-alist) - (nnsoup-dissect-buffer (nth 1 area))) - (let ((entry (assq article (cdr (assoc (gnus-soup-area-prefix - (nth 1 area)) - nnsoup-article-alist))))) - (when entry - (narrow-to-region (cadr entry) (caddr entry)))))) - (goto-char (point-min)) - (if (not head) - () - (narrow-to-region - (point-min) - (if (search-forward "\n\n" nil t) - (1- (point)) - (point-max)))) - msg-buf)))) - -;;;###autoload -(defun nnsoup-pack-replies () - "Make an outbound package of SOUP replies." - (interactive) - (unless (file-exists-p nnsoup-replies-directory) - (nnheader-message 5 "No such directory: %s" nnsoup-replies-directory)) - ;; Write all data buffers. - (gnus-soup-save-areas) - ;; Write the active file. - (nnsoup-write-active-file) - ;; Write the REPLIES file. - (nnsoup-write-replies) - ;; Check whether there is anything here. - (when (null (directory-files nnsoup-replies-directory nil "\\.MSG$")) - (error "No files to pack")) - ;; Pack all these files into a SOUP packet. - (gnus-soup-pack nnsoup-replies-directory nnsoup-packer)) - -(defun nnsoup-write-replies () - "Write the REPLIES file." - (when nnsoup-replies-list - (gnus-soup-write-replies nnsoup-replies-directory nnsoup-replies-list) - (setq nnsoup-replies-list nil))) - -(defun nnsoup-article-to-area (article group) - "Return the area that ARTICLE in GROUP is located in." - (let ((areas (cddr (assoc group nnsoup-group-alist)))) - (while (and areas (< (cdar (car areas)) article)) - (setq areas (cdr areas))) - (and areas (car areas)))) - -(defvar nnsoup-old-functions - (list message-send-mail-real-function message-send-news-function)) - -;;;###autoload -(defun nnsoup-set-variables () - "Use the SOUP methods for posting news and mailing mail." - (interactive) - (setq message-send-news-function 'nnsoup-request-post) - (setq message-send-mail-real-function 'nnsoup-request-mail)) - -;;;###autoload -(defun nnsoup-revert-variables () - "Revert posting and mailing methods to the standard Emacs methods." - (interactive) - (setq message-send-mail-real-function (car nnsoup-old-functions)) - (setq message-send-news-function (cadr nnsoup-old-functions))) - -(defun nnsoup-store-reply (kind) - ;; Mostly stolen from `message.el'. - (require 'mail-utils) - (let ((tembuf (generate-new-buffer " message temp")) - (case-fold-search nil) - delimline - (mailbuf (current-buffer))) - (unwind-protect - (save-excursion - (save-restriction - (message-narrow-to-headers) - (if (equal kind "mail") - (message-generate-headers message-required-mail-headers) - (message-generate-headers message-required-news-headers))) - (set-buffer tembuf) - (erase-buffer) - (insert-buffer-substring mailbuf) - ;; Remove some headers. - (save-restriction - (message-narrow-to-headers) - ;; Remove some headers. - (message-remove-header message-ignored-mail-headers t)) - (goto-char (point-max)) - ;; require one newline at the end. - (or (= (preceding-char) ?\n) - (insert ?\n)) - (let ((case-fold-search t)) - ;; Change header-delimiter to be what sendmail expects. - (goto-char (point-min)) - (re-search-forward - (concat "^" (regexp-quote mail-header-separator) "\n")) - (replace-match "\n") - (backward-char 1) - (setq delimline (point-marker)) - (goto-char (1+ delimline)) - (let ((msg-buf - (gnus-soup-store - nnsoup-replies-directory - (nnsoup-kind-to-prefix kind) nil nnsoup-replies-format-type - nnsoup-replies-index-type)) - (num 0)) - (when (and msg-buf (bufferp msg-buf)) - (save-excursion - (set-buffer msg-buf) - (goto-char (point-min)) - (while (re-search-forward "^#! *rnews" nil t) - (incf num)) - (when nnsoup-always-save - (save-buffer))) - (nnheader-message 5 "Stored %d messages" num))) - (nnsoup-write-replies) - (kill-buffer tembuf)))))) - -(defun nnsoup-kind-to-prefix (kind) - (unless nnsoup-replies-list - (setq nnsoup-replies-list - (gnus-soup-parse-replies - (expand-file-name "REPLIES" nnsoup-replies-directory)))) - (let ((replies nnsoup-replies-list)) - (while (and replies - (not (string= kind (gnus-soup-reply-kind (car replies))))) - (setq replies (cdr replies))) - (if replies - (gnus-soup-reply-prefix (car replies)) - (push (vector (gnus-soup-unique-prefix nnsoup-replies-directory) - kind - (format "%c%c%c" - nnsoup-replies-format-type - nnsoup-replies-index-type - (if (string= kind "news") - ?n ?m))) - nnsoup-replies-list) - (gnus-soup-reply-prefix (car nnsoup-replies-list))))) - -(defun nnsoup-make-active () - "(Re-)create the SOUP active file." - (interactive) - (let ((files (sort (directory-files nnsoup-directory t "IDX$") - (lambda (f1 f2) - (< (progn (string-match "/\\([0-9]+\\)\\." f1) - (string-to-number (match-string 1 f1))) - (progn (string-match "/\\([0-9]+\\)\\." f2) - (string-to-number (match-string 1 f2))))))) - active group lines ident elem min) - (set-buffer (get-buffer-create " *nnsoup work*")) - (dolist (file files) - (nnheader-message 5 "Doing %s..." file) - (erase-buffer) - (nnheader-insert-file-contents file) - (goto-char (point-min)) - (if (not (re-search-forward "^[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t *\\(Xref: \\)? *[^ ]* \\([^ ]+\\):[0-9]" nil t)) - (setq group "unknown") - (setq group (match-string 2))) - (setq lines (count-lines (point-min) (point-max))) - (setq ident (progn (string-match - "/\\([0-9]+\\)\\." file) - (match-string 1 file))) - (if (not (setq elem (assoc group active))) - (push (list group (cons 1 lines) - (list (cons 1 lines) - (vector ident group "ucm" "" lines))) - active) - (nconc elem - (list - (list (cons (1+ (setq min (cdadr elem))) - (+ min lines)) - (vector ident group "ucm" "" lines)))) - (setcdr (cadr elem) (+ min lines)))) - (nnheader-message 5 "") - (setq nnsoup-group-alist active) - (nnsoup-write-active-file t))) - -(defun nnsoup-delete-unreferenced-message-files () - "Delete any *.MSG and *.IDX files that aren't known by nnsoup." - (interactive) - (let* ((known (apply 'nconc (mapcar - (lambda (ga) - (mapcar - (lambda (area) - (gnus-soup-area-prefix (cadr area))) - (cddr ga))) - nnsoup-group-alist))) - (regexp "\\.MSG$\\|\\.IDX$") - (files (directory-files nnsoup-directory nil regexp)) - non-files) - ;; Find all files that aren't known by nnsoup. - (dolist (file files) - (string-match regexp file) - (unless (member (substring file 0 (match-beginning 0)) known) - (push file non-files))) - ;; Sort and delete the files. - (setq non-files (sort non-files 'string<)) - (map-y-or-n-p "Delete file %s? " - (lambda (file) (delete-file - (expand-file-name file nnsoup-directory))) - non-files))) - -(provide 'nnsoup) - -;; arch-tag: b0451389-5703-4450-9425-f66f6b38c828 -;;; nnsoup.el ends here
--- a/lisp/gnus/nnultimate.el Tue Aug 31 04:22:49 2010 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,480 +0,0 @@ -;;; nnultimate.el --- interfacing with the Ultimate Bulletin Board system - -;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, -;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. - -;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> -;; Keywords: news - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. - -;;; Commentary: - -;; Note: You need to have `url' and `w3' installed for this -;; backend to work. - -;;; Code: - -(eval-when-compile (require 'cl)) - -(require 'nnoo) -(require 'message) -(require 'gnus-util) -(require 'gnus) -(require 'nnmail) -(require 'mm-util) -(require 'mm-url) -(require 'nnweb) -(require 'parse-time) -(autoload 'w3-parse-buffer "w3-parse") - -(nnoo-declare nnultimate) - -(defvoo nnultimate-directory (nnheader-concat gnus-directory "ultimate/") - "Where nnultimate will save its files.") - -(defvoo nnultimate-address "" - "The address of the Ultimate bulletin board.") - -;;; Internal variables - -(defvar nnultimate-groups-alist nil) -(defvoo nnultimate-groups nil) -(defvoo nnultimate-headers nil) -(defvoo nnultimate-articles nil) -(defvar nnultimate-table-regexp - "postings.*editpost\\|forumdisplay\\|Forum[0-9]+/HTML\\|getbio") - -;;; Interface functions - -(nnoo-define-basics nnultimate) - -(deffoo nnultimate-retrieve-headers (articles &optional group server fetch-old) - (nnultimate-possibly-change-server group server) - (unless gnus-nov-is-evil - (let* ((last (car (last articles))) - (did nil) - (start 1) - (entry (assoc group nnultimate-groups)) - (sid (nth 2 entry)) - (topics (nth 4 entry)) - (mapping (nth 5 entry)) - (old-total (or (nth 6 entry) 1)) - (furl "forumdisplay.cgi?action=topics&number=%d&DaysPrune=1000") - (furls (list (concat nnultimate-address (format furl sid)))) - (nnultimate-table-regexp - "postings.*editpost\\|forumdisplay\\|getbio") - headers article subject score from date lines parent point - contents tinfo fetchers map elem a href garticles topic old-max - inc datel table current-page total-contents pages - farticles forum-contents parse furl-fetched mmap farticle) - (setq map mapping) - (while (and (setq article (car articles)) - map) - ;; Skip past the articles in the map until we reach the - ;; article we're looking for. - (while (and map - (or (> article (caar map)) - (< (cadar map) (caar map)))) - (pop map)) - (when (setq mmap (car map)) - (setq farticle -1) - (while (and article - (<= article (nth 1 mmap))) - ;; Do we already have a fetcher for this topic? - (if (setq elem (assq (nth 2 mmap) fetchers)) - ;; Yes, so we just add the spec to the end. - (nconc elem (list (cons article - (+ (nth 3 mmap) (incf farticle))))) - ;; No, so we add a new one. - (push (list (nth 2 mmap) - (cons article - (+ (nth 3 mmap) (incf farticle)))) - fetchers)) - (pop articles) - (setq article (car articles))))) - ;; Now we have the mapping from/to Gnus/nnultimate article numbers, - ;; so we start fetching the topics that we need to satisfy the - ;; request. - (if (not fetchers) - (save-excursion - (set-buffer nntp-server-buffer) - (erase-buffer)) - (setq nnultimate-articles nil) - (mm-with-unibyte-buffer - (dolist (elem fetchers) - (setq pages 1 - current-page 1 - total-contents nil) - (while (<= current-page pages) - (erase-buffer) - (setq subject (nth 2 (assq (car elem) topics))) - (setq href (nth 3 (assq (car elem) topics))) - (if (= current-page 1) - (mm-url-insert href) - (string-match "\\.html$" href) - (mm-url-insert (concat (substring href 0 (match-beginning 0)) - "-" (number-to-string current-page) - (match-string 0 href)))) - (goto-char (point-min)) - (setq contents - (ignore-errors (w3-parse-buffer (current-buffer)))) - (setq table (nnultimate-find-forum-table contents)) - (goto-char (point-min)) - (when (re-search-forward "topic is \\([0-9]+\\) pages" nil t) - (setq pages (string-to-number (match-string 1)))) - (setq contents (cdr (nth 2 (car (nth 2 table))))) - (setq total-contents (nconc total-contents contents)) - (incf current-page)) - (when t - (let ((i 0)) - (dolist (co total-contents) - (push (list (or (nnultimate-topic-article-to-article - group (car elem) (incf i)) - 1) - co subject) - nnultimate-articles)))) - (when nil - (dolist (art (cdr elem)) - (when (nth (1- (cdr art)) total-contents) - (push (list (car art) - (nth (1- (cdr art)) total-contents) - subject) - nnultimate-articles)))))) - (setq nnultimate-articles - (sort nnultimate-articles 'car-less-than-car)) - ;; Now we have all the articles, conveniently in an alist - ;; where the key is the Gnus article number. - (dolist (articlef nnultimate-articles) - (setq article (nth 0 articlef) - contents (nth 1 articlef) - subject (nth 2 articlef)) - (setq from (mapconcat 'identity - (nnweb-text (car (nth 2 contents))) - " ") - datel (nnweb-text (nth 2 (car (cdr (nth 2 contents)))))) - (while datel - (when (string-match "Posted" (car datel)) - (setq date (substring (car datel) (match-end 0)) - datel nil)) - (pop datel)) - (when date - (setq date (delete "" (split-string date "[-, \n\t\r ]"))) - (setq date - (if (or (member "AM" date) - (member "PM" date)) - (format - "%s %s %s %s" - (nth 1 date) - (if (and (>= (length (nth 0 date)) 3) - (assoc (downcase - (substring (nth 0 date) 0 3)) - parse-time-months)) - (substring (nth 0 date) 0 3) - (car (rassq (string-to-number (nth 0 date)) - parse-time-months))) - (nth 2 date) (nth 3 date)) - (format "%s %s %s %s" - (car (rassq (string-to-number (nth 1 date)) - parse-time-months)) - (nth 0 date) (nth 2 date) (nth 3 date))))) - (push - (cons - article - (make-full-mail-header - article subject - from (or date "") - (concat "<" (number-to-string sid) "%" - (number-to-string article) - "@ultimate." server ">") - "" 0 - (/ (length (mapconcat - 'identity - (nnweb-text - (cdr (nth 2 (nth 1 (nth 2 contents))))) - "")) - 70) - nil nil)) - headers)) - (setq nnultimate-headers (sort headers 'car-less-than-car)) - (save-excursion - (set-buffer nntp-server-buffer) - (mm-with-unibyte-current-buffer - (erase-buffer) - (dolist (header nnultimate-headers) - (nnheader-insert-nov (cdr header)))))) - 'nov))) - -(defun nnultimate-topic-article-to-article (group topic article) - (catch 'found - (dolist (elem (nth 5 (assoc group nnultimate-groups))) - (when (and (= topic (nth 2 elem)) - (>= article (nth 3 elem)) - (< article (+ (- (nth 1 elem) (nth 0 elem)) 1 - (nth 3 elem)))) - (throw 'found - (+ (nth 0 elem) (- article (nth 3 elem)))))))) - -(deffoo nnultimate-request-group (group &optional server dont-check) - (nnultimate-possibly-change-server nil server) - (when (not nnultimate-groups) - (nnultimate-request-list)) - (unless dont-check - (nnultimate-create-mapping group)) - (let ((elem (assoc group nnultimate-groups))) - (cond - ((not elem) - (nnheader-report 'nnultimate "Group does not exist")) - (t - (nnheader-report 'nnultimate "Opened group %s" group) - (nnheader-insert - "211 %d %d %d %s\n" (cadr elem) 1 (cadr elem) - (prin1-to-string group)))))) - -(deffoo nnultimate-request-close () - (setq nnultimate-groups-alist nil - nnultimate-groups nil)) - -(deffoo nnultimate-request-article (article &optional group server buffer) - (nnultimate-possibly-change-server group server) - (let ((contents (cdr (assq article nnultimate-articles)))) - (setq contents (cddr (nth 2 (nth 1 (nth 2 (car contents)))))) - (when contents - (save-excursion - (set-buffer (or buffer nntp-server-buffer)) - (erase-buffer) - (nnweb-insert-html (cons 'p (cons nil (list contents)))) - (goto-char (point-min)) - (insert "Content-Type: text/html\nMIME-Version: 1.0\n") - (let ((header (cdr (assq article nnultimate-headers)))) - (mm-with-unibyte-current-buffer - (nnheader-insert-header header))) - (nnheader-report 'nnultimate "Fetched article %s" article) - (cons group article))))) - -(deffoo nnultimate-request-list (&optional server) - (nnultimate-possibly-change-server nil server) - (mm-with-unibyte-buffer - (mm-url-insert - (if (string-match "/$" nnultimate-address) - (concat nnultimate-address "Ultimate.cgi") - nnultimate-address)) - (let ((contents (nth 2 (car (nth 2 - (nnultimate-find-forum-table - (w3-parse-buffer (current-buffer))))))) - sid elem description articles a href group forum - a1 a2) - (dolist (row contents) - (setq row (nth 2 row)) - (when (setq a (nnweb-parse-find 'a row)) - (setq group (car (last (nnweb-text a))) - href (cdr (assq 'href (nth 1 a)))) - (setq description (car (last (nnweb-text (nth 1 row))))) - (setq a1 (car (last (nnweb-text (nth 2 row))))) - (setq a2 (car (last (nnweb-text (nth 3 row))))) - (when (string-match "^[0-9]+$" a1) - (setq articles (string-to-number a1))) - (when (and a2 (string-match "^[0-9]+$" a2)) - (setq articles (max articles (string-to-number a2)))) - (when href - (string-match "number=\\([0-9]+\\)" href) - (setq forum (string-to-number (match-string 1 href))) - (if (setq elem (assoc group nnultimate-groups)) - (setcar (cdr elem) articles) - (push (list group articles forum description nil nil nil nil) - nnultimate-groups)))))) - (nnultimate-write-groups) - (nnultimate-generate-active) - t)) - -(deffoo nnultimate-request-newgroups (date &optional server) - (nnultimate-possibly-change-server nil server) - (nnultimate-generate-active) - t) - -(nnoo-define-skeleton nnultimate) - -;;; Internal functions - -(defun nnultimate-prune-days (group time) - "Compute the number of days to fetch info for." - (let ((old-time (nth 7 (assoc group nnultimate-groups)))) - (if (null old-time) - 1000 - (- (time-to-days time) (time-to-days old-time))))) - -(defun nnultimate-create-mapping (group) - (let* ((entry (assoc group nnultimate-groups)) - (sid (nth 2 entry)) - (topics (nth 4 entry)) - (mapping (nth 5 entry)) - (old-total (or (nth 6 entry) 1)) - (current-time (current-time)) - (furl - (concat "forumdisplay.cgi?action=topics&number=%d&DaysPrune=" - (number-to-string - (nnultimate-prune-days group current-time)))) - (furls (list (concat nnultimate-address (format furl sid)))) - contents forum-contents furl-fetched a subject href - garticles topic tinfo old-max inc parse) - (mm-with-unibyte-buffer - (while furls - (erase-buffer) - (mm-url-insert (pop furls)) - (goto-char (point-min)) - (setq parse (w3-parse-buffer (current-buffer))) - (setq contents - (cdr (nth 2 (car (nth 2 (nnultimate-find-forum-table - parse)))))) - (setq forum-contents (nconc contents forum-contents)) - (unless furl-fetched - (setq furl-fetched t) - ;; On the first time through this loop, we find all the - ;; forum URLs. - (dolist (a (nnweb-parse-find-all 'a parse)) - (let ((href (cdr (assq 'href (nth 1 a))))) - (when (and href - (string-match "forumdisplay.*startpoint" href)) - (push href furls)))) - (setq furls (nreverse furls)))) - ;; The main idea here is to map Gnus article numbers to - ;; nnultimate article numbers. Say there are three topics in - ;; this forum, the first with 4 articles, the seconds with 2, - ;; and the third with 1. Then this will translate into 7 Gnus - ;; article numbers, where 1-4 comes from the first topic, 5-6 - ;; from the second and 7 from the third. Now, then next time - ;; the group is entered, there's 2 new articles in topic one - ;; and 1 in topic three. Then Gnus article number 8-9 be 5-6 - ;; in topic one and 10 will be the 2 in topic three. - (dolist (row (nreverse forum-contents)) - (setq row (nth 2 row)) - (when (setq a (nnweb-parse-find 'a row)) - (setq subject (car (last (nnweb-text a))) - href (cdr (assq 'href (nth 1 a)))) - (let ((artlist (nreverse (nnweb-text row))) - art) - (while (and (not art) - artlist) - (when (string-match "^[0-9]+$" (car artlist)) - (setq art (1+ (string-to-number (car artlist))))) - (pop artlist)) - (setq garticles art)) - (when garticles - (string-match "/\\([0-9]+\\).html" href) - (setq topic (string-to-number (match-string 1 href))) - (if (setq tinfo (assq topic topics)) - (progn - (setq old-max (cadr tinfo)) - (setcar (cdr tinfo) garticles)) - (setq old-max 0) - (push (list topic garticles subject href) topics) - (setcar (nthcdr 4 entry) topics)) - (when (not (= old-max garticles)) - (setq inc (- garticles old-max)) - (setq mapping (nconc mapping - (list - (list - old-total (1- (incf old-total inc)) - topic (1+ old-max))))) - (incf old-max inc) - (setcar (nthcdr 5 entry) mapping) - (setcar (nthcdr 6 entry) old-total)))))) - (setcar (nthcdr 7 entry) current-time) - (setcar (nthcdr 1 entry) (1- old-total)) - (nnultimate-write-groups) - mapping)) - -(defun nnultimate-possibly-change-server (&optional group server) - (nnultimate-init server) - (when (and server - (not (nnultimate-server-opened server))) - (nnultimate-open-server server)) - (unless nnultimate-groups-alist - (nnultimate-read-groups) - (setq nnultimate-groups (cdr (assoc nnultimate-address - nnultimate-groups-alist))))) - -(deffoo nnultimate-open-server (server &optional defs connectionless) - (nnheader-init-server-buffer) - (if (nnultimate-server-opened server) - t - (unless (assq 'nnultimate-address defs) - (setq defs (append defs (list (list 'nnultimate-address server))))) - (nnoo-change-server 'nnultimate server defs))) - -(defun nnultimate-read-groups () - (setq nnultimate-groups-alist nil) - (let ((file (expand-file-name "groups" nnultimate-directory))) - (when (file-exists-p file) - (mm-with-unibyte-buffer - (insert-file-contents file) - (goto-char (point-min)) - (setq nnultimate-groups-alist (read (current-buffer))))))) - -(defun nnultimate-write-groups () - (setq nnultimate-groups-alist - (delq (assoc nnultimate-address nnultimate-groups-alist) - nnultimate-groups-alist)) - (push (cons nnultimate-address nnultimate-groups) - nnultimate-groups-alist) - (with-temp-file (expand-file-name "groups" nnultimate-directory) - (prin1 nnultimate-groups-alist (current-buffer)))) - -(defun nnultimate-init (server) - "Initialize buffers and such." - (unless (file-exists-p nnultimate-directory) - (gnus-make-directory nnultimate-directory))) - -(defun nnultimate-generate-active () - (save-excursion - (set-buffer nntp-server-buffer) - (erase-buffer) - (dolist (elem nnultimate-groups) - (insert (prin1-to-string (car elem)) - " " (number-to-string (cadr elem)) " 1 y\n")))) - -(defun nnultimate-find-forum-table (contents) - (catch 'found - (nnultimate-find-forum-table-1 contents))) - -(defun nnultimate-find-forum-table-1 (contents) - (dolist (element contents) - (unless (stringp element) - (when (and (eq (car element) 'table) - (nnultimate-forum-table-p element)) - (throw 'found element)) - (when (nth 2 element) - (nnultimate-find-forum-table-1 (nth 2 element)))))) - -(defun nnultimate-forum-table-p (parse) - (when (not (apply 'gnus-or - (mapcar - (lambda (p) - (nnweb-parse-find 'table p)) - (nth 2 parse)))) - (let ((href (cdr (assq 'href (nth 1 (nnweb-parse-find 'a parse 20))))) - case-fold-search) - (when (and href (string-match nnultimate-table-regexp href)) - t)))) - -(provide 'nnultimate) - -;; Local Variables: -;; coding: iso-8859-1 -;; End: - -;; arch-tag: ab6bfc45-8fe1-4647-9c78-41050eb152b8 -;;; nnultimate.el ends here
--- a/lisp/gnus/nnwarchive.el Tue Aug 31 04:22:49 2010 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,727 +0,0 @@ -;;; nnwarchive.el --- interfacing with web archives - -;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, -;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. - -;; Author: Shenghuo Zhu <zsh@cs.rochester.edu> -;; Keywords: news egroups mail-archive - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. - -;;; Commentary: - -;; Note: You need to have `url' (w3 0.46) or greater version -;; installed for some functions of this backend to work. - -;; Todo: -;; 1. To support more web archives. -;; 2. Generalize webmail to other MHonArc archive. - -;;; Code: - -(eval-when-compile (require 'cl)) - -(require 'nnoo) -(require 'message) -(require 'gnus-util) -(require 'gnus) -(require 'gnus-bcklg) -(require 'nnmail) -(require 'mm-util) -(require 'mm-url) - -(nnoo-declare nnwarchive) - -(defvar nnwarchive-type-definition - '((egroups - (address . "www.egroups.com") - (open-url - "http://www.egroups.com/login.cgi?&login_email=%s&login_password=%s" - nnwarchive-login nnwarchive-passwd) - (list-url - "http://www.egroups.com/mygroups") - (list-dissect . nnwarchive-egroups-list) - (list-groups . nnwarchive-egroups-list-groups) - (xover-url - "http://www.egroups.com/messages/%s/%d" group aux) - (xover-last-url - "http://www.egroups.com/messages/%s/" group) - (xover-page-size . 13) - (xover-dissect . nnwarchive-egroups-xover) - (article-url - "http://www.egroups.com/message/%s/%d?source=1" group article) - (article-dissect . nnwarchive-egroups-article) - (authentication . t) - (article-offset . 0) - (xover-files . nnwarchive-egroups-xover-files)) - (mail-archive - (address . "www.mail-archive.com") - (open-url) - (list-url - "http://www.mail-archive.com/lists.html") - (list-dissect . nnwarchive-mail-archive-list) - (list-groups . nnwarchive-mail-archive-list-groups) - (xover-url - "http://www.mail-archive.com/%s/mail%d.html" group aux) - (xover-last-url - "http://www.mail-archive.com/%s/maillist.html" group) - (xover-page-size) - (xover-dissect . nnwarchive-mail-archive-xover) - (article-url - "http://www.mail-archive.com/%s/msg%05d.html" group article1) - (article-dissect . nnwarchive-mail-archive-article) - (xover-files . nnwarchive-mail-archive-xover-files) - (authentication) - (article-offset . 1)))) - -(defvar nnwarchive-default-type 'egroups) - -(defvoo nnwarchive-directory (nnheader-concat gnus-directory "warchive/") - "Where nnwarchive will save its files.") - -(defvoo nnwarchive-type nil - "The type of nnwarchive.") - -(defvoo nnwarchive-address "" - "The address of nnwarchive.") - -(defvoo nnwarchive-login nil - "Your login name for the group.") - -(defvoo nnwarchive-passwd nil - "Your password for the group.") - -(defvoo nnwarchive-groups nil) - -(defvoo nnwarchive-headers-cache nil) - -(defvoo nnwarchive-authentication nil) - -(defvoo nnwarchive-nov-is-evil nil) - -(defconst nnwarchive-version "nnwarchive 1.0") - -;;; Internal variables - -(defvoo nnwarchive-open-url nil) -(defvoo nnwarchive-open-dissect nil) - -(defvoo nnwarchive-list-url nil) -(defvoo nnwarchive-list-dissect nil) -(defvoo nnwarchive-list-groups nil) - -(defvoo nnwarchive-xover-files nil) -(defvoo nnwarchive-xover-url nil) -(defvoo nnwarchive-xover-last-url nil) -(defvoo nnwarchive-xover-dissect nil) -(defvoo nnwarchive-xover-page-size nil) - -(defvoo nnwarchive-article-url nil) -(defvoo nnwarchive-article-dissect nil) -(defvoo nnwarchive-xover-files nil) -(defvoo nnwarchive-article-offset 0) - -(defvoo nnwarchive-buffer nil) - -(defvoo nnwarchive-keep-backlog 300) -(defvar nnwarchive-backlog-articles nil) -(defvar nnwarchive-backlog-hashtb nil) - -(defvoo nnwarchive-headers nil) - - -;;; Interface functions - -(nnoo-define-basics nnwarchive) - -(defun nnwarchive-set-default (type) - (let ((defs (cdr (assq type nnwarchive-type-definition))) - def) - (dolist (def defs) - (set (intern (concat "nnwarchive-" (symbol-name (car def)))) - (cdr def))))) - -(defmacro nnwarchive-backlog (&rest form) - `(let ((gnus-keep-backlog nnwarchive-keep-backlog) - (gnus-backlog-buffer - (format " *nnwarchive backlog %s*" nnwarchive-address)) - (gnus-backlog-articles nnwarchive-backlog-articles) - (gnus-backlog-hashtb nnwarchive-backlog-hashtb)) - (unwind-protect - (progn ,@form) - (setq nnwarchive-backlog-articles gnus-backlog-articles - nnwarchive-backlog-hashtb gnus-backlog-hashtb)))) -(put 'nnwarchive-backlog 'lisp-indent-function 0) -(put 'nnwarchive-backlog 'edebug-form-spec '(form body)) - -(defun nnwarchive-backlog-enter-article (group number buffer) - (nnwarchive-backlog - (gnus-backlog-enter-article group number buffer))) - -(defun nnwarchive-get-article (article &optional group server buffer) - (if (numberp article) - (if (nnwarchive-backlog - (gnus-backlog-request-article group article - (or buffer nntp-server-buffer))) - (cons group article) - (let (contents) - (save-excursion - (set-buffer nnwarchive-buffer) - (goto-char (point-min)) - (let ((article1 (- article nnwarchive-article-offset))) - (nnwarchive-url nnwarchive-article-url)) - (setq contents (funcall nnwarchive-article-dissect group article))) - (when contents - (save-excursion - (set-buffer (or buffer nntp-server-buffer)) - (erase-buffer) - (insert contents) - (nnwarchive-backlog-enter-article group article (current-buffer)) - (nnheader-report 'nnwarchive "Fetched article %s" article) - (cons group article))))) - nil)) - -(deffoo nnwarchive-retrieve-headers (articles &optional group server fetch-old) - (nnwarchive-possibly-change-server group server) - (if (or gnus-nov-is-evil nnwarchive-nov-is-evil) - (with-temp-buffer - (with-current-buffer nntp-server-buffer - (erase-buffer)) - (let ((buf (current-buffer)) b e) - (dolist (art articles) - (nnwarchive-get-article art group server buf) - (setq b (goto-char (point-min))) - (if (search-forward "\n\n" nil t) - (forward-char -1) - (goto-char (point-max))) - (setq e (point)) - (with-current-buffer nntp-server-buffer - (insert (format "221 %d Article retrieved.\n" art)) - (insert-buffer-substring buf b e) - (insert ".\n")))) - 'headers) - (setq nnwarchive-headers (cdr (assoc group nnwarchive-headers-cache))) - (save-excursion - (set-buffer nnwarchive-buffer) - (erase-buffer) - (funcall nnwarchive-xover-files group articles)) - (save-excursion - (set-buffer nntp-server-buffer) - (erase-buffer) - (let (header) - (dolist (art articles) - (if (setq header (assq art nnwarchive-headers)) - (nnheader-insert-nov (cdr header)))))) - (let ((elem (assoc group nnwarchive-headers-cache))) - (if elem - (setcdr elem nnwarchive-headers) - (push (cons group nnwarchive-headers) nnwarchive-headers-cache))) - 'nov)) - -(deffoo nnwarchive-request-group (group &optional server dont-check) - (nnwarchive-possibly-change-server nil server) - (when (and (not dont-check) nnwarchive-list-groups) - (funcall nnwarchive-list-groups (list group)) - (nnwarchive-write-groups)) - (let ((elem (assoc group nnwarchive-groups))) - (cond - ((not elem) - (nnheader-report 'nnwarchive "Group does not exist")) - (t - (nnheader-report 'nnwarchive "Opened group %s" group) - (nnheader-insert - "211 %d %d %d %s\n" (or (cadr elem) 0) 1 (or (cadr elem) 0) - (prin1-to-string group)) - t)))) - -(deffoo nnwarchive-request-article (article &optional group server buffer) - (nnwarchive-possibly-change-server group server) - (nnwarchive-get-article article group server buffer)) - -(deffoo nnwarchive-close-server (&optional server) - (when (and (nnwarchive-server-opened server) - (gnus-buffer-live-p nnwarchive-buffer)) - (save-excursion - (set-buffer nnwarchive-buffer) - (kill-buffer nnwarchive-buffer))) - (nnwarchive-backlog - (gnus-backlog-shutdown)) - (nnoo-close-server 'nnwarchive server)) - -(deffoo nnwarchive-request-list (&optional server) - (nnwarchive-possibly-change-server nil server) - (save-excursion - (set-buffer nnwarchive-buffer) - (erase-buffer) - (if nnwarchive-list-url - (nnwarchive-url nnwarchive-list-url)) - (if nnwarchive-list-dissect - (funcall nnwarchive-list-dissect)) - (nnwarchive-write-groups) - (nnwarchive-generate-active)) - t) - -(deffoo nnwarchive-open-server (server &optional defs connectionless) - (nnoo-change-server 'nnwarchive server defs) - (nnwarchive-init server) - (when nnwarchive-authentication - (setq nnwarchive-login - (or nnwarchive-login - (read-string - (format "Login at %s: " server) - user-mail-address))) - (setq nnwarchive-passwd - (or nnwarchive-passwd - (read-passwd - (format "Password for %s at %s: " - nnwarchive-login server))))) - (unless nnwarchive-groups - (nnwarchive-read-groups)) - (save-excursion - (set-buffer nnwarchive-buffer) - (erase-buffer) - (if nnwarchive-open-url - (nnwarchive-url nnwarchive-open-url)) - (if nnwarchive-open-dissect - (funcall nnwarchive-open-dissect))) - t) - -(nnoo-define-skeleton nnwarchive) - -;;; Internal functions - -(defun nnwarchive-possibly-change-server (&optional group server) - (nnwarchive-init server) - (when (and server - (not (nnwarchive-server-opened server))) - (nnwarchive-open-server server))) - -(defun nnwarchive-read-groups () - (let ((file (expand-file-name (concat "groups-" nnwarchive-address) - nnwarchive-directory))) - (when (file-exists-p file) - (with-temp-buffer - (insert-file-contents file) - (goto-char (point-min)) - (setq nnwarchive-groups (read (current-buffer))))))) - -(defun nnwarchive-write-groups () - (with-temp-file (expand-file-name (concat "groups-" nnwarchive-address) - nnwarchive-directory) - (prin1 nnwarchive-groups (current-buffer)))) - -(defun nnwarchive-init (server) - "Initialize buffers and such." - (let ((type (intern server)) (defs nnwarchive-type-definition) def) - (cond - ((equal server "") - (setq type nnwarchive-default-type)) - ((assq type nnwarchive-type-definition) t) - (t - (setq type nil) - (while (setq def (pop defs)) - (when (equal (cdr (assq 'address (cdr def))) server) - (setq defs nil) - (setq type (car def)))) - (unless type - (error "Undefined server %s" server)))) - (setq nnwarchive-type type)) - (unless (file-exists-p nnwarchive-directory) - (gnus-make-directory nnwarchive-directory)) - (unless (gnus-buffer-live-p nnwarchive-buffer) - (setq nnwarchive-buffer - (save-excursion - (nnheader-set-temp-buffer - (format " *nnwarchive %s %s*" nnwarchive-type server))))) - (nnwarchive-set-default nnwarchive-type)) - -(defun nnwarchive-eval (expr) - (cond - ((consp expr) - (cons (nnwarchive-eval (car expr)) (nnwarchive-eval (cdr expr)))) - ((symbolp expr) - (eval expr)) - (t - expr))) - -(defun nnwarchive-url (xurl) - (mm-with-unibyte-current-buffer - (let ((url-confirmation-func 'identity) ;; Some hacks. - (url-cookie-multiple-line nil)) - (cond - ((eq (car xurl) 'post) - (pop xurl) - (mm-url-fetch-form (car xurl) (nnwarchive-eval (cdr xurl)))) - (t - (mm-url-insert (apply 'format (nnwarchive-eval xurl)))))))) - -(defun nnwarchive-generate-active () - (save-excursion - (set-buffer nntp-server-buffer) - (erase-buffer) - (dolist (elem nnwarchive-groups) - (insert (prin1-to-string (car elem)) - " " (number-to-string (or (cadr elem) 0)) " 1 y\n")))) - -(defun nnwarchive-paged (articles) - (let (art narts next) - (while (setq art (pop articles)) - (when (and (>= art (or next 0)) - (not (assq art nnwarchive-headers))) - (push art narts) - (setq next (+ art nnwarchive-xover-page-size)))) - narts)) - -;; egroups - -(defun nnwarchive-egroups-list-groups (groups) - (save-excursion - (let (articles) - (set-buffer nnwarchive-buffer) - (dolist (group groups) - (erase-buffer) - (nnwarchive-url nnwarchive-xover-last-url) - (goto-char (point-min)) - (when (re-search-forward "of \\([0-9]+\\)[ \t\n\r]*</title>" nil t) - (setq articles (string-to-number (match-string 1)))) - (let ((elem (assoc group nnwarchive-groups))) - (if elem - (setcar (cdr elem) articles) - (push (list group articles "") nnwarchive-groups))) - (setq nnwarchive-headers (cdr (assoc group nnwarchive-headers-cache))) - (nnwarchive-egroups-xover group) - (let ((elem (assoc group nnwarchive-headers-cache))) - (if elem - (setcdr elem nnwarchive-headers) - (push (cons group nnwarchive-headers) nnwarchive-headers-cache))))))) - -(defun nnwarchive-egroups-list () - (let ((case-fold-search t) - group description elem articles) - (goto-char (point-min)) - (while - (re-search-forward "href=\"/group/\\([^/\"\> ]+\\)" nil t) - (setq group (match-string 1) - description (match-string 2)) - (if (setq elem (assoc group nnwarchive-groups)) - (setcar (cdr elem) 0) - (push (list group articles description) nnwarchive-groups)))) - t) - -(defun nnwarchive-egroups-xover (group) - (let (article subject from date) - (goto-char (point-min)) - (while (re-search-forward - "<a href=\"/group/\\([^/]+\\)/\\([0-9]+\\)[^>]+>\\([^<]+\\)<" - nil t) - (setq group (match-string 1) - article (string-to-number (match-string 2)) - subject (match-string 3)) - (forward-line 1) - (unless (assq article nnwarchive-headers) - (if (looking-at "<td[^>]+><font[^>]+>\\([^<]+\\)</font>") - (setq from (match-string 1))) - (forward-line 1) - (if (looking-at "<td[^>]+><font[^>]+>\\([^<]+\\)</font>") - (setq date (identity (match-string 1)))) - (push (cons - article - (make-full-mail-header - article - (mm-url-decode-entities-string subject) - (mm-url-decode-entities-string from) - date - (concat "<" group "%" - (number-to-string article) - "@egroup.com>") - "" - 0 0 "")) nnwarchive-headers)))) - nnwarchive-headers) - -(defun nnwarchive-egroups-article (group articles) - (goto-char (point-min)) - (if (search-forward "<pre>" nil t) - (delete-region (point-min) (point))) - (goto-char (point-max)) - (if (search-backward "</pre>" nil t) - (delete-region (point) (point-max))) - (goto-char (point-min)) - (while (re-search-forward "<a[^>]+>\\([^<]+\\)</a>" nil t) - (replace-match "\\1")) - (mm-url-decode-entities) - (buffer-string)) - -(defun nnwarchive-egroups-xover-files (group articles) - (let (aux auxs) - (setq auxs (nnwarchive-paged (sort articles '<))) - (while (setq aux (pop auxs)) - (goto-char (point-max)) - (nnwarchive-url nnwarchive-xover-url)) - (if nnwarchive-xover-dissect - (nnwarchive-egroups-xover group)))) - -;; mail-archive - -(defun nnwarchive-mail-archive-list-groups (groups) - (save-excursion - (let (articles) - (set-buffer nnwarchive-buffer) - (dolist (group groups) - (erase-buffer) - (nnwarchive-url nnwarchive-xover-last-url) - (goto-char (point-min)) - (when (re-search-forward "msg\\([0-9]+\\)\\.html" nil t) - (setq articles (1+ (string-to-number (match-string 1))))) - (let ((elem (assoc group nnwarchive-groups))) - (if elem - (setcar (cdr elem) articles) - (push (list group articles "") nnwarchive-groups))) - (setq nnwarchive-headers (cdr (assoc group nnwarchive-headers-cache))) - (nnwarchive-mail-archive-xover group) - (let ((elem (assoc group nnwarchive-headers-cache))) - (if elem - (setcdr elem nnwarchive-headers) - (push (cons group nnwarchive-headers) - nnwarchive-headers-cache))))))) - -(defun nnwarchive-mail-archive-list () - (let ((case-fold-search t) - group description elem articles) - (goto-char (point-min)) - (while (re-search-forward "<a href=\"\\([^/]+\\)/\">\\([^>]+\\)<" nil t) - (setq group (match-string 1) - description (match-string 2)) - (forward-line 1) - (setq articles 0) - (if (setq elem (assoc group nnwarchive-groups)) - (setcar (cdr elem) articles) - (push (list group articles description) nnwarchive-groups)))) - t) - -(defun nnwarchive-mail-archive-xover (group) - (let (article subject from date) - (goto-char (point-min)) - (while (re-search-forward - "<A[^>]*HREF=\"msg\\([0-9]+\\)\\.html[^>]+>\\([^<]+\\)<" - nil t) - (setq article (1+ (string-to-number (match-string 1))) - subject (match-string 2)) - (forward-line 1) - (unless (assq article nnwarchive-headers) - (if (looking-at "<UL><LI><EM>From</EM>: *\\([^<]*[^< ]\\) *<\\([^&]+\\)>") - (progn - (setq from (match-string 1) - date (identity (match-string 2)))) - (setq from "" date "")) - (push (cons - article - (make-full-mail-header - article - (mm-url-decode-entities-string subject) - (mm-url-decode-entities-string from) - date - (format "<%05d%%%s>\n" (1- article) group) - "" - 0 0 "")) nnwarchive-headers)))) - nnwarchive-headers) - -(defun nnwarchive-mail-archive-xover-files (group articles) - (unless nnwarchive-headers - (erase-buffer) - (nnwarchive-url nnwarchive-xover-last-url) - (goto-char (point-min)) - (nnwarchive-mail-archive-xover group)) - (let ((minart (apply 'min articles)) - (min (apply 'min (mapcar 'car nnwarchive-headers))) - (aux 2)) - (while (> min minart) - (erase-buffer) - (nnwarchive-url nnwarchive-xover-url) - (nnwarchive-mail-archive-xover group) - (setq min (apply 'min (mapcar 'car nnwarchive-headers)))))) - -(defvar nnwarchive-caesar-translation-table nil - "Modified rot13 table. tr/@A-Z[a-z/N-Z[@A-Mn-za-m/.") - -(defun nnwarchive-make-caesar-translation-table () - "Create modified rot13 table. tr/@A-Z[a-z/N-Z[@A-Mn-za-m/." - (let ((i -1) - (table (make-string 256 0)) - (a (mm-char-int ?a)) - (A (mm-char-int ?A))) - (while (< (incf i) 256) - (aset table i i)) - (concat - (substring table 0 (1- A)) - (substring table (+ A 13) (+ A 27)) - (substring table (1- A) (+ A 13)) - (substring table (+ A 27) a) - (substring table (+ a 13) (+ a 26)) - (substring table a (+ a 13)) - (substring table (+ a 26) 255)))) - -(defun nnwarchive-from-r13 (from-r13) - (when from-r13 - (with-temp-buffer - (insert from-r13) - (let ((message-caesar-translation-table - (or nnwarchive-caesar-translation-table - (setq nnwarchive-caesar-translation-table - (nnwarchive-make-caesar-translation-table))))) - (message-caesar-region (point-min) (point-max)) - (buffer-string))))) - -(defun nnwarchive-mail-archive-article (group article) - (let (p refs url mime e - from subject date id - done - (case-fold-search t)) - (save-restriction - (goto-char (point-min)) - (when (search-forward "X-Head-End" nil t) - (beginning-of-line) - (narrow-to-region (point-min) (point)) - (mm-url-decode-entities) - (goto-char (point-min)) - (while (search-forward "<!--X-" nil t) - (replace-match "")) - (goto-char (point-min)) - (while (search-forward " -->" nil t) - (replace-match "")) - (setq from - (or (mail-fetch-field "from") - (nnwarchive-from-r13 - (mail-fetch-field "from-r13")))) - (setq date (mail-fetch-field "date")) - (setq id (mail-fetch-field "message-id")) - (setq subject (mail-fetch-field "subject")) - (goto-char (point-max)) - (widen)) - (when (search-forward "<ul>" nil t) - (forward-line) - (delete-region (point-min) (point)) - (search-forward "</ul>" nil t) - (end-of-line) - (narrow-to-region (point-min) (point)) - (mm-url-remove-markup) - (mm-url-decode-entities) - (goto-char (point-min)) - (delete-blank-lines) - (when from - (message-remove-header "from") - (goto-char (point-max)) - (insert "From: " from "\n")) - (when subject - (message-remove-header "subject") - (goto-char (point-max)) - (insert "Subject: " subject "\n")) - (when id - (goto-char (point-max)) - (insert "X-Message-ID: <" id ">\n")) - (when date - (message-remove-header "date") - (goto-char (point-max)) - (insert "Date: " date "\n")) - (goto-char (point-max)) - (widen) - (insert "\n")) - (setq p (point)) - (when (search-forward "X-Body-of-Message" nil t) - (forward-line) - (delete-region p (point)) - (search-forward "X-Body-of-Message-End" nil t) - (beginning-of-line) - (save-restriction - (narrow-to-region p (point)) - (goto-char (point-min)) - (if (> (skip-chars-forward "\040\n\r\t") 0) - (delete-region (point-min) (point))) - (while (not (eobp)) - (cond - ((looking-at "<PRE>\r?\n?") - (delete-region (match-beginning 0) (match-end 0)) - (setq p (point)) - (when (search-forward "</PRE>" nil t) - (delete-region (match-beginning 0) (match-end 0)) - (save-restriction - (narrow-to-region p (point)) - (mm-url-remove-markup) - (mm-url-decode-entities) - (goto-char (point-max))))) - ((looking-at "<P><A HREF=\"\\([^\"]+\\)") - (setq url (match-string 1)) - (delete-region (match-beginning 0) - (progn (forward-line) (point))) - ;; I hate to download the url encode it, then immediately - ;; decode it. - (insert "<#external" - " type=" - (or (and url - (string-match "\\.[^\\.]+$" url) - (mailcap-extension-to-mime - (match-string 0 url))) - "application/octet-stream") - (format " url=\"http://www.mail-archive.com/%s/%s\"" - group url) - ">\n" - "<#/external>") - (setq mime t)) - (t - (setq p (point)) - (insert "<#part type=\"text/html\" disposition=inline>") - (goto-char - (if (re-search-forward - "[\040\n\r\t]*<PRE>\\|[\040\n\r\t]*<P><A HREF=\"" - nil t) - (match-beginning 0) - (point-max))) - (insert "<#/part>") - (setq mime t))) - (setq p (point)) - (if (> (skip-chars-forward "\040\n\r\t") 0) - (delete-region p (point)))) - (goto-char (point-max)))) - (setq p (point)) - (when (search-forward "X-References-End" nil t) - (setq e (point)) - (beginning-of-line) - (search-backward "X-References" p t) - (while (re-search-forward "msg\\([0-9]+\\)\\.html" e t) - (push (concat "<" (match-string 1) "%" group ">") refs))) - (delete-region p (point-max)) - (goto-char (point-min)) - (insert (format "Message-ID: <%05d%%%s>\n" (1- article) group)) - (when refs - (insert "References:") - (while refs - (insert " " (pop refs))) - (insert "\n")) - (when mime - (unless (looking-at "$") - (search-forward "\n\n" nil t) - (forward-line -1)) - (narrow-to-region (point) (point-max)) - (insert "MIME-Version: 1.0\n" - (prog1 - (mml-generate-mime) - (delete-region (point-min) (point-max)))) - (widen))) - (buffer-string))) - -(provide 'nnwarchive) - -;; arch-tag: 1ab7a15c-777a-40e0-95c0-0c41b3963578 -;;; nnwarchive.el ends here
--- a/lisp/progmodes/octave-mod.el Tue Aug 31 04:22:49 2010 +0000 +++ b/lisp/progmodes/octave-mod.el Wed Sep 01 09:55:43 2010 +0900 @@ -223,7 +223,7 @@ (define-key map "\C-c\C-n" 'octave-next-code-line) (define-key map "\C-c\C-a" 'octave-beginning-of-line) (define-key map "\C-c\C-e" 'octave-end-of-line) - (define-key map "\C-c\M-\C-d" 'octave-down-block) + (define-key map [remap down-list] 'smie-down-list) (define-key map "\C-c\M-\C-h" 'octave-mark-block) (define-key map "\C-c]" 'smie-close-block) (define-key map "\C-c/" 'smie-close-block) @@ -258,7 +258,6 @@ ["End of Continuation" octave-end-of-line t] ["Split Line at Point" octave-indent-new-comment-line t]) ("Blocks" - ["Down Block" octave-down-block t] ["Mark Block" octave-mark-block t] ["Close Block" smie-close-block t]) ("Functions" @@ -343,10 +342,6 @@ :type 'integer :group 'octave) -(defvar octave-block-begin-regexp - (concat "\\<\\(" - (mapconcat 'identity octave-begin-keywords "\\|") - "\\)\\>")) (defvar octave-block-else-regexp (concat "\\<\\(" (mapconcat 'identity octave-else-keywords "\\|") @@ -355,8 +350,6 @@ (concat "\\<\\(" (mapconcat 'identity octave-end-keywords "\\|") "\\)\\>")) -(defvar octave-block-begin-or-end-regexp - (concat octave-block-begin-regexp "\\|" octave-block-end-regexp)) (defvar octave-block-else-or-end-regexp (concat octave-block-else-regexp "\\|" octave-block-end-regexp)) (defvar octave-block-match-alist @@ -723,36 +716,12 @@ (let ((pps (parse-partial-sexp (line-beginning-position) (point)))) (not (or (nth 3 pps) (nth 4 pps))))) -(defun octave-in-block-p () - "Return t if point is inside an Octave block. -The block is taken to start at the first letter of the begin keyword and -to end after the end keyword." - (let ((pos (point))) - (save-excursion - (condition-case nil - (progn - (skip-syntax-forward "w") - (octave-up-block -1) - (octave-forward-block) - t) - (error nil)) - (< pos (point))))) (defun octave-looking-at-kw (regexp) "Like `looking-at', but sets `case-fold-search' nil." (let ((case-fold-search nil)) (looking-at regexp))) -(defun octave-re-search-forward-kw (regexp count) - "Like `re-search-forward', but sets `case-fold-search' nil, and moves point." - (let ((case-fold-search nil)) - (re-search-forward regexp nil 'move count))) - -(defun octave-re-search-backward-kw (regexp count) - "Like `re-search-backward', but sets `case-fold-search' nil, and moves point." - (let ((case-fold-search nil)) - (re-search-backward regexp nil 'move count))) - (defun octave-maybe-insert-continuation-string () (if (or (octave-in-comment-p) (save-excursion @@ -764,108 +733,6 @@ ;;; Indentation -(defun octave-indent-calculate () - "Return appropriate indentation for current line as Octave code. -Returns an integer (the column to indent to) unless the line is a -comment line with fixed goal golumn. In that case, returns a list whose -car is the column to indent to, and whose cdr is the current indentation -level." - (let ((is-continuation-line - (save-excursion - (if (zerop (octave-previous-code-line)) - (looking-at octave-continuation-regexp)))) - (icol 0)) - (save-excursion - (beginning-of-line) - ;; If we can move backward out one level of parentheses, take 1 - ;; plus the indentation of that parenthesis. Otherwise, go back - ;; to the beginning of the previous code line, and compute the - ;; offset this line gives. - (if (condition-case nil - (progn - (up-list -1) - t) - (error nil)) - (setq icol (+ 1 (current-column))) - (if (zerop (octave-previous-code-line)) - (progn - (octave-beginning-of-line) - (back-to-indentation) - (setq icol (current-column)) - (let ((bot (point)) - (eol (line-end-position))) - (while (< (point) eol) - (if (octave-not-in-string-or-comment-p) - (cond - ((octave-looking-at-kw "\\<switch\\>") - (setq icol (+ icol (* 2 octave-block-offset)))) - ((octave-looking-at-kw octave-block-begin-regexp) - (setq icol (+ icol octave-block-offset))) - ((octave-looking-at-kw octave-block-else-regexp) - (if (= bot (point)) - (setq icol (+ icol octave-block-offset)))) - ((octave-looking-at-kw octave-block-end-regexp) - (if (and (not (= bot (point))) - ;; special case for `end' keyword, - ;; applied to all keywords - (not (octave-end-as-array-index-p))) - (setq icol (- icol - (octave-block-end-offset))))))) - (forward-char))) - (if is-continuation-line - (setq icol (+ icol octave-continuation-offset))))))) - (save-excursion - (back-to-indentation) - (cond - ((and (octave-looking-at-kw octave-block-else-regexp) - (octave-not-in-string-or-comment-p)) - (setq icol (- icol octave-block-offset))) - ((and (octave-looking-at-kw octave-block-end-regexp) - (octave-not-in-string-or-comment-p)) - (setq icol (- icol (octave-block-end-offset)))) - ((or (looking-at "\\s<\\s<\\s<\\S<") - (octave-before-magic-comment-p)) - (setq icol (list 0 icol))) - ((looking-at "\\s<\\S<") - (setq icol (list comment-column icol))))) - icol)) - -;; FIXME: this should probably also make sure we are actually looking -;; at the "end" keyword. -(defun octave-end-as-array-index-p () - (save-excursion - (condition-case nil - ;; Check if point is between parens - (progn (up-list 1) t) - (error nil)))) - -(defun octave-block-end-offset () - (save-excursion - (octave-backward-up-block 1) - (* octave-block-offset - (if (string-match (match-string 0) "switch") 2 1)))) - -(defun octave-before-magic-comment-p () - (save-excursion - (beginning-of-line) - (and (bobp) (looking-at "\\s-*#!")))) - -(defun octave-indent-line (&optional arg) - "Indent current line as Octave code. -With optional ARG, use this as offset unless this line is a comment with -fixed goal column." - (interactive) - (or arg (setq arg 0)) - (let ((icol (octave-indent-calculate)) - (relpos (- (current-column) (current-indentation)))) - (if (listp icol) - (setq icol (car icol)) - (setq icol (+ icol arg))) - (if (< icol 0) - (error "Unmatched end keyword") - (indent-line-to icol) - (if (> relpos 0) - (move-to-column (+ icol relpos)))))) (defun octave-indent-new-comment-line () "Break Octave line at point, continuing comment if within one. @@ -967,106 +834,17 @@ (zerop (forward-line 1))))) (end-of-line))) -(defun octave-scan-blocks (count depth) - "Scan from point by COUNT Octave begin-end blocks. -Returns the character number of the position thus found. - -If DEPTH is nonzero, block depth begins counting from that value. -Only places where the depth in blocks becomes zero are candidates for -stopping; COUNT such places are counted. - -If the beginning or end of the buffer is reached and the depth is wrong, -an error is signaled." - (let ((min-depth (if (> depth 0) 0 depth)) - (inc (if (> count 0) 1 -1))) - (save-excursion - (while (/= count 0) - (catch 'foo - (while (or (octave-re-search-forward-kw - octave-block-begin-or-end-regexp inc) - (if (/= depth 0) - (error "Unbalanced block"))) - (if (octave-not-in-string-or-comment-p) - (progn - (cond - ((match-end 1) - (setq depth (+ depth inc))) - ((match-end 2) - (setq depth (- depth inc)))) - (if (< depth min-depth) - (error "Containing expression ends prematurely")) - (if (= depth 0) - (throw 'foo nil)))))) - (setq count (- count inc))) - (point)))) - -(defun octave-forward-block (&optional arg) - "Move forward across one balanced Octave begin-end block. -With argument, do it that many times. -Negative arg -N means move backward across N blocks." - (interactive "p") - (or arg (setq arg 1)) - (goto-char (or (octave-scan-blocks arg 0) (buffer-end arg)))) - -(defun octave-backward-block (&optional arg) - "Move backward across one balanced Octave begin-end block. -With argument, do it that many times. -Negative arg -N means move forward across N blocks." - (interactive "p") - (or arg (setq arg 1)) - (octave-forward-block (- arg))) - -(defun octave-down-block (arg) - "Move forward down one begin-end block level of Octave code. -With argument, do this that many times. -A negative argument means move backward but still go down a level. -In Lisp programs, an argument is required." - (interactive "p") - (let ((inc (if (> arg 0) 1 -1))) - (while (/= arg 0) - (goto-char (or (octave-scan-blocks inc -1) - (buffer-end arg))) - (setq arg (- arg inc))))) - -(defun octave-backward-up-block (arg) - "Move backward out of one begin-end block level of Octave code. -With argument, do this that many times. -A negative argument means move forward but still to a less deep spot. -In Lisp programs, an argument is required." - (interactive "p") - (octave-up-block (- arg))) - -(defun octave-up-block (arg) - "Move forward out of one begin-end block level of Octave code. -With argument, do this that many times. -A negative argument means move backward but still to a less deep spot. -In Lisp programs, an argument is required." - (interactive "p") - (let ((inc (if (> arg 0) 1 -1))) - (while (/= arg 0) - (goto-char (or (octave-scan-blocks inc 1) - (buffer-end arg))) - (setq arg (- arg inc))))) - (defun octave-mark-block () "Put point at the beginning of this Octave block, mark at the end. The block marked is the one that contains point or follows point." (interactive) - (let ((pos (point))) - (if (or (and (octave-in-block-p) - (skip-syntax-forward "w")) - (condition-case nil - (progn - (octave-down-block 1) - (octave-in-block-p)) - (error nil))) - (progn - (octave-up-block -1) - (push-mark (point)) - (octave-forward-block) - (exchange-point-and-mark)) - (goto-char pos) - (message "No block to mark found")))) + (unless (or (looking-at "\\s(") + (save-excursion + (let* ((token (funcall smie-forward-token-function)) + (level (assoc token smie-op-levels))) + (and level (null (cadr level)))))) + (backward-up-list 1)) + (mark-sexp)) (defun octave-blink-matching-block-open () "Blink the matching Octave begin block keyword. @@ -1086,12 +864,12 @@ (setq eb-keyword (buffer-substring-no-properties (match-beginning 1) (match-end 1))) - (octave-backward-up-block 1)) + (backward-up-list 1)) ((match-end 2) (setq eb-keyword (buffer-substring-no-properties (match-beginning 2) (match-end 2))) - (octave-backward-block))) + (backward-sexp 1))) (setq pos (match-end 0) bb-keyword (buffer-substring-no-properties @@ -1202,81 +980,73 @@ (not give-up)))) (defun octave-fill-paragraph (&optional arg) - "Fill paragraph of Octave code, handling Octave comments." - ;; FIXME: now that the default fill-paragraph takes care of similar issues, - ;; this seems obsolete. --Stef - (interactive "P") - (save-excursion - (let ((end (progn (forward-paragraph) (point))) - (beg (progn - (forward-paragraph -1) - (skip-chars-forward " \t\n") - (beginning-of-line) - (point))) - (cfc (current-fill-column)) - (ind (octave-indent-calculate)) - comment-prefix) - (save-restriction - (goto-char beg) - (narrow-to-region beg end) - (if (listp ind) (setq ind (nth 1 ind))) - (while (not (eobp)) - (condition-case nil - (octave-indent-line ind) - (error nil)) - (if (and (> ind 0) - (not - (save-excursion - (beginning-of-line) - (looking-at "^\\s-*\\($\\|\\s<+\\)")))) - (setq ind 0)) - (move-to-column cfc) - ;; First check whether we need to combine non-empty comment lines - (if (and (< (current-column) cfc) - (octave-in-comment-p) - (not (save-excursion - (beginning-of-line) - (looking-at "^\\s-*\\s<+\\s-*$")))) - ;; This is a nonempty comment line which does not extend - ;; past the fill column. If it is followed by a nonempty - ;; comment line with the same comment prefix, try to - ;; combine them, and repeat this until either we reach the - ;; fill-column or there is nothing more to combine. - (progn - ;; Get the comment prefix - (save-excursion - (beginning-of-line) - (while (and (re-search-forward "\\s<+") - (not (octave-in-comment-p)))) - (setq comment-prefix (match-string 0))) - ;; And keep combining ... - (while (and (< (current-column) cfc) - (save-excursion - (forward-line 1) - (and (looking-at - (concat "^\\s-*" - comment-prefix - "\\S<")) - (not (looking-at - (concat "^\\s-*" - comment-prefix - "\\s-*$")))))) - (delete-char 1) - (re-search-forward comment-prefix) - (delete-region (match-beginning 0) (match-end 0)) - (fixup-whitespace) - (move-to-column cfc)))) - ;; We might also try to combine continued code lines> Perhaps - ;; some other time ... - (skip-chars-forward "^ \t\n") - (delete-horizontal-space) - (if (or (< (current-column) cfc) - (and (= (current-column) cfc) (eolp))) - (forward-line 1) - (if (not (eolp)) (insert " ")) - (or (octave-auto-fill) - (forward-line 1))))) - t))) + "Fill paragraph of Octave code, handling Octave comments." + ;; FIXME: difference with generic fill-paragraph: + ;; - code lines are only split, never joined. + ;; - \n that end comments are never removed. + ;; - insert continuation marker when splitting code lines. + (interactive "P") + (save-excursion + (let ((end (progn (forward-paragraph) (copy-marker (point) t))) + (beg (progn + (forward-paragraph -1) + (skip-chars-forward " \t\n") + (beginning-of-line) + (point))) + (cfc (current-fill-column)) + comment-prefix) + (goto-char beg) + (while (< (point) end) + (condition-case nil + (indent-according-to-mode) + (error nil)) + (move-to-column cfc) + ;; First check whether we need to combine non-empty comment lines + (if (and (< (current-column) cfc) + (octave-in-comment-p) + (not (save-excursion + (beginning-of-line) + (looking-at "^\\s-*\\s<+\\s-*$")))) + ;; This is a nonempty comment line which does not extend + ;; past the fill column. If it is followed by a nonempty + ;; comment line with the same comment prefix, try to + ;; combine them, and repeat this until either we reach the + ;; fill-column or there is nothing more to combine. + (progn + ;; Get the comment prefix + (save-excursion + (beginning-of-line) + (while (and (re-search-forward "\\s<+") + (not (octave-in-comment-p)))) + (setq comment-prefix (match-string 0))) + ;; And keep combining ... + (while (and (< (current-column) cfc) + (save-excursion + (forward-line 1) + (and (looking-at + (concat "^\\s-*" + comment-prefix + "\\S<")) + (not (looking-at + (concat "^\\s-*" + comment-prefix + "\\s-*$")))))) + (delete-char 1) + (re-search-forward comment-prefix) + (delete-region (match-beginning 0) (match-end 0)) + (fixup-whitespace) + (move-to-column cfc)))) + ;; We might also try to combine continued code lines> Perhaps + ;; some other time ... + (skip-chars-forward "^ \t\n") + (delete-horizontal-space) + (if (or (< (current-column) cfc) + (and (= (current-column) cfc) (eolp))) + (forward-line 1) + (if (not (eolp)) (insert " ")) + (or (octave-auto-fill) + (forward-line 1)))) + t))) ;;; Completions
--- a/lisp/textmodes/nroff-mode.el Tue Aug 31 04:22:49 2010 +0000 +++ b/lisp/textmodes/nroff-mode.el Wed Sep 01 09:55:43 2010 +0900 @@ -55,6 +55,7 @@ (define-key map "\n" 'nroff-electric-newline) (define-key map "\en" 'nroff-forward-text-line) (define-key map "\ep" 'nroff-backward-text-line) + (define-key map "\C-c\C-c" 'nroff-view) (define-key map [menu-bar nroff-mode] (cons "Nroff" menu-map)) (define-key menu-map [nn] '(menu-item "Newline" nroff-electric-newline @@ -73,6 +74,9 @@ nroff-electric-mode :help "Auto insert closing requests if necessary" :button (:toggle . nroff-electric-mode))) + (define-key menu-map [npm] + '(menu-item "Preview as man page" nroff-view + :help "Run man on this file.")) map) "Major mode keymap for `nroff-mode'.") @@ -301,6 +305,17 @@ :lighter " Electric" (or (derived-mode-p 'nroff-mode) (error "Must be in nroff mode"))) +(declare-function Man-getpage-in-background "man" (topic)) + +(defun nroff-view () + "Run man on this file." + (interactive) + (require 'man) + (let* ((file (buffer-file-name))) + (if file + (Man-getpage-in-background file) + (error "No associated file for the current buffer")))) + ;; Old names that were not namespace clean. (define-obsolete-function-alias 'count-text-lines 'nroff-count-text-lines "22.1") (define-obsolete-function-alias 'forward-text-line 'nroff-forward-text-line "22.1")
--- a/src/ChangeLog Tue Aug 31 04:22:49 2010 +0000 +++ b/src/ChangeLog Wed Sep 01 09:55:43 2010 +0900 @@ -1,3 +1,11 @@ +2010-08-31 Stefan Monnier <monnier@iro.umontreal.ca> + + * keyboard.c (Fwindow_system): Fix compilation for USE_LISP_UNION_TYPE. + +2010-08-31 Chong Yidong <cyd@stupidchicken.com> + + * keyboard.c (command_loop_1): Don't call x-set-selection on tty. + 2010-08-30 Stefan Monnier <monnier@iro.umontreal.ca> * marker.c (Fcopy_marker): Make the first arg optional.
--- a/src/keyboard.c Tue Aug 31 04:22:49 2010 +0000 +++ b/src/keyboard.c Wed Sep 01 09:55:43 2010 +0900 @@ -1493,6 +1493,11 @@ } #endif +/* FIXME: This is wrong rather than test window-system, we should call + a new set-selection, which will then dispatch to x-set-selection, or + tty-set-selection, or w32-set-selection, ... */ +EXFUN (Fwindow_system, 1); + Lisp_Object command_loop_1 (void) { @@ -1799,10 +1804,11 @@ { /* Even if not deactivating the mark, set PRIMARY if `select-active-regions' is non-nil. */ - if ((EQ (Vselect_active_regions, Qonly) - ? EQ (CAR_SAFE (Vtransient_mark_mode), Qonly) - : (!NILP (Vselect_active_regions) - && !NILP (Vtransient_mark_mode))) + if (!NILP (Fwindow_system (Qnil)) + && (EQ (Vselect_active_regions, Qonly) + ? EQ (CAR_SAFE (Vtransient_mark_mode), Qonly) + : (!NILP (Vselect_active_regions) + && !NILP (Vtransient_mark_mode))) && !EQ (Vthis_command, Qhandle_switch_frame)) { int beg = XINT (Fmarker_position (current_buffer->mark));