Mercurial > emacs
changeset 111570:ffe2002d45c4
merge trunk
author | Kenichi Handa <handa@m17n.org> |
---|---|
date | Wed, 08 Sep 2010 12:55:57 +0900 |
parents | 0187fc875872 (current diff) 280c5216180d (diff) |
children | 91de9477a77a |
files | lisp/gnus/gnus-move.el lisp/gnus/gnus-soup.el lisp/gnus/nndb.el lisp/gnus/nnkiboze.el lisp/gnus/nnlistserv.el lisp/gnus/nnslashdot.el lisp/gnus/nnsoup.el lisp/gnus/nnultimate.el lisp/gnus/nnwarchive.el lisp/gnus/nnwfm.el |
diffstat | 281 files changed, 7263 insertions(+), 8795 deletions(-) [+] |
line wrap: on
line diff
--- a/.bzrignore Wed Sep 01 11:03:05 2010 +0900 +++ b/.bzrignore Wed Sep 08 12:55:57 2010 +0900 @@ -71,3 +71,4 @@ src/prefix-args* src/stamp-oldxmenu src/temacs +test/indent/*.new
--- a/ChangeLog Wed Sep 01 11:03:05 2010 +0900 +++ b/ChangeLog Wed Sep 08 12:55:57 2010 +0900 @@ -1,3 +1,8 @@ +2010-09-04 Eli Zaretskii <eliz@gnu.org> + + * config.bat: Produce lisp/gnus/_dir-locals.el from + lisp/gnus/.dir-locals.el. + 2010-08-23 Andreas Schwab <schwab@linux-m68k.org> * configure.in: Fix check for librsvg, imagemagick and
--- a/admin/ChangeLog Wed Sep 01 11:03:05 2010 +0900 +++ b/admin/ChangeLog Wed Sep 08 12:55:57 2010 +0900 @@ -1,3 +1,11 @@ +2010-09-05 Juanma Barranquero <lekktu@gmail.com> + + * unidata/BidiMirroring.txt: Update from + http://www.unicode.org/Public/6.0.0/ucd/BidiMirroring-6.0.0d2.txt + + * unidata/UnicodeData.txt: Update from + http://www.unicode.org/Public/6.0.0/ucd/UnicodeData-6.0.0d7.txt + 2010-08-09 Andreas Schwab <schwab@linux-m68k.org> * CPP-DEFINES (WORDS_BIG_ENDIAN): Remove.
--- a/admin/unidata/BidiMirroring.txt Wed Sep 01 11:03:05 2010 +0900 +++ b/admin/unidata/BidiMirroring.txt Wed Sep 08 12:55:57 2010 +0900 @@ -1,12 +1,12 @@ # BidiMirroring-6.0.0.txt -# Date: 2009-11-10, 17:09:00 PST [KW] +# Date: 2010-06-21, 12:09:00 PDT [KW] # # Bidi_Mirroring_Glyph Property # # This file is an informative contributory data file in the # Unicode Character Database. # -# Copyright (c) 1991-2009 Unicode, Inc. +# Copyright (c) 1991-2010 Unicode, Inc. # For terms of use, see http://www.unicode.org/terms_of_use.html # # This data file lists characters that have the Bidi_Mirrored=True property @@ -473,8 +473,8 @@ # 22FF; Z NOTATION BAG MEMBERSHIP # 2320; TOP HALF INTEGRAL # 2321; BOTTOM HALF INTEGRAL +# 27C0; THREE DIMENSIONAL ANGLE # 27CC; LONG DIVISION -# 27C0; THREE DIMENSIONAL ANGLE # 27D3; LOWER RIGHT CORNER WITH DOT # 27D4; UPPER LEFT CORNER WITH DOT # 27DC; LEFT MULTIMAP
--- a/admin/unidata/UnicodeData.txt Wed Sep 01 11:03:05 2010 +0900 +++ b/admin/unidata/UnicodeData.txt Wed Sep 08 12:55:57 2010 +0900 @@ -1699,7 +1699,7 @@ 06DB;ARABIC SMALL HIGH THREE DOTS;Mn;230;NSM;;;;;N;;;;; 06DC;ARABIC SMALL HIGH SEEN;Mn;230;NSM;;;;;N;;;;; 06DD;ARABIC END OF AYAH;Cf;0;AN;;;;;N;;;;; -06DE;ARABIC START OF RUB EL HIZB;Me;0;NSM;;;;;N;;;;; +06DE;ARABIC START OF RUB EL HIZB;So;0;ON;;;;;N;;;;; 06DF;ARABIC SMALL HIGH ROUNDED ZERO;Mn;230;NSM;;;;;N;;;;; 06E0;ARABIC SMALL HIGH UPRIGHT RECTANGULAR ZERO;Mn;230;NSM;;;;;N;;;;; 06E1;ARABIC SMALL HIGH DOTLESS HEAD OF KHAH;Mn;230;NSM;;;;;N;;;;; @@ -5640,9 +5640,9 @@ 19D7;NEW TAI LUE DIGIT SEVEN;Nd;0;L;;7;7;7;N;;;;; 19D8;NEW TAI LUE DIGIT EIGHT;Nd;0;L;;8;8;8;N;;;;; 19D9;NEW TAI LUE DIGIT NINE;Nd;0;L;;9;9;9;N;;;;; -19DA;NEW TAI LUE THAM DIGIT ONE;Nd;0;L;;1;1;1;N;;;;; -19DE;NEW TAI LUE SIGN LAE;Po;0;ON;;;;;N;;;;; -19DF;NEW TAI LUE SIGN LAEV;Po;0;ON;;;;;N;;;;; +19DA;NEW TAI LUE THAM DIGIT ONE;No;0;L;;;1;1;N;;;;; +19DE;NEW TAI LUE SIGN LAE;So;0;ON;;;;;N;;;;; +19DF;NEW TAI LUE SIGN LAEV;So;0;ON;;;;;N;;;;; 19E0;KHMER SYMBOL PATHAMASAT;So;0;ON;;;;;N;;;;; 19E1;KHMER SYMBOL MUOY KOET;So;0;ON;;;;;N;;;;; 19E2;KHMER SYMBOL PII KOET;So;0;ON;;;;;N;;;;; @@ -7119,6 +7119,7 @@ 20B6;LIVRE TOURNOIS SIGN;Sc;0;ET;;;;;N;;;;; 20B7;SPESMILO SIGN;Sc;0;ET;;;;;N;;;;; 20B8;TENGE SIGN;Sc;0;ET;;;;;N;;;;; +20B9;INDIAN RUPEE SIGN;Sc;0;ET;;;;;N;;;;; 20D0;COMBINING LEFT HARPOON ABOVE;Mn;230;NSM;;;;;N;NON-SPACING LEFT HARPOON ABOVE;;;; 20D1;COMBINING RIGHT HARPOON ABOVE;Mn;230;NSM;;;;;N;NON-SPACING RIGHT HARPOON ABOVE;;;; 20D2;COMBINING LONG VERTICAL LINE OVERLAY;Mn;1;NSM;;;;;N;NON-SPACING LONG VERTICAL BAR OVERLAY;;;; @@ -7176,7 +7177,7 @@ 2115;DOUBLE-STRUCK CAPITAL N;Lu;0;L;<font> 004E;;;;N;DOUBLE-STRUCK N;;;; 2116;NUMERO SIGN;So;0;ON;<compat> 004E 006F;;;;N;NUMERO;;;; 2117;SOUND RECORDING COPYRIGHT;So;0;ON;;;;;N;;;;; -2118;SCRIPT CAPITAL P;So;0;ON;;;;;N;SCRIPT P;;;; +2118;SCRIPT CAPITAL P;Sm;0;ON;;;;;N;SCRIPT P;;;; 2119;DOUBLE-STRUCK CAPITAL P;Lu;0;L;<font> 0050;;;;N;DOUBLE-STRUCK P;;;; 211A;DOUBLE-STRUCK CAPITAL Q;Lu;0;L;<font> 0051;;;;N;DOUBLE-STRUCK Q;;;; 211B;SCRIPT CAPITAL R;Lu;0;L;<font> 0052;;;;N;SCRIPT R;;;;
--- a/config.bat Wed Sep 01 11:03:05 2010 +0900 +++ b/config.bat Wed Sep 08 12:55:57 2010 +0900 @@ -250,6 +250,7 @@ rem ---------------------------------------------------------------------- Echo Configuring the lisp directory... cd lisp +If Exist gnus\.dir-locals.el update gnus/.dir-locals.el gnus/_dir-locals.el sed -f ../msdos/sedlisp.inp < Makefile.in > Makefile cd .. rem ----------------------------------------------------------------------
--- a/doc/emacs/ChangeLog Wed Sep 01 11:03:05 2010 +0900 +++ b/doc/emacs/ChangeLog Wed Sep 08 12:55:57 2010 +0900 @@ -1,3 +1,15 @@ +2010-09-06 Chong Yidong <cyd@stupidchicken.com> + + * dired.texi (Dired Enter): Minor doc fix (Bug#6982). + +2010-09-06 Glenn Morris <rgm@gnu.org> + + * misc.texi (Saving Emacs Sessions): Mention desktop-path. (Bug#6948) + +2010-09-02 Jan Djärv <jan.h.d@swipnet.se> + + * frames.texi (Cut/Paste Other App): Remove vut-buffer text. + 2010-08-21 Glenn Morris <rgm@gnu.org> * misc.texi (Amusements): Mention bubbles and animate.
--- a/doc/emacs/dired.texi Wed Sep 01 11:03:05 2010 +0900 +++ b/doc/emacs/dired.texi Wed Sep 08 12:55:57 2010 +0900 @@ -75,13 +75,12 @@ The variable @code{dired-listing-switches} specifies the options to give to @code{ls} for listing the directory; this string @emph{must} -contain @samp{-l}. If you use a numeric prefix argument with the -@code{dired} command, you can specify the @code{ls} switches with the -minibuffer before you enter the directory specification. No matter -how they are specified, the @code{ls} switches can include short -options (that is, single characters) requiring no arguments, and long -options (starting with @samp{--}) whose arguments are specified with -@samp{=}. +contain @samp{-l}. If you use a prefix argument with the @code{dired} +command, you can specify the @code{ls} switches with the minibuffer +before you enter the directory specification. No matter how they are +specified, the @code{ls} switches can include short options (that is, +single characters) requiring no arguments, and long options (starting +with @samp{--}) whose arguments are specified with @samp{=}. On MS-Windows and MS-DOS systems, Emacs @emph{emulates} @code{ls}; see @ref{ls in Lisp}, for options and peculiarities of that emulation.
--- a/doc/emacs/frames.texi Wed Sep 01 11:03:05 2010 +0900 +++ b/doc/emacs/frames.texi Wed Sep 08 12:55:57 2010 +0900 @@ -273,15 +273,6 @@ at the risk of large memory consumption if other applications generate large selections. -@cindex cut buffer -@vindex x-cut-buffer-max - Whenever Emacs saves some text to the primary selection, it may also -save it to the @dfn{cut buffer}. The cut buffer is an obsolete -predecessor to the primary selection; most modern applications do not -use it. Saving text to the cut buffer is slow and inefficient, so -Emacs only does it if the text is shorter than the value of -@code{x-cut-buffer-max} (20000 characters by default). - You can yank the primary selection into Emacs using the usual yank commands, such as @kbd{C-y} (@code{yank}) and @kbd{Mouse-2} (@code{mouse-yank-at-click}). These commands actually check the
--- a/doc/emacs/misc.texi Wed Sep 01 11:03:05 2010 +0900 +++ b/doc/emacs/misc.texi Wed Sep 08 12:55:57 2010 +0900 @@ -2349,8 +2349,11 @@ @findex desktop-change-dir @findex desktop-revert +@vindex desktop-path If you turn on @code{desktop-save-mode} in your init file, then when Emacs starts, it looks for a saved desktop in the current directory. +(More precisely, it looks in the directories specified by +@var{desktop-path}, and uses the first desktop it finds.) Thus, you can have separate saved desktops in different directories, and the starting directory determines which one Emacs reloads. You can save the current desktop and reload one saved in another directory
--- a/doc/lispref/ChangeLog Wed Sep 01 11:03:05 2010 +0900 +++ b/doc/lispref/ChangeLog Wed Sep 08 12:55:57 2010 +0900 @@ -1,3 +1,13 @@ +2010-09-06 Alexander Klimov <alserkli@inbox.ru> (tiny change) + + * files.texi (Directory Names): Use \` rather than ^. + +2010-09-02 Jan Djärv <jan.h.d@swipnet.se> + + * text.texi (Low-Level Kill Ring): + * frames.texi (Window System Selections): Remove cut buffer + documentation. + 2010-08-28 Eli Zaretskii <eliz@gnu.org> * display.texi (Fringe Size/Pos): Add a cross-reference to "Layout
--- a/doc/lispref/files.texi Wed Sep 01 11:03:05 2010 +0900 +++ b/doc/lispref/files.texi Wed Sep 08 12:55:57 2010 +0900 @@ -1933,7 +1933,7 @@ abbreviations to use for file directories. Each element has the form @code{(@var{from} . @var{to})}, and says to replace @var{from} with @var{to} when it appears in a directory name. The @var{from} string is -actually a regular expression; it should always start with @samp{^}. +actually a regular expression; it should always start with @samp{\`}. The @var{to} string should be an ordinary absolute directory name. Do not use @samp{~} to stand for a home directory in that string. The function @code{abbreviate-file-name} performs these substitutions. @@ -1946,9 +1946,9 @@ and so on. @example -(("^/home/fsf" . "/fsf") - ("^/home/gp" . "/gp") - ("^/home/gd" . "/gd")) +(("\\`/home/fsf" . "/fsf") + ("\\`/home/gp" . "/gp") + ("\\`/home/gd" . "/gd")) @end example @end defopt
--- a/doc/lispref/frames.texi Wed Sep 01 11:03:05 2010 +0900 +++ b/doc/lispref/frames.texi Wed Sep 08 12:55:57 2010 +0900 @@ -1985,28 +1985,6 @@ @code{STRING}. @end defun -@cindex cut buffer -The X server also has a set of eight numbered @dfn{cut buffers} which can -store text or other data being moved between applications. Cut buffers -are considered obsolete, but Emacs supports them for the sake of X -clients that still use them. Cut buffers are numbered from 0 to 7. - -@defun x-get-cut-buffer &optional n -This function returns the contents of cut buffer number @var{n}. -If omitted @var{n} defaults to 0. -@end defun - -@defun x-set-cut-buffer string &optional push -@anchor{Definition of x-set-cut-buffer} -This function stores @var{string} into the first cut buffer (cut buffer -0). If @var{push} is @code{nil}, only the first cut buffer is changed. -If @var{push} is non-@code{nil}, that says to move the values down -through the series of cut buffers, much like the way successive kills in -Emacs move down the kill ring. In other words, the previous value of -the first cut buffer moves into the second cut buffer, and the second to -the third, and so on through all eight cut buffers. -@end defun - @defopt selection-coding-system This variable specifies the coding system to use when reading and writing selections or the clipboard. @xref{Coding
--- a/doc/lispref/text.texi Wed Sep 01 11:03:05 2010 +0900 +++ b/doc/lispref/text.texi Wed Sep 08 12:55:57 2010 +0900 @@ -1126,16 +1126,13 @@ @defvar interprogram-cut-function This variable provides a way of communicating killed text to other programs, when you are using a window system. Its value should be -@code{nil} or a function of one required and one optional argument. +@code{nil} or a function of one required argument. If the value is a function, @code{kill-new} and @code{kill-append} call -it with the new first element of the kill ring as the first argument. -The second, optional, argument has the same meaning as the @var{push} -argument to @code{x-set-cut-buffer} (@pxref{Definition of -x-set-cut-buffer}) and only affects the second and later cut buffers. +it with the new first element of the kill ring as the argument. The normal use of this function is to set the window system's primary -selection (and first cut buffer) from the newly killed text. +selection from the newly killed text. @xref{Window System Selections}. @end defvar
--- a/doc/man/ChangeLog Wed Sep 01 11:03:05 2010 +0900 +++ b/doc/man/ChangeLog Wed Sep 08 12:55:57 2010 +0900 @@ -1,3 +1,7 @@ +2010-08-26 Sven Joachim <svenjoac@gmx.de> + + * emacs.1: Mention "maximized" value for the "fullscreen" X resource. + 2010-05-07 Chong Yidong <cyd@stupidchicken.com> * Version 23.2 released.
--- a/doc/man/emacs.1 Wed Sep 01 11:03:05 2010 +0900 +++ b/doc/man/emacs.1 Wed Sep 08 12:55:57 2010 +0900 @@ -403,11 +403,12 @@ The desired fullscreen size. The value can be one of .IR fullboth , +.IR maximized , .IR fullwidth , or .IR fullheight , -which correspond to the command-line options `\-fs', `\-fw', and -`\-fh', respectively. +which correspond to the command-line options `\-fs', `-mm', `\-fw', +and `\-fh', respectively. Note that this applies to the initial frame only. .TP .BR geometry " (class " Geometry )
--- a/doc/misc/ChangeLog Wed Sep 01 11:03:05 2010 +0900 +++ b/doc/misc/ChangeLog Wed Sep 08 12:55:57 2010 +0900 @@ -1,7 +1,64 @@ +2010-09-04 Julien Danjou <julien@danjou.info> (tiny change) + + * gnus.texi (Adaptive Scoring): Fix typo. + +2010-09-03 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * gnus.texi (Article Display): Document gnus-html-show-images. + +2010-09-02 Jan Djärv <jan.h.d@swipnet.se> + + * cl.texi (Basic Setf): Remove x-get-cut-buffer and x-get-cutbuffer. + +2010-09-01 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * gnus.texi (HTML): Document gnus-max-image-proportion. + +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 + the first message are used for wide replies. + (Changing Servers): Remove documentation on gnus-change-server and + friends, since it's been removed. + +2010-08-29 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * gnus.texi (Drafts): Mention B DEL. + +2010-08-29 Tim Landscheidt <tim@tim-landscheidt.de> (tiny change) + + * gnus.texi (Delayed Articles): Mention that the Date header is the + original one, even if you delay. + +2010-08-29 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * gnus.texi (Asynchronous Fetching): Document + gnus-async-post-fetch-function. + (HTML): Made into its own section. + 2010-08-26 Michael Albinus <michael.albinus@gmx.de> Sync with Tramp 2.1.19. + * tramp.texi (Inline methods, Default Method): Mention + `tramp-inline-compress-start-size'. Remove "kludgy" phrase. Remove + remark about doubled "-t" argument. + (Auto-save and Backup): Remove reference to Emacs 21. + (Filename Syntax): Describe port numbers. + (Frequently Asked Questions): Adapt supported (X)Emacs versions. Adapt + supported MS Windows versions. Remove obsolete URL. Recommend "sshx" + and "scpx" for echoing shells. Use the $() syntax, texi2dvi reports + errors with the backquotes. + (External packages): File attributes cache flushing for asynchronous + processes. + (Traces and Profiles): Describe verbose level 9. + * trampver.texi: Update release number. 2010-08-23 Michael Albinus <michael.albinus@gmx.de>
--- a/doc/misc/auth.texi Wed Sep 01 11:03:05 2010 +0900 +++ b/doc/misc/auth.texi Wed Sep 08 12:55:57 2010 +0900 @@ -286,7 +286,3 @@ @bye @c End: - -@ignore - arch-tag: 7b835fd3-473f-40fc-9776-1c4e49d26c94 -@end ignore
--- a/doc/misc/cl.texi Wed Sep 01 11:03:05 2010 +0900 +++ b/doc/misc/cl.texi Wed Sep 08 12:55:57 2010 +0900 @@ -1043,10 +1043,10 @@ frame-width window-point get-register window-start getenv window-width -global-key-binding x-get-cut-buffer -keymap-parent x-get-cutbuffer -local-key-binding x-get-secondary-selection -mark x-get-selection +global-key-binding x-get-secondary-selection +keymap-parent x-get-selection +local-key-binding +mark mark-marker @end smallexample
--- a/doc/misc/doclicense.texi Wed Sep 01 11:03:05 2010 +0900 +++ b/doc/misc/doclicense.texi Wed Sep 08 12:55:57 2010 +0900 @@ -505,7 +505,3 @@ @c Local Variables: @c ispell-local-pdict: "ispell-dict" @c End: - -@ignore - arch-tag: c1679162-1d8a-4f02-bc52-2e71765f0165 -@end ignore
--- a/doc/misc/emacs-mime.texi Wed Sep 01 11:03:05 2010 +0900 +++ b/doc/misc/emacs-mime.texi Wed Sep 08 12:55:57 2010 +0900 @@ -394,7 +394,7 @@ @item mm-text-html-renderer @vindex mm-text-html-renderer This selects the function used to render @acronym{HTML}. The predefined -renderers are selected by the symbols @code{w3}, +renderers are selected by the symbols @code{gnus-article-html}, @code{w3}, @code{w3m}@footnote{See @uref{http://emacs-w3m.namazu.org/} for more information about emacs-w3m}, @code{links}, @code{lynx}, @code{w3m-standalone} or @code{html2text}. If @code{nil} use an @@ -1889,7 +1889,3 @@ @c mode: texinfo @c coding: iso-8859-1 @c End: - -@ignore - arch-tag: c7ef2fd0-a91c-4e10-aa52-c1a2b11b1a8d -@end ignore
--- a/doc/misc/gnus-coding.texi Wed Sep 01 11:03:05 2010 +0900 +++ b/doc/misc/gnus-coding.texi Wed Sep 08 12:55:57 2010 +0900 @@ -387,7 +387,3 @@ @c mode: texinfo @c coding: iso-8859-1 @c End: - -@ignore - arch-tag: ab15234c-2c8a-4cbd-8111-1811bcc6f931 -@end ignore
--- a/doc/misc/gnus-faq.texi Wed Sep 01 11:03:05 2010 +0900 +++ b/doc/misc/gnus-faq.texi Wed Sep 08 12:55:57 2010 +0900 @@ -2331,7 +2331,3 @@ use to read and write Usenet news. @end table - -@ignore -arch-tag: 64dc5692-edb4-4848-a965-7aa0181acbb8 -@end ignore
--- a/doc/misc/gnus-news.el Wed Sep 01 11:03:05 2010 +0900 +++ b/doc/misc/gnus-news.el Wed Sep 08 12:55:57 2010 +0900 @@ -113,5 +113,4 @@ (insert gnus-news-trailer) (write-region (point-min) (point-max) outfile)))) -;; arch-tag: e23cdd27-eafd-4ba0-816f-98f5edb0dc29 ;;; gnus-news.el ends here
--- a/doc/misc/gnus-news.texi Wed Sep 01 11:03:05 2010 +0900 +++ b/doc/misc/gnus-news.texi Wed Sep 08 12:55:57 2010 +0900 @@ -325,7 +325,3 @@ @end itemize @c gnus-news.texi ends here. - -@ignore - arch-tag: 872c7569-4340-4d73-9d1d-7826d9f94a51 -@end ignore
--- a/doc/misc/gnus.texi Wed Sep 01 11:03:05 2010 +0900 +++ b/doc/misc/gnus.texi Wed Sep 08 12:55:57 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,9 +695,6 @@ * Archiving Mail:: * Web Searches:: Creating groups from articles that match a string. -* Slashdot:: Reading the Slashdot comments. -* 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. @@ -715,23 +712,15 @@ * 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. -* Kibozed Groups:: Looking through parts of the newsfeed for articles. Email Based Diary @@ -1295,7 +1284,7 @@ topic parameter that looks like @example -"nnslashdot" +"nnml" @end example will mean that all groups that match that regex will be subscribed under @@ -1385,31 +1374,11 @@ change @code{gnus-select-method}, your @file{.newsrc} file becomes worthless. -Gnus provides a few functions to attempt to translate a @file{.newsrc} -file from one server to another. They all have one thing in -common---they take a looong time to run. You don't want to use these -functions more than absolutely necessary. - -@kindex M-x gnus-change-server -@findex gnus-change-server -If you have access to both servers, Gnus can request the headers for all -the articles you have read and compare @code{Message-ID}s and map the -article numbers of the read articles and article marks. The @kbd{M-x -gnus-change-server} command will do this for all your native groups. It -will prompt for the method you want to move to. - -@kindex M-x gnus-group-move-group-to-server -@findex gnus-group-move-group-to-server -You can also move individual groups with the @kbd{M-x -gnus-group-move-group-to-server} command. This is useful if you want to -move a (foreign) group from one server to another. - @kindex M-x gnus-group-clear-data-on-native-groups @findex gnus-group-clear-data-on-native-groups -If you don't have access to both the old and new server, all your marks -and read ranges have become worthless. You can use the @kbd{M-x -gnus-group-clear-data-on-native-groups} command to clear out all data -that you have on your native groups. Use with caution. +You can use the @kbd{M-x gnus-group-clear-data-on-native-groups} +command to clear out all data that you have on your native groups. +Use with caution. @kindex M-x gnus-group-clear-data @findex gnus-group-clear-data @@ -2654,15 +2623,6 @@ (@code{gnus-group-recent-archive-directory}), but given a prefix, a full group will be created from @code{gnus-group-archive-directory}. -@item G k -@kindex G k (Group) -@findex gnus-group-make-kiboze-group -@cindex nnkiboze -Make a kiboze group. You will be prompted for a name, for a regexp to -match groups to be ``included'' in the kiboze group, and a series of -strings to match on headers (@code{gnus-group-make-kiboze-group}). -@xref{Kibozed Groups}. - @item G D @kindex G D (Group) @findex gnus-group-enter-directory @@ -4450,8 +4410,7 @@ made). Since mairix already presents search results in such a virtual mail folder, it is very well suited for using it as an external program for creating @emph{smart} mail folders, which represent certain mail -searches. This is similar to a Kiboze group (@pxref{Kibozed Groups}), -but much faster. +searches. @node nnmairix requirements @subsubsection nnmairix requirements @@ -6043,6 +6002,11 @@ This variable can also be a number. In that case, center the window at the given number of lines from the top. +@item gnus-summary-stop-at-end-of-message +@vindex gnus-summary-stop-at-end-of-message +If non-@code{nil}, don't go to the next article when hitting +@kbd{SPC}, and you're at the end of the article. + @end table @@ -6350,7 +6314,8 @@ @findex gnus-summary-wide-reply-with-original Mail a wide reply to the current article and include the original message (@code{gnus-summary-wide-reply-with-original}). This command uses -the process/prefix convention. +the process/prefix convention, but only uses the headers from the +first article to determine the recipients. @item S v @kindex S v (Summary) @@ -6414,8 +6379,6 @@ If the prefix is 1, prompt for a group name to find the posting style. @item S i -@itemx i -@kindex i (Summary) @kindex S i (Summary) @findex gnus-summary-news-other-window Prepare a news (@code{gnus-summary-news-other-window}). By default, @@ -6753,6 +6716,12 @@ Just don't forget to set that up :-) @end table +When delaying an article with @kbd{C-c C-j}, Message mode will +automatically add a @code{"Date"} header with the current time. In +many cases you probably want the @code{"Date"} header to reflect the +time the message is sent instead. To do this, you have to delete +@code{Date} from @code{message-draft-headers}. + @node Marking Articles @section Marking Articles @@ -6861,10 +6830,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 @@ -7835,7 +7800,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 @@ -8271,6 +8236,16 @@ preferably be short and sweet to avoid slowing down Gnus too much. It's probably a good idea to byte-compile things like this. +@vindex gnus-async-post-fetch-function +@findex gnus-html-prefetch-images +After an article has been prefetched, this +@code{gnus-async-post-fetch-function} will be called. The buffer will +be narrowed to the region of the article that was fetched. A useful +value would be @code{gnus-html-prefetch-images}, which will prefetch +and store images referenced in the article, so that you don't have to +wait for them to be fetched when you read the article. This is useful +for @acronym{HTML} messages that have external images. + @vindex gnus-prefetched-article-deletion-strategy Articles have to be removed from the asynch buffer sooner or later. The @code{gnus-prefetched-article-deletion-strategy} says when to remove @@ -10376,6 +10351,14 @@ Remove all images from the article buffer (@code{gnus-article-remove-images}). +@item W D W +@kindex W D W (Summary) +@findex gnus-html-show-images +If you're reading an @acronym{HTML} article rendered with +@code{gnus-article-html}, then you can insert any blocked images in +the buffer with this command. +(@code{gnus-html-show-images}). + @end table @@ -12186,6 +12169,7 @@ @menu * Hiding Headers:: Deciding what headers should be displayed. * Using MIME:: Pushing articles through @acronym{MIME} before reading them. +* HTML:: Reading @acronym{HTML} messages. * Customizing Articles:: Tailoring the look of the articles. * Article Keymap:: Keystrokes available in the article buffer. * Misc Article:: Other stuff. @@ -12482,6 +12466,68 @@ Also @pxref{MIME Commands}. +@node HTML +@section @acronym{HTML} +@cindex @acronym{HTML} + +If you have @code{w3m} installed on your system, Gnus can display +@acronym{HTML} articles in the article buffer. There are many Gnus +add-ons for doing this, using various approaches, but there's one +(sort of) built-in method that's used by default. + +For a complete overview, consult @xref{Display Customization, +,Display Customization, emacs-mime, The Emacs MIME Manual}. This +section only describes the default method. + +@table @code +@item mm-text-html-renderer +@vindex mm-text-html-renderer +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{gnus-blocked-images} is set. These images will be stored in +this directory. + +@item gnus-html-cache-size +@vindex gnus-html-cache-size +When @code{gnus-html-cache-size} bytes have been used in that +directory, the oldest files will be deleted. The default is 500MB. + +@item gnus-html-frame-width +@vindex gnus-html-frame-width +The width to use when rendering HTML. The default is 70. + +@item gnus-max-image-proportion +@vindex gnus-max-image-proportion +How big pictures displayed are in relation to the window they're in. +A value of 0.7 (the default) means that they are allowed to take up +70% of the width and height of the window. If they are larger than +this, and Emacs supports it, then the images will be rescaled down to +fit these criteria. + +@end table + +To use this, make sure that you have @code{w3m} and @code{curl} +installed. If you have, then Gnus should display @acronym{HTML} +automatically. + + + @node Customizing Articles @section Customizing Articles @cindex article customization @@ -13559,6 +13605,9 @@ @kbd{D t} (@code{gnus-draft-toggle-sending}) command to mark the message as unsendable. This is a toggling command. +Finally, if you want to delete a draft, use the normal @kbd{B DEL} +command (@pxref{Mail Group Commands}). + @node Rejected Articles @section Rejected Articles @@ -13689,7 +13738,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. @@ -17350,9 +17399,6 @@ @menu * Archiving Mail:: * Web Searches:: Creating groups from articles that match a string. -* Slashdot:: Reading the Slashdot comments. -* 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 @@ -17495,159 +17541,6 @@ @end table -@node Slashdot -@subsection Slashdot -@cindex Slashdot -@cindex nnslashdot - -@uref{http://slashdot.org/, Slashdot} is a popular news site, with -lively discussion following the news articles. @code{nnslashdot} will -let you read this forum in a convenient manner. - -The easiest way to read this source is to put something like the -following in your @file{~/.gnus.el} file: - -@lisp -(setq gnus-secondary-select-methods - '((nnslashdot ""))) -@end lisp - -This will make Gnus query the @code{nnslashdot} back end for new comments -and groups. The @kbd{F} command will subscribe each new news article as -a new Gnus group, and you can read the comments by entering these -groups. (Note that the default subscription method is to subscribe new -groups as zombies. Other methods are available (@pxref{Subscription -Methods}). - -If you want to remove an old @code{nnslashdot} group, the @kbd{G DEL} -command is the most handy tool (@pxref{Foreign Groups}). - -When following up to @code{nnslashdot} comments (or posting new -comments), some light @acronym{HTML}izations will be performed. In -particular, text quoted with @samp{> } will be quoted with -@samp{blockquote} instead, and signatures will have @samp{br} added to -the end of each line. Other than that, you can just write @acronym{HTML} -directly into the message buffer. Note that Slashdot filters out some -@acronym{HTML} forms. - -The following variables can be altered to change its behavior: - -@table @code -@item nnslashdot-threaded -Whether @code{nnslashdot} should display threaded groups or not. The -default is @code{t}. To be able to display threads, @code{nnslashdot} -has to retrieve absolutely all comments in a group upon entry. If a -threaded display is not required, @code{nnslashdot} will only retrieve -the comments that are actually wanted by the user. Threading is nicer, -but much, much slower than unthreaded. - -@item nnslashdot-login-name -@vindex nnslashdot-login-name -The login name to use when posting. - -@item nnslashdot-password -@vindex nnslashdot-password -The password to use when posting. - -@item nnslashdot-directory -@vindex nnslashdot-directory -Where @code{nnslashdot} will store its files. The default is -@file{~/News/slashdot/}. - -@item nnslashdot-active-url -@vindex nnslashdot-active-url -The @acronym{URL} format string that will be used to fetch the -information on news articles and comments. The default is@* -@samp{http://slashdot.org/search.pl?section=&min=%d}. - -@item nnslashdot-comments-url -@vindex nnslashdot-comments-url -The @acronym{URL} format string that will be used to fetch comments. - -@item nnslashdot-article-url -@vindex nnslashdot-article-url -The @acronym{URL} format string that will be used to fetch the news -article. The default is -@samp{http://slashdot.org/article.pl?sid=%s&mode=nocomment}. - -@item nnslashdot-threshold -@vindex nnslashdot-threshold -The score threshold. The default is -1. - -@item nnslashdot-group-number -@vindex nnslashdot-group-number -The number of old groups, in addition to the ten latest, to keep -updated. The default is 0. - -@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 @@ -18584,7 +18477,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 @@ -18952,289 +18844,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 @@ -19321,7 +18930,6 @@ @menu * Virtual Groups:: Combining articles from many groups. -* Kibozed Groups:: Looking through parts of the newsfeed for articles. @end menu @@ -19411,58 +19019,6 @@ inherited. -@node Kibozed Groups -@subsection Kibozed Groups -@cindex nnkiboze -@cindex kibozing - -@dfn{Kibozing} is defined by the @acronym{OED} as ``grepping through -(parts of) the news feed''. @code{nnkiboze} is a back end that will -do this for you. Oh joy! Now you can grind any @acronym{NNTP} server -down to a halt with useless requests! Oh happiness! - -@kindex G k (Group) -To create a kibozed group, use the @kbd{G k} command in the group -buffer. - -The address field of the @code{nnkiboze} method is, as with -@code{nnvirtual}, a regexp to match groups to be ``included'' in the -@code{nnkiboze} group. That's where most similarities between -@code{nnkiboze} and @code{nnvirtual} end. - -In addition to this regexp detailing component groups, an -@code{nnkiboze} group must have a score file to say what articles are -to be included in the group (@pxref{Scoring}). - -@kindex M-x nnkiboze-generate-groups -@findex nnkiboze-generate-groups -You must run @kbd{M-x nnkiboze-generate-groups} after creating the -@code{nnkiboze} groups you want to have. This command will take time. -Lots of time. Oodles and oodles of time. Gnus has to fetch the -headers from all the articles in all the component groups and run them -through the scoring process to determine if there are any articles in -the groups that are to be part of the @code{nnkiboze} groups. - -Please limit the number of component groups by using restrictive -regexps. Otherwise your sysadmin may become annoyed with you, and the -@acronym{NNTP} site may throw you off and never let you back in again. -Stranger things have happened. - -@code{nnkiboze} component groups do not have to be alive---they can be dead, -and they can be foreign. No restrictions. - -@vindex nnkiboze-directory -The generation of an @code{nnkiboze} group means writing two files in -@code{nnkiboze-directory}, which is @file{~/News/kiboze/} by default. -One contains the @acronym{NOV} header lines for all the articles in -the group, and the other is an additional @file{.newsrc} file to store -information on what groups have been searched through to find -component articles. - -Articles marked as read in the @code{nnkiboze} group will have -their @acronym{NOV} lines removed from the @acronym{NOV} file. - - @node Email Based Diary @section Email Based Diary @cindex diary @@ -22018,7 +21574,7 @@ @vindex gnus-adaptive-pretty-print Adaptive score files can get huge and are not meant to be edited by human hands. If @code{gnus-adaptive-pretty-print} is @code{nil} (the -deafult) those files will not be written in a human readable way. +default) those files will not be written in a human readable way. @vindex gnus-score-exact-adapt-limit When doing adaptive scoring, substring or fuzzy matching would probably @@ -27811,10 +27367,6 @@ operations on all the marked items (@pxref{Process/Prefix}). @item -You can grep through a subset of groups and create a group from the -results (@pxref{Kibozed Groups}). - -@item You can list subsets of groups according to, well, anything (@pxref{Listing Groups}). @@ -27959,8 +27511,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. @@ -29521,11 +29072,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{nnslashdot}, @code{nnultimate}, and -@code{nnwfm} don't have their own nn*-nov-is-evil.} +@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. @end table @@ -31356,7 +30905,3 @@ @c mode: texinfo @c coding: iso-8859-1 @c End: - -@ignore - arch-tag: c9fa47e7-78ca-4681-bda9-9fef45d1c819 -@end ignore
--- a/doc/misc/message.texi Wed Sep 01 11:03:05 2010 +0900 +++ b/doc/misc/message.texi Wed Sep 08 12:55:57 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 @@ -1645,7 +1676,8 @@ @cindex split large message The limitation of messages sent as message/partial. The lower bound of message size in characters, beyond which the message should be sent -in several parts. If it is @code{nil}, the size is unlimited. +in several parts. If it is @code{nil} (which is the default), the +size is unlimited. @end table @@ -2441,7 +2473,3 @@ @bye @c End: - -@ignore - arch-tag: 16ab76af-a281-4e34-aed6-5624569f7601 -@end ignore
--- a/doc/misc/pgg.texi Wed Sep 01 11:03:05 2010 +0900 +++ b/doc/misc/pgg.texi Wed Sep 08 12:55:57 2010 +0900 @@ -497,7 +497,3 @@ @bye @c End: - -@ignore - arch-tag: 0c205838-34b9-41a5-b9d7-49ae57ccac85 -@end ignore
--- a/doc/misc/sasl.texi Wed Sep 01 11:03:05 2010 +0900 +++ b/doc/misc/sasl.texi Wed Sep 08 12:55:57 2010 +0900 @@ -267,7 +267,3 @@ @bye @c End: - -@ignore - arch-tag: dc9650be-a953-40bf-bc55-24fe5f19d875 -@end ignore
--- a/doc/misc/sieve.texi Wed Sep 01 11:03:05 2010 +0900 +++ b/doc/misc/sieve.texi Wed Sep 08 12:55:57 2010 +0900 @@ -356,7 +356,3 @@ @bye @c End: - -@ignore - arch-tag: 6e3ad0af-2eaf-4f35-a081-d40f4a683ec3 -@end ignore
--- a/etc/ChangeLog Wed Sep 01 11:03:05 2010 +0900 +++ b/etc/ChangeLog Wed Sep 08 12:55:57 2010 +0900 @@ -6,6 +6,10 @@ * NEWS: dbus.el supports alternative buses. +2010-08-22 Alex Harsanyi <harsanyi@mac.com> (tiny change) + + * emacs3.py: Import imp module and use it (Bug#5756). + 2010-08-14 Eli Zaretskii <eliz@gnu.org> * tutorials/TUTORIAL.he: Use MAQAF instead of hyphen where appropriate.
--- a/etc/NEWS Wed Sep 01 11:03:05 2010 +0900 +++ b/etc/NEWS Wed Sep 08 12:55:57 2010 +0900 @@ -235,6 +235,8 @@ *** `mouse-drag-copy-region' now defaults to nil. +*** Support for X cut buffers has been removed. + * Changes in Specialized Modes and Packages in Emacs 24.1 @@ -425,6 +427,8 @@ * New Modes and Packages in Emacs 24.1 +** New global minor modes electric-pair-mode and electric-indent-mode. + ** pcase.el provides the ML-style pattern matching macro `pcase'. ** smie.el is a package providing a simple generic indentation engine.
--- a/etc/emacs3.py Wed Sep 01 11:03:05 2010 +0900 +++ b/etc/emacs3.py Wed Sep 08 12:55:57 2010 +0900 @@ -1,10 +1,3 @@ -""" -Warning: This file is automatically generated from emacs2.py with the -2to3 script. Do not hand edit. -""" - -"""Definitions used by commands sent to inferior Python in python.el.""" - # Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. # Author: Dave Love <fx@gnu.org> @@ -23,7 +16,7 @@ # You should have received a copy of the GNU General Public License # along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. -import os, sys, traceback, inspect, __main__ +import os, sys, traceback, inspect, imp, __main__ try: set @@ -216,7 +209,7 @@ try: try: if mod in __dict__ and inspect.ismodule (__dict__[mod]): - reload (__dict__[mod]) + imp.reload (__dict__[mod]) else: __dict__[mod] = __import__ (mod) except:
--- a/etc/gnus/gnus-setup.ast Wed Sep 01 11:03:05 2010 +0900 +++ b/etc/gnus/gnus-setup.ast Wed Sep 08 12:55:57 2010 +0900 @@ -48,8 +48,3 @@ @c Local variables: @c mode: texinfo @c End: - -@ignore - arch-tag: 6b7b200b-9169-4b44-8b32-b73773fa71af -@end ignore -
--- a/etc/refcards/gnus-refcard.tex Wed Sep 01 11:03:05 2010 +0900 +++ b/etc/refcards/gnus-refcard.tex Wed Sep 08 12:55:57 2010 +0900 @@ -1425,5 +1425,3 @@ %%% mode: latex %%% TeX-master: t %%% End: - -% arch-tag: be438b0e-6832-4afb-8c56-5f84743e5cd1
--- a/leim/ChangeLog Wed Sep 01 11:03:05 2010 +0900 +++ b/leim/ChangeLog Wed Sep 08 12:55:57 2010 +0900 @@ -1,3 +1,8 @@ +2010-08-28 Kenichi Handa <handa@m17n.org> + + * quail/japanese.el (quail-japanese-update-translation): Fix + handling of invalid key. + 2010-08-15 Andreas Schwab <schwab@linux-m68k.org> * quail/vntelex.el ("vietnamese-telex"): Doc fix.
--- a/leim/quail/japanese.el Wed Sep 01 11:03:05 2010 +0900 +++ b/leim/quail/japanese.el Wed Sep 08 12:55:57 2010 +0900 @@ -43,20 +43,25 @@ (or quail-current-str quail-current-key) "")) (if (integerp control-flag) - (if (= control-flag 0) - (setq quail-current-str (aref quail-current-key 0)) - (cond ((= (aref quail-current-key 0) ?n) + (let ((keylen (length quail-current-key))) + (cond ((= control-flag 0) + (setq quail-current-str (aref quail-current-key 0) + control-flag t)) + ((= (aref quail-current-key 0) ?n) (setq quail-current-str ?$B$s(B) (if (and quail-japanese-use-double-n + (> keylen 0) (= (aref quail-current-key 1) ?n)) (setq control-flag t))) - ((= (aref quail-current-key 0) (aref quail-current-key 1)) + ((and (> keylen 1) + (= (aref quail-current-key 0) (aref quail-current-key 1))) (setq quail-current-str ?$B$C(B)) (t (setq quail-current-str (aref quail-current-key 0)))) (if (integerp control-flag) (setq unread-command-events - (list (aref quail-current-key control-flag))))))) + (string-to-list + (substring quail-current-key control-flag))))))) control-flag) ;; Convert Hiragana <-> Katakana in the current translation region.
--- a/lisp/ChangeLog Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/ChangeLog Wed Sep 08 12:55:57 2010 +0900 @@ -1,3 +1,354 @@ +2010-09-07 AgustÃn MartÃn <agustin.martin@hispalinux.es> + + * textmodes/ispell.el (ispell-start-process): Make sure original + arg list is properly initialized (Bug#6993, Bug#6994). + +2010-09-06 Alexander Klimov <alserkli@inbox.ru> (tiny change) + + * files.el (directory-abbrev-alist): Use \` as default regexp. + + * emacs-lisp/rx.el (rx-any): Don't explode ranges that end in special + chars like - or ] (bug#6984). + (rx-any-condense-range): Explode 2-char ranges. + +2010-09-06 Glenn Morris <rgm@gnu.org> + + * desktop.el (desktop-path): Bump :version after 2009-09-15 change. + +2010-09-06 Stefan Monnier <monnier@iro.umontreal.ca> + + * textmodes/bibtex.el: + * proced.el: Update to new email for Roland Winkler <winkler@gnu.org>. + +2010-09-05 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * net/imap.el (imap-message-map): Removed optional buffer parameter, + since no callers use it. + (imap-message-get): Ditto. + (imap-message-put): Ditto. + (imap-mailbox-map): Ditto. + (imap-mailbox-put): Ditto. + (imap-mailbox-get): Ditto. + (imap-mailbox-get): Revert last change for this function. + +2010-09-05 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * net/imap.el (imap-fetch-safe): Removed function, and altered all + callers to use `imap-fetch' instead. According to the comments, this + should be safe, since all other IMAP clients use the 1:* syntax. + (imap-enable-exchange-bug-workaround): Removed. + (imap-debug): Removed -- doesn't seem very useful. + +2010-09-05 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * net/imap.el (imap-log): New convenience function used throughout + instead of repeating the same code all over the place. + +2010-09-05 David De La Harpe Golden <david@harpegolden.net> + + * mouse.el (mouse-save-then-kill): Save region to kill-ring + when mouse-drag-copy-region is non-nil (Bug#6956). + +2010-09-05 Chong Yidong <cyd@stupidchicken.com> + + * dired.el (dired-ls-sorting-switches, dired-sort-by-name-regexp): + Improve regexps (Bug#6987). + (dired-sort-toggle): Search more robustly for -t flag. + + * files.el (get-free-disk-space): Search more robustly for + "available" column. Suggested by Ehud Karni + <ehud@unix.mvs.co.il>. + +2010-09-05 Juanma Barranquero <lekktu@gmail.com> + + * international/uni-bidi.el: + * international/uni-category.el: + * international/uni-combining.el: + * international/uni-decimal.el: + * international/uni-mirrored.el: + * international/uni-name.el: Regenerate. + +2010-09-04 Stefan Monnier <monnier@iro.umontreal.ca> + + * electric.el (electric-indent-post-self-insert-function): + Don't reindent with a sloppy indentation function. + + * emacs-lisp/syntax.el (syntax-ppss): More sanity check to catch + border case in change-log-mode. + +2010-09-04 Chong Yidong <cyd@stupidchicken.com> + + * progmodes/compile.el (compilation-error-regexp-alist-alist): + Remove ruby regexp; handle Ruby errors with gcc-include and gnu. + Recognize leading tab in gcc-include regexp. Ignore names with + leading "from" or "in" in gnu regexp (Bug#6937). + +2010-09-04 Stefan Monnier <monnier@iro.umontreal.ca> + + Avoid global recursive calls to kill-buffer-hooks; fit into 80 cols. + * textmodes/ispell.el (ispell-process-buffer-name): Remove. + (ispell-start-process): Avoid setq and simplify logic. + (ispell-init-process): Setup kill-buffer-hook locally when needed. + (kill-buffer-hook): Don't use it globally with code that uses + expand-file-name since that may call kill-buffer via + code_conversion_restore. + +2010-09-04 Noorul Islam K M <noorul@noorul.com> (tiny change) + + * emacs-lisp/package.el (package-directory-list): Only call + file-name-nondirectory on a string. + +2010-09-02 Chong Yidong <cyd@stupidchicken.com> + + * emacs-lisp/package.el (package--download-one-archive): + Ensure that archive-contents is valid before saving it. + (package-activate-1, package-mark-obsolete, define-package) + (package-compute-transaction, package-list-maybe-add): Use push. + +2010-09-03 Stefan Monnier <monnier@iro.umontreal.ca> + + Use SMIE's blink-paren for octave-mode. + * progmodes/octave-mod.el (octave-font-lock-close-quotes): + Backslashes do not escape single-quotes, single-quotes do. + (octave-block-else-regexp, octave-block-end-regexp) + (octave-block-match-alist): Remove. + (octave-smie-bnf-table): New var, with old content. + (octave-smie-op-levels): Use it. + (octave-smie-closer-alist): New var. + (octave-mode): Use it. Setup smie-blink-matching and electric-indent. + (octave-blink-matching-block-open): Remove. + (octave-reindent-then-newline-and-indent, octave-electric-semi) + (octave-electric-space): Let self-insert-command run expand-abbrev and + blink parens. + + * electric.el (electricity): New group. + (electric-indent-chars): New var. + (electric-indent-post-self-insert-function): New fun. + (electric-indent-mode): New minor mode. + (electric-pair-skip-self): New custom. + (electric-pair-post-self-insert-function): New function. + (electric-pair-mode): New minor mode. + + * calc/calc-aent.el (calcAlg-blink-matching-check): New fun, to replace + calcAlg-blink-matching-open. + (calc-alg-ent-map, calc-alg-ent-esc-map): Initialize in the declaration. + (calc-do-alg-entry): Only touch the part of the keymap that varies. + Use the new blink-matching-check-function. + + Provide blink-matching support to SMIE. + * emacs-lisp/smie.el (smie-bnf-closer-alist): New function. + (smie-blink-matching-triggers, smie-blink-matching-inners): New vars. + (smie-blink-matching-check, smie-blink-matching-open): New functions. + + * simple.el (newline): Fix last change to properly remove itself from + the hook. + +2010-09-02 Stefan Monnier <monnier@iro.umontreal.ca> + + * simple.el (newline): Eliminate optimization. + Use post-self-insert-hook to set hard-newline and things before + running post-self-insert-hook. + (blink-matching-check-mismatch): New function. + (blink-matching-check-function): New variable. + (blink-matching-open): Use them. + Skip back forward over prefix chars skipped by forward-sexp. + Don't check if the parens are backslash escaped. + (blink-paren-post-self-insert-function): Check backslash escaping here. + +2010-09-02 Chong Yidong <cyd@stupidchicken.com> + + * emacs-lisp/package.el (package-menu-mode-map): + Change package-menu-revert bindings to revert-buffer. + (package-menu-mode): Set revert-buffer-function. + (package-menu-revert): Doc fix. + +2010-09-02 AgustÃn MartÃn <agustin.martin@hispalinux.es> + + * textmodes/ispell.el (ispell-init-process): Use "~/" as + `default-directory' unless using Ispell per-directory personal + dictionaries and not in a mini-buffer under XEmacs. + (kill-buffer-hook): Do not kill ispell process on exit when + `ispell-process-directory' is "~/". (Bug#6143) + +2010-09-02 Jan Djärv <jan.h.d@swipnet.se> + + * simple.el (kill-new): Call interprogram-cut-function with only + one argument. + + * term.el (term-mouse-paste): Don't call x-get-cutbuffer. + Remove cut buffer from error message. + + * term/x-win.el (x-select-text): + * term/pc-win.el (x-selection-value): + * term/ns-win.el (x-selection-value): + * eshell/em-term.el: + * w32-fns.el (x-get-selection-value): + * mouse-sel.el (mouse-sel-set-selection-function): + * frame.el (display-selections-p): Remove cut-buffer in documentation. + + * term/x-win.el: Update documentation for x-last-selected-text-*. + (x-last-selected-text-cut, x-last-selected-text-cut-encoded) + (x-last-cut-buffer-coding, x-cut-buffer-max): Remove. + (x-select-text): Remove argument PUSH, update documentation. Remove + cut-buffer code. + (x-selection-value-internal): Was previously x-selection-value. + (x-selection-value): Rename from x-cut-buffer-or-selection-value. + Update documentation, remove cut-buffer code. Call + x-selection-value-internal. + (x-clipboard-yank): Call x-selection-value-internal. + (x-initialize-window-system): Remove setting of x-cut-buffer-max. + + * term/pc-win.el (x-last-selected-text): + x-cut-buffer-or-selection-value renamed to x-selection-value + (x-select-text): Remove argument PUSH, update documentation. + + * term/ns-win.el (x-setup-function-keys, ns-last-selected-text): + x-cut-buffer-or-selection-value renamed to x-selection-value + (x-selection-value): Renamed from x-cut-buffer-or-selection-value. + (x-select-text): Remove argument PUSH, update documentation. + + * emacs-lisp/cl-macs.el (x-get-cutbuffer, x-get-cut-buffer): Remove. + + * w32-fns.el (x-last-selected-text): + x-cut-buffer-or-selection-value renamed to x-selection-value. + (x-cut-buffer-max): Remove. + (x-select-text): Remove argument PUSH, update documentation. + + * simple.el (interprogram-cut-function): Remove mention of PUSH. + + * select.el (x-get-cut-buffer, x-set-cut-buffer): Remove. + + * mouse-sel.el (mouse-sel-get-selection-function): + x-cut-buffer-or-selection-value renamed to x-selection-value. + (x-select-text): Remove optional push. + +2010-09-01 Stefan Monnier <monnier@iro.umontreal.ca> + + * simple.el (blink-paren-function): Move from C to here. + (blink-paren-post-self-insert-function): New function. + (post-self-insert-hook): Use it. + + * emacs-lisp/pcase.el (pcase-split-memq): + Fix overenthusiastic optimisation. + (pcase-u1): Handle the case of a lambda pred. + +2010-08-31 Kenichi Handa <handa@m17n.org> + + * international/mule-cmds.el (standard-display-european-internal): + Setup standard-display-table for 8-bit characters by storing 8-bit + characters in the element vector. + + * disp-table.el (standard-display-8bit): Setup + standard-display-table for 8-bit characters by storing 8-bit + characters in the element vector. + (standard-display-european): Likewise. + +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 + `read', to avoid copying an additional string. + (package-menu-mode): Set header-line-format here. + (package-menu-refresh, package-menu-revert): Signal an error if + not in the Package Menu. + (package-menu-package-list): New var. + (package--generate-package-list): Operate on the current buffer; + don't assume that it is *Packages*, since the user may rename it. + Allow persistent package listings and sort keys using + 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. + (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): + 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. + (finder-compile-keywords): Simpify printing. + +2010-08-30 Stefan Monnier <monnier@iro.umontreal.ca> + + * progmodes/octave-mod.el (octave-font-lock-keywords): Use regexp-opt. + (octave-mode-map): Remove special bindings for forward/backward-block + and octave-backward-up-block. Use smie-close-block. + (octave-continuation-marker-regexp): New var. + (octave-continuation-regexp): Use it. + (octave-operator-table, octave-smie-op-levels) + (octave-operator-regexp, octave-smie-indent-rules): New vars. + (octave-smie-backward-token, octave-smie-forward-token): New funs. + (octave-mode): Use SMIE. + (octave-close-block): Delete. + +2010-08-30 Eli Zaretskii <eliz@gnu.org> + + * menu-bar.el (menu-bar-edit-menu) <"Paste">: Check selection in + CLIPBOARD, not in PRIMARY. (Bug#6944) + +2010-08-30 Stefan Monnier <monnier@iro.umontreal.ca> + + * emacs-lisp/smie.el (smie-indent-offset-rule): Let :parent take + a list of parents. + (smie-indent-column): Allow indirection through variables. + + * composite.el (save-buffer-state): Delete, unused. + * font-lock.el (save-buffer-state): Use with-silent-modifications. + (font-lock-default-fontify-region): Use with-syntax-table. + * jit-lock.el (with-buffer-unmodified): Remove. + (with-buffer-prepared-for-jit-lock): Use with-silent-modifications. + + Use `declare' in defmacros. + * window.el (save-selected-window): + * subr.el (with-temp-file, with-temp-message, with-syntax-table): + * progmodes/python.el (def-python-skeleton): + * net/dbus.el (dbus-ignore-errors): + * jka-cmpr-hook.el (with-auto-compression-mode): + * international/mule.el (with-category-table): + * emacs-lisp/timer.el (with-timeout): + * emacs-lisp/lisp-mnt.el (lm-with-file): + * emacs-lisp/eieio.el (with-slots): + * emacs-lisp/easymenu.el (easy-menu-define): + * emacs-lisp/debug.el (debugger-env-macro): + * emacs-lisp/cl-compat.el (Multiple-value-bind, Multiple-value-setq) + (Multiple-value-call, Multiple-value-prog1): + * emacs-lisp/cl-seq.el (cl-parsing-keywords, cl-check-key) + (cl-check-test-nokey, cl-check-test, cl-check-match): Move indent and + edebug rule to definition. + * emacs-lisp/lisp-mode.el (save-selected-window) + (with-current-buffer, combine-after-change-calls) + (with-output-to-string, with-temp-file, with-temp-buffer) + (with-temp-message, with-syntax-table, read-if, eval-after-load) + (dolist, dotimes, when, unless): + * emacs-lisp/byte-run.el (inline): Remove indent rule, redundant. + 2010-08-29 Chong Yidong <cyd@stupidchicken.com> * finder.el: Require `package'. @@ -7,8 +358,8 @@ (finder-compile-keywords): Compute package--builtins and finder-keywords-hash instead of finder-keywords-hash, respecting the "Package" header. - (finder-unknown-keywords, finder-list-matches): Use - finder-keywords-hash and package--list-packages. + (finder-unknown-keywords, finder-list-matches): + Use finder-keywords-hash and package--list-packages. (finder-mode): Don't set font-lock-defaults. (finder-exit): We don't use "*Finder-package*" and "*Finder Category*" buffers anymore. @@ -51,6 +402,57 @@ * whitespace.el (whitespace-style): Adjust type declaration. +2010-08-26 Magnus Henoch <magnus.henoch@gmail.com> + + * net/tramp-gvfs.el (tramp-gvfs-handle-copy-file): Do not pass + empty argument to gvfs-copy. + +2010-08-26 Chong Yidong <cyd@stupidchicken.com> + + * net/tramp-compat.el (tramp-compat-delete-file): Rewrite to + handle new TRASH arg of `delete-file'. + +2010-08-26 Christian Lynbech <christian.lynbech@tieto.com> (tiny change) + + * net/tramp.el (tramp-handle-insert-directory): Don't use + `forward-word', its default syntax could be changed. + +2010-08-26 Toru TSUNEYOSHI <t_tuneyosi@hotmail.com> + Michael Albinus <michael.albinus@gmx.de> + + Implement compression for inline methods. + + * net/tramp.el (tramp-inline-compress-start-size): New defcustom. + (tramp-copy-size-limit): Allow also nil. + (tramp-inline-compress-commands): New defconst. + (tramp-find-inline-compress, tramp-get-inline-compress) + (tramp-get-inline-coding): New defuns. + (tramp-get-remote-coding, tramp-get-local-coding): Remove, + replaced by `tramp-get-inline-coding'. + (tramp-handle-file-local-copy, tramp-handle-write-region) + (tramp-method-out-of-band-p): Use `tramp-get-inline-coding'. + +2010-08-26 Noah Lavine <noah549@gmail.com> (tiny change) + + Detect ssh 'ControlMaster' argument automatically in some cases. + + * net/tramp.el (tramp-detect-ssh-controlmaster): New defun. + (tramp-default-method): Use it. + +2010-08-26 Karel KlÃÄ <kklic@redhat.com> + + * net/tramp.el (tramp-file-name-for-operation): + Add file-selinux-context. + +2010-08-26 Åukasz Stelmach <lukasz.stelmach@iem.pw.edu.pl> (tiny change) + + * play/cookie1.el (read-cookie): Fix off-by-one error (bug#6921). + +2010-08-26 Chong Yidong <cyd@stupidchicken.com> + + * simple.el (beginning-of-buffer, end-of-buffer): Doc fix + (Bug#6907). + 2010-08-26 Nathan Weizenbaum <nweiz@cressida.sea.corp.google.com> (tiny change) * progmodes/js.el: Make indentation more customizable (Bug#6914). @@ -74,6 +476,211 @@ Sync with Tramp 2.1.19. + * net/tramp-cmds.el (tramp-cleanup-all-connections) + (tramp-reporter-dump-variable, tramp-load-report-modules) + (tramp-append-tramp-buffers): Use `tramp-compat-funcall'. + (tramp-bug): Recommend setting of `tramp-verbose' to 9. + + * net/tramp-compat.el (top): Do not autoload + `tramp-handle-file-remote-p'. Load tramp-util.el and tramp-vc.el + only when `start-file-process' is not bound. + (byte-compile-not-obsolete-vars): Define if not bound. + (tramp-compat-funcall): New defmacro. + (tramp-compat-line-beginning-position) + (tramp-compat-line-end-position) + (tramp-compat-temporary-file-directory) + (tramp-compat-make-temp-file, tramp-compat-file-attributes) + (tramp-compat-copy-file, tramp-compat-copy-directory) + (tramp-compat-delete-file, tramp-compat-delete-directory) + (tramp-compat-number-sequence, tramp-compat-process-running-p): + Use it. + (tramp-advice-file-expand-wildcards): Do not use + `tramp-handle-file-remote-p'. + (tramp-compat-make-temp-file): Simplify fallback implementation. + (tramp-compat-copy-file): Add PRESERVE-SELINUX-CONTEXT. + (tramp-compat-copy-tree): Remove function. + (tramp-compat-delete-file): New defun. + (tramp-compat-delete-directory): Provide implementation for older + Emacsen. + (tramp-compat-file-attributes): Handle only + `wrong-number-of-arguments' error. + + * net/tramp-fish.el (tramp-fish-handle-copy-file): Add + PRESERVE_SELINUX_CONTEXT. + (tramp-fish-handle-delete-file): Add TRASH arg. + (tramp-fish-handle-directory-files-and-attributes): + Do not use `tramp-fish-handle-file-attributes. + (tramp-fish-handle-file-local-copy) + (tramp-fish-handle-insert-file-contents) + (tramp-fish-maybe-open-connection): Use `with-progress-reporter'. + + * net/tramp-gvfs.el (top): Require url-util. + (tramp-gvfs-mount-point): Remove. + (tramp-gvfs-file-name-handler-alist): Add `file-selinux-context' + and `set-file-selinux-context'. + (tramp-gvfs-stringify-dbus-message, tramp-gvfs-send-command) + (tramp-gvfs-handle-file-selinux-context) + (tramp-gvfs-handle-set-file-selinux-context): New defuns. + (with-tramp-dbus-call-method): Format trace message. + (tramp-gvfs-handle-copy-file): Handle PRESERVE-SELINUX-CONTEXT. + (tramp-gvfs-handle-copy-file, tramp-gvfs-handle-rename-file): + Implement backup call, when operation on local files fails. Use + progress reporter. Flush properties of changed files. + (tramp-gvfs-handle-delete-file): Add TRASH arg. Use + `tramp-compat-delete-file'. + (tramp-gvfs-handle-expand-file-name): Expand "~/". + (tramp-gvfs-handle-make-directory): Make more traces. + (tramp-gvfs-handle-write-region): Protect deleting tmpfile. + (tramp-gvfs-url-file-name): Hexify file name in url. + (tramp-gvfs-fuse-file-name): Take also prefix (like dav shares) + into account for the resulting file name. + (tramp-gvfs-handler-askquestion): Preserve current message, in + order to let progress reporter continue afterwards. (Bug#6257) + Return dummy mountpoint, when the answer is "no". See + `tramp-gvfs-maybe-open-connection'. + (tramp-gvfs-handler-mounted-unmounted) + (tramp-gvfs-connection-mounted-p): Test also for new mountspec + attribute "default_location". Set "prefix" property. Handle + default-location. + (tramp-gvfs-mount-spec): Return both prefix and mountspec. + (tramp-gvfs-maybe-open-connection): Test, whether mountpoint + exists. Raise an error, if not (due to a corresponding answer + "no" in interactive questions, for example). Use + `tramp-compat-funcall'. + + * net/tramp-imap.el (top): Autoload `epg-make-context'. + (tramp-imap-handle-copy-file): Add PRESERVE-SELINUX-CONTEXT. + (tramp-imap-do-copy-or-rename-file) + (tramp-imap-handle-insert-file-contents) + (tramp-imap-handle-file-local-copy): Use `with-progress-reporter'. + (tramp-imap-handle-delete-file): Add TRASH arg. + + * net/tramp-smb.el (tramp-smb-handle-copy-file): Add + PRESERVE-SELINUX-CONTEXT. + (tramp-smb-handle-copy-file) + (tramp-smb-handle-file-local-copy, tramp-smb-handle-rename-file) + (tramp-smb-handle-write-region, tramp-smb-maybe-open-connection): + Use `with-progress-reporter'. + (tramp-smb-handle-delete-file): Add TRASH arg. + + * net/tramp.el (tramp-methods): Move hostname to the end in all + ssh `tramp-login-args'. Add `tramp-async-args' attribute where + appropriate. + (tramp-verbose): Describe verbose level 9. + (tramp-completion-function-alist) + (tramp-file-name-regexp, tramp-chunksize) + (tramp-local-coding-commands, tramp-remote-coding-commands) + (with-connection-property, tramp-completion-mode-p) + (tramp-action-process-alive, tramp-action-out-of-band) + (tramp-check-for-regexp, tramp-file-name-p, tramp-equal-remote) + (tramp-exists-file-name-handler): Fix docstring. + (tramp-remote-process-environment): Use `format' instead of + `concat'. Protect version string by apostroph. + (tramp-shell-prompt-pattern): Do not use a shy group in case of + XEmacs. + (tramp-file-name-regexp-unified) + (tramp-completion-file-name-regexp-unified): On W32 systems, do + not regard the volume letter as remote filename. (Bug#5447) + (tramp-perl-file-attributes) + (tramp-perl-directory-files-and-attributes): Don't pass "$3". + (tramp-vc-registered-read-file-names): Read input as + here-document, otherwise the command could exceed maximum length + of command line. + (tramp-file-name-handler-alist): Add `file-selinux-context' and + `set-file-selinux-context'. + (tramp-debug-message): Add `tramp-compat-funcall' to ignored + backtrace functions. + (tramp-error-with-buffer): Don't show the connection buffer when + we are in completion mode. + (tramp-progress-reporter-update, tramp-remote-selinux-p) + (tramp-handle-file-selinux-context) + (tramp-handle-set-file-selinux-context, tramp-process-sentinel) + (tramp-connectable-p, tramp-open-shell, tramp-get-remote-trash): + New defuns. + (with-progress-reporter): New defmacro. + (tramp-debug-outline-regexp): New defconst. + (top, tramp-rfn-eshadow-setup-minibuffer) + (tramp-rfn-eshadow-update-overlay, tramp-handle-set-file-times) + (tramp-handle-dired-compress-file, tramp-handle-shell-command) + (tramp-completion-mode-p, tramp-check-for-regexp) + (tramp-open-connection-setup-interactive-shell) + (tramp-compute-multi-hops, tramp-read-passwd, tramp-clear-passwd) + (tramp-time-diff, tramp-coding-system-change-eol-conversion) + (tramp-set-process-query-on-exit-flag, tramp-unload-tramp): + Use `tramp-compat-funcall'. + (tramp-handle-make-symbolic-link): Flush file properties. + (tramp-handle-load, tramp-handle-file-local-copy) + (tramp-handle-insert-file-contents, tramp-handle-write-region) + (tramp-handle-vc-registered, tramp-maybe-send-script) + (tramp-find-shell): Use `with-progress-reporter'. + (tramp-do-file-attributes-with-stat): Add space in format string, + in order to work around a bug in pdksh. Reported by Gilles Pion + <gpion@lfdj.com>. + (tramp-handle-verify-visited-file-modtime): Do not send a command + when the connection is not established. + (tramp-handle-set-file-times): Simplify the check for utc. + (tramp-handle-directory-files-and-attributes) + (tramp-get-remote-path): Use `copy-tree'. + (tramp-completion-handle-file-name-all-completions): Ensure, that + non remote files are still checked. Oops. + (tramp-handle-copy-file, tramp-do-copy-or-rename-file): Handle + PRESERVE-SELINUX-CONTEXT. + (tramp-do-copy-or-rename-file): Add progress reporter. + (tramp-do-copy-or-rename-file-directly): Do not use + `tramp-handle-file-remote-p'. + (tramp-do-copy-or-rename-file-out-of-band): + Use `tramp-compat-delete-directory'. + (tramp-do-copy-or-rename-file-out-of-band) + (tramp-compute-multi-hops, tramp-maybe-open-connection): + Use `format-spec-make'. + (tramp-handle-delete-file): Add TRASH arg. + (tramp-handle-dired-uncache): Flush directory cache, not only file + cache. + (tramp-handle-expand-file-name) + (tramp-completion-handle-file-name-all-completions) + (tramp-completion-handle-file-name-completion): Use + `tramp-connectable-p'. + (tramp-handle-start-file-process): Set connection property "vec". + Use it, in order to invalidate file caches. Check only for + `remote-tty' process property. + Implement tty setting. (Bug#4604, Bug#6360) + (tramp-file-name-for-operation): Add `call-process-region' and + `set-file-selinux-context'. + (tramp-find-foreign-file-name-handler) + (tramp-advice-make-auto-save-file-name) + (tramp-set-auto-save-file-modes): Remove superfluous check for + `stringp'. This is done inside `tramp-tramp-file-p'. + (tramp-file-name-handler): Trace 'quit. Catch the error for some + operations when we are in completion mode. This gives the user + the chance to correct the file name in the minibuffer. + (tramp-completion-mode-p): Use `non-essential'. + (tramp-handle-file-name-all-completions): Backward/ XEmacs + compatibility: Use `completion-ignore-case' if + `read-file-name-completion-ignore-case' does not exist. + (tramp-get-debug-buffer): Use `tramp-debug-outline-regexp'. + (tramp-find-shell, tramp-open-connection-setup-interactive-shell): + `tramp-open-shell'. + (tramp-action-password): Hide password prompt before next run. + (tramp-process-actions): Widen connection buffer for the trace. + (tramp-open-connection-setup-interactive-shell): Set `remote-tty' + process property. Trace stty settings if `tramp-verbose' >= 9. + Apply workaround for IRIX64 bug. Move argument of last + `tramp-send-command' where it belongs to. + (tramp-maybe-open-connection): Use `async-args' and `gw-args' in + front of `login-args'. + (tramp-get-ls-command, tramp-get-ls-command-with-dired): Run tests + on "/dev/null" instead of "/". + (tramp-get-ls-command-with-dired): Make test for "--dired" + stronger. + (tramp-set-auto-save-file-modes): Adapt version check. + (tramp-set-process-query-on-exit-flag): Fix wrong parentheses. + (tramp-handle-process-file): Call the program in a subshell, in + order to preserve working directory. + (tramp-handle-shell-command): Don't use hard-wired "/bin/sh" but + `tramp-remote-sh' from `tramp-methods'. + (tramp-get-ls-command): Make test for "--color=never" stronger. + (tramp-check-for-regexp): Use (forward-line 1). + * net/trampver.el: Update release number. 2010-08-26 Chong Yidong <cyd@stupidchicken.com> @@ -159,6 +766,11 @@ * mouse.el (mouse-yank-primary): Avoid setting primary when deactivating the mark (Bug#6872). +2010-08-23 Chris Foote <chris@foote.com.au> (tiny change) + + * progmodes/python.el (python-block-pairs): Allow use of "finally" + with "else" (Bug#3991). + 2010-08-23 Michael Albinus <michael.albinus@gmx.de> * net/dbus.el: Accept UNIX domain sockets as bus address. @@ -185,13 +797,19 @@ * startup.el (command-line-1): Issue warning for ignored arguments --unibyte, etc (Bug#6886). +2010-08-22 Leo <sdl.web@gmail.com> + + * net/rcirc.el (rcirc-add-or-remove): Accept a list of elements. + (ignore, bright, dim, keyword): Split list of nicknames before + passing to rcirc-add-or-remove (Bug#6894). + 2010-08-22 Chong Yidong <cyd@stupidchicken.com> * emacs-lisp/easy-mmode.el (define-minor-mode): Doc fix (Bug#6880). 2010-08-22 Leo <sdl.web@gmail.com> - Fix buffer-list rename&refresh after after killing a buffer in ido. + Fix buffer-list rename&refresh after killing a buffer in ido. * lisp/ido.el: Revert Óscar's. (ido-kill-buffer-at-head): Exit the minibuffer with ido-exit=refresh. Remember the buffers at head, rather than their name. @@ -657,7 +1275,7 @@ * align.el (align-default-spacing): Doc fix. (align-region-heuristic, align-regexp): Fix typos in docstrings. -2010-08-08 Stephen Peters <speters@itasoftware.com> +2010-08-08 Stephen Peters <speters@itasoftware.com> * calendar/icalendar.el (icalendar--split-value): Fixed splitting regexp. (Bug#6766)
--- a/lisp/calc/calc-aent.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/calc/calc-aent.el Wed Sep 08 12:55:57 2010 +0900 @@ -315,10 +315,24 @@ calc-dollar-used 0))) (calc-handle-whys)))) -(defvar calc-alg-ent-map nil +(defvar calc-alg-ent-map + (let ((map (make-sparse-keymap))) + (set-keymap-parent map minibuffer-local-map) + (define-key map "'" 'calcAlg-previous) + (define-key map "`" 'calcAlg-edit) + (define-key map "\C-m" 'calcAlg-enter) + (define-key map "\C-j" 'calcAlg-enter) + map) "The keymap used for algebraic entry.") -(defvar calc-alg-ent-esc-map nil +(defvar calc-alg-ent-esc-map + (let ((map (make-keymap)) + (i 33)) + (set-keymap-parent map esc-map) + (while (< i 127) + (define-key map (vector i) 'calcAlg-escape) + (setq i (1+ i))) + map) "The keymap used for escapes in algebraic entry.") (defvar calc-alg-exp) @@ -326,19 +340,8 @@ ;;;###autoload (defun calc-do-alg-entry (&optional initial prompt no-normalize history) (let* ((calc-buffer (current-buffer)) - (blink-paren-function 'calcAlg-blink-matching-open) + (blink-matching-check-function 'calcAlg-blink-matching-check) (calc-alg-exp 'error)) - (unless calc-alg-ent-map - (setq calc-alg-ent-map (copy-keymap minibuffer-local-map)) - (define-key calc-alg-ent-map "'" 'calcAlg-previous) - (define-key calc-alg-ent-map "`" 'calcAlg-edit) - (define-key calc-alg-ent-map "\C-m" 'calcAlg-enter) - (define-key calc-alg-ent-map "\C-j" 'calcAlg-enter) - (let ((i 33)) - (setq calc-alg-ent-esc-map (copy-keymap esc-map)) - (while (< i 127) - (aset (nth 1 calc-alg-ent-esc-map) i 'calcAlg-escape) - (setq i (1+ i))))) (define-key calc-alg-ent-map "\e" nil) (if (eq calc-algebraic-mode 'total) (define-key calc-alg-ent-map "\e" calc-alg-ent-esc-map) @@ -430,18 +433,9 @@ exp)) (exit-minibuffer)))) -(defun calcAlg-blink-matching-open () - (let ((rightpt (point)) - (leftpt nil) - (rightchar (preceding-char)) - leftchar - rightsyntax - leftsyntax) - (save-excursion - (condition-case () - (setq leftpt (scan-sexps rightpt -1) - leftchar (char-after leftpt)) - (error nil))) +(defun calcAlg-blink-matching-check (leftpt rightpt) + (let ((rightchar (char-before rightpt)) + (leftchar (if leftpt (char-after leftpt)))) (if (and leftpt (or (and (= rightchar ?\)) (= leftchar ?\[)) @@ -450,20 +444,9 @@ (save-excursion (goto-char leftpt) (looking-at ".+\\(\\.\\.\\|\\\\dots\\|\\\\ldots\\)"))) - (let ((leftsaved (aref (syntax-table) leftchar)) - (rightsaved (aref (syntax-table) rightchar))) - (unwind-protect - (progn - (cond ((= leftchar ?\[) - (aset (syntax-table) leftchar (cons 4 ?\))) - (aset (syntax-table) rightchar (cons 5 ?\[))) - (t - (aset (syntax-table) leftchar (cons 4 ?\])) - (aset (syntax-table) rightchar (cons 5 ?\()))) - (blink-matching-open)) - (aset (syntax-table) leftchar leftsaved) - (aset (syntax-table) rightchar rightsaved))) - (blink-matching-open)))) + ;; [2..5) perfectly valid! + nil + (blink-matching-check-mismatch leftpt rightpt)))) ;;;###autoload (defun calc-alg-digit-entry ()
--- a/lisp/calendar/parse-time.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/calendar/parse-time.el Wed Sep 08 12:55:57 2010 +0900 @@ -220,5 +220,4 @@ (provide 'parse-time) -;; arch-tag: 07066094-45a8-4c68-b307-86195e2c1103 ;;; parse-time.el ends here
--- a/lisp/calendar/time-date.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/calendar/time-date.el Wed Sep 08 12:55:57 2010 +0900 @@ -364,5 +364,4 @@ (provide 'time-date) -;; arch-tag: addcf07b-b20a-465b-af72-550b8ac5190f ;;; time-date.el ends here
--- a/lisp/composite.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/composite.el Wed Sep 08 12:55:57 2010 +0900 @@ -413,27 +413,6 @@ ;;; Automatic character composition. -;; Copied from font-lock.el. -(eval-when-compile - ;; Borrowed from lazy-lock.el. - ;; We use this to preserve or protect things when modifying text properties. - (defmacro save-buffer-state (varlist &rest body) - "Bind variables according to VARLIST and eval BODY restoring buffer state." - `(let* ,(append varlist - '((modified (buffer-modified-p)) (buffer-undo-list t) - (inhibit-read-only t) (inhibit-point-motion-hooks t) - (inhibit-modification-hooks t) - deactivate-mark buffer-file-name buffer-file-truename)) - ,@body - (unless modified - (restore-buffer-modified-p nil)))) - ;; Fixme: This makes bootstrapping fail with this error. - ;; Symbol's function definition is void: eval-defun - ;;(def-edebug-spec save-buffer-state let) - ) - -(put 'save-buffer-state 'lisp-indent-function 1) - ;; These macros must match with C macros LGSTRING_XXX and LGLYPH_XXX in font.h (defsubst lgstring-header (gstring) (aref gstring 0)) (defsubst lgstring-set-header (gstring header) (aset gstring 0 header))
--- a/lisp/desktop.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/desktop.el Wed Sep 08 12:55:57 2010 +0900 @@ -226,7 +226,7 @@ The base name of the file is specified in `desktop-base-file-name'." :type '(repeat directory) :group 'desktop - :version "22.1") + :version "23.2") ; user-emacs-directory added (defcustom desktop-missing-file-warning nil "If non-nil, offer to recreate the buffer of a deleted file.
--- a/lisp/dired.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/dired.el Wed Sep 08 12:55:57 2010 +0900 @@ -3249,12 +3249,16 @@ format, use `\\[universal-argument] \\[dired]'.") (defvar dired-sort-by-date-regexp - (concat "^-[^" dired-ls-sorting-switches - "]*t[^" dired-ls-sorting-switches "]*$") + (concat "\\(\\`\\| \\)-[^- ]*t" + ;; `dired-ls-sorting-switches' after -t overrides -t. + "[^ " dired-ls-sorting-switches "]*" + "\\(\\(\\`\\| +\\)\\(--[^ ]+\\|-[^- t" + dired-ls-sorting-switches "]+\\)\\)* *$") "Regexp recognized by Dired to set `by date' mode.") (defvar dired-sort-by-name-regexp - (concat "^-[^t" dired-ls-sorting-switches "]+$") + (concat "\\`\\(\\(\\`\\| +\\)\\(--[^ ]+\\|" + "-[^- t" dired-ls-sorting-switches "]+\\)\\)* *$") "Regexp recognized by Dired to set `by name' mode.") (defvar dired-sort-inhibit nil @@ -3280,8 +3284,8 @@ (force-mode-line-update))) (defun dired-sort-toggle-or-edit (&optional arg) - "Toggle between sort by date/name and refresh the dired buffer. -With a prefix argument you can edit the current listing switches instead." + "Toggle sorting by date, and refresh the Dired buffer. +With a prefix argument, edit the current listing switches instead." (interactive "P") (when dired-sort-inhibit (error "Cannot sort this dired buffer")) @@ -3292,24 +3296,24 @@ (defun dired-sort-toggle () ;; Toggle between sort by date/name. Reverts the buffer. - (setq dired-actual-switches - (let (case-fold-search) - (if (string-match " " dired-actual-switches) - ;; New toggle scheme: add/remove a trailing " -t" - (if (string-match " -t\\'" dired-actual-switches) - (substring dired-actual-switches 0 (match-beginning 0)) - (concat dired-actual-switches " -t")) - ;; old toggle scheme: look for some 't' switch and add/remove it - (concat - "-l" - (dired-replace-in-string (concat "[-lt" - dired-ls-sorting-switches "]") - "" - dired-actual-switches) - (if (string-match (concat "[t" dired-ls-sorting-switches "]") - dired-actual-switches) - "" - "t"))))) + (let ((sorting-by-date (string-match dired-sort-by-date-regexp + dired-actual-switches)) + ;; Regexp for finding (possibly embedded) -t switches. + (switch-regexp "\\(\\`\\| \\)-\\([a-su-zA-Z]*\\)\\(t\\)\\([^ ]*\\)") + case-fold-search) + ;; Remove the -t switch. + (while (string-match switch-regexp dired-actual-switches) + (if (and (equal (match-string 2 dired-actual-switches) "") + (equal (match-string 4 dired-actual-switches) "")) + ;; Remove a stand-alone -t switch. + (setq dired-actual-switches + (replace-match "" t t dired-actual-switches)) + ;; Remove a switch of the form -XtY for some X and Y. + (setq dired-actual-switches + (replace-match "" t t dired-actual-switches 3)))) + ;; Now, if we weren't sorting by date before, add the -t switch. + (unless sorting-by-date + (setq dired-actual-switches (concat dired-actual-switches " -t")))) (dired-sort-set-modeline) (revert-buffer))
--- a/lisp/disp-table.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/disp-table.el Wed Sep 08 12:55:57 2010 +0900 @@ -110,11 +110,27 @@ ;;;###autoload (defun standard-display-8bit (l h) - "Display characters in the range L to H literally." + "Display characters representing raw bytes in the range L to H literally. + +On a terminal display, each character in the range is displayed +by sending the corresponding byte directly to the terminal. + +On a graphic display, each character in the range is displayed +using the default font by a glyph whose code is the corresponding +byte. + +Note that ASCII printable characters (SPC to TILDA) are displayed +in the default way after this call." (or standard-display-table (setq standard-display-table (make-display-table))) + (if (> h 255) + (setq h 255)) (while (<= l h) - (aset standard-display-table l (if (or (< l ?\s) (>= l 127)) (vector l))) + (if (< l 128) + (aset standard-display-table l + (if (or (< l ?\s) (= l 127)) (vector l))) + (let ((c (unibyte-char-to-multibyte l))) + (aset standard-display-table c (vector c)))) (setq l (1+ l)))) ;;;###autoload @@ -236,9 +252,12 @@ (and (null arg) (char-table-p standard-display-table) ;; Test 161, because 160 displays as a space. - (equal (aref standard-display-table 161) [161]))) + (equal (aref standard-display-table + (unibyte-char-to-multibyte 161)) + (vector (unibyte-char-to-multibyte 161))))) (progn - (standard-display-default 160 255) + (standard-display-default + (unibyte-char-to-multibyte 160) (unibyte-char-to-multibyte 255)) (unless (or (memq window-system '(x w32 ns))) (and (terminal-coding-system) (set-terminal-coding-system nil))))
--- a/lisp/electric.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/electric.el Wed Sep 08 12:55:57 2010 +0900 @@ -24,10 +24,23 @@ ;;; Commentary: -; zaaaaaaap +;; "Electric" has been used in Emacs to refer to different things. +;; Among them: +;; +;; - electric modes and buffers: modes that typically pop-up in a modal kind of +;; way a transient buffer that automatically disappears as soon as the user +;; is done with it. +;; +;; - electric keys: self inserting keys which additionally perform some side +;; operation which happens to be often convenient at that time. Examples of +;; such side operations are: reindenting code, inserting a newline, +;; ... auto-fill-mode and abbrev-mode can be considered as built-in forms of +;; electric key behavior. ;;; Code: +(eval-when-compile (require 'cl)) + ;; This loop is the guts for non-standard modes which retain control ;; until some event occurs. It is a `do-forever', the only way out is ;; to throw. It assumes that you have set up the keymap, window, and @@ -157,6 +170,135 @@ (fit-window-to-buffer win max-height)) win))) +;;; Electric keys. + +(defgroup electricity () + "Electric behavior for self inserting keys." + :group 'editing) + +;; Electric indentation. + +(defvar electric-indent-chars '(?\n) + "Characters that should cause automatic reindentation.") + +(defun electric-indent-post-self-insert-function () + ;; FIXME: This reindents the current line, but what we really want instead is + ;; to reindent the whole affected text. That's the current line for simple + ;; cases, but not all cases. We do take care of the newline case in an + ;; ad-hoc fashion, but there are still missing cases such as the case of + ;; electric-pair-mode wrapping a region with a pair of parens. + ;; There might be a way to get it working by analyzing buffer-undo-list, but + ;; it looks challenging. + (when (and (memq last-command-event electric-indent-chars) + ;; Don't reindent while inserting spaces at beginning of line. + (or (not (memq last-command-event '(?\s ?\t))) + (save-excursion (skip-chars-backward " \t") (not (bolp)))) + ;; Not in a string or comment. + (not (nth 8 (syntax-ppss)))) + ;; For newline, we want to reindent both lines and basically behave like + ;; reindent-then-newline-and-indent (whose code we hence copied). + (when (and (eq last-command-event ?\n) + ;; Don't reindent the previous line if the indentation function + ;; is not a real one. + (not (memq indent-line-function + '(indent-relative indent-relative-maybe))) + ;; Sanity check. + (eq (char-before) last-command-event)) + (let ((pos (copy-marker (1- (point)) t))) + (save-excursion + (goto-char pos) + (indent-according-to-mode) + ;; We are at EOL before the call to indent-according-to-mode, and + ;; after it we usually are as well, but not always. We tried to + ;; address it with `save-excursion' but that uses a normal marker + ;; whereas we need `move after insertion', so we do the + ;; save/restore by hand. + (goto-char pos) + ;; Remove the trailing whitespace after indentation because + ;; indentation may (re)introduce the whitespace. + (delete-horizontal-space t)))) + (indent-according-to-mode))) + +;;;###autoload +(define-minor-mode electric-indent-mode + "Automatically reindent lines of code when inserting particular chars. +`electric-indent-chars' specifies the set of chars that should cause reindentation." + :global t + :group 'electricity + (if electric-indent-mode + (add-hook 'post-self-insert-hook + #'electric-indent-post-self-insert-function) + (remove-hook 'post-self-insert-hook + #'electric-indent-post-self-insert-function))) + +;; Electric pairing. + +(defcustom electric-pair-skip-self t + "If non-nil, skip char instead of inserting a second closing paren. +When inserting a closing paren character right before the same character, +just skip that character instead, so that hitting ( followed by ) results +in \"()\" rather than \"())\". +This can be convenient for people who find it easier to hit ) than C-f." + :type 'boolean) + +(defun electric-pair-post-self-insert-function () + (let* ((syntax (and (eq (char-before) last-command-event) ; Sanity check. + (char-syntax last-command-event))) + ;; FIXME: when inserting the closer, we should maybe use + ;; self-insert-command, although it may prove tricky running + ;; post-self-insert-hook recursively, and we wouldn't want to trigger + ;; blink-matching-open. + (closer (if (eq syntax ?\() + (cdr (aref (syntax-table) last-command-event)) + last-command-event))) + (cond + ;; Wrap a pair around the active region. + ((and (memq syntax '(?\( ?\" ?\$)) (use-region-p)) + (if (> (mark) (point)) + (goto-char (mark)) + ;; We already inserted the open-paren but at the end of the region, + ;; so we have to remove it and start over. + (delete-char -1) + (save-excursion + (goto-char (mark)) + (insert last-command-event))) + (insert closer)) + ;; Backslash-escaped: no pairing, no skipping. + ((save-excursion + (goto-char (1- (point))) + (not (zerop (% (skip-syntax-backward "\\") 2)))) + nil) + ;; Skip self. + ((and (memq syntax '(?\) ?\" ?\$)) + electric-pair-skip-self + (eq (char-after) last-command-event)) + ;; This is too late: rather than insert&delete we'd want to only skip (or + ;; insert in overwrite mode). The difference is in what goes in the + ;; undo-log and in the intermediate state which might be visible to other + ;; post-self-insert-hook. We'll just have to live with it for now. + (delete-char 1)) + ;; Insert matching pair. + ((not (or (not (memq syntax `(?\( ?\" ?\$))) + overwrite-mode + ;; I find it more often preferable not to pair when the + ;; same char is next. + (eq last-command-event (char-after)) + (eq last-command-event (char-before (1- (point)))) + ;; I also find it often preferable not to pair next to a word. + (eq (char-syntax (following-char)) ?w))) + (save-excursion (insert closer)))))) + +;;;###autoload +(define-minor-mode electric-pair-mode + "Automatically pair-up parens when inserting an open paren." + :global t + :group 'electricity + (if electric-pair-mode + (add-hook 'post-self-insert-hook + #'electric-pair-post-self-insert-function) + (remove-hook 'post-self-insert-hook + #'electric-pair-post-self-insert-function))) + (provide 'electric) ;; arch-tag: dae045eb-dc2d-4fb7-9f27-9cc2ce277be8
--- a/lisp/emacs-lisp/byte-run.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/emacs-lisp/byte-run.el Wed Sep 08 12:55:57 2010 +0900 @@ -66,7 +66,6 @@ ;; Redefined in byte-optimize.el. ;; This is not documented--it's not clear that we should promote it. (fset 'inline 'progn) -(put 'inline 'lisp-indent-function 0) ;;; Interface to inline functions.
--- a/lisp/emacs-lisp/cl-compat.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/emacs-lisp/cl-compat.el Wed Sep 08 12:55:57 2010 +0900 @@ -71,11 +71,6 @@ ;;; by capitalizing the first letter: Values, Multiple-value-*, ;;; to avoid conflict with the new-style definitions in cl-macs. -(put 'Multiple-value-bind 'lisp-indent-function 2) -(put 'Multiple-value-setq 'lisp-indent-function 2) -(put 'Multiple-value-call 'lisp-indent-function 1) -(put 'Multiple-value-prog1 'lisp-indent-function 1) - (defvar *mvalues-values* nil) (defun Values (&rest val-forms) @@ -91,18 +86,22 @@ (list *mvalues-temp*)))) (defmacro Multiple-value-call (function &rest args) + (declare (indent 1)) (list 'apply function (cons 'append (mapcar (function (lambda (x) (list 'Multiple-value-list x))) args)))) (defmacro Multiple-value-bind (vars form &rest body) + (declare (indent 2)) (list* 'multiple-value-bind vars (list 'Multiple-value-list form) body)) (defmacro Multiple-value-setq (vars form) + (declare (indent 2)) (list 'multiple-value-setq vars (list 'Multiple-value-list form))) (defmacro Multiple-value-prog1 (form &rest body) + (declare (indent 1)) (list 'prog1 form (list* 'let '((*mvalues-values* nil)) body)))
--- a/lisp/emacs-lisp/cl-loaddefs.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/emacs-lisp/cl-loaddefs.el Wed Sep 08 12:55:57 2010 +0900 @@ -282,7 +282,7 @@ ;;;;;; do-all-symbols do-symbols dotimes dolist do* do loop return-from ;;;;;; return block etypecase typecase ecase case load-time-value ;;;;;; eval-when destructuring-bind function* defmacro* defun* gentemp -;;;;;; gensym) "cl-macs" "cl-macs.el" "c5a12d86541b5137054eccc43e4fc839") +;;;;;; gensym) "cl-macs" "cl-macs.el" "c10b5cbebb5267291ef15c782c0271a6") ;;; Generated autoloads from cl-macs.el (autoload 'gensym "cl-macs" "\ @@ -754,7 +754,7 @@ ;;;;;; find nsubstitute-if-not nsubstitute-if nsubstitute substitute-if-not ;;;;;; substitute-if substitute delete-duplicates remove-duplicates ;;;;;; delete-if-not delete-if delete* remove-if-not remove-if remove* -;;;;;; replace fill reduce) "cl-seq" "cl-seq.el" "8f4ba525c894365101b9a53905db94ba") +;;;;;; replace fill reduce) "cl-seq" "cl-seq.el" "7b7531276ddf8457abecdd487d3cf0b7") ;;; Generated autoloads from cl-seq.el (autoload 'reduce "cl-seq" "\
--- a/lisp/emacs-lisp/cl-macs.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/emacs-lisp/cl-macs.el Wed Sep 08 12:55:57 2010 +0900 @@ -1819,8 +1819,6 @@ (defsetf window-start set-window-start) (defsetf window-width () (store) (list 'progn (list 'enlarge-window (list '- store '(window-width)) t) store)) -(defsetf x-get-cutbuffer x-store-cutbuffer t) -(defsetf x-get-cut-buffer x-store-cut-buffer t) ; groan. (defsetf x-get-secondary-selection x-own-secondary-selection t) (defsetf x-get-selection x-own-selection t)
--- a/lisp/emacs-lisp/cl-seq.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/emacs-lisp/cl-seq.el Wed Sep 08 12:55:57 2010 +0900 @@ -48,6 +48,7 @@ ;;; this file independent from cl-macs. (defmacro cl-parsing-keywords (kwords other-keys &rest body) + (declare (indent 2) (debug (sexp sexp &rest form))) (cons 'let* (cons (mapcar @@ -84,13 +85,13 @@ (car cl-keys-temp))) '(setq cl-keys-temp (cdr (cdr cl-keys-temp))))))) body)))) -(put 'cl-parsing-keywords 'lisp-indent-function 2) -(put 'cl-parsing-keywords 'edebug-form-spec '(sexp sexp &rest form)) (defmacro cl-check-key (x) + (declare (debug edebug-forms)) (list 'if 'cl-key (list 'funcall 'cl-key x) x)) (defmacro cl-check-test-nokey (item x) + (declare (debug edebug-forms)) (list 'cond (list 'cl-test (list 'eq (list 'not (list 'funcall 'cl-test item x)) @@ -101,20 +102,17 @@ (list 'equal item x) (list 'eq item x))))) (defmacro cl-check-test (item x) + (declare (debug edebug-forms)) (list 'cl-check-test-nokey item (list 'cl-check-key x))) (defmacro cl-check-match (x y) + (declare (debug edebug-forms)) (setq x (list 'cl-check-key x) y (list 'cl-check-key y)) (list 'if 'cl-test (list 'eq (list 'not (list 'funcall 'cl-test x y)) 'cl-test-not) (list 'if (list 'numberp x) (list 'equal x y) (list 'eq x y)))) -(put 'cl-check-key 'edebug-form-spec 'edebug-forms) -(put 'cl-check-test 'edebug-form-spec 'edebug-forms) -(put 'cl-check-test-nokey 'edebug-form-spec 'edebug-forms) -(put 'cl-check-match 'edebug-form-spec 'edebug-forms) - (defvar cl-test) (defvar cl-test-not) (defvar cl-if) (defvar cl-if-not) (defvar cl-key)
--- a/lisp/emacs-lisp/debug.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/emacs-lisp/debug.el Wed Sep 08 12:55:57 2010 +0900 @@ -514,9 +514,9 @@ (insert ? ))) (beginning-of-line)) -(put 'debugger-env-macro 'lisp-indent-function 0) (defmacro debugger-env-macro (&rest body) "Run BODY in original environment." + (declare (indent 0)) `(save-excursion (if (null (buffer-name debugger-old-buffer)) ;; old buffer deleted
--- a/lisp/emacs-lisp/easymenu.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/emacs-lisp/easymenu.el Wed Sep 08 12:55:57 2010 +0900 @@ -44,8 +44,6 @@ (if (stringp s) (intern s) s)) ;;;###autoload -(put 'easy-menu-define 'lisp-indent-function 'defun) -;;;###autoload (defmacro easy-menu-define (symbol maps doc menu) "Define a menu bar submenu in maps MAPS, according to MENU. @@ -151,6 +149,7 @@ as a solid horizontal line. A menu item can be a list with the same format as MENU. This is a submenu." + (declare (indent defun)) `(progn ,(if symbol `(defvar ,symbol nil ,doc)) (easy-menu-do-define (quote ,symbol) ,maps ,doc ,menu)))
--- a/lisp/emacs-lisp/eieio.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/emacs-lisp/eieio.el Wed Sep 08 12:55:57 2010 +0900 @@ -1610,6 +1610,7 @@ Where each VAR is the local variable given to the associated SLOT. A slot specified without a variable name is given a variable name of the same name as the slot." + (declare (indent 2)) ;; Transform the spec-list into a symbol-macrolet spec-list. (let ((mappings (mapcar (lambda (entry) (let ((var (if (listp entry) (car entry) entry)) @@ -1618,8 +1619,6 @@ spec-list))) (append (list 'symbol-macrolet mappings) body))) -(put 'with-slots 'lisp-indent-function 2) - ;;; Simple generators, and query functions. None of these would do ;; well embedded into an object.
--- a/lisp/emacs-lisp/lisp-mnt.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/emacs-lisp/lisp-mnt.el Wed Sep 08 12:55:57 2010 +0900 @@ -298,6 +298,7 @@ (defmacro lm-with-file (file &rest body) "Execute BODY in a buffer containing the contents of FILE. If FILE is nil, execute BODY in the current buffer." + (declare (indent 1) (debug t)) (let ((filesym (make-symbol "file"))) `(let ((,filesym ,file)) (if ,filesym @@ -311,9 +312,6 @@ (with-syntax-table emacs-lisp-mode-syntax-table ,@body)))))) -(put 'lm-with-file 'lisp-indent-function 1) -(put 'lm-with-file 'edebug-form-spec t) - ;; Fixme: Probably this should be amalgamated with copyright.el; also ;; we need a check for ranges in copyright years.
--- a/lisp/emacs-lisp/lisp-mode.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/emacs-lisp/lisp-mode.el Wed Sep 08 12:55:57 2010 +0900 @@ -1210,31 +1210,17 @@ (put 'prog2 'lisp-indent-function 2) (put 'save-excursion 'lisp-indent-function 0) (put 'save-window-excursion 'lisp-indent-function 0) -(put 'save-selected-window 'lisp-indent-function 0) (put 'save-restriction 'lisp-indent-function 0) (put 'save-match-data 'lisp-indent-function 0) (put 'save-current-buffer 'lisp-indent-function 0) -(put 'with-current-buffer 'lisp-indent-function 1) -(put 'combine-after-change-calls 'lisp-indent-function 0) -(put 'with-output-to-string 'lisp-indent-function 0) -(put 'with-temp-file 'lisp-indent-function 1) -(put 'with-temp-buffer 'lisp-indent-function 0) -(put 'with-temp-message 'lisp-indent-function 1) -(put 'with-syntax-table 'lisp-indent-function 1) (put 'let 'lisp-indent-function 1) (put 'let* 'lisp-indent-function 1) (put 'while 'lisp-indent-function 1) (put 'if 'lisp-indent-function 2) -(put 'read-if 'lisp-indent-function 2) (put 'catch 'lisp-indent-function 1) (put 'condition-case 'lisp-indent-function 2) (put 'unwind-protect 'lisp-indent-function 1) (put 'with-output-to-temp-buffer 'lisp-indent-function 1) -(put 'eval-after-load 'lisp-indent-function 1) -(put 'dolist 'lisp-indent-function 1) -(put 'dotimes 'lisp-indent-function 1) -(put 'when 'lisp-indent-function 1) -(put 'unless 'lisp-indent-function 1) (defun indent-sexp (&optional endpos) "Indent each line of the list starting just after point.
--- a/lisp/emacs-lisp/package.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/emacs-lisp/package.el Wed Sep 08 12:55:57 2010 +0900 @@ -260,8 +260,9 @@ ;; Defaults are subdirs named "elpa" in the site-lisp dirs. (let (result) (dolist (f load-path) - (if (equal (file-name-nondirectory f) "site-lisp") - (push (expand-file-name "elpa" f) result))) + (and (stringp f) + (equal (file-name-nondirectory f) "site-lisp") + (push (expand-file-name "elpa" f) result))) (nreverse result)) "List of additional directories containing Emacs Lisp packages. Each directory name should be absolute. @@ -406,16 +407,15 @@ (error "Internal error: could not find directory for %s-%s" name version-str)) ;; Add info node. - (if (file-exists-p (expand-file-name "dir" pkg-dir)) - (progn - ;; FIXME: not the friendliest, but simple. - (require 'info) - (info-initialize) - (setq Info-directory-list (cons pkg-dir Info-directory-list)))) + (when (file-exists-p (expand-file-name "dir" pkg-dir)) + ;; FIXME: not the friendliest, but simple. + (require 'info) + (info-initialize) + (push pkg-dir Info-directory-list)) ;; Add to load path, add autoloads, and activate the package. - (setq load-path (cons pkg-dir load-path)) + (push pkg-dir load-path) (load (expand-file-name (concat name "-autoloads") pkg-dir) nil t) - (setq package-activated-list (cons package package-activated-list)) + (push package package-activated-list) ;; Don't return nil. t)) @@ -466,22 +466,22 @@ (setcdr elt (cons (cons (package-desc-vers pkg-vec) pkg-vec) (cdr elt)))) ;; Make a new association. - (setq package-obsolete-alist - (cons (cons package (list (cons (package-desc-vers pkg-vec) - pkg-vec))) - package-obsolete-alist))))) + (push (cons package (list (cons (package-desc-vers pkg-vec) + pkg-vec))) + package-obsolete-alist)))) -;; (define-package "emacs" "21.4.1" "GNU Emacs core package.") -;; (define-package "erc" "5.1" "ERC - irc client" '((emacs "21.0"))) (defun define-package (name-str version-string - &optional docstring requirements) + &optional docstring requirements + &rest extra-properties) "Define a new package. NAME is the name of the package, a string. VERSION-STRING is the version of the package, a dotted sequence of integers. DOCSTRING is the optional description. REQUIREMENTS is a list of requirements on other packages. -Each requirement is of the form (OTHER-PACKAGE \"VERSION\")." +Each requirement is of the form (OTHER-PACKAGE \"VERSION\"). + +EXTRA-PROPERTIES is currently unused." (let* ((name (intern name-str)) (pkg-desc (assq name package-alist)) (new-version (version-to-list version-string)) @@ -504,7 +504,7 @@ (setq package-alist (delq pkg-desc package-alist)) (package-mark-obsolete (car pkg-desc) (cdr pkg-desc))) ;; Add package to the alist. - (setq package-alist (cons new-pkg-desc package-alist))) + (push new-pkg-desc package-alist)) ;; You can have two packages with the same version, for instance ;; one in the system package directory and one in your private ;; directory. We just let the first one win. @@ -706,7 +706,7 @@ (package-version-join (package-desc-vers (cdr pkg-desc))))) ;; Only add to the transaction if we don't already have it. (unless (memq next-pkg package-list) - (setq package-list (cons next-pkg package-list))) + (push next-pkg package-list)) (setq package-list (package-compute-transaction package-list (package-desc-reqs @@ -717,13 +717,13 @@ "Read a Lisp expression from STR. Signal an error if the entire string was not used." (let* ((read-data (read-from-string str)) - (more-left - (condition-case nil - ;; The call to `ignore' suppresses a compiler warning. - (progn (ignore (read-from-string - (substring str (cdr read-data)))) - t) - (end-of-file nil)))) + (more-left + (condition-case nil + ;; The call to `ignore' suppresses a compiler warning. + (progn (ignore (read-from-string + (substring str (cdr read-data)))) + t) + (end-of-file nil)))) (if more-left (error "Can't read whole string") (car read-data)))) @@ -733,16 +733,14 @@ Will return the data from the file, or nil if the file does not exist. Will throw an error if the archive version is too new." (let ((filename (expand-file-name file package-user-dir))) - (if (file-exists-p filename) - (with-temp-buffer - (insert-file-contents-literally filename) - (let ((contents (package-read-from-string - (buffer-substring-no-properties (point-min) - (point-max))))) - (if (> (car contents) package-archive-version) - (error "Package archive version %d is greater than %d - upgrade package.el" - (car contents) package-archive-version)) - (cdr contents)))))) + (when (file-exists-p filename) + (with-temp-buffer + (insert-file-contents-literally filename) + (let ((contents (read (current-buffer)))) + (if (> (car contents) package-archive-version) + (error "Package archive version %d is higher than %d" + (car contents) package-archive-version)) + (cdr contents)))))) (defun package-read-all-archive-contents () "Re-read `archive-contents', if it exists. @@ -751,18 +749,17 @@ (package-read-archive-contents (car archive)))) (defun package-read-archive-contents (archive) - "Re-read `archive-contents' and `builtin-packages' for ARCHIVE. -If successful, set `package-archive-contents' and `package--builtins'. + "Re-read archive contents for ARCHIVE. +If successful, set the variable `package-archive-contents'. If the archive version is too new, signal an error." - (let ((archive-contents (package--read-archive-file - (concat "archives/" archive - "/archive-contents")))) - (if archive-contents - ;; Version 1 of 'archive-contents' is identical to our - ;; internal representation. - ;; TODO: merge archive lists - (dolist (package archive-contents) - (package--add-to-archive-contents package archive))))) + ;; Version 1 of 'archive-contents' is identical to our internal + ;; representation. + (let* ((dir (concat "archives/" archive)) + (contents-file (concat dir "/archive-contents")) + contents) + (when (setq contents (package--read-archive-file contents-file)) + (dolist (package contents) + (package--add-to-archive-contents package archive))))) (defun package--add-to-archive-contents (package archive) "Add the PACKAGE from the given ARCHIVE if necessary. @@ -833,61 +830,60 @@ v-str)))) (defun package-buffer-info () - "Return a vector of information about the package in the current buffer. -The vector looks like [FILENAME REQUIRES DESCRIPTION VERSION COMMENTARY] -FILENAME is the file name, a string. It does not have the \".el\" extension. + "Return a vector describing the package in the current buffer. +The vector has the form + + [FILENAME REQUIRES DESCRIPTION VERSION COMMENTARY] + +FILENAME is the file name, a string, sans the \".el\" extension. REQUIRES is a requires list, or nil. -DESCRIPTION is the package description (a string). +DESCRIPTION is the package description, a string. VERSION is the version, a string. COMMENTARY is the commentary section, a string, or nil if none. -Throws an exception if the buffer does not contain a conforming package. -If there is a package, narrows the buffer to the file's boundaries. -May narrow buffer or move point even on failure." + +If the buffer does not contain a conforming package, signal an +error. If there is a package, narrow the buffer to the file's +boundaries." (goto-char (point-min)) - (if (re-search-forward "^;;; \\([^ ]*\\)\\.el --- \\(.*\\)$" nil t) - (let ((file-name (match-string 1)) - (desc (match-string 2)) - (start (progn (beginning-of-line) (point)))) - (if (search-forward (concat ";;; " file-name ".el ends here")) - (progn - ;; Try to include a trailing newline. - (forward-line) - (narrow-to-region start (point)) - (require 'lisp-mnt) - ;; Use some headers we've invented to drive the process. - (let* ((requires-str (lm-header "package-requires")) - (requires (if requires-str - (package-read-from-string requires-str))) - ;; Prefer Package-Version, because if it is - ;; defined the package author probably wants us - ;; to use it. Otherwise try Version. - (pkg-version - (or (package-strip-rcs-id (lm-header "package-version")) - (package-strip-rcs-id (lm-header "version")))) - (commentary (lm-commentary))) - (unless pkg-version - (error - "Package does not define a usable \"Version\" or \"Package-Version\" header")) - ;; Turn string version numbers into list form. - (setq requires - (mapcar - (lambda (elt) - (list (car elt) - (version-to-list (car (cdr elt))))) - requires)) - (set-text-properties 0 (length file-name) nil file-name) - (set-text-properties 0 (length pkg-version) nil pkg-version) - (set-text-properties 0 (length desc) nil desc) - (vector file-name requires desc pkg-version commentary))) - (error "Package missing a terminating comment"))) - (error "No starting comment for package"))) + (unless (re-search-forward "^;;; \\([^ ]*\\)\\.el --- \\(.*\\)$" nil t) + (error "Packages lacks a file header")) + (let ((file-name (match-string-no-properties 1)) + (desc (match-string-no-properties 2)) + (start (line-beginning-position))) + (unless (search-forward (concat ";;; " file-name ".el ends here")) + (error "Package lacks a terminating comment")) + ;; Try to include a trailing newline. + (forward-line) + (narrow-to-region start (point)) + (require 'lisp-mnt) + ;; Use some headers we've invented to drive the process. + (let* ((requires-str (lm-header "package-requires")) + (requires (if requires-str + (package-read-from-string requires-str))) + ;; Prefer Package-Version; if defined, the package author + ;; probably wants us to use it. Otherwise try Version. + (pkg-version + (or (package-strip-rcs-id (lm-header "package-version")) + (package-strip-rcs-id (lm-header "version")))) + (commentary (lm-commentary))) + (unless pkg-version + (error + "Package lacks a \"Version\" or \"Package-Version\" header")) + ;; Turn string version numbers into list form. + (setq requires + (mapcar + (lambda (elt) + (list (car elt) + (version-to-list (car (cdr elt))))) + requires)) + (vector file-name requires desc pkg-version commentary)))) (defun package-tar-file-info (file) "Find package information for a tar file. FILE is the name of the tar file to examine. The return result is a vector like `package-buffer-info'." (unless (string-match "^\\(.+\\)-\\([0-9.]+\\)\\.tar$" file) - (error "`%s' doesn't have a package-ish name" file)) + (error "Invalid package name `%s'" file)) (let* ((pkg-name (file-name-nondirectory (match-string-no-properties 1 file))) (pkg-version (match-string-no-properties 2 file)) ;; Extract the package descriptor. @@ -898,20 +894,19 @@ pkg-name "-pkg.el"))) (pkg-def-parsed (package-read-from-string pkg-def-contents))) (unless (eq (car pkg-def-parsed) 'define-package) - (error "%s-pkg.el doesn't contain `define-package' sexp" pkg-name)) - (let ((name-str (nth 1 pkg-def-parsed)) + (error "No `define-package' sexp is present in `%s-pkg.el'" pkg-name)) + (let ((name-str (nth 1 pkg-def-parsed)) (version-string (nth 2 pkg-def-parsed)) - (docstring (nth 3 pkg-def-parsed)) - (requires (nth 4 pkg-def-parsed)) - + (docstring (nth 3 pkg-def-parsed)) + (requires (nth 4 pkg-def-parsed)) (readme (shell-command-to-string ;; Requires GNU tar. (concat "tar -xOf " file " " pkg-name "-" pkg-version "/README")))) (unless (equal pkg-version version-string) - (error "Inconsistent versions!")) + (error "Package has inconsistent versions")) (unless (equal pkg-name name-str) - (error "Inconsistent names!")) + (error "Package has inconsistent names")) ;; Kind of a hack. (if (string-match ": Not found in archive" readme) (setq readme nil)) @@ -919,18 +914,27 @@ (if (eq (car requires) 'quote) (setq requires (car (cdr requires)))) (setq requires - (mapcar - (lambda (elt) - (list (car elt) - (version-to-list (car (cdr elt))))) - requires)) + (mapcar (lambda (elt) + (list (car elt) + (version-to-list (cadr elt)))) + requires)) (vector pkg-name requires docstring version-string readme)))) -(defun package-install-buffer-internal (pkg-info type) +;;;###autoload +(defun package-install-from-buffer (pkg-info type) + "Install a package from the current buffer. +When called interactively, the current buffer is assumed to be a +single .el file that follows the packaging guidelines; see info +node `(elisp)Packaging'. + +When called from Lisp, PKG-INFO is a vector describing the +information, of the type returned by `package-buffer-info'; and +TYPE is the package type (either `single' or `tar')." + (interactive (list (package-buffer-info) 'single)) (save-excursion (save-restriction (let* ((file-name (aref pkg-info 0)) - (requires (aref pkg-info 1)) + (requires (aref pkg-info 1)) (desc (if (string= (aref pkg-info 2) "") "No description available." (aref pkg-info 2))) @@ -950,15 +954,6 @@ (package-initialize))))) ;;;###autoload -(defun package-install-from-buffer () - "Install a package from the current buffer. -The package is assumed to be a single .el file which -follows the elisp comment guidelines; see -info node `(elisp)Library Headers'." - (interactive) - (package-install-buffer-internal (package-buffer-info) 'single)) - -;;;###autoload (defun package-install-file (file) "Install a package from a file. The file can either be a tar file or an Emacs Lisp file." @@ -966,9 +961,10 @@ (with-temp-buffer (insert-file-contents-literally file) (cond - ((string-match "\\.el$" file) (package-install-from-buffer)) + ((string-match "\\.el$" file) + (package-install-from-buffer (package-buffer-info) 'single)) ((string-match "\\.tar$" file) - (package-install-buffer-internal (package-tar-file-info file) 'tar)) + (package-install-from-buffer (package-tar-file-info file) 'tar)) (t (error "Unrecognized extension `%s'" (file-name-extension file)))))) (defun package-delete (name version) @@ -995,24 +991,26 @@ (re-search-forward "^$" nil 'move) (forward-char) (delete-region (point-min) (point)) - (make-directory dir t) - (setq buffer-file-name (expand-file-name file dir)) - (let ((version-control 'never)) - (save-buffer))) + ;; Read the retrieved buffer to make sure it is valid (e.g. it + ;; may fetch a URL redirect page). + (when (listp (read buffer)) + (make-directory dir t) + (setq buffer-file-name (expand-file-name file dir)) + (let ((version-control 'never)) + (save-buffer)))) (kill-buffer buffer))) (defun package-refresh-contents () "Download the ELPA archive description if needed. -Invoking this will ensure that Emacs knows about the latest versions -of all packages. This will let Emacs make them available for -download." +This informs Emacs about the latest versions of all packages, and +makes them available for download." (interactive) (unless (file-exists-p package-user-dir) (make-directory package-user-dir t)) (dolist (archive package-archives) (condition-case nil (package--download-one-archive archive "archive-contents") - (error (message "Failed to download archive `%s'." + (error (message "Failed to download `%s' archive." (car archive))))) (package-read-all-archive-contents)) @@ -1198,7 +1196,7 @@ (define-key map "\177" 'package-menu-backup-unmark) (define-key map "d" 'package-menu-mark-delete) (define-key map "i" 'package-menu-mark-install) - (define-key map "g" 'package-menu-revert) + (define-key map "g" 'revert-buffer) (define-key map "r" 'package-menu-refresh) (define-key map "~" 'package-menu-mark-obsolete-for-deletion) (define-key map "x" 'package-menu-execute) @@ -1232,7 +1230,7 @@ :help "Mark a package for installation and move to the next line")) (define-key menu-map [s3] '("--")) (define-key menu-map [mg] - '(menu-item "Update package list" package-menu-revert + '(menu-item "Update package list" revert-buffer :help "Update the list of packages")) (define-key menu-map [mr] '(menu-item "Refresh package list" package-menu-refresh @@ -1275,24 +1273,51 @@ (setq mode-name "Package Menu") (setq truncate-lines t) (setq buffer-read-only t) - ;; Support Emacs 21. - (if (fboundp 'run-mode-hooks) - (run-mode-hooks 'package-menu-mode-hook) - (run-hooks 'package-menu-mode-hook))) + (setq revert-buffer-function 'package-menu-revert) + (setq header-line-format + (mapconcat + (lambda (pair) + (let ((column (car pair)) + (name (cdr pair))) + (concat + ;; Insert a space that aligns the button properly. + (propertize " " 'display (list 'space :align-to column) + 'face 'fixed-pitch) + ;; Set up the column button. + (propertize name + 'column-name name + 'help-echo "mouse-1: sort by column" + 'mouse-face 'highlight + 'keymap package-menu-sort-button-map)))) + ;; We take a trick from buff-menu and have a dummy leading + ;; space to align the header line with the beginning of the + ;; text. This doesn't really work properly on Emacs 21, but + ;; it is close enough. + '((0 . "") + (2 . "Package") + (20 . "Version") + (32 . "Status") + (43 . "Description")) + "")) + (run-mode-hooks 'package-menu-mode-hook)) (defun package-menu-refresh () - "Download the ELPA archive. -This fetches the file describing the current contents of -the Emacs Lisp Package Archive, and then refreshes the -package menu. This lets you see what new packages are -available for download." + "Download the Emacs Lisp package archive. +This fetches the contents of each archive specified in +`package-archives', and then refreshes the package menu." (interactive) + (unless (eq major-mode 'package-menu-mode) + (error "The current buffer is not a Package Menu")) (package-refresh-contents) (package--generate-package-list)) -(defun package-menu-revert () - "Update the list of packages." +(defun package-menu-revert (&optional arg noconfirm) + "Update the list of packages. +This function is the `revert-buffer-function' for Package Menu +buffers. The arguments are ignored." (interactive) + (unless (eq major-mode 'package-menu-mode) + (error "The current buffer is not a Package Menu")) (package--generate-package-list)) (defun package-menu-describe-package () @@ -1434,100 +1459,102 @@ (defun package-list-maybe-add (package version status description result) (unless (assoc (cons package version) result) - (setq result (cons (list (cons package version) status description) - result))) + (push (list (cons package version) status description) result)) result) -;; This decides how we should sort; nil means by package name. -(defvar package-menu-sort-key nil) +(defvar package-menu-package-list nil + "List of packages to display in the Package Menu buffer. +A value of nil means to display all packages.") -(defun package--generate-package-list (&optional packages) - (package-initialize) ; FIXME: do this here? - (with-current-buffer (get-buffer-create "*Packages*") +(defvar package-menu-sort-key nil + "Sort key for the current Package Menu buffer.") + +(defun package--generate-package-list () + "Populate the current Package Menu buffer." + (package-initialize) + (let ((inhibit-read-only t) + info-list name desc hold builtin) (setq buffer-read-only nil) (erase-buffer) - (let ((info-list) - name desc hold - builtin) - ;; List installed packages - (dolist (elt package-alist) - (setq name (car elt)) - (when (and (not (eq name 'emacs)) ; Hide the `emacs' package. - (or (null packages) - (memq name packages))) - (setq desc (cdr elt) - hold (cadr (assq name package-load-list)) - builtin (cdr (assq name package--builtins))) - (setq info-list - (package-list-maybe-add - name (package-desc-vers desc) - ;; FIXME: it turns out to be tricky to see if this - ;; package is presently activated. - (cond ((stringp hold) "held") - ((and builtin - (version-list-= - (package-desc-vers builtin) - (package-desc-vers desc))) - "built-in") - (t "installed")) - (package-desc-doc desc) - info-list)))) + ;; List installed packages + (dolist (elt package-alist) + (setq name (car elt)) + (when (and (not (eq name 'emacs)) ; Hide the `emacs' package. + (or (null package-menu-package-list) + (memq name package-menu-package-list))) + (setq desc (cdr elt) + hold (cadr (assq name package-load-list)) + builtin (cdr (assq name package--builtins))) + (setq info-list + (package-list-maybe-add + name (package-desc-vers desc) + ;; FIXME: it turns out to be tricky to see if this + ;; package is presently activated. + (cond ((stringp hold) "held") + ((and builtin + (version-list-= + (package-desc-vers builtin) + (package-desc-vers desc))) + "built-in") + (t "installed")) + (package-desc-doc desc) + info-list)))) - ;; List available and disabled packages - (dolist (elt package-archive-contents) - (setq name (car elt) - desc (cdr elt) - hold (assq name package-load-list)) - (when (or (null packages) - (memq name packages)) - (setq info-list - (package-list-maybe-add name - (package-desc-vers desc) - (if (and hold (null (cadr hold))) - "disabled" - "available") - (package-desc-doc (cdr elt)) - info-list)))) - ;; List obsolete packages - (mapc (lambda (elt) - (mapc (lambda (inner-elt) - (setq info-list - (package-list-maybe-add (car elt) - (package-desc-vers - (cdr inner-elt)) - "obsolete" - (package-desc-doc - (cdr inner-elt)) - info-list))) - (cdr elt))) - package-obsolete-alist) + ;; List available and disabled packages + (dolist (elt package-archive-contents) + (setq name (car elt) + desc (cdr elt) + hold (assq name package-load-list)) + (when (or (null package-menu-package-list) + (memq name package-menu-package-list)) + (setq info-list + (package-list-maybe-add name + (package-desc-vers desc) + (if (and hold (null (cadr hold))) + "disabled" + "available") + (package-desc-doc (cdr elt)) + info-list)))) + ;; List obsolete packages + (mapc (lambda (elt) + (mapc (lambda (inner-elt) + (setq info-list + (package-list-maybe-add (car elt) + (package-desc-vers + (cdr inner-elt)) + "obsolete" + (package-desc-doc + (cdr inner-elt)) + info-list))) + (cdr elt))) + package-obsolete-alist) - (setq info-list - (sort info-list - (cond ((string= package-menu-sort-key "Version") - 'package-menu--version-predicate) - ((string= package-menu-sort-key "Status") - 'package-menu--status-predicate) - ((string= package-menu-sort-key "Description") - 'package-menu--description-predicate) - (t ; Sort by package name by default - 'package-menu--name-predicate)))) + (setq info-list + (sort info-list + (cond ((string= package-menu-sort-key "Package") + 'package-menu--name-predicate) + ((string= package-menu-sort-key "Version") + 'package-menu--version-predicate) + ((string= package-menu-sort-key "Description") + 'package-menu--description-predicate) + (t ; By default, sort by package status + 'package-menu--status-predicate)))) - (dolist (elt info-list) - (package-print-package (car (car elt)) - (cdr (car elt)) - (car (cdr elt)) - (car (cdr (cdr elt)))))) + (dolist (elt info-list) + (package-print-package (car (car elt)) + (cdr (car elt)) + (car (cdr elt)) + (car (cdr (cdr elt))))) (goto-char (point-min)) (set-buffer-modified-p nil) (current-buffer))) (defun package-menu--version-predicate (left right) - (let ((vleft (cdr (car left))) - (vright (cdr (car right)))) - (if (version-list-= vleft right) + (let ((vleft (or (cdr (car left)) '(0))) + (vright (or (cdr (car right)) '(0)))) + (if (version-list-= vleft vright) (package-menu--name-predicate left right) - (version-list-< left right)))) + (version-list-< vleft vright)))) (defun package-menu--status-predicate (left right) (let ((sleft (cadr left)) @@ -1558,53 +1585,28 @@ (symbol-name (caar right)))) (defun package-menu-sort-by-column (&optional e) - "Sort the package menu by the last column clicked on." + "Sort the package menu by the column of the mouse click E." (interactive "e") - (if e (mouse-select-window e)) (let* ((pos (event-start e)) - (obj (posn-object pos)) - (col (if obj - (get-text-property (cdr obj) 'column-name (car obj)) - (get-text-property (posn-point pos) 'column-name))) - (inhibit-read-only t)) - (setq package-menu-sort-key col) - (package--generate-package-list))) + (obj (posn-object pos)) + (col (if obj + (get-text-property (cdr obj) 'column-name (car obj)) + (get-text-property (posn-point pos) 'column-name))) + (buf (window-buffer (posn-window (event-start e))))) + (with-current-buffer buf + (when (eq major-mode 'package-menu-mode) + (setq package-menu-sort-key col) + (package--generate-package-list))))) (defun package--list-packages (&optional packages) - "Display the properties of PACKAGES. -PACKAGES should be a list of package names (symbols). -If PACKAGES is nil, display all packages in `package-alist'." - (with-current-buffer (package--generate-package-list packages) + "Generate and pop to the *Packages* buffer. +Optional PACKAGES is a list of names of packages (symbols) to +list; the default is to display everything in `package-alist'." + (with-current-buffer (get-buffer-create "*Packages*") (package-menu-mode) - ;; Set up the header line. - (setq header-line-format - (mapconcat - (lambda (pair) - (let ((column (car pair)) - (name (cdr pair))) - (concat - ;; Insert a space that aligns the button properly. - (propertize " " 'display (list 'space :align-to column) - 'face 'fixed-pitch) - ;; Set up the column button. - (if (string= name "Version") - name - (propertize name - 'column-name name - 'help-echo "mouse-1: sort by column" - 'mouse-face 'highlight - 'keymap package-menu-sort-button-map))))) - ;; We take a trick from buff-menu and have a dummy leading - ;; space to align the header line with the beginning of the - ;; text. This doesn't really work properly on Emacs 21, - ;; but it is close enough. - '((0 . "") - (2 . "Package") - (20 . "Version") - (32 . "Status") - (43 . "Description")) - "")) - + (set (make-local-variable 'package-menu-package-list) packages) + (set (make-local-variable 'package-menu-sort-key) nil) + (package--generate-package-list) ;; It's okay to use pop-to-buffer here. The package menu buffer ;; has keybindings, and the user just typed `M-x list-packages', ;; suggesting that they might want to use them. @@ -1617,7 +1619,6 @@ The list is displayed in a buffer named `*Packages*'." (interactive) (package-refresh-contents) - (setq package-menu-sort-key "Status") (package--list-packages)) ;;;###autoload
--- a/lisp/emacs-lisp/pcase.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/emacs-lisp/pcase.el Wed Sep 08 12:55:57 2010 +0900 @@ -290,9 +290,13 @@ (defun pcase-split-memq (elems pat) ;; Based on pcase-split-eq. (cond - ;; The same match will give the same result. + ;; The same match will give the same result, but we don't know how + ;; to check it. + ;; (??? + ;; (cons :pcase-succeed nil)) + ;; A match for one of the elements may succeed or fail. ((and (eq (car-safe pat) '\`) (member (cadr pat) elems)) - (cons :pcase-succeed nil)) + nil) ;; A different match will fail if this one succeeds. ((and (eq (car-safe pat) '\`) ;; (or (integerp (cadr pat)) (symbolp (cadr pat)) @@ -383,18 +387,20 @@ `(,(cadr upat) ,sym) (let* ((exp (cadr upat)) ;; `vs' is an upper bound on the vars we need. - (vs (pcase-fgrep (mapcar #'car vars) exp))) - (if vs - ;; Let's not replace `vars' in `exp' since it's - ;; too difficult to do it right, instead just - ;; let-bind `vars' around `exp'. - `(let ,(mapcar (lambda (var) - (list var (cdr (assq var vars)))) - vs) - ;; FIXME: `vars' can capture `sym'. E.g. - ;; (pcase x ((and `(,x . ,y) (pred (fun x))))) - (,@exp ,sym)) - `(,@exp ,sym)))) + (vs (pcase-fgrep (mapcar #'car vars) exp)) + (call (if (functionp exp) + `(,exp ,sym) `(,@exp ,sym)))) + (if (null vs) + call + ;; Let's not replace `vars' in `exp' since it's + ;; too difficult to do it right, instead just + ;; let-bind `vars' around `exp'. + `(let ,(mapcar (lambda (var) + (list var (cdr (assq var vars)))) + vs) + ;; FIXME: `vars' can capture `sym'. E.g. + ;; (pcase x ((and `(,x . ,y) (pred (fun x))))) + ,call)))) (pcase-u1 matches code vars then-rest) (pcase-u else-rest)))) ((symbolp upat)
--- a/lisp/emacs-lisp/rx.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/emacs-lisp/rx.el Wed Sep 08 12:55:57 2010 +0900 @@ -427,7 +427,7 @@ (mapcar (lambda (e) (cond ((= (car e) (cdr e)) (list (car e))) - ;; ((= (1+ (car e)) (cdr e)) (list (car e) (cdr e))) + ((= (1+ (car e)) (cdr e)) (list (car e) (cdr e))) ((list e)))) l)) (delete-dups str)))) @@ -545,7 +545,10 @@ ((numberp e) (string e)) ((consp e) (if (and (= (1+ (car e)) (cdr e)) - (null (memq (car e) '(?\] ?-)))) + ;; rx-any-condense-range should + ;; prevent this case from happening. + (null (memq (car e) '(?\] ?-))) + (null (memq (cdr e) '(?\] ?-)))) (string (car e) (cdr e)) (string (car e) ?- (cdr e)))) (e)))
--- a/lisp/emacs-lisp/smie.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/emacs-lisp/smie.el Wed Sep 08 12:55:57 2010 +0900 @@ -75,6 +75,26 @@ ;;; Building precedence level tables from BNF specs. +;; We have 4 different representations of a "grammar": +;; - a BNF table, which is a list of BNF rules of the form +;; (NONTERM RHS1 ... RHSn) where each RHS is a list of terminals (tokens) +;; or nonterminals. Any element in these lists which does not appear as +;; the `car' of a BNF rule is taken to be a terminal. +;; - A list of precedences (key word "precs"), is a list, sorted +;; from lowest to highest precedence, of precedence classes that +;; have the form (ASSOCIATIVITY TERMINAL1 .. TERMINALn), where +;; ASSOCIATIVITY can be `assoc', `left', `right' or `nonassoc'. +;; - a 2 dimensional precedence table (key word "prec2"), is a 2D +;; table recording the precedence relation (can be `<', `=', `>', or +;; nil) between each pair of tokens. +;; - a precedence-level table (key word "levels"), while is a alist +;; giving for each token its left and right precedence level (a +;; number or nil). This is used in `smie-op-levels'. +;; The prec2 tables are only intermediate data structures: the source +;; code normally provides a mix of BNF and precs tables, and then +;; turns them into a levels table, which is what's used by the rest of +;; the SMIE code. + (defun smie-set-prec2tab (table x y val &optional override) (assert (and x y)) (let* ((key (cons x y)) @@ -206,6 +226,87 @@ (setq rhs (cdr rhs))))) prec2)) +;; (defun smie-prec2-closer-alist (prec2 include-inners) +;; "Build a closer-alist from a PREC2 table. +;; The return value is in the same form as `smie-closer-alist'. +;; INCLUDE-INNERS if non-nil means that inner keywords will be included +;; in the table, e.g. the table will include things like (\"if\" . \"else\")." +;; (let* ((non-openers '()) +;; (non-closers '()) +;; ;; For each keyword, this gives the matching openers, if any. +;; (openers (make-hash-table :test 'equal)) +;; (closers '()) +;; (done nil)) +;; ;; First, find the non-openers and non-closers. +;; (maphash (lambda (k v) +;; (unless (or (eq v '<) (member (cdr k) non-openers)) +;; (push (cdr k) non-openers)) +;; (unless (or (eq v '>) (member (car k) non-closers)) +;; (push (car k) non-closers))) +;; prec2) +;; ;; Then find the openers and closers. +;; (maphash (lambda (k _) +;; (unless (member (car k) non-openers) +;; (puthash (car k) (list (car k)) openers)) +;; (unless (or (member (cdr k) non-closers) +;; (member (cdr k) closers)) +;; (push (cdr k) closers))) +;; prec2) +;; ;; Then collect the matching elements. +;; (while (not done) +;; (setq done t) +;; (maphash (lambda (k v) +;; (when (eq v '=) +;; (let ((aopeners (gethash (car k) openers)) +;; (dopeners (gethash (cdr k) openers)) +;; (new nil)) +;; (dolist (o aopeners) +;; (unless (member o dopeners) +;; (setq new t) +;; (push o dopeners))) +;; (when new +;; (setq done nil) +;; (puthash (cdr k) dopeners openers))))) +;; prec2)) +;; ;; Finally, dump the resulting table. +;; (let ((alist '())) +;; (maphash (lambda (k v) +;; (when (or include-inners (member k closers)) +;; (dolist (opener v) +;; (unless (equal opener k) +;; (push (cons opener k) alist))))) +;; openers) +;; alist))) + +(defun smie-bnf-closer-alist (bnf &optional no-inners) + ;; We can also build this closer-alist table from a prec2 table, + ;; but it takes more work, and the order is unpredictable, which + ;; is a problem for smie-close-block. + ;; More convenient would be to build it from a levels table since we + ;; always have this table (contrary to the BNF), but it has all the + ;; disadvantages of the prec2 case plus the disadvantage that the levels + ;; table has lost some info which would result in extra invalid pairs. + "Build a closer-alist from a BNF table. +The return value is in the same form as `smie-closer-alist'. +NO-INNERS if non-nil means that inner keywords will be excluded +from the table, e.g. the table will not include things like (\"if\" . \"else\")." + (let ((nts (mapcar #'car bnf)) ;non terminals. + (alist '())) + (dolist (nt bnf) + (dolist (rhs (cdr nt)) + (unless (or (< (length rhs) 2) (member (car rhs) nts)) + (if no-inners + (let ((last (car (last rhs)))) + (unless (member last nts) + (pushnew (cons (car rhs) last) alist :test #'equal))) + ;; Reverse so that the "real" closer gets there first, + ;; which is important for smie-close-block. + (dolist (term (reverse (cdr rhs))) + (unless (member term nts) + (pushnew (cons (car rhs) term) alist :test #'equal))))))) + (nreverse alist))) + + (defun smie-prec2-levels (prec2) ;; FIXME: Rather than only return an alist of precedence levels, we should ;; also extract other useful data from it: @@ -223,7 +324,7 @@ `smie-bnf-precedence-table'." ;; For each operator, we create two "variables" (corresponding to ;; the left and right precedence level), which are represented by - ;; cons cells. Those are the vary cons cells that appear in the + ;; cons cells. Those are the very cons cells that appear in the ;; final `table'. The value of each "variable" is kept in the `car'. (let ((table ()) (csts ()) @@ -560,6 +661,117 @@ (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))))))) + +(defvar smie-blink-matching-triggers '(?\s ?\n) + "Chars which might trigger `blink-matching-open'. +These can include the final chars of end-tokens, or chars that are +typically inserted right after an end token. +I.e. a good choice can be: + (delete-dups + (mapcar (lambda (kw) (aref (cdr kw) (1- (length (cdr kw))))) + smie-closer-alist))") + +(defcustom smie-blink-matching-inners t + "Whether SMIE should blink to matching opener for inner keywords. +If non-nil, it will blink not only for \"begin..end\" but also for \"if...else\"." + :type 'boolean) + +(defun smie-blink-matching-check (start end) + (save-excursion + (goto-char end) + (let ((ender (funcall smie-backward-token-function))) + (cond + ((not (and ender (rassoc ender smie-closer-alist))) + ;; This not is one of the begin..end we know how to check. + (blink-matching-check-mismatch start end)) + ((not start) t) + (t + (goto-char start) + (let ((starter (funcall smie-forward-token-function))) + (not (member (cons starter ender) smie-closer-alist)))))))) + +(defun smie-blink-matching-open () + "Blink the matching opener when applicable. +This uses SMIE's tables and is expected to be placed on `post-self-insert-hook'." + (when (and blink-matching-paren + smie-closer-alist ; Optimization. + (eq (char-before) last-command-event) ; Sanity check. + (memq last-command-event smie-blink-matching-triggers) + (save-excursion + ;; FIXME: Here we assume that closers all end + ;; with a word-syntax char. + (unless (eq ?\w (char-syntax last-command-event)) + (forward-char -1)) + (and (looking-at "\\>") + (not (nth 8 (syntax-ppss)))))) + (save-excursion + (let ((pos (point)) + (token (funcall smie-backward-token-function))) + (if (= 1 (length token)) + ;; The trigger char is itself a token but is not + ;; one of the closers (e.g. ?\; in Octave mode), + ;; so go back to the previous token + (setq token (save-excursion + (funcall smie-backward-token-function))) + (goto-char pos)) + ;; Here we assume that smie-backward-token-function + ;; returns a token that is a string and whose content + ;; match the buffer's representation of this token. + (when (and (> (length token) 1) (stringp token) + (memq (aref token (1- (length token))) + smie-blink-matching-triggers) + (not (eq (aref token (1- (length token))) + last-command-event))) + ;; Token ends with a trigger char, so don't blink for + ;; anything else than this trigger char, lest we'd blink + ;; both when inserting the trigger char and when inserting a + ;; subsequent SPC. + (setq token nil)) + (when (and (rassoc token smie-closer-alist) + (or smie-blink-matching-inners + (null (nth 2 (assoc token smie-op-levels))))) + ;; The major mode might set blink-matching-check-function + ;; buffer-locally so that interactive calls to + ;; blink-matching-open work right, but let's not presume + ;; that's the case. + (let ((blink-matching-check-function #'smie-blink-matching-check)) + (blink-matching-open))))))) + ;;; The indentation engine. (defcustom smie-indent-basic 4 @@ -593,20 +805,21 @@ \(:bolp . OFFSET-RULES) If TOK is first on a line, use OFFSET-RULES. OFFSET the offset to use. -PARENT can be either the name of the parent or `open' to mean any parent -which acts as an open-paren (i.e. has a nil left-precedence). +PARENT can be either the name of the parent or a list of such names. OFFSET can be of the form: `point' align with the token. `parent' align with the parent. NUMBER offset by NUMBER. \(+ OFFSETS...) use the sum of OFFSETS. +VARIABLE use the value of VARIABLE as offset. The precise meaning of `point' depends on various details: it can either mean the position of the token we're indenting, or the position of its parent, or the position right after its parent. -A nil offset for indentation after a token defaults to `smie-indent-basic'.") +A nil offset for indentation after an opening token defaults +to `smie-indent-basic'.") (defun smie-indent-hanging-p () ;; A hanging keyword is one that's at the end of a line except it's not at @@ -674,8 +887,9 @@ (save-excursion (if after (goto-char after)) (setq parent (smie-backward-sexp 'halfsexp)))) - (when (or (equal (nth 2 parent) (cadr rule)) - (and (eq (cadr rule) 'open) (null (car parent)))) + (when (if (listp (cadr rule)) + (member (nth 2 parent) (cadr rule)) + (equal (nth 2 parent) (cadr rule))) (setq rules (cddr rule)))) (t (error "Unknown rule %s for indentation of %s" rule (car tokinfo)))))) @@ -726,6 +940,8 @@ (if (consp parent) (goto-char (cadr parent))) (smie-indent-virtual)) ((eq offset nil) nil) + ((and (symbolp offset) (boundp 'offset)) + (smie-indent-column (symbol-value offset) base parent virtual-point)) (t (error "Unknown indentation offset %s" offset)))) (defun smie-indent-forward-token () @@ -1016,6 +1232,7 @@ (positions ;; We're the first arg. (goto-char (car positions)) + ;; FIXME: Use smie-indent-column. (+ (smie-indent-offset 'args) ;; We used to use (smie-indent-virtual), but that ;; doesn't seem right since it might then indent args less than
--- a/lisp/emacs-lisp/syntax.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/emacs-lisp/syntax.el Wed Sep 08 12:55:57 2010 +0900 @@ -209,7 +209,8 @@ (funcall syntax-begin-function) ;; Make sure it's better. (> (point) pt-best)) - ;; Simple sanity check. + ;; Simple sanity checks. + (< (point) pos) ; backward-paragraph can fail here. (not (memq (get-text-property (point) 'face) '(font-lock-string-face font-lock-doc-face font-lock-comment-face))))
--- a/lisp/emacs-lisp/timer.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/emacs-lisp/timer.el Wed Sep 08 12:55:57 2010 +0900 @@ -443,8 +443,6 @@ "This is the timer function used for the timer made by `with-timeout'." (throw tag 'timeout)) -(put 'with-timeout 'lisp-indent-function 1) - (defvar with-timeout-timers nil "List of all timers used by currently pending `with-timeout' calls.") @@ -456,6 +454,7 @@ if the program loops without waiting in any way, the timeout will not be detected. \n(fn (SECONDS TIMEOUT-FORMS...) BODY)" + (declare (indent 1)) (let ((seconds (car list)) (timeout-forms (cdr list))) `(let ((with-timeout-tag (cons nil nil))
--- a/lisp/eshell/em-term.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/eshell/em-term.el Wed Sep 08 12:55:57 2010 +0900 @@ -187,8 +187,7 @@ ; (if (boundp 'xemacs-logo) ; (eshell-term-send-raw-string ; (or (condition-case () (x-get-selection) (error ())) -; (x-get-cutbuffer) -; (error "No selection or cut buffer available"))) +; (error "No selection available"))) ; ;; Give temporary modes such as isearch a chance to turn off. ; (run-hooks 'mouse-leave-buffer-hook) ; (setq this-command 'yank)
--- a/lisp/files.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/files.el Wed Sep 08 12:55:57 2010 +0900 @@ -67,9 +67,9 @@ via absolute symbolic links. Make TO the name of the link, and FROM the name it is linked to." :type '(repeat (cons :format "%v" - :value ("" . "") + :value ("\\`" . "") (regexp :tag "From") - (regexp :tag "To"))) + (string :tag "To"))) :group 'abbrev :group 'find-file) @@ -5563,12 +5563,14 @@ (defun get-free-disk-space (dir) "Return the amount of free space on directory DIR's file system. -The result is a string that gives the number of free 1KB blocks, -or nil if the system call or the program which retrieve the information -fail. It returns also nil when DIR is a remote directory. - -This function calls `file-system-info' if it is available, or invokes the -program specified by `directory-free-space-program' if that is non-nil." +The return value is a string describing the amount of free +space (normally, the number of free 1KB blocks). + +This function calls `file-system-info' if it is available, or +invokes the program specified by `directory-free-space-program' +and `directory-free-space-args'. If the system call or program +is unsuccessful, or if DIR is a remote directory, this function +returns nil." (unless (file-remote-p dir) ;; Try to find the number of free blocks. Non-Posix systems don't ;; always have df, but might have an equivalent system call. @@ -5588,19 +5590,22 @@ directory-free-space-args dir) 0))) - ;; Usual format is a header line followed by a line of - ;; numbers. + ;; Usual format is as follows: + ;; Filesystem ... Used Available Capacity ... + ;; /dev/sda6 ...48106535 35481255 10669850 ... (goto-char (point-min)) - (forward-line 1) - (if (not (eobp)) - (progn - ;; Move to the end of the "available blocks" number. - (skip-chars-forward "^ \t") - (forward-word 3) - ;; Copy it into AVAILABLE. - (let ((end (point))) - (forward-word -1) - (buffer-substring (point) end)))))))))) + (when (re-search-forward " +Avail[^ \n]*" + (line-end-position) t) + (let ((beg (match-beginning 0)) + (end (match-end 0)) + str) + (forward-line 1) + (setq str + (buffer-substring-no-properties + (+ beg (point) (- (point-min))) + (+ end (point) (- (point-min))))) + (when (string-match "\\` *\\([^ ]+\\)" str) + (match-string 1 str)))))))))) ;; The following expression replaces `dired-move-to-filename-regexp'. (defvar directory-listing-before-filename-regexp
--- a/lisp/finder.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/finder.el Wed Sep 08 12:55:57 2010 +0900 @@ -32,10 +32,8 @@ (require 'package) (require 'lisp-mnt) -(require 'find-func) ;for find-library(-suffixes) -;; Use `load' rather than `require' so that it doesn't get loaded -;; during byte-compilation (at which point it might be missing). -(load "finder-inf" t t) +(require 'find-func) ;for find-library(-suffixes) +(require 'finder-inf nil t) ;; These are supposed to correspond to top-level customization groups, ;; says rms. @@ -234,17 +232,10 @@ (search-backward "") (insert "(setq package--builtins '(\n") (dolist (package package--builtins) - (insert " (") - (prin1 (car package) (current-buffer)) - (insert " .\n [") - (let ((desc (cdr package))) - (prin1 (aref desc 0) (current-buffer)) - (insert " ") - (prin1 (aref desc 1) (current-buffer)) - (insert " ") - (prin1 (aref desc 2) (current-buffer))) - (insert "])\n")) - (insert " ))\n\n") + (insert " ") + (prin1 package (current-buffer)) + (insert "\n")) + (insert "))\n\n") ;; Insert hash table. (insert "(setq finder-keywords-hash\n ") (prin1 finder-keywords-hash (current-buffer)) @@ -325,7 +316,6 @@ (packages (gethash id finder-keywords-hash))) (unless packages (error "No packages matching key `%s'" key)) - (setq package-menu-sort-key nil) (package--list-packages packages))) (define-button-type 'finder-xref 'action #'finder-goto-xref)
--- a/lisp/font-lock.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/font-lock.el Wed Sep 08 12:55:57 2010 +0900 @@ -615,21 +615,10 @@ (defmacro save-buffer-state (varlist &rest body) "Bind variables according to VARLIST and eval BODY restoring buffer state." (declare (indent 1) (debug let)) - (let ((modified (make-symbol "modified"))) - `(let* ,(append varlist - `((,modified (buffer-modified-p)) - (buffer-undo-list t) - (inhibit-read-only t) - (inhibit-point-motion-hooks t) - (inhibit-modification-hooks t) - deactivate-mark - buffer-file-name - buffer-file-truename)) - (unwind-protect - (progn - ,@body) - (unless ,modified - (restore-buffer-modified-p nil)))))) + `(let* ,(append varlist + `((inhibit-point-motion-hooks t))) + (with-silent-modifications + ,@body))) ;; ;; Shut up the byte compiler. (defvar font-lock-face-attributes)) ; Obsolete but respected if set. @@ -1125,38 +1114,33 @@ (defun font-lock-default-fontify-region (beg end loudly) (save-buffer-state ((parse-sexp-lookup-properties - (or parse-sexp-lookup-properties font-lock-syntactic-keywords)) - (old-syntax-table (syntax-table))) - (unwind-protect - (save-restriction - (unless font-lock-dont-widen (widen)) - ;; Use the fontification syntax table, if any. - (when font-lock-syntax-table - (set-syntax-table font-lock-syntax-table)) - ;; Extend the region to fontify so that it starts and ends at - ;; safe places. - (let ((funs font-lock-extend-region-functions) - (font-lock-beg beg) - (font-lock-end end)) - (while funs - (setq funs (if (or (not (funcall (car funs))) - (eq funs font-lock-extend-region-functions)) - (cdr funs) - ;; If there's been a change, we should go through - ;; the list again since this new position may - ;; warrant a different answer from one of the fun - ;; we've already seen. - font-lock-extend-region-functions))) - (setq beg font-lock-beg end font-lock-end)) - ;; Now do the fontification. - (font-lock-unfontify-region beg end) - (when font-lock-syntactic-keywords - (font-lock-fontify-syntactic-keywords-region beg end)) - (unless font-lock-keywords-only - (font-lock-fontify-syntactically-region beg end loudly)) - (font-lock-fontify-keywords-region beg end loudly)) - ;; Clean up. - (set-syntax-table old-syntax-table)))) + (or parse-sexp-lookup-properties font-lock-syntactic-keywords))) + ;; Use the fontification syntax table, if any. + (with-syntax-table (or font-lock-syntax-table (syntax-table)) + (save-restriction + (unless font-lock-dont-widen (widen)) + ;; Extend the region to fontify so that it starts and ends at + ;; safe places. + (let ((funs font-lock-extend-region-functions) + (font-lock-beg beg) + (font-lock-end end)) + (while funs + (setq funs (if (or (not (funcall (car funs))) + (eq funs font-lock-extend-region-functions)) + (cdr funs) + ;; If there's been a change, we should go through + ;; the list again since this new position may + ;; warrant a different answer from one of the fun + ;; we've already seen. + font-lock-extend-region-functions))) + (setq beg font-lock-beg end font-lock-end)) + ;; Now do the fontification. + (font-lock-unfontify-region beg end) + (when font-lock-syntactic-keywords + (font-lock-fontify-syntactic-keywords-region beg end)) + (unless font-lock-keywords-only + (font-lock-fontify-syntactically-region beg end loudly)) + (font-lock-fontify-keywords-region beg end loudly))))) ;; The following must be rethought, since keywords can override fontification. ;; ;; Now scan for keywords, but not if we are inside a comment now.
--- a/lisp/format-spec.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/format-spec.el Wed Sep 08 12:55:57 2010 +0900 @@ -76,5 +76,4 @@ (provide 'format-spec) -;; arch-tag: c22d49cf-d167-445d-b7f1-2504d4173f53 ;;; format-spec.el ends here
--- a/lisp/frame.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/frame.el Wed Sep 08 12:55:57 2010 +0900 @@ -1210,8 +1210,7 @@ (defun display-selections-p (&optional display) "Return non-nil if DISPLAY supports selections. A selection is a way to transfer text or other data between programs -via special system buffers called `selection' or `cut buffer' or -`clipboard'. +via special system buffers called `selection' or `clipboard'. DISPLAY can be a display name, a frame, or nil (meaning the selected frame's display)." (let ((frame-type (framep-on-display display)))
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus/.dir-locals.el Wed Sep 08 12:55:57 2010 +0900 @@ -0,0 +1,1 @@ +((emacs-lisp-mode . ((show-trailing-whitespace . t))))
--- a/lisp/gnus/ChangeLog Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/ChangeLog Wed Sep 08 12:55:57 2010 +0900 @@ -1,3 +1,522 @@ +2010-09-07 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-html.el (gnus-html-wash-tags, gnus-html-put-image): Mark cid and + internal images as deletable by `W D D'. + + * gnus-async.el (gnus-html-prefetch-images): Autoload it when compiling. + (gnus-async-article-callback): Fix typo. + +2010-09-06 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * gnus-html.el (gnus-html-wash-tags): Limit end-tag matching to the + current line to work around bugs in the output from w3m. + + * gnus-async.el (gnus-async-article-callback): Always prefetch images + for groups that want that. + + * nntp.el (nntp-wait-for-string): Supply a timeout for + accept-process-output to ensure progress. + + * gnus-start.el (gnus-get-unread-articles): If being given an explicit + level to get unread articles from, then use that for foreign groups, + too. + + * gnus-html.el (gnus-html-wash-tags): Remove <a name...> tags, which + confuses the rest of the function. + + * gnus-start.el (gnus-read-active-for-groups): Do a `gnus-request-scan' + for the methods that support -retrieve-groups, too. + + * nnml.el (nnml-save-nov): Remove some debugging-related messages. + +2010-09-06 Katsumi Yamaoka <yamaoka@jpl.org> + + * pop3.el: Require cl when compiling. + (pop3-number-of-responses): Search for "+OK", not "+OK ". + +2010-09-05 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * gnus-start.el (gnus-get-unread-articles): Don't bother with groups + that aren't going to be activated. + (gnus-get-unread-articles): Fix up the last commit. + + * gnus-html.el (gnus-article-html): Allow calling without specifying + the handle. In that case, dissect the buffer first. + + * gnus-sum.el (gnus-set-mode-line): Don't pad the mode line string. + + * nnimap.el (nnimap-open-connection): Revert the change that would look + into authinfo for imaps instead of imap. + + * gnus-start.el (gnus-activate-group): Take an optional parameter to + say that you don't want to call gnus-request-group with don-check, but + do check the reponse. This is for virtual groups only. + (gnus-get-unread-articles): Count the archive groups as secondary, so + that they're activated the same way as before. + + * nnimap.el (nnimap-request-list): Servers may return \NoSelect + case-insensitively. + (nnimap-debug): Removed. + + * mail-source.el (mail-source-fetch): Don't message if we're fetching + mail from a file, and the file doesn't exist. + + * pop3.el (pop3-streaming-movemail): Return t for success. + + * nnimap.el (nnimap-open-connection): Look for the "imaps" entry in the + .authinfo if we're using ssl connection. + + * nnvirtual.el (nnvirtual-create-mapping): Use the active info we + already have if we're in a main Gnus `g' run. + + * gnus-start.el (gnus-method-rank): Get info for virtual groups last. + +2010-09-05 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-start.el (gnus-method-rank): Replace equalp with equal. + + * nnmh.el (nnmh-request-list-1): Bind `file'. + + * pop3.el (pop3-set-process-query-on-exit-flag): New function that's an + alias to set-process-query-on-exit-flag or process-kill-without-query. + (pop3-open-server): Use it. + +2010-09-04 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * mail-source.el (mail-source-delete-crash-box): Always move the crash + box to the Incoming file. Fixes mistake in previous checkin. + + * pop3.el (pop3-send-streaming-command): Off-by-one error on the + request loop (for debugging purposes) removed. + + * nnml.el (nnml-save-nov): Message around nnml-save-nov so that the + culprit is more visible. + (nnml-save-incremental-nov, nnml-open-incremental-nov) + (nnml-add-incremental-nov): New functions to do "incremental" nov + updates, where we just append to the end of the existing nov files + without reading/writing them in full. + + * mail-source.el (mail-source-delete-crash-box): Really only check the + incoming files once in a while. + + * pop3.el (pop3-streaming-movemail): Always close the pop3 connection. + + * mail-source.el (mail-source-delete-crash-box): Only check the + incoming files for deletion once per day to save a lot of file + accesses. + + * pop3.el (pop3-logon): Fix up unbound variable typo. + + * mail-source.el (pop3-streaming-movemail): Autoload. + + * pop3.el (pop3-streaming-movemail): Respect + pop3-leave-mail-on-server. + + * mail-source.el (mail-source-fetch-pop): Use streaming pop3 + retrieval. + + * pop3.el (pop3-process-filter): Removed unused function. + (pop3-streaming-movemail, pop3-send-streaming-command) + (pop3-wait-for-messages, pop3-write-to-file) + (pop3-number-of-responses): New functions for streaming pop3 + retrieval. + + * gnus-start.el (gnus-get-unread-articles): Protect against groups that + come from no known methods. + (gnus-make-hashtable-from-newsrc-alist): Remove duplicates from .newsrc + list. + + * pop3.el (pop3-display-message-size-flag): Removed -- everybody wants + message sizes. + (pop3-movemail): Use erase-buffer instead of looping and deleting + regions, which seems rather odd. + + * gnus-agent.el (gnus-agent-load-local): Only read the agent.lib/local + file once per `g' run. + + * nnmh.el (nnmh-request-list-1): Output active lines also for empty + directories. This makes the draft queue directory work. + + * gnus-start.el (gnus-get-unread-articles): Rewrite the way we request + data from the backends, so that we only request the list of groups from + each method once. This should speed things up considerably. + + * nnvirtual.el (nnvirtual-request-list): Remove function so that we can + detect that it's not implemented. + + * nnmh.el (nnmh-request-list-1): Fix up the recursion behavior so that + we actually do recurse down into the tree, but don't stat all leaf + nodes. + + * gnus-html.el (gnus-html-show-images): If there are no images to show, + then say so instead of bugging out. + + * gnus-agent.el (gnus-agent-load-alist): Check whether the agentview + files exist before trying to read them. + + * gnus-html.el (gnus-html-wash-tags): Remove even more white space + around <pre_int>. + + * gnus-art.el (gnus-article-copy-string): Say what data we copied. + + * nnmh.el (nnmh-request-list-1): Optimize for speed. + +2010-09-03 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * mm-util.el (mm-image-load-path): Just return the image directories, + not all directories in the path in addition to the image directories. + (mm-image-load-path): Maintain a cache of the image directories so that + the `g' command in Gnus doesn't have to stat dozens of directories each + time. + + * gnus-html.el (gnus-html-put-image): Allow images to be removed. + (gnus-html-wash-tags): Add a new `i' command to insert images. + (gnus-html-insert-image): New command and keystroke. + (gnus-html-redisplay-with-images): New command and keystroke. + (gnus-html-show-images): Renamed command. + (gnus-html-wash-tags): Remove more white space before <pre_int> image + spacers. + (gnus-html-wash-tags): Decode entities at the end, so that entities + inside the tags don't mess up the rest of the "parsing". + + * gnus-agent.el (gnus-agent-auto-agentize-methods): Change the default + so that nnimap methods aren't agentized by default. There's apparently + many problems related to agent/imap behaviour. + + * gnus-art.el (gnus-article-copy-string): New command and key binding. + + * gnus-html.el: Doc fix. + +2010-09-03 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-html.el (gnus-html-put-image): Use gnus-graphic-display-p, + glyph-width and glyph-height instead of display-graphic-p and + image-size; make avoidance of displaying small images work for XEmacs. + + * gnus-util.el (gnus-graphic-display-p): Use device-on-window-system-p + for XEmacs. + + * gnus-ems.el (gnus-set-process-plist, gnus-process-plist): Change name + of symbol that holds plist data. + (gnus-process-plist): Remove plist of process after getting it. + +2010-09-02 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * message.el (message-generate-hashcash): Change default to + 'opportunistic if hashcash is installed. + + * gnus-html.el (gnus-html-rescale-image): Fix up typo in rescaling. + (gnus-html-put-image): Only call image-size once, since it's somewhat + time-consuming on remote X servers. + +2010-09-02 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-html.el (gnus-article-html): Make work buffer multibyte for + decoded contents. + (gnus-html-put-image, gnus-html-rescale-image): Pass `file' argument. + +2010-09-02 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * gnus-group.el (gnus-group-line-format): Remove %O (moderated) from + group line format, since it isn't very interesting. + + * gnus-agent.el (gnus-agent-short-article), + (gnus-agent-long-article): Increase values for these two variables, + since most people are likely to have more network connection and + storage than before. + + * gnus.el (gnus-refer-article-method): Change default to 'current. + When referring an article, the common behaviour is to refer it from the + current select method, not the native select method. The chances of + the native select method having the message in question is rather slim + these days. + + * gnus-sum.el (gnus-auto-select-subject): Change default to + `unseen-or-unread'. I think it's likely that most people want to + select an unseen article over a previously seen, but unread one. + + * gnus.el (gnus-mode-non-string-length): Change default to 30. nil + means that in the article buffer none of the minor mode elements will + be shown, usually, and this is not desirable in most cases. + + * gnus-sum.el (gnus-summary-goto-unread): Change default to nil, so + that commands like `d' (and the like) go to the next line in the + buffer, instead of the next unread article. I think this is the + behaviour that is most natural for most users. + (gnus-single-article-buffer): Change default to nil, so that people can + have as many article buffers open as they have summary buffer. I think + this is the most natural way for the groups to behave. + + * message.el (message-generate-new-buffers): Change default to + `unsent', so that all new message buffers start their names with the + string "*unsent", and it's easier to find the buffers if you move from + them. + +2010-09-01 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * gnus-html.el (gnus-html-wash-tags): Don't show images that are really + small. They're probably tracking images. + (gnus-html-wash-tags): Remove all <pre_int> place holders. + (gnus-html-rescale-image): Yet another try at getting the image sizing + right. + + * nntp.el (nntp-request-set-mark): Refuse to do marks if + nntp-marks-file-name is nil. + +2010-09-01 Teodor Zlatanov <tzz@lifelogs.com> + + * gnus-html.el (gnus-html-wash-tags) + (gnus-html-schedule-image-fetching, gnus-html-image-url-blocked-p): + Better logging. + +2010-09-01 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * nndoc.el (nndoc-type-alist): Added a new type for Google digests. + + * gnus-html.el (gnus-html-wash-tags): Check the value of + gnus-blocked-images in the summary buffer. + +2010-09-01 Teodor Zlatanov <tzz@lifelogs.com> + + * gnus-html.el (gnus-html-image-url-blocked-p): Doc fix. + +2010-09-01 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * gnus-html.el (gnus-html-wash-tags): "A" is also used for links, just + like "a", it seems like. + (gnus-html-image-url-blocked-p): Take a parameter for blocked-images + since it needs to be picked from the correct buffer. + + * nnwfm.el: Removed. + + * nnlistserv.el: Removed. + +2010-09-01 Teodor Zlatanov <tzz@lifelogs.com> + + * gnus-html.el (gnus-html-image-url-blocked-p): New function. + (gnus-html-prefetch-images, gnus-html-wash-tags): Use it. + +2010-09-01 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * nnkiboze.el: Removed. + + * nndb.el: Removed. + + * gnus-html.el (gnus-html-put-image): Use the deleted text as the image + alt text. + (gnus-html-rescale-image): Try to get the rescaling logic right for + images that are just wide and not tall. + + * gnus.el (gnus-string-or): Fix the syntax to not use eval or + overshadow variable bindings. + +2010-09-01 Teodor Zlatanov <tzz@lifelogs.com> + + * gnus-html.el (gnus-html-wash-tags) + (gnus-html-schedule-image-fetching, gnus-html-prefetch-images): Add + extra logging. + +2010-09-01 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * gnus-html.el (gnus-html-wash-tags): Delete the IMG_ALT region. + (gnus-max-image-proportion): New variable. + (gnus-html-rescale-image): New function. + (gnus-html-put-image): Rescale images. + +2010-09-01 Stefan Monnier <monnier@iro.umontreal.ca> + + Fix up some byte-compiler warnings. + * gnus.el (gnus-group-find-parameter, gnus-kill-save-kill-buffer): + * gnus-cite.el (gnus-article-highlight-citation, gnus-dissect-cited-text) + (gnus-article-fill-cited-article, gnus-article-hide-citation) + (gnus-article-hide-citation-in-followups, gnus-cite-toggle): + * gnus-group.el (gnus-group-set-mode-line, gnus-group-quit) + (gnus-group-set-info, gnus-add-mark): Use with-current-buffer. + (gnus-group-update-group): Use save-excursion and with-current-buffer. + +2010-09-01 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-html.el (gnus-article-html): Decode contents by charset. + +2010-09-01 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-html.el (gnus-html-cache-directory, gnus-html-cache-size) + (gnus-html-frame-width, gnus-blocked-images) + * message.el (message-prune-recipient-rules): Add custom version. + * gnus-sum.el (gnus-auto-expirable-marks): Bump custom version. + + * gnus-ems.el (gnus-process-get, gnus-process-put): New compatibility + functions. + + * gnus-html.el (gnus-html-curl-sentinel): Replace process-get with + gnus-process-get. + +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) + * mm-decode.el (mm-text-html-renderer) + * mml.el (mml-insert-mime-headers-always) + * smiley.el (smiley-regexp-alist): Bump custom version. + +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> + + * gnus-sum.el: As per discussion 3 years, 8 weeks, 3 days, 9 hours, 57 + minutes, 56 seconds ago on the ding list, remove the `w' and `i' + bindings, as they aren't useful at all. `w' is moved to `W w'. + + * gnus-move.el: Removed file, since it doesn't really work. + + * gnus-html.el (gnus-article-html): Tell w3m that the input is + UTF-8. This seems to fix problems with some German web feeds. + + * gnus.el (gnus-group-startup-message): Put the xpm version of the logo + at the top so that the proper colours are applied. + + * gnus-art.el (gnus-article-view-part): Doc fix. + + * gnus-html.el (gnus-html-put-image): Use gnus-create-image to be + XEmacs-compatible. + (gnus-html-put-image): Don't do images on non-graphic displays. + + * nnslashdot.el: Removed this unused backend. + + * gnus-undo.el (gnus-undo-register-1): Limit the undo actions to 100 + actions. + (gnus-undo-register-1): Revert last change. + + * gnus-group.el (gnus-group-completing-read): Protect against not + having completion-styles bound. + + * mml.el (mml-insert-mime-headers-always): Change the default to t, to + make broken recipients happier. + + * gnus-html.el (gnus-html-put-image): Use gnus-put-image. + + * gnus-ems.el (gnus-put-image): Have gnus-put-image take an optional + point parameter. + + * gnus-group.el (gnus-group-completing-read): Add 'substring to + completion-styles for group selection. + +2009-02-04 Andreas Schwab <schwab@suse.de> + + * gnus-score.el (gnus-score-string): Fix regex for matching extra + headers and regexp-quote the match if necessary. + +2009-03-24 Miles Bader <miles@gnu.org> + + * smiley.el (smiley-regexp-alist): Don't delete the semicolon before + the blinking smiley. + +2009-03-24 Simon Josefsson <simon@josefsson.org> + + * smiley.el (smiley-regexp-alist): Disallow ;;) from being treated as a + blink smiley. + +2010-08-29 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * gnus-start.el (gnus-dribble-read-file): Ensure that the directory + where the dribbel file lives exists. + + * message.el (message-send-mail-partially-limit): Change the default to + nil, since most people don't want this. + + * mm-url.el (mm-url-decode-entities): Also decode entities like + ㈒. + +2009-07-16 Kevin Ryde <user42@zip.com.au> (tiny change) + + * gnus-sum.el (gnus-summary-idna-message): + * nnrss.el (nnrss-normalize-date, nnrss-discover-feed): + Hyperlink urls in docstrings with URL `...'. + +2010-08-29 Adam Sjøgren <asjo@koldfront.dk> + + * gnus-html.el (gnus-html-put-image): Use XEmacs-compatible image + functions. + +2010-08-29 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * gnus-art.el (gnus-article-add-button): Take an optional parameter to + say what the mouseover text should be. + + * gnus-html.el (gnus-html-prefetch-images): Use the summary-local + version of the mm-w3m-safe-url-regexp variable to only download images + in the groups where we want that to happen. + + * gnus-sum.el (gnus-summary-stop-at-end-of-message): New variable. + + * gnus-art.el (gnus-article-beginning-of-window): Make into defun for + easier debugging. + (gnus-article-beginning-of-window): Add kludge to allow spacing past + big pictures in the article buffer. + + * mm-decode.el (mm-text-html-renderer): Default the html renderer to + gnus-article-html. + (mm-text-html-renderer): gnus-article-html needs curl in addition to + w3m. + + * gnus-html.el: Start a new super-simple HTML renderer based on w3m. + +2010-08-28 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * gnus.el (gnus-valid-select-methods): Remove reference to nngoogle, + which doesn't exist. + + * message.el (message-inhibit-ecomplete): New variable to allow some + function to inhibit ecomplete address storage. + (message-resend): Disable ecomplete message storage when resending + messages. + + * nntp.el (nntp-async-kluge): Remove the Emacs 20.3-related kluge. + 2010-08-27 Katsumi Yamaoka <yamaoka@jpl.org> * gnus-sum.el (gnus-summary-move-article, gnus-summary-delete-article): @@ -14528,5 +15047,3 @@ ;; fill-column: 79 ;; add-log-time-zone-rule: t ;; End: - -;;; arch-tag: 3f33a3e7-090d-492b-bedd-02a1417d32b4
--- a/lisp/gnus/auth-source.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/auth-source.el Wed Sep 08 12:55:57 2010 +0900 @@ -465,5 +465,4 @@ (provide 'auth-source) -;; arch-tag: ff1afe78-06e9-42c2-b693-e9f922cbe4ab ;;; auth-source.el ends here
--- a/lisp/gnus/canlock.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/canlock.el Wed Sep 08 12:55:57 2010 +0900 @@ -247,5 +247,4 @@ (provide 'canlock) -;; arch-tag: 033c4f09-b9f1-459d-bd0d-254430283f78 ;;; canlock.el ends here
--- a/lisp/gnus/compface.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/compface.el Wed Sep 08 12:55:57 2010 +0900 @@ -58,5 +58,4 @@ (provide 'compface) -;; arch-tag: f9c78e84-98c0-4142-9682-8ba4cf4c3441 ;;; compface.el ends here
--- a/lisp/gnus/deuglify.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/deuglify.el Wed Sep 08 12:55:57 2010 +0900 @@ -476,5 +476,4 @@ ;; coding: iso-8859-1 ;; End: -;; arch-tag: 5f895cc9-51a9-487c-b42e-28844d79eb73 ;;; deuglify.el ends here
--- a/lisp/gnus/earcon.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/earcon.el Wed Sep 08 12:55:57 2010 +0900 @@ -229,5 +229,4 @@ (run-hooks 'earcon-load-hook) -;; arch-tag: 844dfeea-980c-4ed0-907f-a30bf139691c ;;; earcon.el ends here
--- a/lisp/gnus/ecomplete.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/ecomplete.el Wed Sep 08 12:55:57 2010 +0900 @@ -95,7 +95,7 @@ (let* ((elems (cdr (assq type ecomplete-database))) (match (regexp-quote match)) (candidates - (sort + (sort (loop for (key count time text) in elems when (string-match match text) collect (list count time text)) @@ -156,5 +156,4 @@ (provide 'ecomplete) -;; arch-tag: 34622935-bb81-4711-a600-57b89c2ece72 ;;; ecomplete.el ends here
--- a/lisp/gnus/flow-fill.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/flow-fill.el Wed Sep 08 12:55:57 2010 +0900 @@ -221,5 +221,4 @@ (provide 'flow-fill) -;; arch-tag: addc0040-bc53-4f17-b4bc-1eb44eed6f0b ;;; flow-fill.el ends here
--- a/lisp/gnus/gmm-utils.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/gmm-utils.el Wed Sep 08 12:55:57 2010 +0900 @@ -433,5 +433,4 @@ (provide 'gmm-utils) -;; arch-tag: e0b60920-2ce6-40c1-bfc0-cadbbe26b602 ;;; gmm-utils.el ends here
--- a/lisp/gnus/gnus-agent.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/gnus-agent.el Wed Sep 08 12:55:57 2010 +0900 @@ -184,7 +184,7 @@ :type 'boolean :group 'gnus-agent) -(defcustom gnus-agent-auto-agentize-methods '(nntp nnimap) +(defcustom gnus-agent-auto-agentize-methods '(nntp) "Initially, all servers from these methods are agentized. The user may remove or add servers using the Server buffer. See Info node `(gnus)Server Buffer'." @@ -1788,7 +1788,7 @@ (while alist (let ((entry (pop alist))) (when (gnus-methods-equal-p gnus-command-method (gnus-info-method entry)) - (gnus-agent-flush-group (gnus-info-group entry))))))) + (gnus-agent-flush-group (gnus-info-group entry))))))) (defun gnus-agent-flush-group (group) "Flush the agent's index files such that the GROUP no longer @@ -2108,13 +2108,15 @@ (defun gnus-agent-load-alist (group) "Load the article-state alist for GROUP." ;; Bind free variable that's used in `gnus-agent-read-agentview'. - (let ((gnus-agent-read-agentview group) - (file-name-coding-system nnmail-pathname-coding-system)) - (setq gnus-agent-article-alist - (gnus-cache-file-contents - (gnus-agent-article-name ".agentview" group) - 'gnus-agent-file-loading-cache - 'gnus-agent-read-agentview)))) + (let* ((gnus-agent-read-agentview group) + (file-name-coding-system nnmail-pathname-coding-system) + (agentview (gnus-agent-article-name ".agentview" group))) + (when (file-exists-p agentview) + (setq gnus-agent-article-alist + (gnus-cache-file-contents + agentview + 'gnus-agent-file-loading-cache + 'gnus-agent-read-agentview))))) (defun gnus-agent-read-agentview (file) "Load FILE and do a `read' there." @@ -2162,13 +2164,13 @@ (gnus-agent-save-alist gnus-agent-read-agentview))) alist)) ((end-of-file file-error) - ;; The agentview file is missing. + ;; The agentview file is missing. (condition-case nil ;; If the agent directory exists, attempt to perform a brute-force ;; reconstruction of its contents. (let* (alist (file-name-coding-system nnmail-pathname-coding-system) - (file-attributes (directory-files-and-attributes + (file-attributes (directory-files-and-attributes (gnus-agent-article-name "" gnus-agent-read-agentview) nil "^[0-9]+$" t))) (while file-attributes @@ -2230,23 +2232,28 @@ (gnus-agent-update-view-total-fetched-for group nil))) (defvar gnus-agent-article-local nil) +(defvar gnus-agent-article-local-times nil) (defvar gnus-agent-file-loading-local nil) (defun gnus-agent-load-local (&optional method) "Load the METHOD'S local file. The local file contains min/max article counts for each of the method's subscribed groups." (let ((gnus-command-method (or method gnus-command-method))) - (setq gnus-agent-article-local - (gnus-cache-file-contents - (gnus-agent-lib-file "local") - 'gnus-agent-file-loading-local - 'gnus-agent-read-and-cache-local)))) + (when (or (null gnus-agent-article-local-times) + (zerop gnus-agent-article-local-times)) + (setq gnus-agent-article-local + (gnus-cache-file-contents + (gnus-agent-lib-file "local") + 'gnus-agent-file-loading-local + 'gnus-agent-read-and-cache-local)) + (when gnus-agent-article-local-times + (incf gnus-agent-article-local-times))) + gnus-agent-article-local)) (defun gnus-agent-read-and-cache-local (file) "Load and read FILE then bind its contents to gnus-agent-article-local. If that variable had `dirty' (also known as modified) original contents, they are first saved to their own file." - (if (and gnus-agent-article-local (symbol-value (intern "+dirty" gnus-agent-article-local))) (gnus-agent-save-local)) @@ -2644,10 +2651,10 @@ (defvar gnus-agent-predicate 'false "The selection predicate used when no other source is available.") -(defvar gnus-agent-short-article 100 +(defvar gnus-agent-short-article 500 "Articles that have fewer lines than this are short.") -(defvar gnus-agent-long-article 200 +(defvar gnus-agent-long-article 1000 "Articles that have more lines than this are long.") (defvar gnus-agent-low-score 0 @@ -3258,7 +3265,7 @@ (gnus-message 7 "gnus-agent-expire: Loading overview...") (nnheader-insert-file-contents nov-file) (goto-char (point-min)) - + (let (p) (while (< (setq p (point)) (point-max)) (condition-case nil @@ -4227,5 +4234,4 @@ (provide 'gnus-agent) -;; arch-tag: b0ba4afc-5229-4cee-ad25-9956daa4e91e ;;; gnus-agent.el ends here
--- a/lisp/gnus/gnus-art.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/gnus-art.el Wed Sep 08 12:55:57 2010 +0900 @@ -4823,6 +4823,22 @@ (vector (caddr c) (car c) :active t)) gnus-mime-button-commands))) +(defvar gnus-url-button-commands + '((gnus-article-copy-string "u" "Copy URL to kill ring"))) + +(defvar gnus-url-button-map + (let ((map (make-sparse-keymap))) + (dolist (c gnus-url-button-commands) + (define-key map (cadr c) (car c))) + map)) + +(easy-menu-define + gnus-url-button-menu gnus-url-button-map "URL button menu." + `("Url Button" + ,@(mapcar (lambda (c) + (vector (caddr c) (car c) :active t)) + gnus-url-button-commands))) + (defmacro gnus-bind-safe-url-regexp (&rest body) "Bind `mm-w3m-safe-url-regexp' according to `gnus-safe-html-newsgroups'." `(let ((mm-w3m-safe-url-regexp @@ -5549,7 +5565,9 @@ 1)) (defun gnus-article-view-part (&optional n) - "View MIME part N, which is the numerical prefix." + "View MIME part N, which is the numerical prefix. +If the part is already shown, hide the part. If N is nil, view +all parts." (interactive "P") (with-current-buffer gnus-article-buffer (or (numberp n) (setq n (gnus-article-mime-match-handle-first @@ -6283,18 +6301,22 @@ (gnus-article-next-page-1 lines) nil)) -(defmacro gnus-article-beginning-of-window () +(defun gnus-article-beginning-of-window () "Move point to the beginning of the window. In Emacs, the point is placed at the line number which `scroll-margin' specifies." (if (featurep 'xemacs) - '(move-to-window-line 0) - '(move-to-window-line - (min (max 0 scroll-margin) - (max 1 (- (window-height) - (if mode-line-format 1 0) - (if header-line-format 1 0) - 2)))))) + (move-to-window-line 0) + ;; There is an obscure bug in Emacs that makes it impossible to + ;; scroll past big pictures in the article buffer. Try to fix + ;; this by adding a sanity check by counting the lines visible. + (when (> (count-lines (window-start) (window-end)) 30) + (move-to-window-line + (min (max 0 scroll-margin) + (max 1 (- (window-height) + (if mode-line-format 1 0) + (if header-line-format 1 0) + 2))))))) (defun gnus-article-next-page-1 (lines) (unless (featurep 'xemacs) @@ -7807,7 +7829,11 @@ (unless (and (eq (car entry) 'gnus-button-url-regexp) (gnus-article-extend-url-button from start end)) (gnus-article-add-button start end - 'gnus-button-push from))))))))) + 'gnus-button-push from) + (gnus-put-text-property + start end + 'gnus-string (buffer-substring-no-properties + start end)))))))))) (defun gnus-article-extend-url-button (beg start end) "Extend url button if url is folded into two or more lines. @@ -7899,7 +7925,7 @@ ;;; External functions: -(defun gnus-article-add-button (from to fun &optional data) +(defun gnus-article-add-button (from to fun &optional data text) "Create a button between FROM and TO with callback FUN and data DATA." (when gnus-article-button-face (gnus-overlay-put (gnus-make-overlay from to nil t) @@ -7911,8 +7937,21 @@ (list 'gnus-callback fun) (and data (list 'gnus-data data)))) (widget-convert-button 'link from to :action 'gnus-widget-press-button + :help-echo (or text "Follow the link") + :keymap gnus-url-button-map :button-keymap gnus-widget-button-keymap)) +(defun gnus-article-copy-string () + "Copy the string in the button to the kill ring." + (interactive) + (gnus-article-check-buffer) + (let ((data (get-text-property (point) 'gnus-string))) + (when data + (with-temp-buffer + (insert data) + (copy-region-as-kill (point-min) (point-max)) + (message "Copied %s" data))))) + ;;; Internal functions: (defun gnus-article-set-globals () @@ -8725,5 +8764,4 @@ (run-hooks 'gnus-art-load-hook) -;; arch-tag: 2654516f-6279-48f9-a83b-05c1fa450c33 ;;; gnus-art.el ends here
--- a/lisp/gnus/gnus-async.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/gnus-async.el Wed Sep 08 12:55:57 2010 +0900 @@ -71,6 +71,13 @@ :group 'gnus-asynchronous :type 'function) +(defcustom gnus-async-post-fetch-function nil + "Function called after an article has been prefetched. +The function will be called narrowed to the region of the article +that was fetched." + :group 'gnus-asynchronous + :type 'function) + ;;; Internal variables. (defvar gnus-async-prefetch-article-buffer " *Async Prefetch Article*") @@ -221,12 +228,23 @@ `(lambda (arg) (gnus-async-article-callback arg ,group ,article ,mark ,summary ,next))) +(eval-when-compile + (autoload 'gnus-html-prefetch-images "gnus-html")) + (defun gnus-async-article-callback (arg group article mark summary next) "Function called when an async article is done being fetched." (save-excursion (setq gnus-async-current-prefetch-article nil) (when arg (gnus-async-set-buffer) + (when gnus-async-post-fetch-function + (save-excursion + (save-restriction + (narrow-to-region mark (point-max)) + ;; Prefetch images for the groups that want that. + (when (fboundp 'gnus-html-prefetch-images) + (gnus-html-prefetch-images summary)) + (funcall gnus-async-post-fetch-function summary)))) (gnus-async-with-semaphore (setq gnus-async-article-alist @@ -372,5 +390,4 @@ (provide 'gnus-async) -;; arch-tag: fee61de5-3ea2-4de6-8578-2f90ce89391d ;;; gnus-async.el ends here
--- a/lisp/gnus/gnus-audio.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/gnus-audio.el Wed Sep 08 12:55:57 2010 +0900 @@ -146,5 +146,4 @@ (run-hooks 'gnus-audio-load-hook) -;; arch-tag: 6f129e78-3416-4fc9-973f-6cf5ac8d654b ;;; gnus-audio.el ends here
--- a/lisp/gnus/gnus-bcklg.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/gnus-bcklg.el Wed Sep 08 12:55:57 2010 +0900 @@ -159,5 +159,4 @@ (provide 'gnus-bcklg) -;; arch-tag: 66259e56-505a-4bba-8a0d-3552c5b94e39 ;;; gnus-bcklg.el ends here
--- a/lisp/gnus/gnus-bookmark.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/gnus-bookmark.el Wed Sep 08 12:55:57 2010 +0900 @@ -828,5 +828,4 @@ (provide 'gnus-bookmark) -;; arch-tag: 779df694-366f-46e8-84b2-1d0340e6f525 ;;; gnus-bookmark.el ends here
--- a/lisp/gnus/gnus-cache.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/gnus-cache.el Wed Sep 08 12:55:57 2010 +0900 @@ -868,7 +868,7 @@ (while (setq file (pop files)) (setq attrs (file-attributes file)) (unless (nth 0 attrs) - (incf size (float (nth 7 attrs))))))) + (incf size (float (nth 7 attrs))))))) (setq gnus-cache-need-update-total-fetched-for t) @@ -879,10 +879,10 @@ (gnus-cache-with-refreshed-group group (let* ((entry (or (gnus-gethash group gnus-cache-total-fetched-hashtb) - (gnus-sethash group (make-list 2 0) + (gnus-sethash group (make-list 2 0) gnus-cache-total-fetched-hashtb))) (file-name-coding-system nnmail-pathname-coding-system) - (size (or (nth 7 (file-attributes + (size (or (nth 7 (file-attributes (or file (gnus-cache-file-name group ".overview")))) 0))) @@ -911,11 +911,10 @@ (if entry (apply '+ entry) (let ((gnus-cache-inhibit-update-total-fetched-for (not no-inhibit))) - (+ + (+ (gnus-cache-update-overview-total-fetched-for group nil) (gnus-cache-update-file-total-fetched-for group nil))))))) (provide 'gnus-cache) -;; arch-tag: 05a79442-8c58-4e65-bd0a-3cbb1b89a33a ;;; gnus-cache.el ends here
--- a/lisp/gnus/gnus-cite.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/gnus-cite.el Wed Sep 08 12:55:57 2010 +0900 @@ -407,9 +407,7 @@ Lines matching `gnus-cite-attribution-suffix' and perhaps `gnus-cite-attribution-prefix' are considered attribution lines." (interactive (list 'force)) - (save-excursion - (unless same-buffer - (set-buffer gnus-article-buffer)) + (with-current-buffer (if same-buffer (current-buffer) gnus-article-buffer) (gnus-cite-parse-maybe force) (let ((buffer-read-only nil) (alist gnus-cite-prefix-alist) @@ -462,8 +460,7 @@ (defun gnus-dissect-cited-text () "Dissect the article buffer looking for cited text." - (save-excursion - (set-buffer gnus-article-buffer) + (with-current-buffer gnus-article-buffer (gnus-cite-parse-maybe nil t) (let ((alist gnus-cite-prefix-alist) prefix numbers number marks m) @@ -523,8 +520,7 @@ "Do word wrapping in the current article. If WIDTH (the numerical prefix), use that text width when filling." (interactive (list t current-prefix-arg)) - (save-excursion - (set-buffer gnus-article-buffer) + (with-current-buffer gnus-article-buffer (let ((buffer-read-only nil) (inhibit-point-motion-hooks t) (marks (gnus-dissect-cited-text)) @@ -552,6 +548,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'. @@ -560,67 +574,66 @@ (interactive (append (gnus-article-hidden-arg) (list 'force))) (gnus-set-format 'cited-opened-text-button t) (gnus-set-format 'cited-closed-text-button t) - (save-excursion - (set-buffer gnus-article-buffer) - (let ((buffer-read-only nil) - marks - (inhibit-point-motion-hooks t) - (props (nconc (list 'article-type 'cite) - gnus-hidden-properties)) - (point (point-min)) - found beg end start) - (while (setq point - (text-property-any point (point-max) - 'gnus-callback - 'gnus-article-toggle-cited-text)) - (setq found t) - (goto-char point) - (gnus-article-toggle-cited-text - (get-text-property point 'gnus-data) arg) - (forward-line 1) - (setq point (point))) - (unless found - (setq marks (gnus-dissect-cited-text)) - (while marks - (setq beg nil - end nil) - (while (and marks (string= (cdar marks) "")) - (setq marks (cdr marks))) - (when marks - (setq beg (caar marks))) - (while (and marks (not (string= (cdar marks) ""))) - (setq marks (cdr marks))) - (when marks + (with-current-buffer gnus-article-buffer + (let ((buffer-read-only nil) + marks + (inhibit-point-motion-hooks t) + (props (nconc (list 'article-type 'cite) + gnus-hidden-properties)) + (point (point-min)) + found beg end start) + (while (setq point + (text-property-any point (point-max) + 'gnus-callback + 'gnus-article-toggle-cited-text)) + (setq found t) + (goto-char point) + (gnus-article-toggle-cited-text + (get-text-property point 'gnus-data) arg) + (forward-line 1) + (setq point (point))) + (unless found + (setq marks (gnus-dissect-cited-text)) + (while marks + (setq beg nil + end nil) + (while (and marks (string= (cdar marks) "")) + (setq marks (cdr marks))) + (when marks + (setq beg (caar marks))) + (while (and marks (not (string= (cdar marks) ""))) + (setq marks (cdr marks))) + (when marks (setq end (caar marks))) - ;; Skip past lines we want to leave visible. - (when (and beg end gnus-cited-lines-visible) - (goto-char beg) - (forward-line (if (consp gnus-cited-lines-visible) - (car gnus-cited-lines-visible) - gnus-cited-lines-visible)) - (if (>= (point) end) - (setq beg nil) - (setq beg (point-marker)) - (when (consp gnus-cited-lines-visible) - (goto-char end) - (forward-line (- (cdr gnus-cited-lines-visible))) - (if (<= (point) beg) - (setq beg nil) + ;; Skip past lines we want to leave visible. + (when (and beg end gnus-cited-lines-visible) + (goto-char beg) + (forward-line (if (consp gnus-cited-lines-visible) + (car gnus-cited-lines-visible) + gnus-cited-lines-visible)) + (if (>= (point) end) + (setq beg nil) + (setq beg (point-marker)) + (when (consp gnus-cited-lines-visible) + (goto-char end) + (forward-line (- (cdr gnus-cited-lines-visible))) + (if (<= (point) beg) + (setq beg nil) (setq end (point-marker)))))) - (when (and beg end) - (gnus-add-wash-type 'cite) - ;; We use markers for the end-points to facilitate later - ;; wrapping and mangling of text. - (setq beg (set-marker (make-marker) beg) - end (set-marker (make-marker) end)) - (gnus-add-text-properties-when 'article-type nil beg end props) - (goto-char beg) - (when (and gnus-cite-blank-line-after-header - (not (save-excursion (search-backward "\n\n" nil t)))) - (insert "\n")) - (put-text-property - (setq start (point-marker)) - (progn + (when (and beg end) + (gnus-add-wash-type 'cite) + ;; We use markers for the end-points to facilitate later + ;; wrapping and mangling of text. + (setq beg (set-marker (make-marker) beg) + end (set-marker (make-marker) end)) + (gnus-add-text-properties-when 'article-type nil beg end props) + (goto-char beg) + (when (and gnus-cite-blank-line-after-header + (not (save-excursion (search-backward "\n\n" nil t)))) + (insert "\n")) + (put-text-property + (setq start (point-marker)) + (progn (gnus-article-add-button (point) (progn (eval gnus-cited-closed-text-button-line-format-spec) @@ -628,8 +641,8 @@ `gnus-article-toggle-cited-text (list (cons beg end) start)) (point)) - 'article-type 'annotation) - (set-marker beg (point)))))))) + 'article-type 'annotation) + (set-marker beg (point)))))))) (defun gnus-article-toggle-cited-text (args &optional arg) "Toggle hiding the text in REGION. @@ -732,11 +745,9 @@ (defun gnus-article-hide-citation-in-followups () "Hide cited text in non-root articles." (interactive) - (save-excursion - (set-buffer gnus-article-buffer) + (with-current-buffer gnus-article-buffer (let ((article (cdr gnus-article-current))) - (unless (save-excursion - (set-buffer gnus-summary-buffer) + (unless (with-current-buffer gnus-summary-buffer (gnus-article-displayed-root-p article)) (gnus-article-hide-citation))))) @@ -1079,8 +1090,7 @@ (gnus-overlay-put overlay 'face face)))))) (defun gnus-cite-toggle (prefix) - (save-excursion - (set-buffer gnus-article-buffer) + (with-current-buffer gnus-article-buffer (gnus-cite-parse-maybe nil t) (let ((buffer-read-only nil) (numbers (cdr (assoc prefix gnus-cite-prefix-alist))) @@ -1248,5 +1258,4 @@ ;; coding: iso-8859-1 ;; End: -;; arch-tag: 1997b044-6067-471e-8c8f-dc903093098a ;;; gnus-cite.el ends here
--- a/lisp/gnus/gnus-cus.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/gnus-cus.el Wed Sep 08 12:55:57 2010 +0900 @@ -1118,5 +1118,4 @@ (provide 'gnus-cus) -;; arch-tag: a37c285a-49bc-4235-8244-804536effeaf ;;; gnus-cus.el ends here
--- a/lisp/gnus/gnus-delay.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/gnus-delay.el Wed Sep 08 12:55:57 2010 +0900 @@ -192,5 +192,4 @@ ;; coding: iso-8859-1 ;; End: -;; arch-tag: fb2ad634-a897-4142-a503-f5991ec2349d ;;; gnus-delay.el ends here
--- a/lisp/gnus/gnus-demon.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/gnus-demon.el Wed Sep 08 12:55:57 2010 +0900 @@ -319,5 +319,4 @@ (provide 'gnus-demon) -;; arch-tag: 8dd5cd3d-6ae4-46b4-9b15-f5fca09fd392 ;;; gnus-demon.el ends here
--- a/lisp/gnus/gnus-diary.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/gnus-diary.el Wed Sep 08 12:55:57 2010 +0900 @@ -401,5 +401,4 @@ (provide 'gnus-diary) -;; arch-tag: 98467e70-337e-4ddc-b92d-45d403ff1b4b ;;; gnus-diary.el ends here
--- a/lisp/gnus/gnus-dired.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/gnus-dired.el Wed Sep 08 12:55:57 2010 +0900 @@ -204,7 +204,7 @@ (setq method (cdr (assoc 'viewer (car (mailcap-mime-info mime-type - 'all + 'all 'no-decode))))))) (let ((view-command (mm-mailcap-command method file-name nil))) (message "viewing via %s" view-command) @@ -261,5 +261,4 @@ (provide 'gnus-dired) -;; arch-tag: 44737731-e445-4638-a31e-713c7590ec76 ;;; gnus-dired.el ends here
--- a/lisp/gnus/gnus-draft.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/gnus-draft.el Wed Sep 08 12:55:57 2010 +0900 @@ -325,5 +325,4 @@ (provide 'gnus-draft) -;; arch-tag: 3d92af58-8c97-4a5c-9db4-a98e85198022 ;;; gnus-draft.el ends here
--- a/lisp/gnus/gnus-dup.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/gnus-dup.el Wed Sep 08 12:55:57 2010 +0900 @@ -159,5 +159,4 @@ (provide 'gnus-dup) -;; arch-tag: 903e94db-7b00-4d19-83ee-cf34a81fa5fb ;;; gnus-dup.el ends here
--- a/lisp/gnus/gnus-eform.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/gnus-eform.el Wed Sep 08 12:55:57 2010 +0900 @@ -130,5 +130,4 @@ (provide 'gnus-eform) -;; arch-tag: ef50678c-2c28-49ef-affc-e53b3b2c0bf6 ;;; gnus-eform.el ends here
--- a/lisp/gnus/gnus-ems.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/gnus-ems.el Wed Sep 08 12:55:57 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,7 +305,47 @@ (setq start end end nil)))))) +(eval-and-compile + (if (fboundp 'set-process-plist) + (progn + (defalias 'gnus-set-process-plist 'set-process-plist) + (defalias 'gnus-process-plist 'process-plist) + (defalias 'gnus-process-get 'process-get) + (defalias 'gnus-process-put 'process-put)) + (defun gnus-set-process-plist (process plist) + "Replace the plist of PROCESS with PLIST. Returns PLIST." + (put 'gnus-process-plist-internal process plist)) + + (defun gnus-process-plist (process) + "Return the plist of PROCESS." + ;; This form works but can't prevent the plist data from + ;; growing infinitely. + ;;(get 'gnus-process-plist-internal process) + (let* ((plist (symbol-plist 'gnus-process-plist-internal)) + (tem (memq process plist))) + (prog1 + (cadr tem) + ;; Remove it from the plist data. + (when tem + (if (eq plist tem) + (progn + (setcar plist (caddr plist)) + (setcdr plist (or (cdddr plist) '(nil)))) + (setcdr (nthcdr (- (length plist) (length tem) 1) plist) + (cddr tem))))))) + + (defun gnus-process-get (process propname) + "Return the value of PROCESS' PROPNAME property. +This is the last value stored with `(gnus-process-put PROCESS PROPNAME VALUE)'." + (plist-get (gnus-process-plist process) propname)) + + (defun gnus-process-put (process propname value) + "Change PROCESS' PROPNAME property to VALUE. +It can be retrieved with `(gnus-process-get PROCESS PROPNAME)'." + (gnus-set-process-plist process + (plist-put (gnus-process-plist process) + propname value))))) + (provide 'gnus-ems) -;; arch-tag: e7360b45-14b5-4171-aa39-69a44aed3cdb ;;; gnus-ems.el ends here
--- a/lisp/gnus/gnus-fun.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/gnus-fun.el Wed Sep 08 12:55:57 2010 +0900 @@ -290,5 +290,4 @@ (provide 'gnus-fun) -;; arch-tag: 9d000a69-15cc-4491-9dc0-4627484f50c1 ;;; gnus-fun.el ends here
--- a/lisp/gnus/gnus-group.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/gnus-group.el Wed Sep 08 12:55:57 2010 +0900 @@ -169,7 +169,7 @@ (function-item gnus-group-sort-by-rank) (function :tag "other" nil)))) -(defcustom gnus-group-line-format "%M\%S\%p\%P\%5y:%B%(%g%)%O\n" +(defcustom gnus-group-line-format "%M\%S\%p\%P\%5y:%B%(%g%)\n" "*Format of group lines. It works along the same lines as a normal formatting string, with some simple extensions. @@ -660,7 +660,6 @@ "h" gnus-group-make-help-group "u" gnus-group-make-useful-group "a" gnus-group-make-archive-group - "k" gnus-group-make-kiboze-group "l" gnus-group-nnimap-edit-acl "m" gnus-group-make-group "E" gnus-group-edit-group @@ -680,13 +679,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 @@ -938,7 +930,6 @@ ["Add the archive group" gnus-group-make-archive-group t] ["Make a doc group..." gnus-group-make-doc-group t] ["Make a web group..." gnus-group-make-web-group t] - ["Make a kiboze group..." gnus-group-make-kiboze-group t] ["Make a virtual group..." gnus-group-make-empty-virtual t] ["Add a group to a virtual..." gnus-group-add-to-virtual t] ["Make an ephemeral group..." gnus-group-read-ephemeral-group t] @@ -972,13 +963,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] @@ -996,7 +980,6 @@ ["Browse foreign server..." gnus-group-browse-foreign-server t] ["Enter server buffer" gnus-group-enter-server-mode t] ["Expire all expirable articles" gnus-group-expire-all-groups t] - ["Generate any kiboze groups" nnkiboze-generate-groups t] ["Gnus version" gnus-version t] ["Save .newsrc files" gnus-group-save-newsrc t] ["Suspend Gnus" gnus-group-suspend t] @@ -1705,72 +1688,66 @@ "Update all lines where GROUP appear. If VISIBLE-ONLY is non-nil, the group won't be displayed if it isn't already." - ;; Can't use `save-excursion' here, so we do it manually. - (let ((buf (current-buffer)) - mark) - (set-buffer gnus-group-buffer) - (setq mark (point-marker)) - ;; The buffer may be narrowed. - (save-restriction - (widen) - (let ((ident (gnus-intern-safe group gnus-active-hashtb)) - (loc (point-min)) - found buffer-read-only) - ;; Enter the current status into the dribble buffer. - (let ((entry (gnus-group-entry group))) - (when (and entry - (not (gnus-ephemeral-group-p group))) - (gnus-dribble-enter - (concat "(gnus-group-set-info '" - (gnus-prin1-to-string (nth 2 entry)) - ")")))) - ;; Find all group instances. If topics are in use, each group - ;; may be listed in more than once. - (while (setq loc (text-property-any - loc (point-max) 'gnus-group ident)) - (setq found t) - (goto-char loc) - (let ((gnus-group-indentation (gnus-group-group-indentation))) - (gnus-delete-line) - (gnus-group-insert-group-line-info group) - (save-excursion - (forward-line -1) - (gnus-run-hooks 'gnus-group-update-group-hook))) - (setq loc (1+ loc))) - (unless (or found visible-only) - ;; No such line in the buffer, find out where it's supposed to - ;; go, and insert it there (or at the end of the buffer). - (if gnus-goto-missing-group-function - (funcall gnus-goto-missing-group-function group) - (let ((entry (cddr (gnus-group-entry group)))) - (while (and entry (car entry) - (not - (gnus-goto-char - (text-property-any - (point-min) (point-max) - 'gnus-group (gnus-intern-safe - (caar entry) gnus-active-hashtb))))) - (setq entry (cdr entry))) - (or entry (goto-char (point-max))))) - ;; Finally insert the line. - (let ((gnus-group-indentation (gnus-group-group-indentation))) - (gnus-group-insert-group-line-info group) - (save-excursion - (forward-line -1) - (gnus-run-hooks 'gnus-group-update-group-hook)))) - (when gnus-group-update-group-function - (funcall gnus-group-update-group-function group)) - (gnus-group-set-mode-line))) - (goto-char mark) - (set-marker mark nil) - (set-buffer buf))) + (with-current-buffer gnus-group-buffer + (save-excursion + ;; The buffer may be narrowed. + (save-restriction + (widen) + (let ((ident (gnus-intern-safe group gnus-active-hashtb)) + (loc (point-min)) + found buffer-read-only) + ;; Enter the current status into the dribble buffer. + (let ((entry (gnus-group-entry group))) + (when (and entry + (not (gnus-ephemeral-group-p group))) + (gnus-dribble-enter + (concat "(gnus-group-set-info '" + (gnus-prin1-to-string (nth 2 entry)) + ")")))) + ;; Find all group instances. If topics are in use, each group + ;; may be listed in more than once. + (while (setq loc (text-property-any + loc (point-max) 'gnus-group ident)) + (setq found t) + (goto-char loc) + (let ((gnus-group-indentation (gnus-group-group-indentation))) + (gnus-delete-line) + (gnus-group-insert-group-line-info group) + (save-excursion + (forward-line -1) + (gnus-run-hooks 'gnus-group-update-group-hook))) + (setq loc (1+ loc))) + (unless (or found visible-only) + ;; No such line in the buffer, find out where it's supposed to + ;; go, and insert it there (or at the end of the buffer). + (if gnus-goto-missing-group-function + (funcall gnus-goto-missing-group-function group) + (let ((entry (cddr (gnus-group-entry group)))) + (while (and entry (car entry) + (not + (gnus-goto-char + (text-property-any + (point-min) (point-max) + 'gnus-group (gnus-intern-safe + (caar entry) + gnus-active-hashtb))))) + (setq entry (cdr entry))) + (or entry (goto-char (point-max))))) + ;; Finally insert the line. + (let ((gnus-group-indentation (gnus-group-group-indentation))) + (gnus-group-insert-group-line-info group) + (save-excursion + (forward-line -1) + (gnus-run-hooks 'gnus-group-update-group-hook)))) + (when gnus-group-update-group-function + (funcall gnus-group-update-group-function group)) + (gnus-group-set-mode-line)))))) (defun gnus-group-set-mode-line () "Update the mode line in the group buffer." (when (memq 'group gnus-updated-mode-lines) ;; Yes, we want to keep this mode line updated. - (save-excursion - (set-buffer gnus-group-buffer) + (with-current-buffer gnus-group-buffer (let* ((gformat (or gnus-group-mode-line-format-spec (gnus-set-format 'group-mode))) (gnus-tmp-news-server (cadr gnus-select-method)) @@ -1783,8 +1760,7 @@ (and gnus-dribble-buffer (buffer-name gnus-dribble-buffer) (buffer-modified-p gnus-dribble-buffer) - (save-excursion - (set-buffer gnus-dribble-buffer) + (with-current-buffer gnus-dribble-buffer (not (zerop (buffer-size)))))) (mode-string (eval gformat))) ;; Say whether the dribble buffer has been modified. @@ -2202,7 +2178,10 @@ The arguments are the same as `completing-read' except that COLLECTION and HIST default to `gnus-active-hashtb' and `gnus-group-history' respectively if they are omitted." - (let (group) + (let ((completion-styles (and (boundp 'completion-styles) + completion-styles)) + group) + (push 'substring completion-styles) (mapatoms (lambda (symbol) (setq group (symbol-name symbol)) (set (intern (if (string-match "[^\000-\177]" group) @@ -3094,42 +3073,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." @@ -3170,41 +3113,6 @@ (gnus-group-real-name group) (list 'nndir (gnus-group-real-name group) (list 'nndir-directory dir))))) -(defvar nnkiboze-score-file) -(declare-function nnkiboze-score-file "nnkiboze" (group)) - -(defun gnus-group-make-kiboze-group (group address scores) - "Create an nnkiboze group. -The user will be prompted for a name, a regexp to match groups, and -score file entries for articles to include in the group." - (interactive - (list - (read-string "nnkiboze group name: ") - (read-string "Source groups (regexp): ") - (let ((headers (mapcar 'list - '("subject" "from" "number" "date" "message-id" - "references" "chars" "lines" "xref" - "followup" "all" "body" "head"))) - scores header regexp regexps) - (while (not (equal "" (setq header (completing-read - "Match on header: " headers nil t)))) - (setq regexps nil) - (while (not (equal "" (setq regexp (read-string - (format "Match on %s (regexp): " - header))))) - (push (list regexp nil nil 'r) regexps)) - (push (cons header regexps) scores)) - scores))) - (gnus-group-make-group group "nnkiboze" address) - (let* ((nnkiboze-current-group group) - (score-file (car (nnkiboze-score-file ""))) - (score-dir (file-name-directory score-file))) - (unless (file-exists-p score-dir) - (make-directory score-dir)) - (with-temp-file score-file - (let (emacs-lisp-mode-hook) - (gnus-pp scores))))) - (defun gnus-group-add-to-virtual (n vgroup) "Add the current group to a virtual group." (interactive @@ -4074,23 +3982,13 @@ (>= arg gnus-use-nocem)) (not arg))) (gnus-nocem-scan-groups)) - ;; If ARG is not a number, then we read the active file. - (when (and arg (not (numberp arg))) - (let ((gnus-read-active-file t)) - (gnus-read-active-file)) - (setq arg nil) - - ;; If the user wants it, we scan for new groups. - (when (eq gnus-check-new-newsgroups 'always) - (gnus-find-new-newsgroups))) - - (setq arg (gnus-group-default-level arg t)) - (if (and gnus-read-active-file (not arg)) - (progn - (gnus-read-active-file) - (gnus-get-unread-articles arg)) - (let ((gnus-read-active-file (if arg nil gnus-read-active-file))) - (gnus-get-unread-articles arg))) + + (gnus-get-unread-articles arg) + + ;; If the user wants it, we scan for new groups. + (when (eq gnus-check-new-newsgroups 'always) + (gnus-find-new-newsgroups)) + (gnus-check-reasonable-setup) (gnus-run-hooks 'gnus-after-getting-new-news-hook) (gnus-group-list-groups (and (numberp arg) @@ -4480,8 +4378,7 @@ (gnus-run-hooks 'gnus-exit-gnus-hook) (gnus-configure-windows 'group t) (when (and (gnus-buffer-live-p gnus-dribble-buffer) - (not (zerop (save-excursion - (set-buffer gnus-dribble-buffer) + (not (zerop (with-current-buffer gnus-dribble-buffer (buffer-size))))) (gnus-dribble-enter ";;; Gnus was exited on purpose without saving the .newsrc files.")) @@ -4542,13 +4439,11 @@ (setcar (nthcdr (1- total) info) part-info))) (unless entry ;; This is a new group, so we just create it. - (save-excursion - (set-buffer gnus-group-buffer) + (with-current-buffer gnus-group-buffer (setq method (gnus-info-method info)) (when (gnus-server-equal method "native") (setq method nil)) - (save-excursion - (set-buffer gnus-group-buffer) + (with-current-buffer gnus-group-buffer (if method ;; It's a foreign group... (gnus-group-make-group @@ -4612,8 +4507,7 @@ "Mark ARTICLE in GROUP with MARK, whether the group is displayed or not." (let ((buffer (gnus-summary-buffer-name group))) (if (gnus-buffer-live-p buffer) - (save-excursion - (set-buffer (get-buffer buffer)) + (with-current-buffer (get-buffer buffer) (gnus-summary-add-mark article mark)) (gnus-add-marked-articles group (cdr (assq mark gnus-article-mark-lists)) (list article))))) @@ -4813,5 +4707,4 @@ (provide 'gnus-group) -;; arch-tag: 2eb5440f-0bca-4091-814c-e37817536af6 ;;; gnus-group.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus/gnus-html.el Wed Sep 08 12:55:57 2010 +0900 @@ -0,0 +1,412 @@ +;;; gnus-html.el --- Render HTML in a buffer. + +;; Copyright (C) 2010 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> +;; Keywords: html, web + +;; 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: + +;; The idea is to provide a simple, fast and pretty minimal way to +;; render HTML (including links and images) in a buffer, based on an +;; external HTML renderer (i.e., w3m). + +;;; 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/") + "Where Gnus will cache images it downloads from the web." + :version "24.1" + :group 'gnus-art + :type 'directory) + +(defcustom gnus-html-cache-size 500000000 + "The size of the Gnus image cache." + :version "24.1" + :group 'gnus-art + :type 'integer) + +(defcustom gnus-html-frame-width 70 + "What width to use when rendering HTML." + :version "24.1" + :group 'gnus-art + :type 'integer) + +(defcustom gnus-blocked-images "." + "Images that have URLs matching this regexp will be blocked." + :version "24.1" + :group 'gnus-art + :type 'regexp) + +(defcustom gnus-max-image-proportion 0.7 + "How big pictures displayed are in relation to the window they're in. +A value of 0.7 means that they are allowed to take up 70% of the +width and height of the window. If they are larger than this, +and Emacs supports it, then the images will be rescaled down to +fit these criteria." + :version "24.1" + :group 'gnus-art + :type 'float) + +(defvar gnus-html-image-map + (let ((map (make-sparse-keymap))) + (define-key map "u" 'gnus-article-copy-string) + (define-key map "i" 'gnus-html-insert-image) + map)) + +;;;###autoload +(defun gnus-article-html (&optional handle) + (let ((article-buffer (current-buffer))) + (unless handle + (setq handle (mm-dissect-buffer t))) + (save-restriction + (narrow-to-region (point) (point)) + (save-excursion + (mm-with-part handle + (let* ((coding-system-for-read 'utf-8) + (coding-system-for-write 'utf-8) + (default-process-coding-system + (cons coding-system-for-read coding-system-for-write)) + (charset (mail-content-type-get (mm-handle-type handle) + 'charset))) + (when (and charset + (setq charset (mm-charset-to-coding-system charset)) + (not (eq charset 'ascii))) + (insert (prog1 + (mm-decode-coding-string (buffer-string) charset) + (erase-buffer) + (mm-enable-multibyte)))) + (call-process-region (point-min) (point-max) + "w3m" + nil article-buffer nil + "-halfdump" + "-no-cookie" + "-I" "UTF-8" + "-O" "UTF-8" + "-o" "ext_halfdump=1" + "-o" "pre_conv=1" + "-t" (format "%s" tab-width) + "-cols" (format "%s" gnus-html-frame-width) + "-o" "display_image=on" + "-T" "text/html")))) + (gnus-html-wash-tags)))) + +(defvar gnus-article-mouse-face) + +(defun gnus-html-wash-tags () + (let (tag parameters string start end images url) + (goto-char (point-min)) + (while (re-search-forward " *<pre_int> *</pre_int> *\n" nil t) + (replace-match "" t t)) + (goto-char (point-min)) + (while (re-search-forward "<a name[^\n>]+>" nil t) + (replace-match "" t t)) + (goto-char (point-min)) + (while (re-search-forward "<\\([^ />]+\\)\\([^>]*\\)>" nil t) + (setq tag (match-string 1) + parameters (match-string 2) + start (match-beginning 0)) + (when (plusp (length parameters)) + (set-text-properties 0 (1- (length parameters)) nil parameters)) + (delete-region start (point)) + (when (search-forward (concat "</" tag ">") (line-end-position) t) + (delete-region (match-beginning 0) (match-end 0))) + (setq end (point)) + (cond + ;; Fetch and insert a picture. + ((equal tag "img_alt") + (when (string-match "src=\"\\([^\"]+\\)" parameters) + (setq url (match-string 1 parameters)) + (gnus-message 8 "gnus-html-wash-tags: fetching image URL %s" url) + (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 + (let ((string (buffer-substring start end))) + (delete-region start end) + (gnus-put-image image (gnus-string-or string "*") 'cid) + (gnus-add-image 'cid image)))) + ;; Normal, external URL. + (if (gnus-html-image-url-blocked-p + url + (if (buffer-live-p gnus-summary-buffer) + (with-current-buffer gnus-summary-buffer + gnus-blocked-images) + gnus-blocked-images)) + (progn + (widget-convert-button + 'link start end + :action 'gnus-html-insert-image + :help-echo url + :keymap gnus-html-image-map + :button-keymap gnus-html-image-map) + (let ((overlay (gnus-make-overlay start end)) + (spec (list url + (set-marker (make-marker) start) + (set-marker (make-marker) end)))) + (gnus-overlay-put overlay 'local-map gnus-html-image-map) + (gnus-overlay-put overlay 'gnus-image spec) + (gnus-put-text-property + start end + 'gnus-image spec))) + (let ((file (gnus-html-image-id url)) + width height) + (when (string-match "height=\"?\\([0-9]+\\)" parameters) + (setq height (string-to-number (match-string 1 parameters)))) + (when (string-match "width=\"?\\([0-9]+\\)" parameters) + (setq width (string-to-number (match-string 1 parameters)))) + ;; Don't fetch images that are really small. They're + ;; probably tracking pictures. + (when (and (or (null height) + (> height 4)) + (or (null width) + (> width 4))) + (if (file-exists-p file) + ;; It's already cached, so just insert it. + (let ((string (buffer-substring start end))) + ;; Delete the ALT text. + (delete-region start end) + (gnus-html-put-image file (point) string)) + ;; 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. + ((or (equal tag "a") + (equal tag "A")) + (when (string-match "href=\"\\([^\"]+\\)" parameters) + (setq url (match-string 1 parameters)) + (gnus-message 8 "gnus-html-wash-tags: fetching link URL %s" url) + (gnus-article-add-button start end + 'browse-url url + url) + (let ((overlay (gnus-make-overlay start end))) + (gnus-overlay-put overlay 'evaporate t) + (gnus-overlay-put overlay 'gnus-button-url url) + (gnus-put-text-property start end 'gnus-string url) + (when gnus-article-mouse-face + (gnus-overlay-put overlay 'mouse-face gnus-article-mouse-face))))) + ;; The upper-case IMG_ALT is apparently just an artifact that + ;; should be deleted. + ((equal tag "IMG_ALT") + (delete-region start end)) + ;; Whatever. Just ignore the tag. + (t + )) + (goto-char start)) + (goto-char (point-min)) + ;; The output from -halfdump isn't totally regular, so strip + ;; off any </pre_int>s that were left over. + (while (re-search-forward "</pre_int>\\|</internal>" nil t) + (replace-match "" t t)) + (when images + (gnus-html-schedule-image-fetching (current-buffer) (nreverse images))) + (mm-url-decode-entities))) + +(defun gnus-html-insert-image () + "Fetch and insert the image under point." + (interactive) + (gnus-html-schedule-image-fetching + (current-buffer) (list (get-text-property (point) 'gnus-image)))) + +(defun gnus-html-schedule-image-fetching (buffer images) + (gnus-message 8 "gnus-html-schedule-image-fetching: buffer %s, images %s" + buffer images) + (let* ((url (caar images)) + (process (start-process + "images" nil "curl" + "-s" "--create-dirs" + "--location" + "--max-time" "60" + "-o" (gnus-html-image-id url) + url))) + (process-kill-without-query process) + (set-process-sentinel process 'gnus-html-curl-sentinel) + (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 (gnus-process-get process 'images)) + (buffer (gnus-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 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)) (point-min)))) + (with-current-buffer buffer + (let ((inhibit-read-only t) + (string (buffer-substring (cadr spec) (caddr spec)))) + (delete-region (cadr spec) (caddr spec)) + (gnus-html-put-image file (cadr spec) string)))) + (when images + (gnus-html-schedule-image-fetching buffer images))))) + +(defun gnus-html-put-image (file point string) + (when (gnus-graphic-display-p) + (let* ((image (ignore-errors + (gnus-create-image file))) + (size (and image + (if (featurep 'xemacs) + (cons (glyph-width image) (glyph-height image)) + (image-size image t))))) + (save-excursion + (goto-char point) + (if (and image + ;; Kludge to avoid displaying 30x30 gif images, which + ;; seems to be a signal of a broken image. + (not (and (if (featurep 'xemacs) + (glyphp image) + (listp image)) + (eq (if (featurep 'xemacs) + (let ((data (cdadar (specifier-spec-list + (glyph-image image))))) + (and (vectorp data) + (aref data 0))) + (plist-get (cdr image) :type)) + 'gif) + (= (car size) 30) + (= (cdr size) 30)))) + (progn + (setq image (gnus-html-rescale-image image file size)) + (gnus-put-image image + (gnus-string-or string "*") + 'external) + (gnus-add-image 'external image) + t) + (insert string) + (when (fboundp 'find-image) + (setq image (find-image '((:type xpm :file "lock-broken.xpm")))) + (gnus-put-image image + (gnus-string-or string "*") + 'internal) + (gnus-add-image 'internal image)) + nil))))) + +(defun gnus-html-rescale-image (image file size) + (if (or (not (fboundp 'imagemagick-types)) + (not (get-buffer-window (current-buffer)))) + image + (let* ((width (car size)) + (height (cdr size)) + (edges (window-pixel-edges (get-buffer-window (current-buffer)))) + (window-width (truncate (* gnus-max-image-proportion + (- (nth 2 edges) (nth 0 edges))))) + (window-height (truncate (* gnus-max-image-proportion + (- (nth 3 edges) (nth 1 edges))))) + scaled-image) + (when (> height window-height) + (setq image (or (create-image file 'imagemagick nil + :height window-height) + image)) + (setq size (image-size image t))) + (when (> (car size) window-width) + (setq image (or + (create-image file 'imagemagick nil + :width window-width) + image))) + image))) + +(defun gnus-html-prune-cache () + (let ((total-size 0) + files) + (dolist (file (directory-files gnus-html-cache-directory t nil t)) + (let ((attributes (file-attributes file))) + (unless (nth 0 attributes) + (incf total-size (nth 7 attributes)) + (push (list (time-to-seconds (nth 5 attributes)) + (nth 7 attributes) file) + files)))) + (when (> total-size gnus-html-cache-size) + (setq files (sort files (lambda (f1 f2) + (< (car f1) (car f2))))) + (dolist (file files) + (when (> total-size gnus-html-cache-size) + (decf total-size (cadr file)) + (delete-file (nth 2 file))))))) + +(defun gnus-html-image-url-blocked-p (url blocked-images) +"Find out if URL is blocked by BLOCKED-IMAGES." + (let ((ret (and blocked-images + (string-match blocked-images url)))) + (if ret + (gnus-message 8 "gnus-html-image-url-blocked-p: %s blocked by regex %s" + url blocked-images) + (gnus-message 9 "gnus-html-image-url-blocked-p: %s passes regex %s" + url blocked-images)) + ret)) + +(defun gnus-html-show-images () + "Show any images that are in the HTML-rendered article buffer. +This only works if the article in question is HTML." + (interactive) + (gnus-with-article-buffer + (let ((overlays (overlays-in (point-min) (point-max))) + overlay images) + (while (setq overlay (pop overlays)) + (when (overlay-get overlay 'gnus-image) + (push (overlay-get overlay 'gnus-image) images))) + (if (not images) + (message "No images to show") + (gnus-html-schedule-image-fetching (current-buffer) images))))) + +;;;###autoload +(defun gnus-html-prefetch-images (summary) + (let (blocked-images urls) + (when (buffer-live-p summary) + (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))) + (unless (gnus-html-image-url-blocked-p url blocked-images) + (unless (file-exists-p (gnus-html-image-id url)) + (push url urls) + (push (gnus-html-image-id url) urls) + (push "-o" urls))))) + (let ((process + (apply 'start-process + "images" nil "curl" + "-s" "--create-dirs" + "--location" + "--max-time" "60" + urls))) + (process-kill-without-query process)))))) + +(provide 'gnus-html) + +;;; gnus-html.el ends here
--- a/lisp/gnus/gnus-int.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/gnus-int.el Wed Sep 08 12:55:57 2010 +0900 @@ -365,7 +365,7 @@ (when (stringp gnus-command-method) (setq gnus-command-method (inline (gnus-server-to-method gnus-command-method)))) - (funcall (inline (gnus-get-function gnus-command-method 'request-group)) + (funcall (inline (gnus-get-function gnus-command-method 'request-group)) (gnus-group-real-name group) (nth 1 gnus-command-method) dont-check))) @@ -544,7 +544,8 @@ (if group (gnus-find-method-for-group group) gnus-command-method)) (gnus-inhibit-demon t) (mail-source-plugged gnus-plugged)) - (when (or gnus-plugged (not (gnus-agent-method-p gnus-command-method))) + (when (or gnus-plugged + (not (gnus-agent-method-p gnus-command-method))) (setq gnus-internal-registry-spool-current-method gnus-command-method) (funcall (gnus-get-function gnus-command-method 'request-scan) (and group (gnus-group-real-name group)) @@ -716,5 +717,4 @@ (provide 'gnus-int) -;; arch-tag: bbc90087-9b7f-4017-a92c-3abf180ac86d ;;; gnus-int.el ends here
--- a/lisp/gnus/gnus-kill.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/gnus-kill.el Wed Sep 08 12:55:57 2010 +0900 @@ -715,5 +715,4 @@ (provide 'gnus-kill) -;; arch-tag: b30c0f53-df1a-490b-b81e-17b13474f395 ;;; gnus-kill.el ends here
--- a/lisp/gnus/gnus-logic.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/gnus-logic.el Wed Sep 08 12:55:57 2010 +0900 @@ -225,5 +225,4 @@ (provide 'gnus-logic) -;; arch-tag: 9651a100-4a59-4b69-a55b-e511e67c0f8d ;;; gnus-logic.el ends here
--- a/lisp/gnus/gnus-mh.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/gnus-mh.el Wed Sep 08 12:55:57 2010 +0900 @@ -109,5 +109,4 @@ (provide 'gnus-mh) -;; arch-tag: 2d5696d3-b363-48e5-8749-c256be56acca ;;; gnus-mh.el ends here
--- a/lisp/gnus/gnus-ml.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/gnus-ml.el Wed Sep 08 12:55:57 2010 +0900 @@ -180,5 +180,4 @@ (provide 'gnus-ml) -;; arch-tag: 936c0fe6-acce-4c16-87d0-eded88078896 ;;; gnus-ml.el ends here
--- a/lisp/gnus/gnus-mlspl.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/gnus-mlspl.el Wed Sep 08 12:55:57 2010 +0900 @@ -227,5 +227,4 @@ (provide 'gnus-mlspl) -;; arch-tag: 62b3381f-1e45-4b61-be1a-29fb27703322 ;;; gnus-mlspl.el ends here
--- a/lisp/gnus/gnus-move.el Wed Sep 01 11:03:05 2010 +0900 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,181 +0,0 @@ -;;; gnus-move.el --- commands for moving Gnus from one server to another - -;; Copyright (C) 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> -;; 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: - -;;; Code: - -(eval-when-compile (require 'cl)) - -(require 'gnus) -(require 'gnus-start) -(require 'gnus-int) -(require 'gnus-range) - -;;; -;;; Moving by comparing Message-ID's. -;;; - -;;;###autoload -(defun gnus-change-server (from-server to-server) - "Move from FROM-SERVER to TO-SERVER. -Update the .newsrc.eld file to reflect the change of nntp server." - (interactive - (list gnus-select-method (gnus-read-method "Move to method: "))) - - ;; First start Gnus. - (let ((gnus-activate-level 0) - (mail-sources nil)) - (gnus)) - - (save-excursion - ;; Go through all groups and translate. - (let ((nntp-nov-gap nil)) - (dolist (info gnus-newsrc-alist) - (when (gnus-group-native-p (gnus-info-group info)) - (gnus-move-group-to-server info from-server to-server)))))) - -(defun gnus-move-group-to-server (info from-server to-server) - "Move group INFO from FROM-SERVER to TO-SERVER." - (let ((group (gnus-info-group info)) - to-active hashtb type mark marks - to-article to-reads to-marks article - act-articles) - (gnus-message 7 "Translating %s..." group) - (when (gnus-request-group group nil to-server) - (setq to-active (gnus-parse-active) - hashtb (gnus-make-hashtable 1024) - act-articles (gnus-uncompress-range to-active)) - ;; Fetch the headers from the `to-server'. - (when (and to-active - act-articles - (setq type (gnus-retrieve-headers - act-articles - group to-server))) - ;; Convert HEAD headers. I don't care. - (when (eq type 'headers) - (nnvirtual-convert-headers)) - ;; Create a mapping from Message-ID to article number. - (set-buffer nntp-server-buffer) - (goto-char (point-min)) - (while (looking-at - "^[0-9]+\t[^\t]*\t[^\t]*\t[^\t]*\t\\([^\t]*\\)\t") - (gnus-sethash - (buffer-substring (match-beginning 1) (match-end 1)) - (read (current-buffer)) - hashtb) - (forward-line 1)) - ;; Then we read the headers from the `from-server'. - (when (and (gnus-request-group group nil from-server) - (gnus-active group) - (gnus-uncompress-range - (gnus-active group)) - (setq type (gnus-retrieve-headers - (gnus-uncompress-range - (gnus-active group)) - group from-server))) - ;; Make it easier to map marks. - (let ((mark-lists (gnus-info-marks info)) - ms type m) - (while mark-lists - (setq type (caar mark-lists) - ms (gnus-uncompress-range (cdr (pop mark-lists)))) - (while ms - (if (setq m (assq (car ms) marks)) - (setcdr m (cons type (cdr m))) - (push (list (car ms) type) marks)) - (pop ms)))) - ;; Convert. - (when (eq type 'headers) - (nnvirtual-convert-headers)) - ;; Go through the headers and map away. - (set-buffer nntp-server-buffer) - (goto-char (point-min)) - (while (looking-at - "^[0-9]+\t[^\t]*\t[^\t]*\t[^\t]*\t\\([^\t]*\\)\t") - (when (setq to-article - (gnus-gethash - (buffer-substring (match-beginning 1) (match-end 1)) - hashtb)) - ;; Add this article to the list of read articles. - (push to-article to-reads) - ;; See if there are any marks and then add them. - (when (setq mark (assq (read (current-buffer)) marks)) - (setq marks (delq mark marks)) - (setcar mark to-article) - (push mark to-marks)) - (forward-line 1))) - ;; Now we know what the read articles are and what the - ;; article marks are. We transform the information - ;; into the Gnus info format. - (setq to-reads - (gnus-range-add - (gnus-compress-sequence - (and (setq to-reads (delq nil to-reads)) - (sort to-reads '<)) - t) - (cons 1 (1- (car to-active))))) - (gnus-info-set-read info to-reads) - ;; Do the marks. I'm sure y'all understand what's - ;; going on down below, so I won't bother with any - ;; further comments. <duck> - (let ((mlists gnus-article-mark-lists) - lists ms a) - (while mlists - (push (list (cdr (pop mlists))) lists)) - (while (setq ms (pop marks)) - (setq article (pop ms)) - (while ms - (setcdr (setq a (assq (pop ms) lists)) - (cons article (cdr a))))) - (setq a lists) - (while a - (setcdr (car a) (gnus-compress-sequence - (and (cdar a) (sort (cdar a) '<)))) - (pop a)) - (gnus-info-set-marks info lists t))))) - (gnus-message 7 "Translating %s...done" group))) - -(defun gnus-group-move-group-to-server (info from-server to-server) - "Move the group on the current line from FROM-SERVER to TO-SERVER." - (interactive - (let ((info (gnus-get-info (gnus-group-group-name)))) - (list info (gnus-find-method-for-group (gnus-info-group info)) - (gnus-read-method (format "Move group %s to method: " - (gnus-info-group info)))))) - (save-excursion - (gnus-move-group-to-server info from-server to-server) - ;; We have to update the group info to point use the right server. - (gnus-info-set-method info to-server t) - ;; We also have to change the name of the group and stuff. - (let* ((group (gnus-info-group info)) - (new-name (gnus-group-prefixed-name - (gnus-group-real-name group) to-server))) - (gnus-info-set-group info new-name) - (gnus-sethash new-name (gnus-group-entry group) gnus-newsrc-hashtb) - (gnus-sethash group nil gnus-newsrc-hashtb)))) - -(provide 'gnus-move) - -;; arch-tag: 503742b8-7d66-4d79-bb31-4a698070707b -;;; gnus-move.el ends here
--- a/lisp/gnus/gnus-msg.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/gnus-msg.el Wed Sep 08 12:55:57 2010 +0900 @@ -1989,5 +1989,4 @@ (provide 'gnus-msg) -;; arch-tag: 9f22b2f5-1c0a-49de-916e-4c88e984852b ;;; gnus-msg.el ends here
--- a/lisp/gnus/gnus-nocem.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/gnus-nocem.el Wed Sep 08 12:55:57 2010 +0900 @@ -449,5 +449,4 @@ (provide 'gnus-nocem) -;; arch-tag: 0e0c74ea-2f8e-4f3e-8fff-09f767c1adef ;;; gnus-nocem.el ends here
--- a/lisp/gnus/gnus-picon.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/gnus-picon.el Wed Sep 08 12:55:57 2010 +0900 @@ -319,5 +319,4 @@ (provide 'gnus-picon) -;; arch-tag: fe9aede0-1b1b-463a-b4ab-807f98bcb31f ;;; gnus-picon.el ends here
--- a/lisp/gnus/gnus-range.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/gnus-range.el Wed Sep 08 12:55:57 2010 +0900 @@ -187,7 +187,7 @@ RANGE1 and RANGE2 have to be sorted over <." (let* (out (min1 (car range1)) - (max1 (if (numberp min1) + (max1 (if (numberp min1) (if (numberp (cdr range1)) (prog1 (cdr range1) (setq range1 nil)) min1) @@ -196,8 +196,8 @@ (min2 (car range2)) (max2 (if (numberp min2) (if (numberp (cdr range2)) - (prog1 (cdr range2) - (setq range2 nil)) min2) + (prog1 (cdr range2) + (setq range2 nil)) min2) (prog1 (cdr min2) (setq min2 (car min2)))))) (setq range1 (cdr range1) @@ -654,5 +654,4 @@ (provide 'gnus-range) -;; arch-tag: 4780bdd8-5a15-4aff-be28-18727895b6ad ;;; gnus-range.el ends here
--- a/lisp/gnus/gnus-registry.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/gnus-registry.el Wed Sep 08 12:55:57 2010 +0900 @@ -1,6 +1,6 @@ ;;; gnus-registry.el --- article registry for Gnus -;;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 +;;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 ;;; Free Software Foundation, Inc. ;; Author: Ted Zlatanov <tzz@lifelogs.com> @@ -72,7 +72,7 @@ :version "22.1" :group 'gnus) -(defvar gnus-registry-hashtb (make-hash-table +(defvar gnus-registry-hashtb (make-hash-table :size 256 :test 'equal) "*The article registry by Message ID.") @@ -97,7 +97,7 @@ "List of registry marks and their options. `gnus-registry-mark-article' will offer symbols from this list -for completion. +for completion. Each entry must have a character to be useful for summary mode line display and for keyboard shortcuts. @@ -121,7 +121,7 @@ :group 'gnus-registry :type 'symbol) -(defcustom gnus-registry-unfollowed-groups +(defcustom gnus-registry-unfollowed-groups '("delayed$" "drafts$" "queue$" "INBOX$") "List of groups that gnus-registry-split-fancy-with-parent won't return. The group names are matched, they don't have to be fully @@ -206,9 +206,9 @@ :group 'gnus-registry :type '(repeat symbol)) -(defcustom gnus-registry-cache-file - (nnheader-concat - (or gnus-dribble-directory gnus-home-directory "~/") +(defcustom gnus-registry-cache-file + (nnheader-concat + (or gnus-dribble-directory gnus-home-directory "~/") ".gnus.registry.eld") "File where the Gnus registry will be stored." :group 'gnus-registry @@ -253,7 +253,7 @@ (if gnus-save-startup-file-via-temp-buffer (let ((coding-system-for-write gnus-ding-file-coding-system) (standard-output (current-buffer))) - (gnus-gnus-to-quick-newsrc-format + (gnus-gnus-to-quick-newsrc-format t "gnus registry startup file" 'gnus-registry-alist) (gnus-registry-cache-whitespace file) (save-buffer)) @@ -276,7 +276,7 @@ (unwind-protect (progn (gnus-with-output-to-file working-file - (gnus-gnus-to-quick-newsrc-format + (gnus-gnus-to-quick-newsrc-format t "gnus registry startup file" 'gnus-registry-alist)) ;; These bindings will mislead the current buffer @@ -326,7 +326,7 @@ (when gnus-registry-clean-empty (gnus-registry-clean-empty-function)) ;; now trim and clean text properties from the registry appropriately - (setq gnus-registry-alist + (setq gnus-registry-alist (gnus-registry-remove-alist-text-properties (gnus-registry-trim (gnus-hashtable-to-alist @@ -346,7 +346,7 @@ (dolist (group (gnus-registry-fetch-groups key)) (when (gnus-parameter-registry-ignore group) (gnus-message - 10 + 10 "gnus-registry: deleted ignored group %s from key %s" group key) (gnus-registry-delete-group key group))) @@ -361,14 +361,14 @@ (gnus-registry-fetch-extra key 'label)) (incf count) (gnus-registry-delete-id key)) - + (unless (stringp key) - (gnus-message - 10 - "gnus-registry key %s was not a string, removing" + (gnus-message + 10 + "gnus-registry key %s was not a string, removing" key) (gnus-registry-delete-id key)))) - + gnus-registry-hashtb) count)) @@ -391,7 +391,7 @@ (defun gnus-registry-trim (alist) "Trim alist to size, using gnus-registry-max-entries. Any entries with extra data (marks, currently) are left alone." - (if (null gnus-registry-max-entries) + (if (null gnus-registry-max-entries) alist ; just return the alist ;; else, when given max-entries, trim the alist (let* ((timehash (make-hash-table @@ -420,25 +420,25 @@ (push item precious-list) (push item junk-list)))) - (sort + (sort junk-list (lambda (a b) - (let ((t1 (or (cdr (gethash (car a) timehash)) + (let ((t1 (or (cdr (gethash (car a) timehash)) '(0 0 0))) - (t2 (or (cdr (gethash (car b) timehash)) + (t2 (or (cdr (gethash (car b) timehash)) '(0 0 0)))) (time-less-p t1 t2)))) ;; we use the return value of this setq, which is the trimmed alist (setq alist (append precious-list (nthcdr trim-length junk-list)))))) - + (defun gnus-registry-action (action data-header from &optional to method) (let* ((id (mail-header-id data-header)) (subject (gnus-string-remove-all-properties (gnus-registry-simplify-subject (mail-header-subject data-header)))) - (sender (gnus-string-remove-all-properties + (sender (gnus-string-remove-all-properties (mail-header-from data-header))) (from (gnus-group-guess-full-name-from-command-method from)) (to (if to (gnus-group-guess-full-name-from-command-method to) nil)) @@ -489,7 +489,7 @@ (let* ((refstr (or (message-fetch-field "references") "")) ; guaranteed (reply-to (message-fetch-field "in-reply-to")) ; may be nil ;; now, if reply-to is valid, append it to the References - (refstr (if reply-to + (refstr (if reply-to (concat refstr " " reply-to) refstr)) ;; these may not be used, but the code is cleaner having them up here @@ -517,8 +517,8 @@ 9 "%s is looking for matches for reference %s from [%s]" log-agent reference refstr) - (dolist (group (gnus-registry-fetch-groups - reference + (dolist (group (gnus-registry-fetch-groups + reference gnus-registry-max-track-groups)) (when (and group (gnus-registry-follow-group-p group)) (gnus-message @@ -528,9 +528,9 @@ (push group found)))) ;; filter the found groups and return them ;; the found groups are the full groups - (setq found (gnus-registry-post-process-groups + (setq found (gnus-registry-post-process-groups "references" refstr found found))) - + ;; else: there were no matches, now try the extra tracking by sender ((and (gnus-registry-track-sender-p) sender @@ -543,7 +543,7 @@ matches) (when (and this-sender (equal sender this-sender)) - (let ((groups (gnus-registry-fetch-groups + (let ((groups (gnus-registry-fetch-groups key gnus-registry-max-track-groups))) (dolist (group groups) @@ -558,9 +558,9 @@ gnus-registry-hashtb) ;; filter the found groups and return them ;; the found groups are NOT the full groups - (setq found (gnus-registry-post-process-groups + (setq found (gnus-registry-post-process-groups "sender" sender found found-full))) - + ;; else: there were no matches, now try the extra tracking by subject ((and (gnus-registry-track-subject-p) subject @@ -572,7 +572,7 @@ matches) (when (and this-subject (equal subject this-subject)) - (let ((groups (gnus-registry-fetch-groups + (let ((groups (gnus-registry-fetch-groups key gnus-registry-max-track-groups))) (dolist (group groups) @@ -587,7 +587,7 @@ gnus-registry-hashtb) ;; filter the found groups and return them ;; the found groups are NOT the full groups - (setq found (gnus-registry-post-process-groups + (setq found (gnus-registry-post-process-groups "subject" subject found found-full)))) ;; after the (cond) we extract the actual value safely (car-safe found))) @@ -627,7 +627,7 @@ (lambda (a b) (> (gethash a freq 0) (gethash b freq 0))))))))) - + (if gnus-registry-use-long-group-names (dolist (group groups) (let ((m1 (gnus-find-method-for-group group)) @@ -708,8 +708,8 @@ (unless (member gnus-newsgroup-name (gnus-registry-fetch-groups id)) (gnus-message 9 "Registry: Registering article %d with group %s" article gnus-newsgroup-name) - (gnus-registry-add-group - id + (gnus-registry-add-group + id gnus-newsgroup-name (gnus-registry-fetch-simplified-message-subject-fast article) (gnus-registry-fetch-sender-fast article))))))) @@ -785,18 +785,18 @@ (shortcut (if remove (upcase shortcut) shortcut))) (unintern function-name) (eval - `(defun + `(defun ;; function name - ,(intern function-name) + ,(intern function-name) ;; parameter definition (&rest articles) ;; documentation - ,(format + ,(format "%s the %s mark over process-marked ARTICLES." (upcase-initials variant-name) mark) ;; interactive definition - (interactive + (interactive (gnus-summary-work-articles current-prefix-arg)) ;; actual code @@ -807,49 +807,49 @@ ;; now the user is asked if gnus-registry-install is 'ask (when (gnus-registry-install-p) - (gnus-registry-set-article-mark-internal + (gnus-registry-set-article-mark-internal ;; all this just to get the mark, I must be doing it wrong (intern ,(symbol-name mark)) articles ,remove t) (gnus-message - 9 + 9 "Applying mark %s to %d articles" ,(symbol-name mark) (length articles)) (dolist (article articles) - (gnus-summary-update-article + (gnus-summary-update-article article (assoc article (gnus-data-list nil))))))) (push (intern function-name) keys-plist) - (push shortcut keys-plist) + (push shortcut keys-plist) (push (vector (format "%s %s" (upcase-initials variant-name) (symbol-name mark)) (intern function-name) t) gnus-registry-misc-menus) (gnus-message - 9 - "Defined mark handling function %s" + 9 + "Defined mark handling function %s" function-name)))))) (gnus-define-keys-1 '(gnus-registry-mark-map "M" gnus-summary-mark-map) keys-plist) (add-hook 'gnus-summary-menu-hook (lambda () - (easy-menu-add-item + (easy-menu-add-item gnus-summary-misc-menu - nil + nil (cons "Registry Marks" gnus-registry-misc-menus)))))) ;;; use like this: -;;; (defalias 'gnus-user-format-function-M +;;; (defalias 'gnus-user-format-function-M ;;; 'gnus-registry-user-format-function-M) (defun gnus-registry-user-format-function-M (headers) (let* ((id (mail-header-message-id headers)) (marks (when id (gnus-registry-fetch-extra-marks id)))) (apply 'concat (mapcar (lambda(mark) - (let ((c + (let ((c (plist-get - (cdr-safe + (cdr-safe (assoc mark gnus-registry-marks)) :char))) (if c @@ -859,9 +859,9 @@ (defun gnus-registry-read-mark () "Read a mark name from the user with completion." - (let ((mark (gnus-completing-read-with-default + (let ((mark (gnus-completing-read-with-default (symbol-name gnus-registry-default-mark) - "Label" + "Label" (mapcar (lambda (x) ; completion list (cons (symbol-name (car-safe x)) (car-safe x))) gnus-registry-marks)))) @@ -896,7 +896,7 @@ (gnus-message 1 "%s mark %s with message ID %s, resulting in %S" (if remove "Removing" "Adding") mark id new-marks)) - + (apply 'gnus-registry-store-extra-marks ; set the extra marks id ; for the message ID new-marks))))) @@ -1007,7 +1007,7 @@ "Put a specific entry in the extras field of the registry entry for id." (let* ((extra (gnus-registry-fetch-extra id)) ;; all the entries except the one for `key' - (the-rest (gnus-assq-delete-all key (gnus-registry-fetch-extra id))) + (the-rest (gnus-assq-delete-all key (gnus-registry-fetch-extra id))) (alist (if value (gnus-registry-remove-alist-text-properties (cons (cons key value) @@ -1034,7 +1034,7 @@ (dolist (crumb trail) (when (stringp crumb) ;; push the group name into the list - (setq + (setq groups (cons (if (or (not (stringp crumb)) gnus-registry-use-long-group-names) @@ -1183,5 +1183,4 @@ (provide 'gnus-registry) -;; arch-tag: 5cba0a32-718a-4a97-8c91-0a15af21da94 ;;; gnus-registry.el ends here
--- a/lisp/gnus/gnus-salt.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/gnus-salt.el Wed Sep 08 12:55:57 2010 +0900 @@ -1045,5 +1045,4 @@ (provide 'gnus-salt) -;; arch-tag: 35449164-77b3-4398-bcbd-a2e3e998f810 ;;; gnus-salt.el ends here
--- a/lisp/gnus/gnus-score.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/gnus-score.el Wed Sep 08 12:55:57 2010 +0900 @@ -2055,8 +2055,11 @@ ;; Evil hackery to make match usable in non-standard headers. (when extra - (setq match (concat "[ (](" extra " \\. \"[^)]*" - match "[^\"]*\")[ )]") + (setq match (concat "[ (](" extra " \\. \"\\([^\"]*\\\\\"\\)*[^\"]*" + (if (eq search-func 're-search-forward) + match + (regexp-quote match)) + "\\([^\"]*\\\\\"\\)*[^\"]*\")[ )]") search-func 're-search-forward)) ; XXX danger?!? (cond @@ -3119,5 +3122,4 @@ (provide 'gnus-score) -;; arch-tag: d3922589-764d-46ae-9954-9330fd192634 ;;; gnus-score.el ends here
--- a/lisp/gnus/gnus-setup.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/gnus-setup.el Wed Sep 08 12:55:57 2010 +0900 @@ -189,5 +189,4 @@ (run-hooks 'gnus-setup-load-hook) -;; arch-tag: 08e4af93-8565-46bf-905c-36229400609d ;;; gnus-setup.el ends here
--- a/lisp/gnus/gnus-sieve.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/gnus-sieve.el Wed Sep 08 12:55:57 2010 +0900 @@ -235,5 +235,4 @@ (provide 'gnus-sieve) -;; arch-tag: 3b906527-c7f3-4c86-9e82-62e2697998a3 ;;; gnus-sieve.el ends here
--- a/lisp/gnus/gnus-soup.el Wed Sep 01 11:03:05 2010 +0900 +++ /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-spec.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/gnus-spec.el Wed Sep 08 12:55:57 2010 +0900 @@ -767,5 +767,4 @@ ;; coding: iso-8859-1 ;; End: -;; arch-tag: a4328fa1-1f84-4b09-97ad-4b5767cfd50f ;;; gnus-spec.el ends here
--- a/lisp/gnus/gnus-srvr.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/gnus-srvr.el Wed Sep 08 12:55:57 2010 +0900 @@ -1033,5 +1033,4 @@ (provide 'gnus-srvr) -;; arch-tag: c0117f64-27ca-475d-9406-8da6854c7a25 ;;; gnus-srvr.el ends here
--- a/lisp/gnus/gnus-start.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/gnus-start.el Wed Sep 08 12:55:57 2010 +0900 @@ -765,7 +765,7 @@ (when gnus-select-method (push (cons "native" gnus-select-method) gnus-predefined-server-alist)) - + (if gnus-agent (gnus-agentize)) @@ -869,6 +869,8 @@ (defun gnus-dribble-read-file () "Read the dribble file from disk." (let ((dribble-file (gnus-dribble-file-name))) + (unless (file-exists-p (file-name-directory dribble-file)) + (make-directory (file-name-directory dribble-file) t)) (save-excursion (set-buffer (setq gnus-dribble-buffer (gnus-get-buffer-create @@ -1524,7 +1526,8 @@ (when (> (cdr cache-active) (cdr active)) (setcdr active (cdr cache-active)))))))) -(defun gnus-activate-group (group &optional scan dont-check method) +(defun gnus-activate-group (group &optional scan dont-check method + dont-sub-check) "Check whether a group has been activated or not. If SCAN, request a scan of that group as well." (let ((method (or method (inline (gnus-find-method-for-group group)))) @@ -1539,9 +1542,11 @@ (gnus-request-scan group method)) t) (if (or debug-on-error debug-on-quit) - (inline (gnus-request-group group dont-check method)) + (inline (gnus-request-group group (or dont-sub-check dont-check) + method)) (condition-case nil - (inline (gnus-request-group group dont-check method)) + (inline (gnus-request-group group (or dont-sub-check dont-check) + method)) ;;(error nil) (quit (message "Quit activating %s" group) @@ -1672,18 +1677,22 @@ (let* ((newsrc (cdr gnus-newsrc-alist)) (alevel (or level gnus-activate-level (1+ gnus-level-subscribed))) (foreign-level - (min - (cond ((and gnus-activate-foreign-newsgroups - (not (numberp gnus-activate-foreign-newsgroups))) - (1+ gnus-level-subscribed)) - ((numberp gnus-activate-foreign-newsgroups) - gnus-activate-foreign-newsgroups) - (t 0)) - alevel)) + (or + level + (min + (cond ((and gnus-activate-foreign-newsgroups + (not (numberp gnus-activate-foreign-newsgroups))) + (1+ gnus-level-subscribed)) + ((numberp gnus-activate-foreign-newsgroups) + gnus-activate-foreign-newsgroups) + (t 0)) + alevel))) (methods-cache nil) (type-cache nil) - scanned-methods info group active method retrieve-groups cmethod - method-type) + (gnus-agent-article-local-times 0) + (archive-method (gnus-server-to-method "archive")) + infos info group active method cmethod + method-type method-group-list) (gnus-message 6 "Checking new news...") (while newsrc @@ -1702,114 +1711,101 @@ ;; nil for non-foreign groups that the user has requested not be checked ;; t for unchecked foreign groups or bogus groups, or groups that can't ;; be checked, for one reason or other. - (when (setq method (gnus-info-method info)) + + ;; First go through all the groups, see what select methods they + ;; belong to, and then collect them into lists per unique select + ;; method. + (if (not (setq method (gnus-info-method info))) + (setq method gnus-select-method) (if (setq cmethod (assoc method methods-cache)) (setq method (cdr cmethod)) (setq cmethod (inline (gnus-server-get-method nil method))) (push (cons method cmethod) methods-cache) (setq method cmethod))) - (when (and method - (not (setq method-type (cdr (assoc method type-cache))))) + (setq method-group-list (assoc method type-cache)) + (unless method-group-list (setq method-type (cond - ((gnus-secondary-method-p method) + ((or (gnus-secondary-method-p method) + (and (gnus-archive-server-wanted-p) + (gnus-methods-equal-p archive-method method))) 'secondary) ((inline (gnus-server-equal gnus-select-method method)) 'primary) (t 'foreign))) - (push (cons method method-type) type-cache)) + (push (setq method-group-list (list method method-type nil)) + type-cache)) + ;; Only add groups that need updating. + (when (<= (gnus-info-level info) + (if (eq (cadr method-group-list) 'foreign) + foreign-level + alevel)) + (setcar (nthcdr 2 method-group-list) + (cons info (nth 2 method-group-list))))) + + ;; Sort the methods based so that the primary and secondary + ;; methods come first. This is done for legacy reasons to try to + ;; ensure that side-effect behaviour doesn't change from previous + ;; Gnus versions. + (setq type-cache + (sort (nreverse type-cache) + (lambda (c1 c2) + (< (gnus-method-rank (cadr c1) (car c1)) + (gnus-method-rank (cadr c2) (car c2)))))) + + (while type-cache + (setq method (nth 0 (car type-cache)) + method-type (nth 1 (car type-cache)) + infos (nth 2 (car type-cache))) + (pop type-cache) + + (when (and method + infos) + ;; See if any of the groups from this method require updating. + (gnus-read-active-for-groups method infos) + (dolist (info infos) + (inline (gnus-get-unread-articles-in-group + info (gnus-active (gnus-info-group info))))))) + (gnus-message 6 "Checking new news...done"))) - (cond ((and method (eq method-type 'foreign)) - ;; These groups are foreign. Check the level. - (if (<= (gnus-info-level info) foreign-level) - (when (setq active (gnus-activate-group group 'scan)) - ;; Let the Gnus agent save the active file. - (when (and gnus-agent active (gnus-online method)) - (gnus-agent-save-group-info - method (gnus-group-real-name group) active)) - (unless (inline (gnus-virtual-group-p group)) - (inline (gnus-close-group group))) - (when (fboundp (intern (concat (symbol-name (car method)) - "-request-update-info"))) - (inline (gnus-request-update-info info method)))) - (if (and level - ;; If `active' is nil that means the group has - ;; never been read, the group should be marked - ;; as having never been checked (see below). - active - (> (gnus-info-level info) level)) - ;; Don't check groups of which levels are higher - ;; than the one that a user specified. - (setq active 'ignore)))) - ;; These groups are native or secondary. - ((> (gnus-info-level info) alevel) - ;; We don't want these groups. - (setq active 'ignore)) - ;; Activate groups. - ((not gnus-read-active-file) - (if (gnus-check-backend-function 'retrieve-groups group) - ;; if server support gnus-retrieve-groups we push - ;; the group onto retrievegroups for later checking - (if (assoc method retrieve-groups) - (setcdr (assoc method retrieve-groups) - (cons group (cdr (assoc method retrieve-groups)))) - (push (list method group) retrieve-groups)) - ;; hack: `nnmail-get-new-mail' changes the mail-source depending - ;; on the group, so we must perform a scan for every group - ;; if the users has any directory mail sources. - ;; hack: if `nnmail-scan-directory-mail-source-once' is non-nil, - ;; for it scan all spool files even when the groups are - ;; not required. - (if (and - (or nnmail-scan-directory-mail-source-once - (null (assq 'directory mail-sources))) - (member method scanned-methods)) - (setq active (gnus-activate-group group)) - (setq active (gnus-activate-group group 'scan)) - (push method scanned-methods)) - (when active - (gnus-close-group group))))) +(defun gnus-method-rank (type method) + (cond + ;; Get info for virtual groups last. + ((eq (car method) 'nnvirtual) + 200) + ((eq type 'primary) + 1) + ;; Compute the rank of the secondary methods based on where they + ;; are in the secondary select list. + ((eq type 'secondary) + (let ((i 2)) + (block nil + (dolist (smethod gnus-secondary-select-methods) + (when (equal method smethod) + (return i)) + (incf i)) + i))) + ;; Just say that all foreign groups have the same rank. + (t + 100))) - ;; Get the number of unread articles in the group. - (cond - ((eq active 'ignore) - ;; Don't do anything. - ) - (active - (inline (gnus-get-unread-articles-in-group info active t))) - (t - ;; The group couldn't be reached, so we nix out the number of - ;; unread articles and stuff. - (gnus-set-active group nil) - (let ((tmp (gnus-group-entry group))) - (when tmp - (setcar tmp t)))))) - - ;; iterate through groups on methods which support gnus-retrieve-groups - ;; and fetch a partial active file and use it to find new news. - (dolist (rg retrieve-groups) - (let ((method (or (car rg) gnus-select-method)) - (groups (cdr rg))) - (when (gnus-check-server method) - ;; Request that the backend scan its incoming messages. - (when (gnus-check-backend-function 'request-scan (car method)) - (gnus-request-scan nil method)) - (gnus-read-active-file-2 - (mapcar (lambda (group) (gnus-group-real-name group)) groups) - method) - (dolist (group groups) - (cond - ((setq active (gnus-active (gnus-info-group - (setq info (gnus-get-info group))))) - (inline (gnus-get-unread-articles-in-group info active t))) - (t - ;; The group couldn't be reached, so we nix out the number of - ;; unread articles and stuff. - (gnus-set-active group nil) - (setcar (gnus-group-entry group) t))))))) - - (gnus-message 6 "Checking new news...done"))) +(defun gnus-read-active-for-groups (method infos) + (with-current-buffer nntp-server-buffer + (cond + ((gnus-check-backend-function 'retrieve-groups (car method)) + (when (gnus-check-backend-function 'request-scan (car method)) + (gnus-request-scan nil method)) + (gnus-read-active-file-2 + (mapcar (lambda (info) + (gnus-group-real-name (gnus-info-group info))) + infos) + method)) + ((gnus-check-backend-function 'request-list (car method)) + (gnus-read-active-file-1 method nil)) + (t + (dolist (info infos) + (gnus-activate-group (gnus-info-group info) nil nil method t)))))) ;; Create a hash table out of the newsrc alist. The `car's of the ;; alist elements are used as keys. @@ -1831,14 +1827,18 @@ (if (setq rest (member method methods)) (gnus-info-set-method info (car rest)) (push method methods))) - (gnus-sethash - (car info) - ;; Preserve number of unread articles in groups. - (cons (and ohashtb (car (gnus-gethash (car info) ohashtb))) - prev) - gnus-newsrc-hashtb) - (setq prev alist - alist (cdr alist))) + ;; Check for duplicates. + (if (gnus-gethash (car info) gnus-newsrc-hashtb) + ;; Remove this entry from the alist. + (setcdr prev (cddr prev)) + (gnus-sethash + (car info) + ;; Preserve number of unread articles in groups. + (cons (and ohashtb (car (gnus-gethash (car info) ohashtb))) + prev) + gnus-newsrc-hashtb) + (setq prev alist)) + (setq alist (cdr alist))) ;; Make the same select-methods in `gnus-server-alist' identical ;; as well. (while methods @@ -2041,7 +2041,9 @@ (gnus-message 5 mesg) (when (gnus-check-server method) ;; Request that the backend scan its incoming messages. - (when (gnus-check-backend-function 'request-scan (car method)) + (when (and gnus-agent + (gnus-online method) + (gnus-check-backend-function 'request-scan (car method))) (gnus-request-scan nil method)) (cond ((and (eq gnus-read-active-file 'some) @@ -3193,7 +3195,4 @@ (provide 'gnus-start) -;; arch-tag: f4584a22-b7b7-4853-abfc-a637329af5d2 ;;; gnus-start.el ends here - -
--- a/lisp/gnus/gnus-sum.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/gnus-sum.el Wed Sep 08 12:55:57 2010 +0900 @@ -76,6 +76,13 @@ :version "23.1" ;; No Gnus :type 'boolean) +(defcustom gnus-summary-stop-at-end-of-message nil + "If non-nil, don't select the next message when using `SPC'." + :link '(custom-manual "(gnus)Group Maneuvering") + :group 'gnus-summary-maneuvering + :version "24.1" + :type 'boolean) + (defcustom gnus-fetch-old-headers nil "*Non-nil means that Gnus will try to build threads by grabbing old headers. If an unread article in the group refers to an older, already @@ -214,7 +221,7 @@ :group 'gnus-summary-format :type 'string) -(defcustom gnus-summary-goto-unread t +(defcustom gnus-summary-goto-unread nil "*If t, many commands will go to the next unread article. This applies to marking commands as well as other commands that \"naturally\" select the next article, like, for instance, `SPC' at @@ -224,6 +231,7 @@ \(they go to the next article instead). If `never', commands that usually go to the next unread article, will go to the next article, whether it is read or not." + :version "24.1" :group 'gnus-summary-marks :link '(custom-manual "(gnus)Setting Marks") :type '(choice (const :tag "off" nil) @@ -342,7 +350,7 @@ :type '(choice (const :tag "none" nil) (sexp :menu-tag "first" t))) -(defcustom gnus-auto-select-subject 'unread +(defcustom gnus-auto-select-subject 'unseen-or-unread "*Says what subject to place under point when entering a group. This variable can either be the symbols `first' (place point on the @@ -353,7 +361,7 @@ line of the first unseen article or, if all article have been seen, on the subject line of the first unread article), or a function to be called to place point on some subject line." - :version "22.1" + :version "24.1" :group 'gnus-group-select :type '(choice (const best) (const unread) @@ -457,9 +465,10 @@ :group 'gnus-summary :type 'boolean) -(defcustom gnus-single-article-buffer t +(defcustom gnus-single-article-buffer nil "*If non-nil, display all articles in the same buffer. If nil, each group will get its own article buffer." + :version "24.1" :group 'gnus-article-various :type 'boolean) @@ -531,11 +540,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 @@ -659,9 +663,9 @@ (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" + :version "24.1" :group 'gnus-summary :type '(repeat character)) @@ -1251,7 +1255,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)) @@ -1853,7 +1857,6 @@ "=" gnus-summary-expand-window "\C-x\C-s" gnus-summary-reselect-current-group "\M-g" gnus-summary-rescan-group - "w" gnus-summary-stop-page-breaking "\C-c\C-r" gnus-summary-caesar-message "f" gnus-summary-followup "F" gnus-summary-followup-with-original @@ -1875,7 +1878,6 @@ [follow-link] mouse-face "m" gnus-summary-mail-other-window "a" gnus-summary-post-news - "i" gnus-summary-news-other-window "x" gnus-summary-limit-to-unread "s" gnus-summary-isearch-article "t" gnus-summary-toggle-header @@ -2108,6 +2110,7 @@ "d" gnus-article-display-face "s" gnus-treat-smiley "D" gnus-article-remove-images + "W" gnus-html-show-images "f" gnus-treat-from-picon "m" gnus-treat-mail-picon "n" gnus-treat-newsgroups-picon) @@ -2175,8 +2178,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 @@ -2440,7 +2442,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) @@ -6050,9 +6051,7 @@ (when (> (length mode-string) max-len) (setq mode-string (concat (truncate-string-to-width mode-string (- max-len 3)) - "..."))) - ;; Pad the mode string a bit. - (setq mode-string (format (format "%%-%ds" max-len) mode-string)))) + "..."))))) ;; Update the mode line. (setq mode-line-buffer-identification (gnus-mode-line-buffer-identification (list mode-string))) @@ -7781,7 +7780,7 @@ (setq endp (or (gnus-article-next-page lines) (gnus-article-only-boring-p)))) (when endp - (cond (stop + (cond ((or stop gnus-summary-stop-at-end-of-message) (gnus-message 3 "End of message")) (circular (gnus-summary-beginning-of-article)) @@ -8300,7 +8299,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) @@ -9518,7 +9517,7 @@ remain unencoded after running this function, it is likely an invalid IDNA string (`xn--bar' is invalid). -You must have GNU Libidn (`http://www.gnu.org/software/libidn/') +You must have GNU Libidn (URL `http://www.gnu.org/software/libidn/') installed for this command to work." (interactive "P") (if (not (and (condition-case nil (require 'idna) @@ -12693,5 +12692,4 @@ ;; coding: iso-8859-1 ;; End: -;; arch-tag: 17c6748f-6d00-4d36-bf01-835c42f31235 ;;; gnus-sum.el ends here
--- a/lisp/gnus/gnus-topic.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/gnus-topic.el Wed Sep 08 12:55:57 2010 +0900 @@ -1779,5 +1779,4 @@ (provide 'gnus-topic) -;; arch-tag: bf176856-f30c-40f0-ae77-e41529a1134c ;;; gnus-topic.el ends here
--- a/lisp/gnus/gnus-undo.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/gnus-undo.el Wed Sep 08 12:55:57 2010 +0900 @@ -188,5 +188,4 @@ (provide 'gnus-undo) -;; arch-tag: 0d787bc7-787d-499a-837f-211d2cb07f2e ;;; gnus-undo.el ends here
--- a/lisp/gnus/gnus-util.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/gnus-util.el Wed Sep 08 12:55:57 2010 +0900 @@ -1580,11 +1580,9 @@ (car (symbol-value history)))) (defun gnus-graphic-display-p () - (or (and (fboundp 'display-graphic-p) - (display-graphic-p)) - ;;;!!!This is bogus. Fixme! - (and (featurep 'xemacs) - t))) + (if (featurep 'xemacs) + (device-on-window-system-p) + (display-graphic-p))) (put 'gnus-parse-without-error 'lisp-indent-function 0) (put 'gnus-parse-without-error 'edebug-form-spec '(body)) @@ -1899,5 +1897,4 @@ (provide 'gnus-util) -;; arch-tag: f94991af-d32b-4c97-8c26-ca12a934de49 ;;; gnus-util.el ends here
--- a/lisp/gnus/gnus-uu.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/gnus-uu.el Wed Sep 08 12:55:57 2010 +0900 @@ -2170,5 +2170,4 @@ (provide 'gnus-uu) -;; arch-tag: 05312384-0a83-4720-9a58-b3160b888853 ;;; gnus-uu.el ends here
--- a/lisp/gnus/gnus-vm.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/gnus-vm.el Wed Sep 08 12:55:57 2010 +0900 @@ -103,5 +103,4 @@ (provide 'gnus-vm) -;; arch-tag: 42ca7f88-a12f-461d-be3e-cac7efb44866 ;;; gnus-vm.el ends here
--- a/lisp/gnus/gnus-win.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/gnus-win.el Wed Sep 08 12:55:57 2010 +0900 @@ -590,5 +590,4 @@ (provide 'gnus-win) -;; arch-tag: ccd5a394-2ddf-4397-b8f8-6d80d3e46e2b ;;; gnus-win.el ends here
--- a/lisp/gnus/gnus.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/gnus.el Wed Sep 08 12:55:57 2010 +0900 @@ -1058,14 +1058,14 @@ (symbol-value 'image-load-path)) (t load-path))) (image (find-image - `((:type svg :file "gnus.svg") - (:type png :file "gnus.png") - (:type xpm :file "gnus.xpm" + `((:type xpm :file "gnus.xpm" :color-symbols (("thing" . ,(car gnus-logo-colors)) ("shadow" . ,(cadr gnus-logo-colors)) ("oort" . "#eeeeee") ("background" . ,(face-background 'default)))) + (:type svg :file "gnus.svg") + (:type png :file "gnus.png") (:type pbm :file "gnus.pbm" ;; Account for the pbm's blackground. :background ,(face-foreground 'gnus-splash) @@ -1443,7 +1443,7 @@ ;; Customization variables -(defcustom gnus-refer-article-method nil +(defcustom gnus-refer-article-method 'current "Preferred method for fetching an article by Message-ID. If you are reading news from the local spool (with nnspool), fetching articles by Message-ID is painfully slow. By setting this method to an @@ -1455,6 +1455,7 @@ It can also be a list of select methods, as well as the special symbol `current', which means to use the current select method. If it is a list, Gnus will try all the methods in the list until it finds a match." + :version "24.1" :group 'gnus-server :type '(choice (const :tag "default" nil) (const current) @@ -1740,19 +1741,11 @@ ("nneething" none address prompt-address physical-address) ("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) - ("nngoogle" post) - ("nnslashdot" post) - ("nnultimate" none) ("nnrss" none) - ("nnwfm" none) - ("nnwarchive" none) - ("nnlistserv" none) ("nnagent" post-mail) ("nnimap" post-mail address prompt-address physical-address) ("nnmaildir" mail respool address) @@ -1775,7 +1768,8 @@ (const :format "%v " prompt-address) (const :format "%v " physical-address) (const :format "%v " virtual) - (const respool))))) + (const respool)))) + :version "24.1") (defun gnus-redefine-select-method-widget () "Recomputes the select-method widget based on the value of @@ -1811,12 +1805,11 @@ (const summary) (const tree))) -;; Added by Keinonen Kari <kk85613@cs.tut.fi>. -(defcustom gnus-mode-non-string-length nil +(defcustom gnus-mode-non-string-length 30 "*Max length of mode-line non-string contents. If this is nil, Gnus will take space as is needed, leaving the rest -of the mode line intact. Note that the default of nil is unlikely -to be desirable; see the manual for further details." +of the mode line intact." + :version "24.1" :group 'gnus-various :type '(choice (const nil) integer)) @@ -2893,10 +2886,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) @@ -3028,8 +3017,6 @@ gnus-dup-enter-articles) ("gnus-range" gnus-copy-sequence) ("gnus-eform" gnus-edit-form) - ("gnus-move" :interactive t - gnus-group-move-group-to-server gnus-change-server) ("gnus-logic" gnus-score-advanced) ("gnus-undo" gnus-undo-mode gnus-undo-register) ("gnus-async" gnus-async-request-fetched-article gnus-async-prefetch-next @@ -3299,12 +3286,12 @@ (defmacro gnus-string-or (&rest strings) "Return the first element of STRINGS that is a non-blank string. STRINGS will be evaluated in normal `or' order." - `(gnus-string-or-1 ',strings)) + `(gnus-string-or-1 (list ,@strings))) (defun gnus-string-or-1 (strings) (let (string) (while strings - (setq string (eval (pop strings))) + (setq string (pop strings)) (if (string-match "^[ \t]*$" string) (setq string nil) (setq strings nil))) @@ -3947,8 +3934,7 @@ If you call this function inside a loop, consider using the faster `gnus-group-fast-parameter' instead." - (save-excursion - (set-buffer gnus-group-buffer) + (with-current-buffer gnus-group-buffer (if symbol (gnus-group-fast-parameter group symbol allow-list) (nconc @@ -4107,8 +4093,7 @@ (defun gnus-kill-save-kill-buffer () (let ((file (gnus-newsgroup-kill-file gnus-newsgroup-name))) (when (get-file-buffer file) - (save-excursion - (set-buffer (get-file-buffer file)) + (with-current-buffer (get-file-buffer file) (when (buffer-modified-p) (save-buffer)) (kill-buffer (current-buffer)))))) @@ -4421,5 +4406,4 @@ (provide 'gnus) -;; arch-tag: acebeeab-f331-4f8f-a7ea-89c58c84f636 ;;; gnus.el ends here
--- a/lisp/gnus/html2text.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/html2text.el Wed Sep 08 12:55:57 2010 +0900 @@ -508,5 +508,5 @@ ;; </Interactive functions> ;; (provide 'html2text) -;; arch-tag: e9e57b79-35d4-4de1-a647-e7e01fe56d1e + ;;; html2text.el ends here
--- a/lisp/gnus/ietf-drums.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/ietf-drums.el Wed Sep 08 12:55:57 2010 +0900 @@ -295,5 +295,4 @@ (provide 'ietf-drums) -;; arch-tag: 379a0191-dbae-4ca6-a0f5-d4202c209ef9 ;;; ietf-drums.el ends here
--- a/lisp/gnus/legacy-gnus-agent.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/legacy-gnus-agent.el Wed Sep 08 12:55:57 2010 +0900 @@ -250,5 +250,4 @@ (provide 'legacy-gnus-agent) -;; arch-tag: 845c7b8a-88f7-4468-b8d7-94e8fc72cf1a ;;; legacy-gnus-agent.el ends here
--- a/lisp/gnus/mail-parse.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/mail-parse.el Wed Sep 08 12:55:57 2010 +0900 @@ -74,5 +74,4 @@ (provide 'mail-parse) -;; arch-tag: 3e63d75c-c962-4784-ab01-7ba07ca9d2d4 ;;; mail-parse.el ends here
--- a/lisp/gnus/mail-prsvr.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/mail-prsvr.el Wed Sep 08 12:55:57 2010 +0900 @@ -41,5 +41,4 @@ (provide 'mail-prsvr) -;; arch-tag: 9ba878cc-8b43-4f7a-85b1-69b1a9a5d9f5 ;;; mail-prsvr.el ends here
--- a/lisp/gnus/mail-source.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/mail-source.el Wed Sep 08 12:55:57 2010 +0900 @@ -34,7 +34,7 @@ (require 'cl) (require 'imap)) (autoload 'auth-source-user-or-password "auth-source") -(autoload 'pop3-movemail "pop3") +(autoload 'pop3-streaming-movemail "pop3") (autoload 'pop3-get-message-count "pop3") (autoload 'nnheader-cancel-timer "nnheader") (require 'mm-util) @@ -466,10 +466,10 @@ ;; 1) the auth-sources user and password override everything ;; 2) it avoids macros, so it's cleaner ;; 3) it falls through to the mail-sources and then default values - (cond + (cond ((and (eq keyword :user) - (setq user-auth + (setq user-auth (nth 0 (auth-source-user-or-password '("login" "password") ;; this is "host" in auth-sources @@ -536,7 +536,7 @@ (t value))) -(defun mail-source-fetch (source callback) +(defun mail-source-fetch (source callback &optional method) "Fetch mail from SOURCE and call CALLBACK zero or more times. CALLBACK will be called with the name of the file where (some of) the mail from SOURCE is put. @@ -544,6 +544,16 @@ (mail-source-bind-common source (if (or mail-source-plugged plugged) (save-excursion + ;; Special-case the `file' handler since it's so common and + ;; just adds noise. + (when (or (not (eq (car source) 'file)) + (mail-source-bind (file source) + (file-exists-p path))) + (nnheader-message 4 "%sReading incoming mail from %s..." + (if method + (format "%s: " method) + "") + (car source))) (let ((function (cadr (assq (car source) mail-source-fetcher-alist))) (found 0)) (unless function @@ -619,6 +629,8 @@ 0) (funcall callback mail-source-crash-box info))) +(defvar mail-source-incoming-last-checked-time nil) + (defun mail-source-delete-crash-box () (when (file-exists-p mail-source-crash-box) ;; Delete or move the incoming mail out of the way. @@ -634,9 +646,16 @@ (rename-file mail-source-crash-box incoming t) ;; remove old incoming files? (when (natnump mail-source-delete-incoming) - (mail-source-delete-old-incoming - mail-source-delete-incoming - mail-source-delete-old-incoming-confirm)))))) + ;; Don't check for old incoming files more than once per day to + ;; save a lot of file accesses. + (when (or (null mail-source-incoming-last-checked-time) + (> (time-to-seconds + (time-since mail-source-incoming-last-checked-time)) + (* 24 60 60))) + (setq mail-source-incoming-last-checked-time (current-time)) + (mail-source-delete-old-incoming + mail-source-delete-incoming + mail-source-delete-old-incoming-confirm))))))) (defun mail-source-movemail (from to) "Move FROM to TO using movemail." @@ -820,9 +839,11 @@ (if (eq authentication 'apop) 'apop 'pass)) (pop3-stream-type stream)) (if (or debug-on-quit debug-on-error) - (save-excursion (pop3-movemail mail-source-crash-box)) + (save-excursion (pop3-streaming-movemail + mail-source-crash-box)) (condition-case err - (save-excursion (pop3-movemail mail-source-crash-box)) + (save-excursion (pop3-streaming-movemail + mail-source-crash-box)) (error ;; We nix out the password in case the error ;; was because of a wrong password being given. @@ -1145,5 +1166,4 @@ (provide 'mail-source) -;; arch-tag: 72948025-1d17-4d6c-bb12-ef1aa2c490fd ;;; mail-source.el ends here
--- a/lisp/gnus/mailcap.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/mailcap.el Wed Sep 08 12:55:57 2010 +0900 @@ -335,7 +335,7 @@ :group 'mailcap) (defvar mailcap-poor-system-types - '(ms-dos ms-windows windows-nt win32 w32 mswindows) + '(ms-dos windows-nt) "Systems that don't have a Unix-like directory hierarchy.") ;;; @@ -1069,5 +1069,4 @@ (provide 'mailcap) -;; arch-tag: 1fd4f9c9-c305-4d2e-9747-3a4d45baa0bd ;;; mailcap.el ends here
--- a/lisp/gnus/message.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/message.el Wed Sep 08 12:55:57 2010 +0900 @@ -249,6 +249,15 @@ :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." + :version "24.1" + :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 @@ -455,7 +464,7 @@ :link '(custom-manual "(message)Sending Variables") :type 'boolean) -(defcustom message-generate-new-buffers 'unique +(defcustom message-generate-new-buffers 'unsent "*Say whether to create a new message buffer to compose a message. Valid values include: @@ -478,6 +487,7 @@ If this is a function, call that function with three parameters: The type, the To address and the group name (any of these may be nil). The function should return the new buffer name." + :version "24.1" :group 'message-buffers :link '(custom-manual "(message)Message Buffers") :type '(choice (const nil) @@ -1620,11 +1630,11 @@ and Emacs, you may use `iso-2022-7bit' for this value at your own risk. Note that the coding-system `iso-2022-7bit' isn't suitable to all data.") -(defcustom message-send-mail-partially-limit 1000000 +(defcustom message-send-mail-partially-limit nil "The limitation of messages sent as message/partial. The lower bound of message size in characters, beyond which the message should be sent in several parts. If it is nil, the size is unlimited." - :version "21.1" + :version "24.1" :group 'message-buffers :link '(custom-manual "(message)Mail Variables") :type '(choice (const :tag "unlimited" nil) @@ -1716,13 +1726,14 @@ (const :tag "Never" nil) (const :tag "Always" t))) -(defcustom message-generate-hashcash (if (executable-find "hashcash") t) +(defcustom message-generate-hashcash (if (executable-find "hashcash") 'opportunistic) "*Whether to generate X-Hashcash: headers. If t, always generate hashcash headers. If `opportunistic', only generate hashcash headers if it can be done without the user waiting (i.e., only asynchronously). You must have the \"hashcash\" binary installed, see `hashcash-path'." + :version "24.1" :group 'message-headers :link '(custom-manual "(message)Mail Headers") :type '(choice (const :tag "Always" t) @@ -1739,6 +1750,7 @@ (defvar message-mime-part nil) (defvar message-posting-charset nil) (defvar message-inserted-headers nil) +(defvar message-inhibit-ecomplete nil) ;; Byte-compiler warning (defvar gnus-active-hashtb) @@ -4091,7 +4103,8 @@ (run-hooks 'message-sent-hook)) (message "Sending...done") ;; Do ecomplete address snarfing. - (when (message-mail-alias-type-p 'ecomplete) + (when (and (message-mail-alias-type-p 'ecomplete) + (not message-inhibit-ecomplete)) (message-put-addresses-in-ecomplete)) ;; Mark the buffer as unmodified and delete auto-save. (set-buffer-modified-p nil) @@ -5431,7 +5444,7 @@ (* 25 25))) (let ((tm (current-time))) (concat - (if (or (memq system-type '(ms-dos emx)) + (if (or (eq system-type 'ms-dos) ;; message-number-base36 doesn't handle bigints. (floatp (user-uid))) (let ((user (downcase (user-login-name)))) @@ -6449,9 +6462,7 @@ (setq buffer-file-name (expand-file-name (concat (if (memq system-type - '(ms-dos ms-windows windows-nt - cygwin cygwin32 win32 w32 - mswindows)) + '(ms-dos windows-nt cygwin)) "message" "*message*") (format-time-string "-%Y%m%d-%H%M%S")) @@ -6551,7 +6562,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 +6688,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 +6703,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 @@ -7425,6 +7454,7 @@ (replace-match "X-From-Line: ")) ;; Send it. (let ((message-inhibit-body-encoding t) + (message-inhibit-ecomplete t) message-required-mail-headers message-generate-hashcash rfc2047-encode-encoded-words) @@ -8230,5 +8260,4 @@ ;; coding: iso-8859-1 ;; End: -;; arch-tag: 94b32cac-4504-4b6c-8181-030ebf380ee0 ;;; message.el ends here
--- a/lisp/gnus/messcompat.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/messcompat.el Wed Sep 08 12:55:57 2010 +0900 @@ -89,5 +89,4 @@ (provide 'messcompat) -;; arch-tag: a76673be-905e-4bbd-8966-615370494a7b ;;; messcompat.el ends here
--- a/lisp/gnus/mm-bodies.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/mm-bodies.el Wed Sep 08 12:55:57 2010 +0900 @@ -302,5 +302,4 @@ (provide 'mm-bodies) -;; arch-tag: 41104bb6-4443-4ca9-8d5c-ff87ecf27d8d ;;; mm-bodies.el ends here
--- a/lisp/gnus/mm-decode.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/mm-decode.el Wed Sep 08 12:55:57 2010 +0900 @@ -105,10 +105,9 @@ ,disposition ,description ,cache ,id)) (defcustom mm-text-html-renderer - (cond ((executable-find "w3m") - (if (locate-library "w3m") - 'w3m - 'w3m-standalone)) + (cond ((and (executable-find "w3m") + (executable-find "curl")) + 'gnus-article-html) ((executable-find "links") 'links) ((executable-find "lynx") 'lynx) ((locate-library "w3") 'w3) @@ -124,7 +123,7 @@ `w3' : use Emacs/W3; `html2text' : use html2text; nil : use external viewer (default web browser)." - :version "23.0" ;; No Gnus + :version "24.1" :type '(choice (const w3) (const w3m :tag "emacs-w3m") (const w3m-standalone :tag "standalone w3m" ) @@ -1671,5 +1670,4 @@ (provide 'mm-decode) -;; arch-tag: 4f35d360-56b8-4030-9388-3ed82d359b9b ;;; mm-decode.el ends here
--- a/lisp/gnus/mm-encode.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/mm-encode.el Wed Sep 08 12:55:57 2010 +0900 @@ -223,5 +223,4 @@ (provide 'mm-encode) -;; arch-tag: 7d01bba4-d469-4851-952b-dc863f84ed66 ;;; mm-encode.el ends here
--- a/lisp/gnus/mm-extern.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/mm-extern.el Wed Sep 08 12:55:57 2010 +0900 @@ -167,5 +167,4 @@ (provide 'mm-extern) -;; arch-tag: 9653808e-14d9-4172-86e6-adceaa05378e ;;; mm-extern.el ends here
--- a/lisp/gnus/mm-partial.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/mm-partial.el Wed Sep 08 12:55:57 2010 +0900 @@ -150,5 +150,4 @@ (provide 'mm-partial) -;; arch-tag: 460e7424-05f2-4a1d-a0f2-70ec081eff7d ;;; mm-partial.el ends here
--- a/lisp/gnus/mm-url.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/mm-url.el Wed Sep 08 12:55:57 2010 +0900 @@ -365,15 +365,20 @@ (defun mm-url-decode-entities () "Decode all HTML entities." (goto-char (point-min)) - (while (re-search-forward "&\\(#[0-9]+\\|[a-z]+[0-9]*\\);" nil t) - (let ((elem (if (eq (aref (match-string 1) 0) ?\#) - (let ((c (mm-ucs-to-char - (string-to-number - (substring (match-string 1) 1))))) - (if (mm-char-or-char-int-p c) c ?#)) - (or (cdr (assq (intern (match-string 1)) - mm-url-html-entities)) - ?#)))) + (while (re-search-forward "&\\(#[0-9]+\\|#x[0-9a-f]+\\|[a-z]+[0-9]*\\);" nil t) + (let* ((entity (match-string 1)) + (elem (if (eq (aref entity 0) ?\#) + (let ((c (mm-ucs-to-char + ;; Hex number: ㈒ + (if (eq (aref entity 1) ?x) + (string-to-number (substring entity 2) + 16) + ;; Decimal number:  + (string-to-number (substring entity 1)))))) + (if (mm-char-or-char-int-p c) c ?#)) + (or (cdr (assq (intern entity) + mm-url-html-entities)) + ?#)))) (unless (stringp elem) (setq elem (char-to-string elem))) (replace-match elem t t)))) @@ -496,5 +501,4 @@ (provide 'mm-url) -;; arch-tag: 0594f9b3-417c-48b0-adc2-5082e1e7917f ;;; mm-url.el ends here
--- a/lisp/gnus/mm-util.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/mm-util.el Wed Sep 08 12:55:57 2010 +0900 @@ -680,7 +680,7 @@ "100% binary coding system.") (defvar mm-text-coding-system - (or (if (memq system-type '(windows-nt ms-dos ms-windows)) + (or (if (memq system-type '(windows-nt ms-dos)) (and (mm-coding-system-p 'raw-text-dos) 'raw-text-dos) (and (mm-coding-system-p 'raw-text) 'raw-text)) mm-binary-coding-system) @@ -692,12 +692,12 @@ (defvar mm-auto-save-coding-system (cond ((mm-coding-system-p 'utf-8-emacs) ; Mule 7 - (if (memq system-type '(windows-nt ms-dos ms-windows)) + (if (memq system-type '(windows-nt ms-dos)) (if (mm-coding-system-p 'utf-8-emacs-dos) 'utf-8-emacs-dos mm-binary-coding-system) 'utf-8-emacs)) ((mm-coding-system-p 'emacs-mule) - (if (memq system-type '(windows-nt ms-dos ms-windows)) + (if (memq system-type '(windows-nt ms-dos)) (if (mm-coding-system-p 'emacs-mule-dos) 'emacs-mule-dos mm-binary-coding-system) 'emacs-mule)) @@ -1429,16 +1429,23 @@ ;; Reset the umask. (set-default-file-modes umask))))) +(defvar mm-image-load-path-cache nil) + (defun mm-image-load-path (&optional package) - (let (dir result) - (dolist (path load-path (nreverse result)) - (when (and path - (file-directory-p - (setq dir (concat (file-name-directory - (directory-file-name path)) - "etc/images/" (or package "gnus/"))))) - (push dir result)) - (push path result)))) + (if (and mm-image-load-path-cache + (equal load-path (car mm-image-load-path-cache))) + (cdr mm-image-load-path-cache) + (let (dir result) + (dolist (path load-path) + (when (and path + (file-directory-p + (setq dir (concat (file-name-directory + (directory-file-name path)) + "etc/images/" (or package "gnus/"))))) + (push dir result))) + (setq result (nreverse result) + mm-image-load-path-cache (cons load-path result)) + result))) ;; Fixme: This doesn't look useful where it's used. (if (fboundp 'detect-coding-region) @@ -1653,5 +1660,4 @@ (provide 'mm-util) -;; arch-tag: 94dc5388-825d-4fd1-bfa5-2100aa351238 ;;; mm-util.el ends here
--- a/lisp/gnus/mm-uu.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/mm-uu.el Wed Sep 08 12:55:57 2010 +0900 @@ -441,7 +441,7 @@ (defun mm-uu-yenc-extract () ;; This might not be exactly correct, but we sure can't get the ;; binary data from the article buffer, since that's already in a - ;; non-binary charset. So get it from the original article buffer. + ;; non-binary charset. So get it from the original article buffer. (mm-make-handle (with-current-buffer gnus-original-article-buffer (mm-uu-copy-to-buffer start-point end-point)) (list (or (and file-name @@ -729,5 +729,4 @@ (provide 'mm-uu) -;; arch-tag: 7db076bf-53db-4320-aa19-ca76a1d2ab2c ;;; mm-uu.el ends here
--- a/lisp/gnus/mm-view.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/mm-view.el Wed Sep 08 12:55:57 2010 +0900 @@ -688,5 +688,4 @@ (provide 'mm-view) -;; arch-tag: b60e749a-d05c-47f2-bccd-bdaa59327cb2 ;;; mm-view.el ends here
--- a/lisp/gnus/mml-sec.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/mml-sec.el Wed Sep 08 12:55:57 2010 +0900 @@ -380,5 +380,4 @@ (provide 'mml-sec) -;; arch-tag: 111c56e7-df5e-4287-87d7-93ed2911ec6c ;;; mml-sec.el ends here
--- a/lisp/gnus/mml-smime.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/mml-smime.el Wed Sep 08 12:55:57 2010 +0900 @@ -554,5 +554,4 @@ (provide 'mml-smime) -;; arch-tag: f1bf94d4-f2cd-4c6f-b059-ad69492817e2 ;;; mml-smime.el ends here
--- a/lisp/gnus/mml.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/mml.el Wed Sep 08 12:55:57 2010 +0900 @@ -120,10 +120,10 @@ ,dispositions)))) :group 'message) -(defcustom mml-insert-mime-headers-always nil +(defcustom mml-insert-mime-headers-always t "If non-nil, always put Content-Type: text/plain at top of empty parts. It is necessary to work against a bug in certain clients." - :version "22.1" + :version "24.1" :type 'boolean :group 'message) @@ -1570,5 +1570,4 @@ (provide 'mml) -;; arch-tag: 583c96cf-1ffe-451b-a5e5-4733ae9ddd12 ;;; mml.el ends here
--- a/lisp/gnus/mml1991.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/mml1991.el Wed Sep 08 12:55:57 2010 +0900 @@ -521,5 +521,4 @@ ;; coding: iso-8859-1 ;; End: -;; arch-tag: e542be18-ab28-4393-9b33-97fe9cf30706 ;;; mml1991.el ends here
--- a/lisp/gnus/mml2015.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/mml2015.el Wed Sep 08 12:55:57 2010 +0900 @@ -1420,5 +1420,4 @@ (provide 'mml2015) -;; arch-tag: b04701d5-0b09-44d8-bed8-de901bf435f2 ;;; mml2015.el ends here
--- a/lisp/gnus/nnagent.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/nnagent.el Wed Sep 08 12:55:57 2010 +0900 @@ -121,7 +121,7 @@ (deffoo nnagent-request-set-mark (group action server) (mm-with-unibyte-buffer (insert "(gnus-agent-synchronize-group-flags \"" - group + group "\" '") (gnus-pp action) (insert " \"" @@ -151,7 +151,7 @@ ;; Assume that articles with smaller numbers than the first one ;; Agent knows are gone. (setq first (caar gnus-agent-article-alist)) - (when first + (when first (while (and arts (< (car arts) first)) (pop arts))) (set-buffer nntp-server-buffer) @@ -261,5 +261,4 @@ (provide 'nnagent) -;; arch-tag: af710b77-f816-4969-af31-6fd94fb42245 ;;; nnagent.el ends here
--- a/lisp/gnus/nnbabyl.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/nnbabyl.el Wed Sep 08 12:55:57 2010 +0900 @@ -344,7 +344,7 @@ (while (re-search-backward "^X-Gnus-Newsgroup: " beg t) (delete-region (point) (progn (forward-line 1) (point))))) (when nnmail-cache-accepted-message-ids - (nnmail-cache-insert (nnmail-fetch-field "message-id") + (nnmail-cache-insert (nnmail-fetch-field "message-id") group (nnmail-fetch-field "subject") (nnmail-fetch-field "from"))) @@ -363,7 +363,7 @@ (insert-buffer-substring buf) (when last (when nnmail-cache-accepted-message-ids - (nnmail-cache-insert (nnmail-fetch-field "message-id") + (nnmail-cache-insert (nnmail-fetch-field "message-id") group (nnmail-fetch-field "subject") (nnmail-fetch-field "from"))) @@ -663,5 +663,4 @@ (provide 'nnbabyl) -;; arch-tag: aa7ddedb-8c07-4c0e-beb0-58e795c2b81b ;;; nnbabyl.el ends here
--- a/lisp/gnus/nndb.el Wed Sep 01 11:03:05 2010 +0900 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,325 +0,0 @@ -;;; nndb.el --- nndb access for Gnus - -;; Copyright (C) 1997, 1998, 2000, 2002, 2003, 2004, 2005, 2006, 2007, -;; 2008, 2009, 2010 Free Software Foundation, Inc. - -;; Author: Masanobu UMEDA <umerin@flab.flab.fujitsu.junet> -;; Kai Grossjohann <grossjohann@ls6.informatik.uni-dortmund.de> -;; Joe Hildebrand <joe.hildebrand@ilg.com> -;; David Blacka <davidb@rwhois.net> -;; 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: - -;;; This was based upon Kai Grossjohan's shamessly snarfed code and -;;; further modified by Joe Hildebrand. It has been updated for Red -;;; Gnus. - -;; TODO: -;; -;; * Fix bug where server connection can be lost and impossible to regain -;; This hasn't happened to me in a while; think it was fixed in Rgnus -;; -;; * make it handle different nndb servers seemlessly -;; -;; * Optimize expire if FORCE -;; -;; * Optimize move (only expire once) -;; -;; * Deal with add/deletion of groups -;; -;; * make the backend TOUCH an article when marked as expireable (will -;; make article expire 'expiry' days after that moment). - -;;; Code: - -;; For Emacs < 22.2. -(eval-and-compile - (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) - -;;- -;; Register nndb with known select methods. - -(require 'gnus-start) -(unless (assoc "nndb" gnus-valid-select-methods) - (gnus-declare-backend "nndb" 'mail 'respool 'address 'prompt-address)) - -(require 'nnmail) -(require 'nnheader) -(require 'nntp) -(eval-when-compile (require 'cl)) - -;; Declare nndb as derived from nntp - -(nnoo-declare nndb nntp) - -;; Variables specific to nndb - -;;- currently not used but just in case... -(defvoo nndb-deliver-program "nndel" - "*The program used to put a message in an NNDB group.") - -(defvoo nndb-server-side-expiry nil - "If t, expiry calculation will occur on the server side.") - -(defvoo nndb-set-expire-date-on-mark nil - "If t, the expiry date for a given article will be set to the time -it was marked as expireable; otherwise the date will be the time the -article was posted to nndb") - -;; Variables copied from nntp - -(defvoo nndb-server-opened-hook '(nntp-send-authinfo-from-file) - "Like nntp-server-opened-hook." - nntp-server-opened-hook) - -(defvoo nndb-address "localhost" - "*The name of the NNDB server." - nntp-address) - -(defvoo nndb-port-number 9000 - "*Port number to connect to." - nntp-port-number) - -;; change to 'news if you are actually using nndb for news -(defvoo nndb-article-type 'mail) - -(defvoo nndb-status-string nil "" nntp-status-string) - - - -(defconst nndb-version "nndb 0.7" - "Version numbers of this version of NNDB.") - - -;;; Interface functions. - -(nnoo-define-basics nndb) - -;;------------------------------------------------------------------ - -;; this function turns the lisp list into a string list. There is -;; probably a more efficient way to do this. -(defun nndb-build-article-string (articles) - (let (art-string art) - (while articles - (setq art (pop articles)) - (setq art-string (concat art-string art " "))) - art-string)) - -(defun nndb-build-expire-rest-list (total expire) - (let (art rest) - (while total - (setq art (pop total)) - (if (memq art expire) - () - (push art rest))) - rest)) - - -;; -(deffoo nndb-request-type (group &optional article) - nndb-article-type) - -;; nndb-request-update-info does not exist and is not needed - -;; nndb-request-update-mark does not exist; it should be used to TOUCH -;; articles as they are marked exipirable -(defun nndb-touch-article (group article) - (nntp-send-command nil "X-TOUCH" article)) - -(deffoo nndb-request-update-mark - (group article mark) - "Sets the expiry date for ARTICLE in GROUP to now, if the mark is 'E'" - (if (and nndb-set-expire-date-on-mark (string-equal mark "E")) - (nndb-touch-article group article)) - mark) - -;; nndb-request-create-group -- currently this isn't necessary; nndb -;; creates groups on demand. - -;; todo -- use some other time than the creation time of the article -;; best is time since article has been marked as expirable - -(defun nndb-request-expire-articles-local - (articles &optional group server force) - "Let gnus do the date check and issue the delete commands." - (let (msg art delete-list (num-delete 0) rest) - (nntp-possibly-change-group group server) - (while articles - (setq art (pop articles)) - (nntp-send-command "^\\([23]\\|^423\\).*\n" "X-DATE" art) - (setq msg (nndb-status-message)) - (if (string-match "^423" msg) - () - (or (string-match "'\\(.+\\)'" msg) - (error "Not a valid response for X-DATE command: %s" - msg)) - (if (nnmail-expired-article-p - group - (date-to-time (substring msg (match-beginning 1) (match-end 1))) - force) - (progn - (setq delete-list (concat delete-list " " (int-to-string art))) - (setq num-delete (1+ num-delete))) - (push art rest)))) - (if (> (length delete-list) 0) - (progn - (nnheader-message 5 "Deleting %s article(s) from %s" - (int-to-string num-delete) group) - (nntp-send-command "^[23].*\n" "X-DELETE" delete-list)) - ) - - (nnheader-message 5 "") - (nconc rest articles))) - -(defun nndb-get-remote-expire-response () - (let (list) - (set-buffer nntp-server-buffer) - (goto-char (point-min)) - (if (looking-at "^[34]") - ;; x-expire returned error--presume no articles were expirable) - (setq list nil) - ;; otherwise, pull all of the following numbers into the list - (re-search-forward "follows\r?\n?" nil t) - (while (re-search-forward "^[0-9]+$" nil t) - (push (string-to-number (match-string 0)) list))) - list)) - -(defun nndb-request-expire-articles-remote - (articles &optional group server force) - "Let the nndb backend expire articles" - (let (days art-string delete-list (num-delete 0)) - (nntp-possibly-change-group group server) - - ;; first calculate the wait period in days - (setq days (or (and nnmail-expiry-wait-function - (funcall nnmail-expiry-wait-function group)) - nnmail-expiry-wait)) - ;; now handle the special cases - (cond (force - (setq days 0)) - ((eq days 'never) - ;; This isn't an expirable group. - (setq days -1)) - ((eq days 'immediate) - (setq days 0))) - - - ;; build article string - (setq art-string (concat days " " (nndb-build-article-string articles))) - (nntp-send-command "^\.\r?\n\\|^[345].*\n" "X-EXPIRE" art-string) - - (setq delete-list (nndb-get-remote-expire-response)) - (setq num-delete (length delete-list)) - (if (> num-delete 0) - (nnheader-message 5 "Deleting %s article(s) from %s" - (int-to-string num-delete) group)) - - (nndb-build-expire-rest-list articles delete-list))) - -(deffoo nndb-request-expire-articles - (articles &optional group server force) - "Expires ARTICLES from GROUP on SERVER. -If FORCE, delete regardless of exiration date, otherwise use normal -expiry mechanism." - (if nndb-server-side-expiry - (nndb-request-expire-articles-remote articles group server force) - (nndb-request-expire-articles-local articles group server force))) - -;; _Something_ defines it... -(declare-function nndb-request-article "nndb" t t) - -(deffoo nndb-request-move-article - (article group server accept-form &optional last move-is-internal) - "Move ARTICLE (a number) from GROUP on SERVER. -Evals ACCEPT-FORM in current buffer, where the article is. -Optional LAST is ignored." - ;; we guess that the second arg in accept-form is the new group, - ;; which it will be for nndb, which is all that matters anyway - (let ((new-group (nth 1 accept-form)) result) - (nntp-possibly-change-group group server) - - ;; use the move command for nndb-to-nndb moves - (if (string-match "^nndb" new-group) - (let ((new-group-name (gnus-group-real-name new-group))) - (nntp-send-command "^[23].*\n" "X-MOVE" article new-group-name) - (cons new-group article)) - ;; else move normally - (let ((artbuf (get-buffer-create " *nndb move*"))) - (and - (nndb-request-article article group server artbuf) - (save-excursion - (set-buffer artbuf) - (insert-buffer-substring nntp-server-buffer) - (setq result (eval accept-form)) - (kill-buffer (current-buffer)) - result) - (nndb-request-expire-articles (list article) - group - server - t)) - result) - ))) - -(deffoo nndb-request-accept-article (group server &optional last) - "The article in the current buffer is put into GROUP." - (nntp-possibly-change-group group server) - (let (art msg) - (when (nntp-send-command "^[23].*\r?\n" "ACCEPT" group) - (nnheader-insert "") - (nntp-send-buffer "^[23].*\n")) - - (set-buffer nntp-server-buffer) - (setq msg (buffer-string)) - (or (string-match "^\\([0-9]+\\)" msg) - (error "nndb: %s" msg)) - (setq art (substring msg (match-beginning 1) (match-end 1))) - (nnheader-message 5 "nndb: accepted %s" art) - (list art))) - -(deffoo nndb-request-replace-article (article group buffer) - "ARTICLE is the number of the article in GROUP to be replaced with the contents of the BUFFER." - (set-buffer buffer) - (when (nntp-send-command "^[23].*\r?\n" "X-REPLACE" (int-to-string article)) - (nnheader-insert "") - (nntp-send-buffer "^[23.*\n") - (list (int-to-string article)))) - - ; nndb-request-delete-group does not exist - ; todo -- maybe later - - ; nndb-request-rename-group does not exist - ; todo -- maybe later - -;; -- standard compatibility functions - -(deffoo nndb-status-message (&optional server) - "Return server status as a string." - (set-buffer nntp-server-buffer) - (buffer-string)) - -;; Import stuff from nntp - -(nnoo-import nndb - (nntp)) - -(provide 'nndb) - -;; arch-tag: 83bd6fb4-58d9-4fed-a901-c6c625ad5f8a -;;; nndb.el ends here
--- a/lisp/gnus/nndiary.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/nndiary.el Wed Sep 08 12:55:57 2010 +0900 @@ -1584,6 +1584,4 @@ (provide 'nndiary) - -;; arch-tag: 9c542b95-92e7-4ace-a038-330ab296e203 ;;; nndiary.el ends here
--- a/lisp/gnus/nndir.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/nndir.el Wed Sep 08 12:55:57 2010 +0900 @@ -96,5 +96,4 @@ (provide 'nndir) -;; arch-tag: 56f09f68-0e4e-4816-818a-df80b4a394c8 ;;; nndir.el ends here
--- a/lisp/gnus/nndoc.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/nndoc.el Wed Sep 08 12:55:57 2010 +0900 @@ -100,7 +100,7 @@ (head-end . "^\t") (generate-head-function . nndoc-generate-clari-briefs-head) (article-transform-function . nndoc-transform-clari-briefs)) - + (standard-digest (first-article . ,(concat "^" (make-string 70 ?-) "\n *\n+")) (article-begin . ,(concat "^\n" (make-string 30 ?-) "\n *\n+")) @@ -118,6 +118,16 @@ (file-end . "^End of") (prepare-body-function . nndoc-unquote-dashes) (subtype digest guess)) + (google + (pre-dissection-function . nndoc-decode-content-transfer-encoding) + (article-begin . "^== [0-9]+ of [0-9]+ ==$") + (head-begin . "^Date:") + (head-end . "^$") + (body-end-function . nndoc-digest-body-end) + (body-begin . "^$") + (file-end . "^==============================================================================$") + (prepare-body-function . nndoc-unquote-dashes) + (subtype digest guess)) (lanl-gov-announce (article-begin . "^\\\\\\\\\n") (head-begin . "^\\(Paper.*:\\|arXiv:\\)") @@ -186,6 +196,7 @@ (defvoo nndoc-article-begin-function nil) (defvoo nndoc-generate-article-function nil) (defvoo nndoc-dissection-function nil) +(defvoo nndoc-pre-dissection-function nil) (defvoo nndoc-status-string "") (defvoo nndoc-group-alist nil) @@ -363,7 +374,8 @@ nndoc-generate-head-function nndoc-body-begin-function nndoc-head-begin-function nndoc-generate-article-function - nndoc-dissection-function))) + nndoc-dissection-function + nndoc-pre-dissection-function))) (while vars (set (pop vars) nil))) (let (defs) @@ -445,6 +457,22 @@ (forward-line 1) (goto-char (+ (point) (string-to-number (match-string 1)))))) +(defun nndoc-google-type-p () + (when (re-search-forward "^=3D=3D 1 of [0-9]+ =3D=3D$" nil t) + t)) + +(defun nndoc-decode-content-transfer-encoding () + (let ((encoding + (save-restriction + (message-narrow-to-head) + (message-fetch-field "content-transfer-encoding")))) + (when (and encoding + (search-forward "\n\n" nil t)) + (save-restriction + (narrow-to-region (point) (point-max)) + (mm-decode-content-transfer-encoding + (intern (downcase (mail-header-strip encoding)))))))) + (defun nndoc-babyl-type-p () (when (re-search-forward "\^_\^L *\n" nil t) t)) @@ -807,6 +835,9 @@ ;; Remove blank lines. (while (eq (following-char) ?\n) (delete-char 1)) + (when nndoc-pre-dissection-function + (save-excursion + (funcall nndoc-pre-dissection-function))) (if nndoc-dissection-function (funcall nndoc-dissection-function) ;; Find the beginning of the file. @@ -1025,5 +1056,4 @@ (provide 'nndoc) -;; arch-tag: f5c2970e-0387-47ac-a0b3-6cc317dffabe ;;; nndoc.el ends here
--- a/lisp/gnus/nndraft.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/nndraft.el Wed Sep 08 12:55:57 2010 +0900 @@ -202,7 +202,7 @@ 'nnmh-request-group (list group server dont-check))) -(deffoo nndraft-request-move-article (article group server accept-form +(deffoo nndraft-request-move-article (article group server accept-form &optional last move-is-internal) (nndraft-possibly-change-group group) (let ((buf (get-buffer-create " *nndraft move*")) @@ -313,5 +313,4 @@ (provide 'nndraft) -;; arch-tag: 3ce26ca0-41cb-48b1-8703-4dad35e188aa ;;; nndraft.el ends here
--- a/lisp/gnus/nneething.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/nneething.el Wed Sep 08 12:55:57 2010 +0900 @@ -427,5 +427,4 @@ (provide 'nneething) -;; arch-tag: 1277f386-88f2-4459-bb24-f3f45962a6c5 ;;; nneething.el ends here
--- a/lisp/gnus/nnfolder.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/nnfolder.el Wed Sep 08 12:55:57 2010 +0900 @@ -494,7 +494,7 @@ (nnfolder-save-active nnfolder-group-alist nnfolder-active-file) (gnus-sorted-difference articles (nreverse deleted-articles))))) -(deffoo nnfolder-request-move-article (article group server accept-form +(deffoo nnfolder-request-move-article (article group server accept-form &optional last move-is-internal) (save-excursion (let ((buf (get-buffer-create " *nnfolder move*")) @@ -552,7 +552,7 @@ (while (re-search-backward (concat "^" nnfolder-article-marker) nil t) (delete-region (point) (progn (forward-line 1) (point)))) (when nnmail-cache-accepted-message-ids - (nnmail-cache-insert (nnmail-fetch-field "message-id") + (nnmail-cache-insert (nnmail-fetch-field "message-id") group (nnmail-fetch-field "subject") (nnmail-fetch-field "from"))) @@ -1301,5 +1301,4 @@ (provide 'nnfolder) -;; arch-tag: a040d0f4-4f4e-445f-8972-839575c5f7e6 ;;; nnfolder.el ends here
--- a/lisp/gnus/nngateway.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/nngateway.el Wed Sep 08 12:55:57 2010 +0900 @@ -89,5 +89,4 @@ (provide 'nngateway) -;; arch-tag: f7ecb92e-b10c-43d5-9a9b-1314233341fc ;;; nngateway.el ends here
--- a/lisp/gnus/nnheader.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/nnheader.el Wed Sep 08 12:55:57 2010 +0900 @@ -77,7 +77,7 @@ "*Length of each read operation when trying to fetch HEAD headers.") (defvar nnheader-read-timeout - (if (string-match "windows-nt\\|os/2\\|emx\\|cygwin" + (if (string-match "windows-nt\\|os/2\\|cygwin" (symbol-name system-type)) ;; http://thread.gmane.org/v9655t3pjo.fsf@marauder.physik.uni-ulm.de ;; @@ -102,7 +102,7 @@ (defvar nnheader-file-name-translation-alist (let ((case-fold-search t)) (cond - ((string-match "windows-nt\\|os/2\\|emx\\|cygwin" + ((string-match "windows-nt\\|os/2\\|cygwin" (symbol-name system-type)) (append (mapcar (lambda (c) (cons c ?_)) '(?: ?* ?\" ?< ?> ??)) @@ -786,8 +786,7 @@ ;; We translate -- but only the file name. We leave the directory ;; alone. (if (and (featurep 'xemacs) - (memq system-type '(cygwin32 win32 w32 mswindows windows-nt - cygwin))) + (memq system-type '(windows-nt cygwin))) ;; This is needed on NT and stuff, because ;; file-name-nondirectory is not enough to split ;; file names, containing ':', e.g. @@ -1086,5 +1085,4 @@ (provide 'nnheader) -;; arch-tag: a9c4b7d9-52ae-4ec9-b196-dfd93124d202 ;;; nnheader.el ends here
--- a/lisp/gnus/nnimap.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/nnimap.el Wed Sep 08 12:55:57 2010 +0900 @@ -588,11 +588,12 @@ (imap-mailbox-select decoded-group examine)) (let (minuid maxuid) (when (> (imap-mailbox-get 'exists) 0) - (imap-fetch-safe '("1,*" . "1,*:*") "UID" nil 'nouidfetch) - (imap-message-map (lambda (uid Uid) - (setq minuid (if minuid (min minuid uid) uid) - maxuid (if maxuid (max maxuid uid) uid))) - 'UID)) + (imap-fetch "1:*" "UID" nil 'nouidfetch) + (imap-message-map + (lambda (uid Uid) + (setq minuid (if minuid (min minuid uid) uid) + maxuid (if maxuid (max maxuid uid) uid))) + 'UID)) (list (imap-mailbox-get 'exists) minuid maxuid)))))) (defun nnimap-possibly-change-group (group &optional server) @@ -833,8 +834,8 @@ nnimap-authinfo-file) (netrc-parse nnimap-authinfo-file))) (port (if nnimap-server-port - (int-to-string nnimap-server-port) - "imap")) + (int-to-string nnimap-server-port) + "imap")) (auth-info (auth-source-user-or-password '("login" "password") server port)) (auth-user (nth 0 auth-info)) @@ -1114,14 +1115,16 @@ (dolist (pattern (nnimap-pattern-to-list-arguments nnimap-list-pattern)) (dolist (mbx (funcall nnimap-request-list-method (cdr pattern) (car pattern))) - (or (member "\\NoSelect" (imap-mailbox-get 'list-flags mbx)) - (let* ((encoded-mbx (nnimap-encode-group-name mbx)) - (info (nnimap-find-minmax-uid encoded-mbx 'examine))) - (when info - (with-current-buffer nntp-server-buffer - (insert (format "\"%s\" %d %d y\n" - encoded-mbx (or (nth 2 info) 0) - (max 1 (or (nth 1 info) 1))))))))))) + (unless (member "\\noselect" + (mapcar #'downcase + (imap-mailbox-get 'list-flags mbx))) + (let* ((encoded-mbx (nnimap-encode-group-name mbx)) + (info (nnimap-find-minmax-uid encoded-mbx 'examine))) + (when info + (with-current-buffer nntp-server-buffer + (insert (format "\"%s\" %d %d y\n" + encoded-mbx (or (nth 2 info) 0) + (max 1 (or (nth 1 info) 1))))))))))) (gnus-message 5 "nnimap: Generating active list%s...done" (if (> (length server) 0) (concat " for " server) "")) t)) @@ -1499,8 +1502,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)) @@ -1807,69 +1810,6 @@ "Return t if MARK can be permanently (between IMAP sessions) saved on articles, in GROUP." (imap-message-flag-permanent-p (nnimap-mark-to-flag mark))) -(when nnimap-debug - (require 'trace) - (buffer-disable-undo (get-buffer-create nnimap-debug-buffer)) - (mapc (lambda (f) (trace-function-background f nnimap-debug-buffer)) - '( - nnimap-possibly-change-server - nnimap-verify-uidvalidity - nnimap-find-minmax-uid - nnimap-before-find-minmax-bugworkaround - nnimap-possibly-change-group - ;;nnimap-replace-whitespace - nnimap-retrieve-headers-progress - nnimap-retrieve-which-headers - nnimap-group-overview-filename - nnimap-retrieve-headers-from-file - nnimap-retrieve-headers-from-server - nnimap-retrieve-headers - nnimap-open-connection - nnimap-open-server - nnimap-server-opened - nnimap-close-server - nnimap-request-close - nnimap-status-message - ;;nnimap-demule - nnimap-request-article-part - nnimap-request-article - nnimap-request-head - nnimap-request-body - nnimap-request-group - nnimap-close-group - nnimap-pattern-to-list-arguments - nnimap-request-list - nnimap-request-post - nnimap-retrieve-groups - nnimap-request-update-info-internal - nnimap-request-type - nnimap-request-set-mark - nnimap-split-to-groups - nnimap-split-find-rule - nnimap-split-find-inbox - nnimap-split-articles - nnimap-request-scan - nnimap-request-newgroups - nnimap-request-create-group - nnimap-time-substract - nnimap-date-days-ago - nnimap-request-expire-articles-progress - nnimap-request-expire-articles - nnimap-request-move-article - nnimap-request-accept-article - nnimap-request-delete-group - nnimap-request-rename-group - gnus-group-nnimap-expunge - gnus-group-nnimap-edit-acl - gnus-group-nnimap-edit-acl-done - nnimap-group-mode-hook - nnimap-mark-to-predicate - nnimap-mark-to-flag-1 - nnimap-mark-to-flag - nnimap-mark-permanent-p - ))) - (provide 'nnimap) -;; arch-tag: 2b001f20-3ff9-4094-a0ad-46807c1ba70b ;;; nnimap.el ends here
--- a/lisp/gnus/nnir.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/nnir.el Wed Sep 08 12:55:57 2010 +0900 @@ -263,10 +263,10 @@ ;; I have tried to make the code expandable. Basically, it is divided ;; into two layers. The upper layer is somewhat like the `nnvirtual' -;; or `nnkiboze' backends: given a specification of what articles to -;; show from another backend, it creates a group containing exactly -;; those articles. The lower layer issues a query to a search engine -;; and produces such a specification of what articles to show from the +;; backend: given a specification of what articles to show from +;; another backend, it creates a group containing exactly those +;; articles. The lower layer issues a query to a search engine and +;; produces such a specification of what articles to show from the ;; other backend. ;; The interface between the two layers consists of the single @@ -792,7 +792,7 @@ (setq novitem (funcall nnir-get-article-nov-override-function artitem)) ;; else, set novitem through nnheader-parse-nov/nnheader-parse-head - (case (setq foo (gnus-retrieve-headers (list artno) + (case (setq foo (gnus-retrieve-headers (list artno) artfullgroup nil)) (nov (goto-char (point-min)) @@ -1697,5 +1697,4 @@ ;; The end. (provide 'nnir) -;; arch-tag: 9b3fecf8-4397-4bbb-bf3c-6ac3cbbc6664 ;;; nnir.el ends here
--- a/lisp/gnus/nnkiboze.el Wed Sep 01 11:03:05 2010 +0900 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,391 +0,0 @@ -;;; nnkiboze.el --- select virtual news 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> -;; 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: - -;; The other access methods (nntp, nnspool, etc) are general news -;; access methods. This module relies on Gnus and can't be used -;; separately. - -;;; Code: - -(require 'nntp) -(require 'nnheader) -(require 'gnus) -(require 'gnus-score) -(require 'nnoo) -(require 'mm-util) -(eval-when-compile (require 'cl)) - -(nnoo-declare nnkiboze) -(defvoo nnkiboze-directory (nnheader-concat gnus-directory "kiboze/") - "nnkiboze will put its files in this directory.") - -(defvoo nnkiboze-level 9 - "The maximum level to be searched for articles.") - -(defvoo nnkiboze-remove-read-articles t - "If non-nil, nnkiboze will remove read articles from the kiboze group.") - -(defvoo nnkiboze-ephemeral nil - "If non-nil, don't store any data anywhere.") - -(defvoo nnkiboze-scores nil - "Score rules for generating the nnkiboze group.") - -(defvoo nnkiboze-regexp nil - "Regexp for matching component groups.") - -(defvoo nnkiboze-file-coding-system mm-text-coding-system - "Coding system for nnkiboze files.") - - - -(defconst nnkiboze-version "nnkiboze 1.0") - -(defvoo nnkiboze-current-group nil) -(defvoo nnkiboze-status-string "") - -(defvoo nnkiboze-headers nil) - - - -;;; Interface functions. - -(nnoo-define-basics nnkiboze) - -(deffoo nnkiboze-retrieve-headers (articles &optional group server fetch-old) - (nnkiboze-possibly-change-group group) - (unless gnus-nov-is-evil - (if (stringp (car articles)) - 'headers - (let ((nov (nnkiboze-nov-file-name))) - (when (file-exists-p nov) - (save-excursion - (set-buffer nntp-server-buffer) - (erase-buffer) - (let ((nnheader-file-coding-system nnkiboze-file-coding-system)) - (nnheader-insert-file-contents nov)) - (nnheader-nov-delete-outside-range - (car articles) (car (last articles))) - 'nov)))))) - -(deffoo nnkiboze-request-article (article &optional newsgroup server buffer) - (nnkiboze-possibly-change-group newsgroup) - (if (not (numberp article)) - ;; This is a real kludge. It might not work at times, but it - ;; does no harm I think. The only alternative is to offer no - ;; article fetching by message-id at all. - (nntp-request-article article newsgroup gnus-nntp-server buffer) - (let* ((header (gnus-summary-article-header article)) - (xref (mail-header-xref header)) - num group) - (unless xref - (error "nnkiboze: No xref")) - (unless (string-match " \\([^ ]+\\):\\([0-9]+\\)" xref) - (error "nnkiboze: Malformed xref")) - (setq num (string-to-number (match-string 2 xref)) - group (match-string 1 xref)) - (or (with-current-buffer buffer - (or (and gnus-use-cache (gnus-cache-request-article num group)) - (gnus-agent-request-article num group))) - (gnus-request-article num group buffer))))) - -(deffoo nnkiboze-request-scan (&optional group server) - (nnkiboze-possibly-change-group group) - (nnkiboze-generate-group (concat "nnkiboze:" group))) - -(deffoo nnkiboze-request-group (group &optional server dont-check) - "Make GROUP the current newsgroup." - (nnkiboze-possibly-change-group group) - (if dont-check - t - (let ((nov-file (nnkiboze-nov-file-name)) - beg end total) - (save-excursion - (set-buffer nntp-server-buffer) - (erase-buffer) - (unless (file-exists-p nov-file) - (nnkiboze-request-scan group)) - (if (not (file-exists-p nov-file)) - (nnheader-report 'nnkiboze "Can't select group %s" group) - (let ((nnheader-file-coding-system nnkiboze-file-coding-system)) - (nnheader-insert-file-contents nov-file)) - (if (zerop (buffer-size)) - (nnheader-insert "211 0 0 0 %s\n" group) - (goto-char (point-min)) - (when (looking-at "[0-9]+") - (setq beg (read (current-buffer)))) - (goto-char (point-max)) - (when (re-search-backward "^[0-9]" nil t) - (setq end (read (current-buffer)))) - (setq total (count-lines (point-min) (point-max))) - (nnheader-insert "211 %d %d %d %s\n" total beg end group))))))) - -(deffoo nnkiboze-close-group (group &optional server) - (nnkiboze-possibly-change-group group) - ;; Remove NOV lines of articles that are marked as read. - (when (and (file-exists-p (nnkiboze-nov-file-name)) - nnkiboze-remove-read-articles) - (let ((coding-system-for-write nnkiboze-file-coding-system)) - (with-temp-file (nnkiboze-nov-file-name) - (let ((cur (current-buffer)) - (nnheader-file-coding-system nnkiboze-file-coding-system)) - (nnheader-insert-file-contents (nnkiboze-nov-file-name)) - (goto-char (point-min)) - (while (not (eobp)) - (if (not (gnus-article-read-p (read cur))) - (forward-line 1) - (gnus-delete-line)))))) - (setq nnkiboze-current-group nil))) - -(deffoo nnkiboze-open-server (server &optional defs) - (unless (assq 'nnkiboze-regexp defs) - (push `(nnkiboze-regexp ,server) - defs)) - (nnoo-change-server 'nnkiboze server defs)) - -(deffoo nnkiboze-request-delete-group (group &optional force server) - (nnkiboze-possibly-change-group group) - (when force - (let ((files (nconc - (nnkiboze-score-file group) - (list (nnkiboze-nov-file-name) - (nnkiboze-nov-file-name ".newsrc"))))) - (while files - (and (file-exists-p (car files)) - (file-writable-p (car files)) - (delete-file (car files))) - (setq files (cdr files))))) - (setq nnkiboze-current-group nil) - t) - -(nnoo-define-skeleton nnkiboze) - - -;;; Internal functions. - -(defun nnkiboze-possibly-change-group (group) - (setq nnkiboze-current-group group)) - -(defun nnkiboze-prefixed-name (group) - (gnus-group-prefixed-name group '(nnkiboze ""))) - -;;;###autoload -(defun nnkiboze-generate-groups () - "\"Usage: emacs -batch -l nnkiboze -f nnkiboze-generate-groups\". -Finds out what articles are to be part of the nnkiboze groups." - (interactive) - (let ((mail-sources nil) - (gnus-use-dribble-file nil) - (gnus-read-active-file t) - (gnus-expert-user t)) - (gnus)) - (let* ((gnus-newsrc-alist (gnus-copy-sequence gnus-newsrc-alist)) - (newsrc (cdr gnus-newsrc-alist)) - gnus-newsrc-hashtb info) - (gnus-make-hashtable-from-newsrc-alist) - ;; We have copied all the newsrc alist info over to local copies - ;; so that we can mess all we want with these lists. - (while (setq info (pop newsrc)) - (when (string-match "nnkiboze" (gnus-info-group info)) - ;; For each kiboze group, we call this function to generate - ;; it. - (nnkiboze-generate-group (gnus-info-group info) t)))) - (save-excursion - (set-buffer gnus-group-buffer) - (gnus-group-list-groups))) - -(defun nnkiboze-score-file (group) - (list (expand-file-name - (concat (file-name-as-directory gnus-kill-files-directory) - (nnheader-translate-file-chars - (concat (nnkiboze-prefixed-name nnkiboze-current-group) - "." gnus-score-file-suffix)))))) - -(defun nnkiboze-generate-group (group &optional inhibit-list-groups) - (let* ((info (gnus-get-info group)) - (newsrc-file (concat nnkiboze-directory - (nnheader-translate-file-chars - (concat group ".newsrc")))) - (nov-file (concat nnkiboze-directory - (nnheader-translate-file-chars - (concat group ".nov")))) - method nnkiboze-newsrc gname newsrc active - ginfo lowest glevel orig-info nov-buffer - ;; Bind various things to nil to make group entry faster. - (gnus-expert-user t) - (gnus-large-newsgroup nil) - (gnus-score-find-score-files-function 'nnkiboze-score-file) - ;; Use only nnkiboze-score-file! - (gnus-score-use-all-scores nil) - (gnus-use-scoring t) - (gnus-verbose (min gnus-verbose 3)) - gnus-select-group-hook gnus-summary-prepare-hook - gnus-thread-sort-functions gnus-show-threads - gnus-visual gnus-suppress-duplicates num-unread) - (unless info - (error "No such group: %s" group)) - ;; Load the kiboze newsrc file for this group. - (when (file-exists-p newsrc-file) - (load newsrc-file)) - (let ((coding-system-for-write nnkiboze-file-coding-system)) - (gnus-make-directory (file-name-directory nov-file)) - (with-temp-file nov-file - (mm-disable-multibyte) - (when (file-exists-p nov-file) - (insert-file-contents nov-file)) - (setq nov-buffer (current-buffer)) - ;; Go through the active hashtb and add new all groups that match the - ;; kiboze regexp. - (mapatoms - (lambda (group) - (and (string-match nnkiboze-regexp - (setq gname (symbol-name group))) ; Match - (not (assoc gname nnkiboze-newsrc)) ; It isn't registered - (numberp (car (symbol-value group))) ; It is active - (or (> nnkiboze-level 7) - (and (setq glevel - (gnus-info-level (gnus-get-info gname))) - (>= nnkiboze-level glevel))) - (not (string-match "^nnkiboze:" gname)) ; Exclude kibozes - (push (cons gname (1- (car (symbol-value group)))) - nnkiboze-newsrc))) - gnus-active-hashtb) - ;; `newsrc' is set to the list of groups that possibly are - ;; component groups to this kiboze group. This list has elements - ;; on the form `(GROUP . NUMBER)', where NUMBER is the highest - ;; number that has been kibozed in GROUP in this kiboze group. - (setq newsrc nnkiboze-newsrc) - (while newsrc - (if (not (setq active (gnus-active (caar newsrc)))) - ;; This group isn't active after all, so we remove it from - ;; the list of component groups. - (setq nnkiboze-newsrc (delq (car newsrc) nnkiboze-newsrc)) - (setq lowest (cdar newsrc)) - ;; Ok, we have a valid component group, so we jump to it. - (switch-to-buffer gnus-group-buffer) - (gnus-group-jump-to-group (caar newsrc)) - (gnus-message 3 "nnkiboze: Checking %s..." (caar newsrc)) - (setq ginfo (gnus-get-info (gnus-group-group-name)) - orig-info (gnus-copy-sequence ginfo) - num-unread (gnus-group-unread (caar newsrc))) - (unwind-protect - (progn - ;; We set all list of article marks to nil. Since we operate - ;; on copies of the real lists, we can destroy anything we - ;; want here. - (when (nth 3 ginfo) - (setcar (nthcdr 3 ginfo) nil)) - ;; We set the list of read articles to be what we expect for - ;; this kiboze group -- either nil or `(1 . LOWEST)'. - (when ginfo - (setcar (nthcdr 2 ginfo) - (and (not (= lowest 1)) (cons 1 lowest)))) - (when (and (or (not ginfo) - (> (length (gnus-list-of-unread-articles - (car ginfo))) - 0)) - (progn - (ignore-errors - (gnus-group-select-group nil)) - (eq major-mode 'gnus-summary-mode))) - ;; We are now in the group where we want to be. - (setq method (gnus-find-method-for-group - gnus-newsgroup-name)) - (when (eq method gnus-select-method) - (setq method nil)) - ;; We go through the list of scored articles. - (while gnus-newsgroup-scored - (when (> (caar gnus-newsgroup-scored) lowest) - ;; If it has a good score, then we enter this article - ;; into the kiboze group. - (nnkiboze-enter-nov - nov-buffer - (gnus-summary-article-header - (caar gnus-newsgroup-scored)) - gnus-newsgroup-name)) - (setq gnus-newsgroup-scored (cdr gnus-newsgroup-scored))) - ;; That's it. We exit this group. - (when (eq major-mode 'gnus-summary-mode) - (kill-buffer (current-buffer))))) - ;; Restore the proper info. - (when ginfo - (setcdr ginfo (cdr orig-info))) - (setcar (gnus-group-entry (caar newsrc)) num-unread))) - (setcdr (car newsrc) (cdr active)) - (gnus-message 3 "nnkiboze: Checking %s...done" (caar newsrc)) - (setq newsrc (cdr newsrc))))) - ;; We save the kiboze newsrc for this group. - (gnus-make-directory (file-name-directory newsrc-file)) - (with-temp-file newsrc-file - (mm-disable-multibyte) - (insert "(setq nnkiboze-newsrc '") - (gnus-prin1 nnkiboze-newsrc) - (insert ")\n")) - (unless inhibit-list-groups - (save-excursion - (set-buffer gnus-group-buffer) - (gnus-group-list-groups))) - t)) - -(defun nnkiboze-enter-nov (buffer header group) - (save-excursion - (set-buffer buffer) - (goto-char (point-max)) - (let ((prefix (gnus-group-real-prefix group)) - (oheader (copy-sequence header)) - article) - (if (zerop (forward-line -1)) - (progn - (setq article (1+ (read (current-buffer)))) - (forward-line 1)) - (setq article 1)) - (mail-header-set-number oheader article) - (with-temp-buffer - (insert (or (mail-header-xref oheader) "")) - (goto-char (point-min)) - (if (re-search-forward " [^ ]+:[0-9]+" nil t) - (goto-char (match-beginning 0)) - (or (eobp) (forward-char 1))) - ;; The first Xref has to be the group this article - ;; really came for - this is the article nnkiboze - ;; will request when it is asked for the article. - (insert " " group ":" - (int-to-string (mail-header-number header)) " ") - (while (re-search-forward " [^ ]+:[0-9]+" nil t) - (goto-char (1+ (match-beginning 0))) - (insert prefix)) - (mail-header-set-xref oheader (buffer-string))) - (nnheader-insert-nov oheader)))) - -(defun nnkiboze-nov-file-name (&optional suffix) - (concat (file-name-as-directory nnkiboze-directory) - (nnheader-translate-file-chars - (concat (nnkiboze-prefixed-name nnkiboze-current-group) - (or suffix ".nov"))))) - -(provide 'nnkiboze) - -;; arch-tag: 66068271-bdc9-4801-bcde-779702e73a05 -;;; nnkiboze.el ends here
--- a/lisp/gnus/nnlistserv.el Wed Sep 01 11:03:05 2010 +0900 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,152 +0,0 @@ -;;; nnlistserv.el --- retrieving articles via web mailing list archives - -;; Copyright (C) 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> -;; 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 'nnoo) -(require 'mm-url) -(require 'nnweb) - -(nnoo-declare nnlistserv - nnweb) - -(defvoo nnlistserv-directory (nnheader-concat gnus-directory "nnlistserv/") - "Where nnlistserv will save its files." - nnweb-directory) - -(defvoo nnlistserv-name 'kk - "What search engine type is being used." - nnweb-type) - -(defvoo nnlistserv-type-definition - '((kk - (article . nnlistserv-kk-wash-article) - (map . nnlistserv-kk-create-mapping) - (search . nnlistserv-kk-search) - (address . "http://www.itk.ntnu.no/ansatte/Andresen_Trond/kk-f/%s/") - (pages "fra160396" "fra160796" "fra061196" "fra160197" - "fra090997" "fra040797" "fra130397" "nye") - (index . "date.html") - (identifier . nnlistserv-kk-identity))) - "Type-definition alist." - nnweb-type-definition) - -(defvoo nnlistserv-search nil - "Search string to feed to DejaNews." - nnweb-search) - -(defvoo nnlistserv-ephemeral-p nil - "Whether this nnlistserv server is ephemeral." - nnweb-ephemeral-p) - -;;; Internal variables - -;;; Interface functions - -(nnoo-define-basics nnlistserv) - -(nnoo-import nnlistserv - (nnweb)) - -;;; Internal functions - -;;; -;;; KK functions. -;;; - -(defun nnlistserv-kk-create-mapping () - "Perform the search and create a number-to-url alist." - (save-excursion - (set-buffer nnweb-buffer) - (let ((case-fold-search t) - (active (or (cadr (assoc nnweb-group nnweb-group-alist)) - (cons 1 0))) - (pages (nnweb-definition 'pages)) - map url page subject from ) - (while (setq page (pop pages)) - (erase-buffer) - (when (funcall (nnweb-definition 'search) page) - ;; Go through all the article hits on this page. - (goto-char (point-min)) - (mm-url-decode-entities) - (goto-char (point-min)) - (while (re-search-forward "^<li> *<a href=\"\\([^\"]+\\)\"><b>\\([^\\>]+\\)</b></a> *<[^>]+><i>\\([^>]+\\)<" nil t) - (setq url (match-string 1) - subject (match-string 2) - from (match-string 3)) - (setq url (concat (format (nnweb-definition 'address) page) url)) - (unless (nnweb-get-hashtb url) - (push - (list - (incf (cdr active)) - (make-full-mail-header - (cdr active) subject from "" - (concat "<" (nnweb-identifier url) "@kk>") - nil 0 0 url)) - map) - (nnweb-set-hashtb (cadar map) (car map)) - (nnheader-message 5 "%s %s %s" (cdr active) (point) pages))))) - ;; Return the articles in the right order. - (setq nnweb-articles - (sort (nconc nnweb-articles map) 'car-less-than-car))))) - -(defun nnlistserv-kk-wash-article () - (let ((case-fold-search t) - (headers '(sent name email subject id)) - sent name email subject id) - (mm-url-decode-entities) - (while headers - (goto-char (point-min)) - (re-search-forward (format "<!-- %s=\"\\([^\"]+\\)" (car headers)) nil t) - (set (pop headers) (match-string 1))) - (goto-char (point-min)) - (search-forward "<!-- body" nil t) - (delete-region (point-min) (progn (forward-line 1) (point))) - (goto-char (point-max)) - (search-backward "<!-- body" nil t) - (delete-region (point-max) (progn (beginning-of-line) (point))) - (mm-url-remove-markup) - (goto-char (point-min)) - (insert (format "From: %s <%s>\n" name email) - (format "Subject: %s\n" subject) - (format "Message-ID: %s\n" id) - (format "Date: %s\n\n" sent)))) - -(defun nnlistserv-kk-search (search) - (mm-url-insert - (concat (format (nnweb-definition 'address) search) - (nnweb-definition 'index))) - t) - -(defun nnlistserv-kk-identity (url) - "Return an unique identifier based on URL." - url) - -(provide 'nnlistserv) - -;; arch-tag: 7705176f-d332-4a5e-a520-d0d319445617 -;;; nnlistserv.el ends here
--- a/lisp/gnus/nnmail.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/nnmail.el Wed Sep 08 12:55:57 2010 +0900 @@ -265,7 +265,7 @@ :type 'function) (defcustom nnmail-crosspost-link-function - (if (string-match "windows-nt\\|emx" (symbol-name system-type)) + (if (string-match "windows-nt" (symbol-name system-type)) 'copy-file 'add-name-to-file) "*Function called to create a copy of a file. @@ -1823,8 +1823,6 @@ ;; The we go through all the existing mail source specification ;; and fetch the mail from each. (while (setq source (pop fetching-sources)) - (nnheader-message 4 "%s: Reading incoming mail from %s..." - method (car source)) (when (setq new (mail-source-fetch source @@ -1842,8 +1840,9 @@ (incf i))) ;; If we did indeed read any incoming spools, we save all info. (if (zerop total) - (nnheader-message 4 "%s: Reading incoming mail (no new mail)...done" - method (car source)) + (when mail-source-plugged + (nnheader-message 4 "%s: Reading incoming mail (no new mail)...done" + method (car source))) (nnmail-save-active (nnmail-get-value "%s-group-alist" method) (nnmail-get-value "%s-active-file" method)) @@ -2052,5 +2051,4 @@ (provide 'nnmail) -;; arch-tag: fe8f671a-50db-428a-bb5d-f00462f72ed7 ;;; nnmail.el ends here
--- a/lisp/gnus/nnmaildir.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/nnmaildir.el Wed Sep 08 12:55:57 2010 +0900 @@ -1667,5 +1667,4 @@ ;; fill-column: 77 ;; End: -;; arch-tag: 0c4e44cd-dfde-4040-888e-5597ec771849 ;;; nnmaildir.el ends here
--- a/lisp/gnus/nnmairix.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/nnmairix.el Wed Sep 08 12:55:57 2010 +0900 @@ -556,7 +556,7 @@ (mapcar (lambda (arg) (- arg numcorr)) articles))) - (setq rval + (setq rval (if (eq nnmairix-backend 'nnimap) (let ((gnus-nov-is-evil t)) (nnmairix-call-backend @@ -2044,5 +2044,4 @@ (provide 'nnmairix) -;; arch-tag: bb187498-b229-4a55-8c07-6d3f80713e94 ;;; nnmairix.el ends here
--- a/lisp/gnus/nnmbox.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/nnmbox.el Wed Sep 08 12:55:57 2010 +0900 @@ -718,5 +718,4 @@ (provide 'nnmbox) -;; arch-tag: 611dd95f-be37-413a-b3ae-8b059ba93659 ;;; nnmbox.el ends here
--- a/lisp/gnus/nnmh.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/nnmh.el Wed Sep 08 12:55:57 2010 +0900 @@ -207,40 +207,48 @@ (defun nnmh-request-list-1 (dir) (setq dir (expand-file-name dir)) ;; Recurse down all directories. - (let ((dirs (and (file-readable-p dir) - (nnheader-directory-files dir t nil t))) - rdir) + (let ((files (nnheader-directory-files dir t nil t)) + (max 0) + min rdir num subdirectoriesp file) ;; Recurse down directories. - (while (setq rdir (pop dirs)) - (when (and (file-directory-p rdir) - (file-readable-p rdir) - (not (equal (file-truename rdir) - (file-truename dir)))) - (nnmh-request-list-1 rdir)))) - ;; For each directory, generate an active file line. - (unless (string= (expand-file-name nnmh-toplev) dir) - (let ((files (mapcar 'string-to-number - (directory-files dir nil "^[0-9]+$" t)))) - (when files - (with-current-buffer nntp-server-buffer - (goto-char (point-max)) - (insert - (format - "%s %.0f %.0f y\n" - (progn - (string-match - (regexp-quote - (file-truename (file-name-as-directory - (expand-file-name nnmh-toplev)))) - dir) - (mm-string-to-multibyte ;Why? Isn't it multibyte already? - (mm-encode-coding-string - (nnheader-replace-chars-in-string - (substring dir (match-end 0)) - ?/ ?.) - nnmail-pathname-coding-system))) - (apply 'max files) - (apply 'min files))))))) + (setq subdirectoriesp (> (nth 1 (file-attributes dir)) 2)) + (dolist (rdir files) + (if (or (not subdirectoriesp) + (file-regular-p rdir)) + (progn + (setq file (file-name-nondirectory rdir)) + (when (string-match "^[0-9]+$" file) + (setq num (string-to-number file)) + (setq max (max max num)) + (when (or (null min) + (< num min)) + (setq min num)))) + ;; This is a directory. + (when (and (file-readable-p rdir) + (not (equal (file-truename rdir) + (file-truename dir)))) + (nnmh-request-list-1 rdir)))) + ;; For each directory, generate an active file line. + (unless (string= (expand-file-name nnmh-toplev) dir) + (with-current-buffer nntp-server-buffer + (goto-char (point-max)) + (insert + (format + "%s %.0f %.0f y\n" + (progn + (string-match + (regexp-quote + (file-truename (file-name-as-directory + (expand-file-name nnmh-toplev)))) + dir) + (mm-string-to-multibyte ;Why? Isn't it multibyte already? + (mm-encode-coding-string + (nnheader-replace-chars-in-string + (substring dir (match-end 0)) + ?/ ?.) + nnmail-pathname-coding-system))) + (or max 0) + (or min 1)))))) t) (deffoo nnmh-request-newgroups (date &optional server) @@ -287,7 +295,7 @@ (deffoo nnmh-close-group (group &optional server) t) -(deffoo nnmh-request-move-article (article group server accept-form +(deffoo nnmh-request-move-article (article group server accept-form &optional last move-is-internal) (let ((buf (get-buffer-create " *nnmh move*")) result) @@ -312,7 +320,7 @@ (nnmh-possibly-change-directory group server) (nnmail-check-syntax) (when nnmail-cache-accepted-message-ids - (nnmail-cache-insert (nnmail-fetch-field "message-id") + (nnmail-cache-insert (nnmail-fetch-field "message-id") group (nnmail-fetch-field "subject") (nnmail-fetch-field "from"))) @@ -574,5 +582,4 @@ (provide 'nnmh) -;; arch-tag: 36c12a98-3bad-44b3-9953-628078ef0e04 ;;; nnmh.el ends here
--- a/lisp/gnus/nnml.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/nnml.el Wed Sep 08 12:55:57 2010 +0900 @@ -283,7 +283,7 @@ (deffoo nnml-request-scan (&optional group server) (setq nnml-article-file-alist nil) (nnml-possibly-change-directory group server) - (nnmail-get-new-mail 'nnml 'nnml-save-nov nnml-directory group)) + (nnmail-get-new-mail 'nnml 'nnml-save-incremental-nov nnml-directory group)) (deffoo nnml-close-group (group &optional server) (setq nnml-article-file-alist nil) @@ -438,7 +438,7 @@ (setq result (car (nnml-save-mail (list (cons group (nnml-active-number group server))) - server))) + server t))) (progn (nnmail-save-active nnml-group-alist nnml-active-file) (and last (nnml-save-nov)))) @@ -449,7 +449,7 @@ (nnml-active-number group ,server))))) (yes-or-no-p "Moved to `junk' group; delete article? ")) (setq result 'junk) - (setq result (car (nnml-save-mail result server)))) + (setq result (car (nnml-save-mail result server t)))) (when last (nnmail-save-active nnml-group-alist nnml-active-file) (when nnmail-cache-accepted-message-ids @@ -691,7 +691,7 @@ (make-directory (directory-file-name dir) t) (nnheader-message 5 "Creating mail directory %s" dir)))) -(defun nnml-save-mail (group-art &optional server) +(defun nnml-save-mail (group-art &optional server full-nov) "Save a mail into the groups GROUP-ART in the nnml server SERVER. GROUP-ART is a list that each element is a cons of a group name and an article number. This function is called narrowed to an article." @@ -742,11 +742,14 @@ ;; header. (setq headers (nnml-parse-head chars)) ;; Output the nov line to all nov databases that should have it. - (if nnmail-group-names-not-encoded-p + (let ((func (if full-nov + 'nnml-add-nov + 'nnml-add-incremental-nov))) + (if nnmail-group-names-not-encoded-p + (dolist (ga group-art) + (funcall func (pop dec) (cdr ga) headers)) (dolist (ga group-art) - (nnml-add-nov (pop dec) (cdr ga) headers)) - (dolist (ga group-art) - (nnml-add-nov (car ga) (cdr ga) headers)))) + (funcall func (car ga) (cdr ga) headers))))) group-art) (defun nnml-active-number (group &optional server) @@ -778,6 +781,35 @@ (setcdr active (1+ (cdr active)))) (cdr active))) +(defvar nnml-incremental-nov-buffer-alist nil) + +(defun nnml-save-incremental-nov () + (save-excursion + (while nnml-incremental-nov-buffer-alist + (when (buffer-name (cdar nnml-incremental-nov-buffer-alist)) + (set-buffer (cdar nnml-incremental-nov-buffer-alist)) + (when (buffer-modified-p) + (nnmail-write-region (point-min) (point-max) + nnml-nov-buffer-file-name t 'nomesg)) + (set-buffer-modified-p nil) + (kill-buffer (current-buffer))) + (setq nnml-incremental-nov-buffer-alist + (cdr nnml-incremental-nov-buffer-alist))))) + +(defun nnml-open-incremental-nov (group) + (or (cdr (assoc group nnml-incremental-nov-buffer-alist)) + (let ((buffer (nnml-get-nov-buffer group t))) + (push (cons group buffer) nnml-incremental-nov-buffer-alist) + buffer))) + +(defun nnml-add-incremental-nov (group article headers) + "Add a nov line for the GROUP nov headers, incrementally." + (save-excursion + (set-buffer (nnml-open-incremental-nov group)) + (goto-char (point-max)) + (mail-header-set-number headers article) + (nnheader-insert-nov headers))) + (defun nnml-add-nov (group article headers) "Add a nov line for the GROUP base." (save-excursion @@ -804,16 +836,21 @@ (mail-header-set-number headers number) headers)))) -(defun nnml-get-nov-buffer (group) +(defun nnml-get-nov-buffer (group &optional incrementalp) (let* ((decoded (nnml-decoded-group-name group)) - (buffer (get-buffer-create (format " *nnml overview %s*" decoded))) + (buffer (get-buffer-create (format " *nnml %soverview %s*" + (if incrementalp + "incremental " + "") + decoded))) (file-name-coding-system nnmail-pathname-coding-system)) (save-excursion (set-buffer buffer) (set (make-local-variable 'nnml-nov-buffer-file-name) (nnmail-group-pathname decoded nnml-directory nnml-nov-file-name)) (erase-buffer) - (when (file-exists-p nnml-nov-buffer-file-name) + (when (and (not incrementalp) + (file-exists-p nnml-nov-buffer-file-name)) (nnheader-insert-file-contents nnml-nov-buffer-file-name))) buffer)) @@ -1306,5 +1343,4 @@ (provide 'nnml) -;; arch-tag: 52c97dc3-9735-45de-b439-9e4d23b52004 ;;; nnml.el ends here
--- a/lisp/gnus/nnnil.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/nnnil.el Wed Sep 08 12:55:57 2010 +0900 @@ -79,4 +79,4 @@ (provide 'nnnil) -;; arch-tag: a982a1a3-bc5e-4fb1-a233-d7657a3e3257 +;;; nnnil.el ends here
--- a/lisp/gnus/nnoo.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/nnoo.el Wed Sep 08 12:55:57 2010 +0900 @@ -322,5 +322,4 @@ (provide 'nnoo) -;; arch-tag: 0196b5ed-6f34-4778-a455-73a971f837e7 ;;; nnoo.el ends here
--- a/lisp/gnus/nnrss.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/nnrss.el Wed Sep 08 12:55:57 2010 +0900 @@ -498,7 +498,7 @@ (defun nnrss-normalize-date (date) "Return a date string of DATE in the RFC822 style. This function handles the ISO 8601 date format described in -<URL:http://www.w3.org/TR/NOTE-datetime>, and also the RFC822 style +URL `http://www.w3.org/TR/NOTE-datetime', and also the RFC822 style which RSS 2.0 allows." (let (case-fold-search vector year month day time zone cts given) (cond ((null date)) ; do nothing for this case @@ -1012,7 +1012,7 @@ (defun nnrss-discover-feed (url) "Given a page, find an RSS feed using Mark Pilgrim's -`ultra-liberal rss locator' (http://diveintomark.org/2002/08/15.html)." +`ultra-liberal rss locator' (URL `http://diveintomark.org/2002/08/15.html')." (let ((parsed-page (nnrss-fetch url))) @@ -1134,5 +1134,4 @@ (provide 'nnrss) -;; arch-tag: 12910c07-0cdf-44fb-8d2c-416ded64c267 ;;; nnrss.el ends here
--- a/lisp/gnus/nnslashdot.el Wed Sep 01 11:03:05 2010 +0900 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,505 +0,0 @@ -;;; nnslashdot.el --- interfacing with Slashdot - -;; 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: - -;;; Code: - -(eval-when-compile (require 'cl)) - -(require 'nnoo) -(require 'message) -(require 'gnus-util) -(require 'gnus) -(require 'nnmail) -(require 'mm-util) -(require 'mm-url) - -(nnoo-declare nnslashdot) - -(defvoo nnslashdot-directory (nnheader-concat gnus-directory "slashdot/") - "Where nnslashdot will save its files.") - -(defvoo nnslashdot-active-url "http://slashdot.org/search.pl?section=&min=%d" - "Where nnslashdot will fetch the active file from.") - -(defvoo nnslashdot-comments-url "http://slashdot.org/comments.pl?sid=%s&threshold=%d&commentsort=%d&mode=flat&startat=%d" - "Where nnslashdot will fetch comments from.") - -(defvoo nnslashdot-article-url - "http://slashdot.org/article.pl?sid=%s&mode=nocomment" - "Where nnslashdot will fetch the article from.") - -(defvoo nnslashdot-backslash-url "http://slashdot.org/slashdot.xml" - "Where nnslashdot will fetch the stories from.") - -(defvoo nnslashdot-use-front-page nil - "Use the front page in addition to the backslash page.") - -(defvoo nnslashdot-threshold -1 - "The article threshold.") - -(defvoo nnslashdot-threaded t - "Whether the nnslashdot groups should be threaded or not.") - -(defvoo nnslashdot-group-number 0 - "The number of non-fresh groups to keep updated.") - -(defvoo nnslashdot-login-name "" - "The login name to use when posting.") - -(defvoo nnslashdot-password "" - "The password to use when posting.") - -;;; Internal variables - -(defvar nnslashdot-groups nil) -(defvar nnslashdot-buffer nil) -(defvar nnslashdot-headers nil) - -;;; Interface functions - -(nnoo-define-basics nnslashdot) - -(deffoo nnslashdot-retrieve-headers (articles &optional group server fetch-old) - (nnslashdot-possibly-change-server group server) - (condition-case why - (unless gnus-nov-is-evil - (nnslashdot-retrieve-headers-1 articles group)) - (search-failed (nnslashdot-lose why)))) - -(deffoo nnslashdot-retrieve-headers-1 (articles group) - (let* ((last (car (last articles))) - (start (if nnslashdot-threaded 1 (pop articles))) - (entry (assoc group nnslashdot-groups)) - (sid (nth 2 entry)) - (first-comments t) - headers article subject score from date lines parent point cid - s startats changed) - (save-excursion - (set-buffer nnslashdot-buffer) - (let ((case-fold-search t)) - (erase-buffer) - (when (= start 1) - (mm-url-insert (format nnslashdot-article-url sid) t) - (goto-char (point-min)) - (if (eobp) - (error "Couldn't open connection to slashdot")) - (re-search-forward "Posted by[ \t\r\n]+") - (when (looking-at "\\(<a[^>]+>\\)?[ \t\r\n]*\\([^<\r\n]+\\)") - (setq from (mm-url-decode-entities-string (match-string 2)))) - (search-forward "on ") - (setq date (nnslashdot-date-to-date - (buffer-substring (point) (1- (search-forward "<"))))) - (setq lines (/ (- (point) - (progn (forward-line 1) (point))) - 60)) - (push - (cons - 1 - (make-full-mail-header - 1 group from date - (concat "<" sid "%1@slashdot>") - "" 0 lines nil nil)) - headers) - (setq start (if nnslashdot-threaded 2 (pop articles)))) - (while (and start (<= start last)) - (setq point (goto-char (point-max))) - (mm-url-insert - (format nnslashdot-comments-url sid - nnslashdot-threshold 0 (- start 2)) - t) - (when (and nnslashdot-threaded first-comments) - (setq first-comments nil) - (goto-char (point-max)) - (while (re-search-backward "startat=\\([0-9]+\\)" nil t) - (setq s (string-to-number (match-string 1))) - (unless (memq s startats) - (push s startats))) - (setq startats (sort startats '<))) - (setq article (if (and article (< start article)) article start)) - (goto-char point) - (while (re-search-forward - "<a name=\"\\([0-9]+\\)\">\\([^<]+\\)\\(?:.*\n\\)\\{2,10\\}.*score:\\([^)]+\\))" - nil t) - (setq cid (match-string 1) - subject (match-string 2) - score (match-string 3)) - (unless (assq article (nth 4 entry)) - (setcar (nthcdr 4 entry) (cons (cons article cid) (nth 4 entry))) - (setq changed t)) - (when (string-match "^Re: *" subject) - (setq subject (concat "Re: " (substring subject (match-end 0))))) - (setq subject (mm-url-decode-entities-string subject) - from "") - (when (re-search-forward "by[ \t\n]+<[^>]+>\\([^<(]+\\)" nil t) - (setq from - (concat - (mm-url-decode-entities-string (match-string 1)) - " <nobody@slashdot.org>"))) - (search-forward "on ") - (setq date - (nnslashdot-date-to-date - (buffer-substring - (point) (progn (skip-chars-forward "^()<>\n\r") (point))))) - (setq lines (/ (abs (- (search-forward "<div") - (search-forward "</div>"))) - 70)) - (if (not - (re-search-forward ".*cid=\\([0-9]+\\)\">Parent</A>" nil t)) - (setq parent nil) - (setq parent (match-string 1)) - (when (string= parent "0") - (setq parent nil))) - (push - (cons - article - (make-full-mail-header - article - (concat subject " (" score ")") - from date - (concat "<" sid "%" cid "@slashdot>") - (if parent - (concat "<" sid "%" parent "@slashdot>") - "") - 0 lines nil nil)) - headers) - (while (and articles (<= (car articles) article)) - (pop articles)) - (setq article (1+ article))) - (if nnslashdot-threaded - (progn - (setq start (pop startats)) - (if start (setq start (+ start 2)))) - (setq start (pop articles)))))) - (if changed (nnslashdot-write-groups)) - (setq nnslashdot-headers (sort headers 'car-less-than-car)) - (save-excursion - (set-buffer nntp-server-buffer) - (erase-buffer) - (mm-with-unibyte-current-buffer - (dolist (header nnslashdot-headers) - (nnheader-insert-nov (cdr header))))) - 'nov)) - -(deffoo nnslashdot-request-group (group &optional server dont-check) - (nnslashdot-possibly-change-server nil server) - (let ((elem (assoc group nnslashdot-groups))) - (cond - ((not elem) - (nnheader-report 'nnslashdot "Group does not exist")) - (t - (nnheader-report 'nnslashdot "Opened group %s" group) - (nnheader-insert - "211 %d %d %d %s\n" (cadr elem) 1 (cadr elem) - (prin1-to-string group)))))) - -(deffoo nnslashdot-close-group (group &optional server) - (nnslashdot-possibly-change-server group server) - (when (gnus-buffer-live-p nnslashdot-buffer) - (save-excursion - (set-buffer nnslashdot-buffer) - (kill-buffer nnslashdot-buffer))) - t) - -(deffoo nnslashdot-request-article (article &optional group server buffer) - (nnslashdot-possibly-change-server group server) - (let (contents cid) - (condition-case why - (save-excursion - (set-buffer nnslashdot-buffer) - (let ((case-fold-search t)) - (goto-char (point-min)) - (when (and (stringp article) - (string-match "%\\([0-9]+\\)@" article)) - (setq cid (match-string 1 article)) - (let ((map (nth 4 (assoc group nnslashdot-groups)))) - (while map - (if (equal (cdar map) cid) - (setq article (caar map) - map nil) - (setq map (cdr map)))))) - (when (numberp article) - (if (= article 1) - (progn - (search-forward "Posted by") - (search-forward "<div class=\"intro\">") - (setq contents - (buffer-substring - (point) - (progn - (search-forward "commentwrap") - (match-beginning 0))))) - (setq cid (cdr (assq article - (nth 4 (assoc group nnslashdot-groups))))) - (search-forward (format "<a name=\"%s\">" cid)) - (setq contents - (buffer-substring - (search-forward "<div class=\"commentBody\">") - (progn - (search-forward "<div class=\"commentSub\"") - (match-beginning 0)))))))) - (search-failed (nnslashdot-lose why))) - - (when contents - (save-excursion - (set-buffer (or buffer nntp-server-buffer)) - (erase-buffer) - (mm-with-unibyte-current-buffer - (insert contents) - (goto-char (point-min)) - (while (re-search-forward "\\(<br>\r?\\)+" nil t) - (replace-match "<p>" t t)) - (goto-char (point-min)) - (insert "Content-Type: text/html\nMIME-Version: 1.0\n") - (insert "Newsgroups: " (caddr (assoc group nnslashdot-groups)) - "\n") - (let ((header (cdr (assq article nnslashdot-headers)))) - (nnheader-insert-header header)) - (nnheader-report 'nnslashdot "Fetched article %s" article)) - (cons group article))))) - -(deffoo nnslashdot-close-server (&optional server) - (when (and (nnslashdot-server-opened server) - (gnus-buffer-live-p nnslashdot-buffer)) - (save-excursion - (set-buffer nnslashdot-buffer) - (kill-buffer nnslashdot-buffer))) - (nnoo-close-server 'nnslashdot server)) - -(deffoo nnslashdot-request-list (&optional server) - (nnslashdot-possibly-change-server nil server) - (let ((number 0) - (first nnslashdot-use-front-page) - sid elem description articles gname) - (condition-case why - ;; First we do the Ultramode to get info on all the latest groups. - (progn - (mm-with-unibyte-buffer - (mm-url-insert nnslashdot-backslash-url t) - (goto-char (point-min)) - (if (eobp) - (error "Couldn't open connection to slashdot")) - (while (search-forward "<story>" nil t) - (narrow-to-region (point) (search-forward "</story>")) - (goto-char (point-min)) - (re-search-forward "<title>\\([^<]+\\)</title>") - (setq description - (mm-url-decode-entities-string (match-string 1))) - (re-search-forward "<url>\\([^<]+\\)</url>") - (setq sid (match-string 1)) - (string-match "sid=\\([0-9/]+\\)\\(.shtml\\|$\\)" sid) - (setq sid (match-string 1 sid)) - (re-search-forward "<comments>\\([^<]+\\)</comments>") - (setq articles (string-to-number (match-string 1))) - (setq gname (concat description " (" sid ")")) - (if (setq elem (assoc gname nnslashdot-groups)) - (setcar (cdr elem) articles) - (push (list gname articles sid (current-time) nil) - nnslashdot-groups)) - (goto-char (point-max)) - (widen))) - ;; Then do the older groups. - (while (or first - (> (- nnslashdot-group-number number) 0)) - (setq first nil) - (mm-with-unibyte-buffer - (let ((case-fold-search t)) - (mm-url-insert (format nnslashdot-active-url number) t) - (goto-char (point-min)) - (while (re-search-forward - "article.pl\\?sid=\\([^&]+\\).*>\\([^<]+\\)</a>" - nil t) - (setq sid (match-string 1) - description - (mm-url-decode-entities-string (match-string 2))) - (forward-line 1) - (when (re-search-forward "with \\([0-9]+\\) comment" nil t) - (setq articles (1+ (string-to-number (match-string 1))))) - (setq gname (concat description " (" sid ")")) - (if (setq elem (assoc gname nnslashdot-groups)) - (setcar (cdr elem) articles) - (push (list gname articles sid (current-time) nil) - nnslashdot-groups))))) - (incf number 30))) - (search-failed (nnslashdot-lose why))) - (nnslashdot-write-groups) - (nnslashdot-generate-active) - t)) - -(deffoo nnslashdot-request-newgroups (date &optional server) - (nnslashdot-possibly-change-server nil server) - (nnslashdot-generate-active) - t) - -(deffoo nnslashdot-request-post (&optional server) - (nnslashdot-possibly-change-server nil server) - (let ((sid (message-fetch-field "newsgroups")) - (subject (message-fetch-field "subject")) - (references (car (last (split-string - (message-fetch-field "references"))))) - body quoted pid) - (string-match "%\\([0-9]+\\)@slashdot" references) - (setq pid (match-string 1 references)) - (message-goto-body) - (narrow-to-region (point) (progn (message-goto-signature) (point))) - (goto-char (point-min)) - (while (not (eobp)) - (if (looking-at "> ") - (progn - (delete-region (point) (+ (point) 2)) - (unless quoted - (insert "<blockquote>\n")) - (setq quoted t)) - (when quoted - (insert "</blockquote>\n") - (setq quoted nil))) - (forward-line 1)) - (goto-char (point-min)) - (while (re-search-forward "^ *\n" nil t) - (replace-match "<p>\n")) - (widen) - (when (message-goto-signature) - (forward-line -1) - (insert "<p>\n") - (while (not (eobp)) - (end-of-line) - (insert "<br>") - (forward-line 1))) - (message-goto-body) - (setq body (buffer-substring (point) (point-max))) - (erase-buffer) - (mm-url-fetch-form - "http://slashdot.org/comments.pl" - `(("sid" . ,sid) - ("pid" . ,pid) - ("rlogin" . "userlogin") - ("unickname" . ,nnslashdot-login-name) - ("upasswd" . ,nnslashdot-password) - ("postersubj" . ,subject) - ("op" . "Submit") - ("postercomment" . ,body) - ("posttype" . "html"))))) - -(deffoo nnslashdot-request-delete-group (group &optional force server) - (nnslashdot-possibly-change-server group server) - (setq nnslashdot-groups (delq (assoc group nnslashdot-groups) - nnslashdot-groups)) - (nnslashdot-write-groups)) - -(deffoo nnslashdot-request-close () - (setq nnslashdot-headers nil - nnslashdot-groups nil)) - -(deffoo nnslashdot-request-expire-articles - (articles group &optional server force) - (nnslashdot-possibly-change-server group server) - (let ((item (assoc group nnslashdot-groups))) - (when item - (if (fourth item) - (when (and (>= (length articles) (cadr item)) ;; All are expirable. - (nnmail-expired-article-p - group - (fourth item) - force)) - (setq nnslashdot-groups (delq item nnslashdot-groups)) - (nnslashdot-write-groups) - (setq articles nil)) ;; all expired. - (setcdr (cddr item) (list (current-time))) - (nnslashdot-write-groups)))) - articles) - -(nnoo-define-skeleton nnslashdot) - -;;; Internal functions - -(defun nnslashdot-possibly-change-server (&optional group server) - (nnslashdot-init server) - (when (and server - (not (nnslashdot-server-opened server))) - (nnslashdot-open-server server)) - (unless nnslashdot-groups - (nnslashdot-read-groups))) - -(defun nnslashdot-make-tuple (tuple n) - (prog1 - tuple - (while (> n 1) - (unless (cdr tuple) - (setcdr tuple (list nil))) - (setq tuple (cdr tuple) - n (1- n))))) - -(defun nnslashdot-read-groups () - (let ((file (expand-file-name "groups" nnslashdot-directory))) - (when (file-exists-p file) - (mm-with-unibyte-buffer - (insert-file-contents file) - (goto-char (point-min)) - (setq nnslashdot-groups (read (current-buffer)))) - (when (and nnslashdot-groups (< (length (car nnslashdot-groups)) 5)) - (dolist (group nnslashdot-groups) - (nnslashdot-make-tuple group 5)))))) - -(defun nnslashdot-write-groups () - (with-temp-file (expand-file-name "groups" nnslashdot-directory) - (gnus-prin1 nnslashdot-groups))) - -(defun nnslashdot-init (server) - "Initialize buffers and such." - (unless (file-exists-p nnslashdot-directory) - (gnus-make-directory nnslashdot-directory)) - (unless (gnus-buffer-live-p nnslashdot-buffer) - (setq nnslashdot-buffer - (save-excursion - (nnheader-set-temp-buffer - (format " *nnslashdot %s*" server)))) - (push nnslashdot-buffer gnus-buffers))) - -(defun nnslashdot-date-to-date (sdate) - (condition-case err - (let ((elem (delete "" (split-string sdate)))) - (concat (substring (nth 0 elem) 0 3) " " - (substring (nth 1 elem) 0 3) " " - (substring (nth 2 elem) 0 2) " " - (substring (nth 3 elem) 1 6) " " - (format-time-string "%Y") " " - (nth 4 elem))) - (error ""))) - -(defun nnslashdot-generate-active () - (save-excursion - (set-buffer nntp-server-buffer) - (erase-buffer) - (dolist (elem nnslashdot-groups) - (when (numberp (cadr elem)) - (insert (prin1-to-string (car elem)) - " " (number-to-string (cadr elem)) " 1 y\n"))))) - -(defun nnslashdot-lose (why) - (error "Slashdot HTML has changed; please get a new version of nnslashdot")) - -(provide 'nnslashdot) - -;; arch-tag: aa73df7a-f7e6-4eef-bdea-5ce2f8c691b3 -;;; nnslashdot.el ends here
--- a/lisp/gnus/nnsoup.el Wed Sep 01 11:03:05 2010 +0900 +++ /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/nnspool.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/nnspool.el Wed Sep 08 12:55:57 2010 +0900 @@ -458,5 +458,4 @@ (provide 'nnspool) -;; arch-tag: bdac8d27-2934-4eee-bad0-49e6b90c0d05 ;;; nnspool.el ends here
--- a/lisp/gnus/nntp.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/nntp.el Wed Sep 08 12:55:57 2010 +0900 @@ -298,13 +298,6 @@ (defvoo nntp-server-xover 'try) (defvoo nntp-server-list-active-group 'try) -(defvar nntp-async-needs-kluge - (string-match "^GNU Emacs 20\\.3\\." (emacs-version)) - "*When non-nil, nntp will poll asynchronous connections -once a second. By default, this is turned on only for Emacs -20.3, which has a bug that breaks nntp's normal method of -noticing asynchronous data.") - (defvar nntp-async-timer nil) (defvar nntp-async-process-list nil) @@ -316,8 +309,8 @@ stdin and return responses to stdout.") (defvar nntp-authinfo-rejected nil -"A custom error condition used to report 'Authentication Rejected' errors. -Condition handlers that match just this condition ensure that the nntp +"A custom error condition used to report 'Authentication Rejected' errors. +Condition handlers that match just this condition ensure that the nntp backend doesn't catch this error.") (put 'nntp-authinfo-rejected 'error-conditions '(error nntp-authinfo-rejected)) (put 'nntp-authinfo-rejected 'error-message "Authorization Rejected") @@ -1116,7 +1109,8 @@ t) (deffoo nntp-request-set-mark (group actions &optional server) - (unless nntp-marks-is-evil + (when (and (not nntp-marks-is-evil) + nntp-marks-file-name) (nntp-possibly-create-directory group server) (nntp-open-marks group server) (dolist (action actions) @@ -1136,7 +1130,8 @@ nil) (deffoo nntp-request-update-info (group info &optional server) - (unless nntp-marks-is-evil + (when (and (not nntp-marks-is-evil) + nntp-marks-file-name) (nntp-possibly-create-directory group server) (when (nntp-marks-changed-p group server) (nnheader-message 8 "Updating marks for %s..." group) @@ -1368,17 +1363,7 @@ nntp-process-decode decode nntp-process-callback callback nntp-process-start-point (point-max)) - (setq after-change-functions '(nntp-after-change-function)) - (if nntp-async-needs-kluge - (nntp-async-kluge process)))) - -(defun nntp-async-kluge (process) - ;; emacs 20.3 bug: process output with encoding 'binary - ;; doesn't trigger after-change-functions. - (unless nntp-async-timer - (setq nntp-async-timer - (run-at-time 1 1 'nntp-async-timer-handler))) - (add-to-list 'nntp-async-process-list process)) + (setq after-change-functions '(nntp-after-change-function)))) (defun nntp-async-timer-handler () (mapcar @@ -1783,7 +1768,7 @@ (while (and (setq proc (get-buffer-process buf)) (memq (process-status proc) '(open run)) (not (re-search-forward regexp nil t))) - (accept-process-output proc) + (accept-process-output proc 0.1) (set-buffer buf) (goto-char (point-min))))) @@ -2028,7 +2013,7 @@ (and nntp-pre-command (push nntp-pre-command command)) (let ((process-connection-type nil)) ;See `nntp-open-via-rlogin-and-netcat'. (apply 'start-process "nntpd" buffer command)))) - + (defun nntp-open-via-telnet-and-telnet (buffer) "Open a connection to an nntp server through an intermediate host. @@ -2195,5 +2180,4 @@ (provide 'nntp) -;; arch-tag: 8655466a-b1b5-4929-9c45-7b1b2e767271 ;;; nntp.el ends here
--- a/lisp/gnus/nnultimate.el Wed Sep 01 11:03:05 2010 +0900 +++ /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/nnvirtual.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/nnvirtual.el Wed Sep 08 12:55:57 2010 +0900 @@ -260,13 +260,11 @@ (nnheader-report 'nnvirtual "No component groups in %s" group)) (t (setq nnvirtual-current-group group) - (when (or (not dont-check) - nnvirtual-always-rescan) - (nnvirtual-create-mapping) - (when nnvirtual-always-rescan - (nnvirtual-request-update-info - (nnvirtual-current-group) - (gnus-get-info (nnvirtual-current-group))))) + (nnvirtual-create-mapping dont-check) + (when nnvirtual-always-rescan + (nnvirtual-request-update-info + (nnvirtual-current-group) + (gnus-get-info (nnvirtual-current-group)))) (nnheader-insert "211 %d 1 %d %s\n" nnvirtual-mapping-len nnvirtual-mapping-len group)))) @@ -300,10 +298,6 @@ t) -(deffoo nnvirtual-request-list (&optional server) - (nnheader-report 'nnvirtual "LIST is not implemented.")) - - (deffoo nnvirtual-request-newgroups (date &optional server) (nnheader-report 'nnvirtual "NEWGROUPS is not supported.")) @@ -674,7 +668,7 @@ carticles)) -(defun nnvirtual-create-mapping () +(defun nnvirtual-create-mapping (dont-check) "Build the tables necessary to map between component (group, article) to virtual article. Generate the set of read messages and marks for the virtual group based on the marks on the component groups." @@ -693,7 +687,9 @@ ;; Into all-marks we put (g marks). ;; We also increment cnt and tot here, and compute M (max of sizes). (mapc (lambda (g) - (setq active (gnus-activate-group g) + (setq active (or (and dont-check + (gnus-active g)) + (gnus-activate-group g)) min (car active) max (cdr active)) (when (and active (>= max min) (not (zerop max))) @@ -809,5 +805,4 @@ (provide 'nnvirtual) -;; arch-tag: ca8c8ad9-1bd8-4b0f-9722-90dc645a45f5 ;;; nnvirtual.el ends here
--- a/lisp/gnus/nnwarchive.el Wed Sep 01 11:03:05 2010 +0900 +++ /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/gnus/nnweb.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/nnweb.el Wed Sep 08 12:55:57 2010 +0900 @@ -612,5 +612,4 @@ (provide 'nnweb) -;; arch-tag: f59307eb-c90f-479f-b7d2-dbd8bf51b697 ;;; nnweb.el ends here
--- a/lisp/gnus/nnwfm.el Wed Sep 01 11:03:05 2010 +0900 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,432 +0,0 @@ -;;; nnwfm.el --- interfacing with a web forum - -;; Copyright (C) 2000, 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) -(autoload 'w3-parse-buffer "w3-parse") - -(nnoo-declare nnwfm) - -(defvoo nnwfm-directory (nnheader-concat gnus-directory "wfm/") - "Where nnwfm will save its files.") - -(defvoo nnwfm-address "" - "The address of the Ultimate bulletin board.") - -;;; Internal variables - -(defvar nnwfm-groups-alist nil) -(defvoo nnwfm-groups nil) -(defvoo nnwfm-headers nil) -(defvoo nnwfm-articles nil) -(defvar nnwfm-table-regexp - "postings.*editpost\\|forumdisplay\\|Forum[0-9]+/HTML\\|getbio") - -;;; Interface functions - -(nnoo-define-basics nnwfm) - -(deffoo nnwfm-retrieve-headers (articles &optional group server fetch-old) - (nnwfm-possibly-change-server group server) - (unless gnus-nov-is-evil - (let* ((last (car (last articles))) - (did nil) - (start 1) - (entry (assoc group nnwfm-groups)) - (sid (nth 2 entry)) - (topics (nth 4 entry)) - (mapping (nth 5 entry)) - (old-total (or (nth 6 entry) 1)) - (nnwfm-table-regexp "Thread.asp") - headers article subject score from date lines parent point - contents tinfo fetchers map elem a href garticles topic old-max - inc datel table string current-page total-contents pages - farticles forum-contents parse furl-fetched mmap farticle - thread-id tables hstuff bstuff time) - (setq map mapping) - (while (and (setq article (car articles)) - map) - (while (and map - (or (> article (caar map)) - (< (cadar map) (caar map)))) - (pop map)) - (when (setq mmap (car map)) - (setq farticle -1) - (while (and article - (<= article (nth 1 mmap))) - ;; Do we already have a fetcher for this topic? - (if (setq elem (assq (nth 2 mmap) fetchers)) - ;; Yes, so we just add the spec to the end. - (nconc elem (list (cons article - (+ (nth 3 mmap) (incf farticle))))) - ;; No, so we add a new one. - (push (list (nth 2 mmap) - (cons article - (+ (nth 3 mmap) (incf farticle)))) - fetchers)) - (pop articles) - (setq article (car articles))))) - ;; Now we have the mapping from/to Gnus/nnwfm article numbers, - ;; so we start fetching the topics that we need to satisfy the - ;; request. - (if (not fetchers) - (save-excursion - (set-buffer nntp-server-buffer) - (erase-buffer)) - (setq nnwfm-articles nil) - (mm-with-unibyte-buffer - (dolist (elem fetchers) - (erase-buffer) - (setq subject (nth 2 (assq (car elem) topics)) - thread-id (nth 0 (assq (car elem) topics))) - (mm-url-insert - (concat nnwfm-address - (format "Item.asp?GroupID=%d&ThreadID=%d" sid - thread-id))) - (goto-char (point-min)) - (setq tables (caddar - (caddar - (cdr (caddar - (caddar - (ignore-errors - (w3-parse-buffer (current-buffer))))))))) - (setq tables (cdr (caddar (memq (assq 'div tables) tables)))) - (setq contents nil) - (dolist (table tables) - (when (eq (car table) 'table) - (setq table (caddar (caddar (caddr table))) - hstuff (delete ":link" (nnweb-text (car table))) - bstuff (car (caddar (cdr table))) - from (car hstuff)) - (when (nth 2 hstuff) - (setq time (nnwfm-date-to-time (nth 2 hstuff))) - (push (list from time bstuff) contents)))) - (setq contents (nreverse contents)) - (dolist (art (cdr elem)) - (push (list (car art) - (nth (1- (cdr art)) contents) - subject) - nnwfm-articles)))) - (setq nnwfm-articles - (sort nnwfm-articles 'car-less-than-car)) - ;; Now we have all the articles, conveniently in an alist - ;; where the key is the Gnus article number. - (dolist (articlef nnwfm-articles) - (setq article (nth 0 articlef) - contents (nth 1 articlef) - subject (nth 2 articlef)) - (setq from (nth 0 contents) - date (message-make-date (nth 1 contents))) - (push - (cons - article - (make-full-mail-header - article subject - from (or date "") - (concat "<" (number-to-string sid) "%" - (number-to-string article) - "@wfm>") - "" 0 - (/ (length (mapconcat 'identity (nnweb-text (nth 2 contents)) "")) - 70) - nil nil)) - headers)) - (setq nnwfm-headers (sort headers 'car-less-than-car)) - (save-excursion - (set-buffer nntp-server-buffer) - (mm-with-unibyte-current-buffer - (erase-buffer) - (dolist (header nnwfm-headers) - (nnheader-insert-nov (cdr header)))))) - 'nov))) - -(deffoo nnwfm-request-group (group &optional server dont-check) - (nnwfm-possibly-change-server nil server) - (when (not nnwfm-groups) - (nnwfm-request-list)) - (unless dont-check - (nnwfm-create-mapping group)) - (let ((elem (assoc group nnwfm-groups))) - (cond - ((not elem) - (nnheader-report 'nnwfm "Group does not exist")) - (t - (nnheader-report 'nnwfm "Opened group %s" group) - (nnheader-insert - "211 %d %d %d %s\n" (cadr elem) 1 (cadr elem) - (prin1-to-string group)))))) - -(deffoo nnwfm-request-close () - (setq nnwfm-groups-alist nil - nnwfm-groups nil)) - -(deffoo nnwfm-request-article (article &optional group server buffer) - (nnwfm-possibly-change-server group server) - (let ((contents (cdr (assq article nnwfm-articles)))) - (when (setq contents (nth 2 (car contents))) - (save-excursion - (set-buffer (or buffer nntp-server-buffer)) - (erase-buffer) - (nnweb-insert-html contents) - (goto-char (point-min)) - (insert "Content-Type: text/html\nMIME-Version: 1.0\n") - (let ((header (cdr (assq article nnwfm-headers)))) - (mm-with-unibyte-current-buffer - (nnheader-insert-header header))) - (nnheader-report 'nnwfm "Fetched article %s" article) - (cons group article))))) - -(deffoo nnwfm-request-list (&optional server) - (nnwfm-possibly-change-server nil server) - (mm-with-unibyte-buffer - (mm-url-insert - (if (string-match "/$" nnwfm-address) - (concat nnwfm-address "Group.asp") - nnwfm-address)) - (let* ((nnwfm-table-regexp "Thread.asp") - (contents (w3-parse-buffer (current-buffer))) - sid elem description articles a href group forum - a1 a2) - (dolist (row (cdr (nth 2 (car (nth 2 (nnwfm-find-forum-table - contents)))))) - (setq row (nth 2 row)) - (when (setq a (nnweb-parse-find 'a row)) - (setq group (car (last (nnweb-text a))) - href (cdr (assq 'href (nth 1 a)))) - (setq description (car (last (nnweb-text (nth 1 row))))) - (setq articles - (string-to-number - (gnus-replace-in-string - (car (last (nnweb-text (nth 3 row)))) "," ""))) - (when (and href - (string-match "GroupId=\\([0-9]+\\)" href)) - (setq forum (string-to-number (match-string 1 href))) - (if (setq elem (assoc group nnwfm-groups)) - (setcar (cdr elem) articles) - (push (list group articles forum description nil nil nil nil) - nnwfm-groups)))))) - (nnwfm-write-groups) - (nnwfm-generate-active) - t)) - -(deffoo nnwfm-request-newgroups (date &optional server) - (nnwfm-possibly-change-server nil server) - (nnwfm-generate-active) - t) - -(nnoo-define-skeleton nnwfm) - -;;; Internal functions - -(defun nnwfm-new-threads-p (group time) - "See whether we want to fetch the threads for GROUP written before TIME." - (let ((old-time (nth 7 (assoc group nnwfm-groups)))) - (or (null old-time) - (time-less-p old-time time)))) - -(defun nnwfm-create-mapping (group) - (let* ((entry (assoc group nnwfm-groups)) - (sid (nth 2 entry)) - (topics (nth 4 entry)) - (mapping (nth 5 entry)) - (old-total (or (nth 6 entry) 1)) - (current-time (current-time)) - (nnwfm-table-regexp "Thread.asp") - (furls (list (concat nnwfm-address - (format "Thread.asp?GroupId=%d" sid)))) - fetched-urls - contents forum-contents a subject href - garticles topic tinfo old-max inc parse elem date - url time) - (mm-with-unibyte-buffer - (while furls - (erase-buffer) - (push (car furls) fetched-urls) - (mm-url-insert (pop furls)) - (goto-char (point-min)) - (while (re-search-forward " wr(" nil t) - (forward-char -1) - (setq elem (message-tokenize-header - (gnus-replace-in-string - (buffer-substring - (1+ (point)) - (progn - (forward-sexp 1) - (1- (point)))) - "\\\\[\"\\\\]" ""))) - (push (list - (string-to-number (nth 1 elem)) - (gnus-replace-in-string (nth 2 elem) "\"" "") - (string-to-number (nth 5 elem))) - forum-contents)) - (when (re-search-forward "href=\"\\(Thread.*DateLast=\\([^\"]+\\)\\)" - nil t) - (setq url (match-string 1) - time (nnwfm-date-to-time (gnus-url-unhex-string - (match-string 2)))) - (when (and (nnwfm-new-threads-p group time) - (not (member - (setq url (concat - nnwfm-address - (mm-url-decode-entities-string url))) - fetched-urls))) - (push url furls)))) - ;; The main idea here is to map Gnus article numbers to - ;; nnwfm article numbers. Say there are three topics in - ;; this forum, the first with 4 articles, the seconds with 2, - ;; and the third with 1. Then this will translate into 7 Gnus - ;; article numbers, where 1-4 comes from the first topic, 5-6 - ;; from the second and 7 from the third. Now, then next time - ;; the group is entered, there's 2 new articles in topic one - ;; and 1 in topic three. Then Gnus article number 8-9 be 5-6 - ;; in topic one and 10 will be the 2 in topic three. - (dolist (elem (nreverse forum-contents)) - (setq subject (nth 1 elem) - topic (nth 0 elem) - garticles (nth 2 elem)) - (if (setq tinfo (assq topic topics)) - (progn - (setq old-max (cadr tinfo)) - (setcar (cdr tinfo) garticles)) - (setq old-max 0) - (push (list topic garticles subject) topics) - (setcar (nthcdr 4 entry) topics)) - (when (not (= old-max garticles)) - (setq inc (- garticles old-max)) - (setq mapping (nconc mapping - (list - (list - old-total (1- (incf old-total inc)) - topic (1+ old-max))))) - (incf old-max inc) - (setcar (nthcdr 5 entry) mapping) - (setcar (nthcdr 6 entry) old-total)))) - (setcar (nthcdr 7 entry) current-time) - (setcar (nthcdr 1 entry) (1- old-total)) - (nnwfm-write-groups) - mapping)) - -(defun nnwfm-possibly-change-server (&optional group server) - (nnwfm-init server) - (when (and server - (not (nnwfm-server-opened server))) - (nnwfm-open-server server)) - (unless nnwfm-groups-alist - (nnwfm-read-groups) - (setq nnwfm-groups (cdr (assoc nnwfm-address - nnwfm-groups-alist))))) - -(deffoo nnwfm-open-server (server &optional defs connectionless) - (nnheader-init-server-buffer) - (if (nnwfm-server-opened server) - t - (unless (assq 'nnwfm-address defs) - (setq defs (append defs (list (list 'nnwfm-address server))))) - (nnoo-change-server 'nnwfm server defs))) - -(defun nnwfm-read-groups () - (setq nnwfm-groups-alist nil) - (let ((file (expand-file-name "groups" nnwfm-directory))) - (when (file-exists-p file) - (mm-with-unibyte-buffer - (insert-file-contents file) - (goto-char (point-min)) - (setq nnwfm-groups-alist (read (current-buffer))))))) - -(defun nnwfm-write-groups () - (setq nnwfm-groups-alist - (delq (assoc nnwfm-address nnwfm-groups-alist) - nnwfm-groups-alist)) - (push (cons nnwfm-address nnwfm-groups) - nnwfm-groups-alist) - (with-temp-file (expand-file-name "groups" nnwfm-directory) - (prin1 nnwfm-groups-alist (current-buffer)))) - -(defun nnwfm-init (server) - "Initialize buffers and such." - (unless (file-exists-p nnwfm-directory) - (gnus-make-directory nnwfm-directory))) - -(defun nnwfm-generate-active () - (save-excursion - (set-buffer nntp-server-buffer) - (erase-buffer) - (dolist (elem nnwfm-groups) - (insert (prin1-to-string (car elem)) - " " (number-to-string (cadr elem)) " 1 y\n")))) - -(defun nnwfm-find-forum-table (contents) - (catch 'found - (nnwfm-find-forum-table-1 contents))) - -(defun nnwfm-find-forum-table-1 (contents) - (dolist (element contents) - (unless (stringp element) - (when (and (eq (car element) 'table) - (nnwfm-forum-table-p element)) - (throw 'found element)) - (when (nth 2 element) - (nnwfm-find-forum-table-1 (nth 2 element)))))) - -(defun nnwfm-forum-table-p (parse) - (when (not (apply 'gnus-or - (mapcar - (lambda (p) - (nnweb-parse-find 'table p)) - (nth 2 parse)))) - (let ((href (cdr (assq 'href (nth 1 (nnweb-parse-find 'a parse 20))))) - case-fold-search) - (when (and href (string-match nnwfm-table-regexp href)) - t)))) - -(defun nnwfm-date-to-time (date) - (let ((time (mapcar #'string-to-number (split-string date "[\\.\\+ :]")))) - (encode-time 0 (nth 4 time) (nth 3 time) - (nth 0 time) (nth 1 time) - (if (< (nth 2 time) 70) - (+ 2000 (nth 2 time)) - (+ 1900 (nth 2 time)))))) - -(provide 'nnwfm) - -;; Local Variables: -;; coding: iso-8859-1 -;; End: - -;; arch-tag: d813966a-4211-4557-ad11-d1ac2bc86536 -;;; nnwfm.el ends here
--- a/lisp/gnus/pop3.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/pop3.el Wed Sep 08 12:55:57 2010 +0900 @@ -33,6 +33,7 @@ ;;; Code: +(eval-when-compile (require 'cl)) (require 'mail-utils) (defvar parse-time-months) @@ -98,12 +99,6 @@ :type 'boolean :group 'pop3) -(defcustom pop3-display-message-size-flag t - "*If non-nil, display the size of the message that is being fetched." - :version "22.1" ;; Oort Gnus - :type 'boolean - :group 'pop3) - (defvar pop3-timestamp nil "Timestamp returned when initially connected to the POP server. Used for APOP authentication.") @@ -120,7 +115,7 @@ (defalias 'pop3-accept-process-output 'nnheader-accept-process-output) ;; Borrowed from `nnheader.el': (defvar pop3-read-timeout - (if (string-match "windows-nt\\|os/2\\|emx\\|cygwin" + (if (string-match "windows-nt\\|os/2\\|cygwin" (symbol-name system-type)) 1.0 0.01) @@ -134,15 +129,91 @@ (truncate pop3-read-timeout)) 1000)))))) -(defun pop3-movemail (&optional crashbox) - "Transfer contents of a maildrop to the specified CRASHBOX." - (or crashbox (setq crashbox (expand-file-name "~/.crashbox"))) +(defun pop3-streaming-movemail (file) + "Transfer contents of a maildrop to the specified FILE. +Use streaming commands." (let* ((process (pop3-open-server pop3-mailhost pop3-port)) - (crashbuf (get-buffer-create " *pop3-retr*")) - (n 1) - message-count - message-sizes - (pop3-password pop3-password)) + message-count message-total-size) + (pop3-logon process) + (with-current-buffer (process-buffer process) + (let ((size (pop3-stat process))) + (setq message-count (car size) + message-total-size (cadr size))) + (when (plusp message-count) + (pop3-send-streaming-command + process "RETR" message-count message-total-size) + (pop3-write-to-file file) + (unless pop3-leave-mail-on-server + (pop3-send-streaming-command + process "DELE" message-count nil)))) + (pop3-quit process) + t)) + +(defun pop3-send-streaming-command (process command count total-size) + (erase-buffer) + (let ((i 1)) + (while (>= count i) + (process-send-string process (format "%s %d\r\n" command i)) + ;; Only do 100 messages at a time to avoid pipe stalls. + (when (zerop (% i 100)) + (pop3-wait-for-messages process i total-size)) + (incf i))) + (pop3-wait-for-messages process count total-size)) + +(defun pop3-wait-for-messages (process count total-size) + (while (< (pop3-number-of-responses total-size) count) + (when total-size + (message "pop3 retrieved %dKB (%d%%)" + (truncate (/ (buffer-size) 1000)) + (truncate (* (/ (* (buffer-size) 1.0) + total-size) 100)))) + (nnheader-accept-process-output process))) + +(defun pop3-write-to-file (file) + (let ((pop-buffer (current-buffer)) + (start (point-min)) + beg end + temp-buffer) + (with-temp-buffer + (setq temp-buffer (current-buffer)) + (with-current-buffer pop-buffer + (goto-char (point-min)) + (while (re-search-forward "^\\+OK" nil t) + (forward-line 1) + (setq beg (point)) + (when (re-search-forward "^\\.\r?\n" nil t) + (setq start (point)) + (forward-line -1) + (setq end (point))) + (with-current-buffer temp-buffer + (goto-char (point-max)) + (let ((hstart (point))) + (insert-buffer-substring pop-buffer beg end) + (pop3-clean-region hstart (point)) + (goto-char (point-max)) + (pop3-munge-message-separator hstart (point)) + (goto-char (point-max)))))) + (let ((coding-system-for-write 'binary)) + (goto-char (point-min)) + ;; Check whether something inserted a newline at the start and + ;; delete it. + (when (eolp) + (delete-char 1)) + (write-region (point-min) (point-max) file nil 'nomesg))))) + +(defun pop3-number-of-responses (endp) + (let ((responses 0)) + (save-excursion + (goto-char (point-min)) + (while (or (and (re-search-forward "^\\+OK" nil t) + (or (not endp) + (re-search-forward "^\\.\r?\n" nil t))) + (re-search-forward "^-ERR " nil t)) + (incf responses))) + responses)) + +(defun pop3-logon (process) + (let ((pop3-password pop3-password)) ;; for debugging only (if pop3-debug (switch-to-buffer (process-buffer process))) ;; query for password @@ -154,30 +225,33 @@ ((equal 'pass pop3-authentication-scheme) (pop3-user process pop3-maildrop) (pop3-pass process)) - (t (error "Invalid POP3 authentication scheme"))) + (t (error "Invalid POP3 authentication scheme"))))) + +(defun pop3-movemail (&optional crashbox) + "Transfer contents of a maildrop to the specified CRASHBOX." + (or crashbox (setq crashbox (expand-file-name "~/.crashbox"))) + (let* ((process (pop3-open-server pop3-mailhost pop3-port)) + (crashbuf (get-buffer-create " *pop3-retr*")) + (n 1) + message-count + message-sizes) + (pop3-logon process) (setq message-count (car (pop3-stat process))) - (when (and pop3-display-message-size-flag - (> message-count 0)) + (when (> message-count 0) (setq message-sizes (pop3-list process))) (unwind-protect (while (<= n message-count) - (if pop3-display-message-size-flag - (message "Retrieving message %d of %d from %s... (%.1fk)" - n message-count pop3-mailhost - (/ (cdr (assoc n message-sizes)) - 1024.0)) - (message "Retrieving message %d of %d from %s..." - n message-count pop3-mailhost)) + (message "Retrieving message %d of %d from %s... (%.1fk)" + n message-count pop3-mailhost + (/ (cdr (assoc n message-sizes)) + 1024.0)) (pop3-retr process n crashbuf) (save-excursion (set-buffer crashbuf) (let ((coding-system-for-write 'binary)) (write-region (point-min) (point-max) crashbox t 'nomesg)) (set-buffer (process-buffer process)) - (while (> (buffer-size) 5000) - (goto-char (point-min)) - (forward-line 50) - (delete-region (point-min) (point)))) + (erase-buffer)) (unless pop3-leave-mail-on-server (pop3-dele process n)) (setq n (+ 1 n)) @@ -229,6 +303,13 @@ (const :tag "SSL/TLS" ssl) (const starttls))) +(eval-and-compile + (if (fboundp 'set-process-query-on-exit-flag) + (defalias 'pop3-set-process-query-on-exit-flag + 'set-process-query-on-exit-flag) + (defalias 'pop3-set-process-query-on-exit-flag + 'process-kill-without-query))) + (defun pop3-open-server (mailhost port) "Open TCP connection to MAILHOST on PORT. Returns the process associated with the connection." @@ -283,22 +364,17 @@ (pop3-quit process) (error "POP server doesn't support starttls"))) process)) - (t + (t (open-network-stream "POP" (current-buffer) mailhost port)))) (let ((response (pop3-read-response process t))) (setq pop3-timestamp (substring response (or (string-match "<" response) 0) (+ 1 (or (string-match ">" response) -1))))) + (pop3-set-process-query-on-exit-flag process nil) process))) ;; Support functions -(defun pop3-process-filter (process output) - (save-excursion - (set-buffer (process-buffer process)) - (goto-char (point-max)) - (insert output))) - (defun pop3-send-command (process command) (set-buffer (process-buffer process)) (goto-char (point-max)) @@ -415,10 +491,7 @@ nil (goto-char (point-max)) (insert "\n")) - (narrow-to-region (point) (point-max)) - (let ((size (- (point-max) (point-min)))) - (goto-char (point-min)) - (widen) + (let ((size (- (point-max) (point)))) (forward-line -1) (insert (format "Content-Length: %s\n" size))) ))))) @@ -468,7 +541,7 @@ (defun pop3-list (process &optional msg) "If MSG is nil, return an alist of (MESSAGE-ID . SIZE) pairs. Otherwise, return the size of the message-id MSG" - (pop3-send-command process (if msg + (pop3-send-command process (if msg (format "LIST %d" msg) "LIST")) (let ((response (pop3-read-response process t))) @@ -643,5 +716,4 @@ (provide 'pop3) -;; arch-tag: 2facc142-1d74-498e-82af-4659b64cac12 ;;; pop3.el ends here
--- a/lisp/gnus/qp.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/qp.el Wed Sep 08 12:55:57 2010 +0900 @@ -164,5 +164,4 @@ (provide 'qp) -;; arch-tag: db89e52a-e4a1-4b69-926f-f434f04216ba ;;; qp.el ends here
--- a/lisp/gnus/rfc1843.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/rfc1843.el Wed Sep 08 12:55:57 2010 +0900 @@ -192,5 +192,4 @@ (provide 'rfc1843) -;; arch-tag: 5149c301-a6ca-4731-9c9d-ba616e2cb687 ;;; rfc1843.el ends here
--- a/lisp/gnus/rfc2045.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/rfc2045.el Wed Sep 08 12:55:57 2010 +0900 @@ -39,5 +39,4 @@ (provide 'rfc2045) -;; arch-tag: 9ca54127-97bc-432c-b6e2-8c59cadba306 ;;; rfc2045.el ends here
--- a/lisp/gnus/rfc2047.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/rfc2047.el Wed Sep 08 12:55:57 2010 +0900 @@ -1175,5 +1175,4 @@ (provide 'rfc2047) -;; arch-tag: a07fe3d4-22b5-4c4a-bd89-b1f82d5d36f6 ;;; rfc2047.el ends here
--- a/lisp/gnus/rfc2104.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/rfc2104.el Wed Sep 08 12:55:57 2010 +0900 @@ -122,5 +122,4 @@ (provide 'rfc2104) -;; arch-tag: cf671d5c-a45f-4a09-815e-704e59e43950 ;;; rfc2104.el ends here
--- a/lisp/gnus/rfc2231.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/rfc2231.el Wed Sep 08 12:55:57 2010 +0900 @@ -296,5 +296,4 @@ (provide 'rfc2231) -;; arch-tag: c3ab751d-d108-406a-b301-68882ad8cd63 ;;; rfc2231.el ends here
--- a/lisp/gnus/score-mode.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/score-mode.el Wed Sep 08 12:55:57 2010 +0900 @@ -116,5 +116,4 @@ (provide 'score-mode) -;; arch-tag: a74a416b-2505-4ad4-bc4e-a418c96b8845 ;;; score-mode.el ends here
--- a/lisp/gnus/sieve-manage.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/sieve-manage.el Wed Sep 08 12:55:57 2010 +0900 @@ -335,7 +335,7 @@ (defun sieve-sasl-auth (buffer mech) "Login to server using the SASL MECH method." (message "sieve: Authenticating using %s..." mech) - (if (sieve-manage-interactive-login + (if (sieve-manage-interactive-login buffer (lambda (user passwd) (let (client step tag data rsp) @@ -701,5 +701,4 @@ (provide 'sieve-manage) -;; arch-tag: 321c4640-1371-4495-9baf-8ccb71dd5bd1 ;; sieve-manage.el ends here
--- a/lisp/gnus/sieve-mode.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/sieve-mode.el Wed Sep 08 12:55:57 2010 +0900 @@ -216,5 +216,4 @@ (provide 'sieve-mode) -;; arch-tag: 3b8ab76d-065d-4c52-b1e8-ab2ec21f2ace ;; sieve-mode.el ends here
--- a/lisp/gnus/sieve.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/sieve.el Wed Sep 08 12:55:57 2010 +0900 @@ -380,5 +380,4 @@ (provide 'sieve) -;; arch-tag: 7f6a6d94-94e1-4654-ab9a-aee21b9b8a94 ;; sieve.el ends here
--- a/lisp/gnus/smiley.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/smiley.el Wed Sep 08 12:55:57 2010 +0900 @@ -102,7 +102,8 @@ ;; The XEmacs version has a baroque, if not rococo, set of these. (defcustom smiley-regexp-alist - '(("\\(;-?)\\)\\W" 1 "blink") + '(("\\(;-)\\)\\W" 1 "blink") + ("[^;]\\(;)\\)\\W" 1 "blink") ("\\(:-]\\)\\W" 1 "forced") ("\\(8-)\\)\\W" 1 "braindamaged") ("\\(:-|\\)\\W" 1 "indifferent") @@ -119,6 +120,7 @@ The elements are (REGEXP MATCH IMAGE), where MATCH is the submatch in regexp to replace with IMAGE. IMAGE is the name of an image file in `smiley-data-directory'." + :version "24.1" :type '(repeat (list regexp (integer :tag "Regexp match number") (string :tag "Image name"))) @@ -226,5 +228,4 @@ (provide 'smiley) -;; arch-tag: 5beb161b-4321-40af-8ac9-876afb8ee818 ;;; smiley.el ends here
--- a/lisp/gnus/smime.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/smime.el Wed Sep 08 12:55:57 2010 +0900 @@ -729,5 +729,4 @@ (provide 'smime) -;; arch-tag: e3f9b938-5085-4510-8a11-6625269c9a9e ;;; smime.el ends here
--- a/lisp/gnus/spam-report.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/spam-report.el Wed Sep 08 12:55:57 2010 +0900 @@ -95,12 +95,12 @@ "Report an article as spam by resending via email. Reports is as ham when HAM is set." (dolist (article articles) - (gnus-message 6 + (gnus-message 6 "Reporting %s article %d to <%s>..." (if ham "ham" "spam") article spam-report-resend-to) (unless spam-report-resend-to - (customize-set-variable + (customize-set-variable spam-report-resend-to (read-from-minibuffer "email address to resend SPAM/HAM to? "))) ;; This is ganked from the `gnus-summary-resend-message' function. @@ -267,7 +267,7 @@ (gnus-message 7 "Waiting for response from %s..." host) (while (and (memq (process-status tcp-connection) '(open run)) (zerop (buffer-size))) - (accept-process-output tcp-connection)) + (accept-process-output tcp-connection 1)) (gnus-message 7 "Waiting for response from %s... done" host))))) ;;;###autoload @@ -385,5 +385,4 @@ (provide 'spam-report) -;; arch-tag: f6683295-ec89-4ab5-8803-8cc842293022 ;;; spam-report.el ends here.
--- a/lisp/gnus/spam-stat.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/spam-stat.el Wed Sep 08 12:55:57 2010 +0900 @@ -674,5 +674,4 @@ (provide 'spam-stat) -;; arch-tag: ff1d2200-8ddb-42fb-bb7b-1b5e20448554 ;;; spam-stat.el ends here
--- a/lisp/gnus/spam-wash.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/spam-wash.el Wed Sep 08 12:55:57 2010 +0900 @@ -69,5 +69,4 @@ (provide 'spam-wash) -;; arch-tag: 3c7f94a7-c96d-4c77-bb59-950df12bc85f ;;; spam-wash.el ends here
--- a/lisp/gnus/spam.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/spam.el Wed Sep 08 12:55:57 2010 +0900 @@ -2941,5 +2941,4 @@ (provide 'spam) -;; arch-tag: 07e6e0ca-ab0a-4412-b445-1f6c72a4f27f ;;; spam.el ends here
--- a/lisp/gnus/starttls.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/starttls.el Wed Sep 08 12:55:57 2010 +0900 @@ -311,5 +311,4 @@ (provide 'starttls) -;; arch-tag: 648b3bd8-63bd-47f5-904c-7c819aea2297 ;;; starttls.el ends here
--- a/lisp/gnus/utf7.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/utf7.el Wed Sep 08 12:55:57 2010 +0900 @@ -228,5 +228,4 @@ (provide 'utf7) -;; arch-tag: 96078b55-85c7-4161-aed2-932c24b282c7 ;;; utf7.el ends here
--- a/lisp/gnus/webmail.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/webmail.el Wed Sep 08 12:55:57 2010 +0900 @@ -1148,5 +1148,4 @@ (provide 'webmail) -;; arch-tag: f75a4558-a8f6-46ec-b1c3-7a6434b3dd71 ;;; webmail.el ends here
--- a/lisp/gnus/yenc.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/gnus/yenc.el Wed Sep 08 12:55:57 2010 +0900 @@ -136,5 +136,4 @@ (provide 'yenc) -;; arch-tag: 74df17e8-6fa8-4071-9f7d-54d548d79d9a ;;; yenc.el ends here
--- a/lisp/hex-util.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/hex-util.el Wed Sep 08 12:55:57 2010 +0900 @@ -69,5 +69,4 @@ (provide 'hex-util) -;; arch-tag: fe8aaa79-6c86-400e-813f-5a8cc4cb3859 ;;; hex-util.el ends here
--- a/lisp/hfy-cmap.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/hfy-cmap.el Wed Sep 08 12:55:57 2010 +0900 @@ -13,6 +13,7 @@ ;; Description: fallback code for colour name -> rgb mapping ;; URL: http://rtfm.etla.org/emacs/htmlfontify/ ;; Last-Updated: Sat 2003-02-15 03:49:32 +0000 +;; Package: htmlfontify ;; This file is part of GNU Emacs.
--- a/lisp/htmlfontify.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/htmlfontify.el Wed Sep 08 12:55:57 2010 +0900 @@ -2349,7 +2349,7 @@ ;;;### (autoloads (hfy-fallback-colour-values htmlfontify-load-rgb-file) -;;;;;; "hfy-cmap" "hfy-cmap.el" "3de2db2d213813bb3afe170ffd66cdde") +;;;;;; "hfy-cmap" "hfy-cmap.el" "7e622e4b131ea5efbe9d258f719822d6") ;;; Generated autoloads from hfy-cmap.el (autoload 'htmlfontify-load-rgb-file "hfy-cmap" "\
--- a/lisp/international/mule-cmds.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/international/mule-cmds.el Wed Sep 08 12:55:57 2010 +0900 @@ -1952,7 +1952,7 @@ (> (aref (number-to-string (nth 2 (x-server-version))) 0) ?3)) ;; Make non-line-break space display as a plain space. - (aset standard-display-table 160 [32])) + (aset standard-display-table (unibyte-char-to-multibyte 160) [32])) ;; Most Windows programs send out apostrophes as \222. Most X fonts ;; don't contain a character at that position. Map it to the ASCII ;; apostrophe. [This is actually RIGHT SINGLE QUOTATION MARK, @@ -1960,7 +1960,7 @@ ;; fonts probably have the appropriate glyph at this position, ;; so they could use standard-display-8bit. It's better to use a ;; proper windows-1252 coding system. --fx] - (aset standard-display-table 146 [39])))) + (aset standard-display-table (unibyte-char-to-multibyte 146) [39])))) (defun set-language-environment-coding-systems (language-name) "Do various coding system setups for language environment LANGUAGE-NAME."
--- a/lisp/international/mule.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/international/mule.el Wed Sep 08 12:55:57 2010 +0900 @@ -2297,13 +2297,12 @@ (setq table val))) (translate-region-internal start end table)) -(put 'with-category-table 'lisp-indent-function 1) - (defmacro with-category-table (table &rest body) "Execute BODY like `progn' with TABLE the current category table. The category table of the current buffer is saved, BODY is evaluated, then the saved table is restored, even in case of an abnormal exit. Value is what BODY returns." + (declare (indent 1) (debug t)) (let ((old-table (make-symbol "old-table")) (old-buffer (make-symbol "old-buffer"))) `(let ((,old-table (category-table))
--- a/lisp/jit-lock.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/jit-lock.el Wed Sep 08 12:55:57 2010 +0900 @@ -32,33 +32,13 @@ (eval-when-compile (require 'cl) - (defmacro with-buffer-unmodified (&rest body) - "Eval BODY, preserving the current buffer's modified state." - (declare (debug t)) - (let ((modified (make-symbol "modified"))) - `(let ((,modified (buffer-modified-p))) - (unwind-protect - (progn ,@body) - (unless ,modified - (restore-buffer-modified-p nil)))))) - (defmacro with-buffer-prepared-for-jit-lock (&rest body) "Execute BODY in current buffer, overriding several variables. Preserves the `buffer-modified-p' state of the current buffer." (declare (debug t)) - `(let ((buffer-undo-list t) - (inhibit-read-only t) - (inhibit-point-motion-hooks t) - (inhibit-modification-hooks t) - deactivate-mark - buffer-file-name - buffer-file-truename) - ;; Do reset the modification status from within the let, since - ;; otherwise set-buffer-modified-p may try to unlock the file. - (with-buffer-unmodified - ,@body)))) - - + `(let ((inhibit-point-motion-hooks t)) + (with-silent-modifications + ,@body)))) ;;; Customization.
--- a/lisp/jka-cmpr-hook.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/jka-cmpr-hook.el Wed Sep 08 12:55:57 2010 +0900 @@ -335,6 +335,7 @@ (defmacro with-auto-compression-mode (&rest body) "Evalute BODY with automatic file compression and uncompression enabled." + (declare (indent 0)) (let ((already-installed (make-symbol "already-installed"))) `(let ((,already-installed (jka-compr-installed-p))) (unwind-protect @@ -344,8 +345,6 @@ ,@body) (unless ,already-installed (jka-compr-uninstall)))))) -(put 'with-auto-compression-mode 'lisp-indent-function 0) - ;; This is what we need to know about jka-compr-handler ;; in order to decide when to call it.
--- a/lisp/mail/binhex.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/mail/binhex.el Wed Sep 08 12:55:57 2010 +0900 @@ -328,5 +328,4 @@ (provide 'binhex) -;; arch-tag: 8476badd-1e76-4f1d-a640-f9a38c72eed8 ;;; binhex.el ends here
--- a/lisp/mail/hashcash.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/mail/hashcash.el Wed Sep 08 12:55:57 2010 +0900 @@ -276,7 +276,7 @@ (unless buffer (setq buffer (current-buffer))) (let (entry) (while (setq entry (rassq buffer hashcash-process-alist)) - (accept-process-output (car entry))))) + (accept-process-output (car entry) 1)))) (defun hashcash-processes-running-p (buffer) "Return non-nil if hashcash processes in BUFFER are still running." @@ -375,4 +375,4 @@ (provide 'hashcash) -;; arch-tag: 0e7fe983-a124-4392-9788-0dbcbd2c4d62 +;;; hashcash.el ends here
--- a/lisp/mail/uudecode.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/mail/uudecode.el Wed Sep 08 12:55:57 2010 +0900 @@ -236,5 +236,4 @@ (provide 'uudecode) -;; arch-tag: e1f09ed5-62b4-4677-9f13-4e81c4fe8ce3 ;;; uudecode.el ends here
--- a/lisp/md4.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/md4.el Wed Sep 08 12:55:57 2010 +0900 @@ -225,5 +225,4 @@ (provide 'md4) -;; arch-tag: 99d706fe-089b-42ea-9507-67ae41091e6e ;;; md4.el ends here
--- a/lisp/menu-bar.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/menu-bar.el Wed Sep 08 12:55:57 2010 +0900 @@ -463,7 +463,7 @@ ;; Emacs compiled --without-x doesn't have ;; x-selection-exists-p. (and (fboundp 'x-selection-exists-p) - (x-selection-exists-p)) + (x-selection-exists-p 'CLIPBOARD)) kill-ring) (not buffer-read-only)) :help ,(purecopy "Paste (yank) text most recently cut/copied")))
--- a/lisp/mouse-sel.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/mouse-sel.el Wed Sep 08 12:55:57 2010 +0900 @@ -98,7 +98,7 @@ ;; ;; Selection/kill-ring interaction is retained ;; interprogram-cut-function = x-select-text -;; interprogram-paste-function = x-cut-buffer-or-selection-value +;; interprogram-paste-function = x-selection-value ;; ;; What you lose is the ability to select some text in ;; delete-selection-mode and yank over the top of it. @@ -299,7 +299,7 @@ SELECTION-THING-SYMBOL = name of variable where the current selection type for this selection should be stored.") -(declare-function x-select-text "term/x-win" (text &optional push)) +(declare-function x-select-text "term/x-win" (text)) (defvar mouse-sel-set-selection-function (if (eq mouse-sel-default-bindings 'interprogram-cut-paste) @@ -314,15 +314,15 @@ SELECTION, the name of the selection concerned, and VALUE, the text to store. -This sets the selection as well as the cut buffer for the older applications, -unless `mouse-sel-default-bindings' is `interprogram-cut-paste'.") +This sets the selection, unless `mouse-sel-default-bindings' +is `interprogram-cut-paste'.") -(declare-function x-cut-buffer-or-selection-value "term/x-win" ()) +(declare-function x-selection-value "term/x-win" ()) (defvar mouse-sel-get-selection-function (lambda (selection) (if (eq selection 'PRIMARY) - (or (x-cut-buffer-or-selection-value) + (or (x-selection-value) (bound-and-true-p x-last-selected-text) (bound-and-true-p x-last-selected-text-primary)) (x-get-selection selection)))
--- a/lisp/mouse.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/mouse.el Wed Sep 08 12:55:57 2010 +0900 @@ -43,7 +43,10 @@ :group 'mouse) (defcustom mouse-drag-copy-region nil - "If non-nil, mouse drag copies region to kill-ring." + "If non-nil, copy to kill-ring upon mouse adjustments of the region. + +This affects `mouse-save-then-kill' (\\[mouse-save-then-kill]) in +addition to mouse drags." :type 'boolean :version "24.1" :group 'mouse) @@ -1348,8 +1351,13 @@ have selected whole words or lines, move point or mark to the word or line boundary closest to CLICK instead. +If `mouse-drag-copy-region' is non-nil, this command also saves the +new region to the kill ring (replacing the previous kill if the +previous region was just saved to the kill ring). + If this command is called a second consecutive time with the same -CLICK position, kill the region." +CLICK position, kill the region (or delete it +if `mouse-drag-copy-region' is non-nil)" (interactive "e") (mouse-minibuffer-check click) (let* ((posn (event-start click)) @@ -1371,7 +1379,11 @@ ((and (eq last-command 'mouse-save-then-kill) (eq click-pt mouse-save-then-kill-posn) (eq window (selected-window))) - (kill-region (mark t) (point)) + (if mouse-drag-copy-region + ;; Region already saved in the previous click; + ;; don't make a duplicate entry, just delete. + (delete-region (mark t) (point)) + (kill-region (mark t) (point))) (setq mouse-selection-click-count 0) (setq mouse-save-then-kill-posn nil)) @@ -1394,6 +1406,9 @@ (goto-char (nth 1 range))) (setq deactivate-mark nil) (mouse-set-region-1) + (when mouse-drag-copy-region + ;; Region already copied to kill-ring once, so replace. + (kill-new (filter-buffer-substring (mark t) (point)) t)) ;; Arrange for a repeated mouse-3 to kill the region. (setq mouse-save-then-kill-posn click-pt))) @@ -1405,6 +1420,8 @@ (if before-scroll (goto-char before-scroll))) (exchange-point-and-mark) (mouse-set-region-1) + (when mouse-drag-copy-region + (kill-new (filter-buffer-substring (mark t) (point)))) (setq mouse-save-then-kill-posn click-pt)))))
--- a/lisp/net/dbus.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/net/dbus.el Wed Sep 08 12:55:57 2010 +0900 @@ -92,12 +92,10 @@ (defmacro dbus-ignore-errors (&rest body) "Execute BODY; signal D-Bus error when `dbus-debug' is non-nil. Otherwise, return result of last form in BODY, or all other errors." + (declare (indent 0) (debug t)) `(condition-case err (progn ,@body) (dbus-error (when dbus-debug (signal (car err) (cdr err)))))) - -(put 'dbus-ignore-errors 'lisp-indent-function 0) -(put 'dbus-ignore-errors 'edebug-form-spec '(form body)) (font-lock-add-keywords 'emacs-lisp-mode '("\\<dbus-ignore-errors\\>")) (defvar dbus-event-error-hooks nil
--- a/lisp/net/dig.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/net/dig.el Wed Sep 08 12:55:57 2010 +0900 @@ -184,5 +184,4 @@ (provide 'dig) -;; arch-tag: 1d61726e-9400-4013-9ae7-4035e0c7f7d6 ;;; dig.el ends here
--- a/lisp/net/dns.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/net/dns.el Wed Sep 08 12:55:57 2010 +0900 @@ -151,7 +151,7 @@ (lsh (if (dns-get 'truncated-p spec) 1 0) -1) (lsh (if (dns-get 'recursion-desired-p spec) 1 0) 0))) (dns-write-bytes - (cond + (cond ((eq (dns-get 'response-code spec) 'no-error) 0) ((eq (dns-get 'response-code spec) 'format-error) 1) ((eq (dns-get 'response-code spec) 'server-failure) 2) @@ -438,5 +438,4 @@ (provide 'dns) -;; arch-tag: d0edd0c4-4cce-4538-ae92-06c3356ee80a ;;; dns.el ends here
--- a/lisp/net/hmac-def.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/net/hmac-def.el Wed Sep 08 12:55:57 2010 +0900 @@ -80,5 +80,4 @@ (provide 'hmac-def) -;; arch-tag: 645adcef-b835-4900-a10a-11f636c982b9 ;;; hmac-def.el ends here
--- a/lisp/net/hmac-md5.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/net/hmac-md5.el Wed Sep 08 12:55:57 2010 +0900 @@ -79,5 +79,4 @@ (provide 'hmac-md5) -;; arch-tag: 0ab3f4f6-3d4b-4167-a9fa-635b7fed7f27 ;;; hmac-md5.el ends here
--- a/lisp/net/imap.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/net/imap.el Wed Sep 08 12:55:57 2010 +0900 @@ -267,7 +267,7 @@ :type 'string) (defcustom imap-read-timeout (if (string-match - "windows-nt\\|os/2\\|emx\\|cygwin" + "windows-nt\\|os/2\\|cygwin" (symbol-name system-type)) 1.0 0.1) @@ -448,18 +448,6 @@ The function should take two arguments, the first the IMAP tag and the second the status (OK, NO, BAD etc) of the command.") -(defvar imap-enable-exchange-bug-workaround nil - "Send FETCH UID commands as *:* instead of *. - -When non-nil, use an alternative UIDS form. Enabling appears to -be required for some servers (e.g., Microsoft Exchange 2007) -which otherwise would trigger a response 'BAD The specified -message set is invalid.'. We don't unconditionally use this -form, since this is said to be significantly inefficient. - -This variable is set to t automatically per server if the -canonical form fails.") - ;; Utility functions: @@ -515,6 +503,16 @@ ;; Server functions; stream stuff: +(defun imap-log (string-or-buffer) + (when imap-log + (with-current-buffer (get-buffer-create imap-log-buffer) + (imap-disable-multibyte) + (buffer-disable-undo) + (goto-char (point-max)) + (if (bufferp string-or-buffer) + (insert-buffer-substring string-or-buffer) + (insert string-or-buffer))))) + (defun imap-kerberos4-stream-p (buffer) (imap-capability 'AUTH=KERBEROS_V4 buffer)) @@ -569,12 +567,6 @@ (setq response (match-string 1))))) (accept-process-output process 1) (sit-for 1)) - (and imap-log - (with-current-buffer (get-buffer-create imap-log-buffer) - (imap-disable-multibyte) - (buffer-disable-undo) - (goto-char (point-max)) - (insert-buffer-substring buffer))) (erase-buffer) (message "Opening Kerberos 4 IMAP connection with `%s'...%s" cmd (if response (concat "done, " response) "failed")) @@ -645,12 +637,7 @@ (setq response (match-string 1))))) (accept-process-output process 1) (sit-for 1)) - (and imap-log - (with-current-buffer (get-buffer-create imap-log-buffer) - (imap-disable-multibyte) - (buffer-disable-undo) - (goto-char (point-max)) - (insert-buffer-substring buffer))) + (imap-log buffer) (erase-buffer) (message "GSSAPI IMAP connection: %s" (or response "failed")) (if (and response (let ((case-fold-search nil)) @@ -701,12 +688,7 @@ (not (imap-parse-greeting))) (accept-process-output process 1) (sit-for 1)) - (and imap-log - (with-current-buffer (get-buffer-create imap-log-buffer) - (imap-disable-multibyte) - (buffer-disable-undo) - (goto-char (point-max)) - (insert-buffer-substring buffer))) + (imap-log buffer) (erase-buffer) (when (memq (process-status process) '(open run)) (setq done process)))))) @@ -740,12 +722,7 @@ (not (imap-parse-greeting))) (accept-process-output process 1) (sit-for 1)) - (and imap-log - (with-current-buffer (get-buffer-create imap-log-buffer) - (imap-disable-multibyte) - (buffer-disable-undo) - (goto-char (point-max)) - (insert-buffer-substring buffer))) + (imap-log buffer) (when (memq (process-status process) '(open run)) process)))) @@ -764,12 +741,7 @@ (not (imap-parse-greeting))) (accept-process-output process 1) (sit-for 1)) - (and imap-log - (with-current-buffer (get-buffer-create imap-log-buffer) - (imap-disable-multibyte) - (buffer-disable-undo) - (goto-char (point-max)) - (insert-buffer-substring buffer))) + (imap-log buffer) (when (memq (process-status process) '(open run)) process)))) @@ -803,12 +775,7 @@ (not (imap-parse-greeting))) (accept-process-output process 1) (sit-for 1)) - (and imap-log - (with-current-buffer (get-buffer-create imap-log-buffer) - (imap-disable-multibyte) - (buffer-disable-undo) - (goto-char (point-max)) - (insert-buffer-substring buffer))) + (imap-log buffer) (erase-buffer) (when (memq (process-status process) '(open run)) (setq done process))))) @@ -845,11 +812,7 @@ (not (re-search-forward "[0-9]+ OK.*\r?\n" nil t))) (accept-process-output process 1) (sit-for 1)) - (and imap-log - (with-current-buffer (get-buffer-create imap-log-buffer) - (buffer-disable-undo) - (goto-char (point-max)) - (insert-buffer-substring buffer))) + (imap-log buffer) (when (and (setq tls-info (starttls-negotiate process)) (memq (process-status process) '(open run))) (setq done process))) @@ -1227,7 +1190,7 @@ (when user (setq imap-username user)) (when passwd (setq imap-password passwd)) (if imap-auth - (and (setq imap-last-authenticator + (and (setq imap-last-authenticator (assq imap-auth imap-authenticator-alist)) (funcall (nth 2 imap-last-authenticator) (current-buffer)) (setq imap-state 'auth)) @@ -1340,40 +1303,38 @@ ;; Mailbox functions: -(defun imap-mailbox-put (propname value &optional mailbox buffer) - (with-current-buffer (or buffer (current-buffer)) - (if imap-mailbox-data - (put (intern (or mailbox imap-current-mailbox) imap-mailbox-data) - propname value) - (error "Imap-mailbox-data is nil, prop %s value %s mailbox %s buffer %s" - propname value mailbox (current-buffer))) - t)) +(defun imap-mailbox-put (propname value &optional mailbox) + (if imap-mailbox-data + (put (intern (or mailbox imap-current-mailbox) imap-mailbox-data) + propname value) + (error "Imap-mailbox-data is nil, prop %s value %s mailbox %s buffer %s" + propname value mailbox (current-buffer))) + t) (defsubst imap-mailbox-get-1 (propname &optional mailbox) (get (intern-soft (or mailbox imap-current-mailbox) imap-mailbox-data) propname)) (defun imap-mailbox-get (propname &optional mailbox buffer) - (let ((mailbox (imap-utf7-encode mailbox))) - (with-current-buffer (or buffer (current-buffer)) - (imap-mailbox-get-1 propname (or mailbox imap-current-mailbox))))) + (with-current-buffer (or buffer (current-buffer)) + (imap-mailbox-get-1 propname (or (imap-utf7-encode mailbox) + imap-current-mailbox)))) -(defun imap-mailbox-map-1 (func &optional mailbox-decoder buffer) - (with-current-buffer (or buffer (current-buffer)) - (let (result) - (mapatoms - (lambda (s) - (push (funcall func (if mailbox-decoder - (funcall mailbox-decoder (symbol-name s)) - (symbol-name s))) result)) - imap-mailbox-data) - result))) +(defun imap-mailbox-map-1 (func &optional mailbox-decoder) + (let (result) + (mapatoms + (lambda (s) + (push (funcall func (if mailbox-decoder + (funcall mailbox-decoder (symbol-name s)) + (symbol-name s))) result)) + imap-mailbox-data) + result)) -(defun imap-mailbox-map (func &optional buffer) +(defun imap-mailbox-map (func) "Map a function across each mailbox in `imap-mailbox-data', returning a list. Function should take a mailbox name (a string) as the only argument." - (imap-mailbox-map-1 func 'imap-utf7-decode buffer)) + (imap-mailbox-map-1 func 'imap-utf7-decode)) (defun imap-current-mailbox (&optional buffer) (with-current-buffer (or buffer (current-buffer)) @@ -1687,29 +1648,26 @@ uids) (imap-message-get uids receive)))))) -(defun imap-message-put (uid propname value &optional buffer) - (with-current-buffer (or buffer (current-buffer)) - (if imap-message-data - (put (intern (number-to-string uid) imap-message-data) - propname value) - (error "Imap-message-data is nil, uid %s prop %s value %s buffer %s" - uid propname value (current-buffer))) - t)) +(defun imap-message-put (uid propname value) + (if imap-message-data + (put (intern (number-to-string uid) imap-message-data) + propname value) + (error "Imap-message-data is nil, uid %s prop %s value %s buffer %s" + uid propname value (current-buffer))) + t) -(defun imap-message-get (uid propname &optional buffer) - (with-current-buffer (or buffer (current-buffer)) - (get (intern-soft (number-to-string uid) imap-message-data) - propname))) +(defun imap-message-get (uid propname) + (get (intern-soft (number-to-string uid) imap-message-data) + propname)) -(defun imap-message-map (func propname &optional buffer) +(defun imap-message-map (func propname) "Map a function across each message in `imap-message-data', returning a list." - (with-current-buffer (or buffer (current-buffer)) - (let (result) - (mapatoms - (lambda (s) - (push (funcall func (get s 'UID) (get s propname)) result)) - imap-message-data) - result))) + (let (result) + (mapatoms + (lambda (s) + (push (funcall func (get s 'UID) (get s propname)) result)) + imap-message-data) + result)) (defmacro imap-message-envelope-date (uid &optional buffer) `(with-current-buffer (or ,buffer (current-buffer)) @@ -1805,48 +1763,6 @@ (format "String %s cannot be converted to a Lisp integer" number)) number))) -(defun imap-fetch-safe (uids props &optional receive nouidfetch buffer) - "Like `imap-fetch', but DTRT with Exchange 2007 bug. -However, UIDS here is a cons, where the car is the canonical form -of the UIDS specification, and the cdr is the one which works with -Exchange 2007 or, potentially, other buggy servers. -See `imap-enable-exchange-bug-workaround'." - ;; The first time we get here for a given, we'll try the canonical - ;; form. If we get the known error from the buggy server, set the - ;; flag buffer-locally (to account for connections to multiple - ;; servers), then re-try with the alternative UIDS spec. We don't - ;; unconditionally use the alternative form, since the - ;; currently-used alternatives are seriously inefficient with some - ;; servers (although they are valid). - ;; - ;; FIXME: Maybe it would be cleaner to have a flag to not signal - ;; the error (which otherwise gives a message), and test - ;; `imap-failed-tags'. Also, Other IMAP clients use other forms of - ;; request which work with Exchange, e.g. Claws does "UID FETCH 1:* - ;; (UID)" rather than "FETCH UID 1,*". Is there a good reason not - ;; to do the same? - (condition-case data - ;; Binding `debug-on-error' allows us to get the error from - ;; `imap-parse-response' -- it's normally caught by Emacs around - ;; execution of a process filter. - (let ((debug-on-error t)) - (imap-fetch (if imap-enable-exchange-bug-workaround - (cdr uids) - (car uids)) - props receive nouidfetch buffer)) - (error - (if (and (not imap-enable-exchange-bug-workaround) - ;; This is the Exchange 2007 response. It may be more - ;; robust just to check for a BAD response to the - ;; attempted fetch. - (string-match "The specified message set is invalid" - (cadr data))) - (with-current-buffer (or buffer (current-buffer)) - (set (make-local-variable 'imap-enable-exchange-bug-workaround) - t) - (imap-fetch (cdr uids) props receive nouidfetch)) - (signal (car data) (cdr data)))))) - (defun imap-message-copyuid-1 (mailbox) (if (imap-capability 'UIDPLUS) (list (nth 0 (imap-mailbox-get-1 'copyuid mailbox)) @@ -1856,7 +1772,7 @@ (imap-message-data (make-vector 2 0))) (when (imap-mailbox-examine-1 mailbox) (prog1 - (and (imap-fetch-safe '("*" . "*:*") "UID") + (and (imap-fetch "*:*" "UID") (list (imap-mailbox-get-1 'uidvalidity mailbox) (apply 'max (imap-message-map (lambda (uid prop) uid) 'UID)))) @@ -1902,7 +1818,7 @@ (imap-message-data (make-vector 2 0))) (when (imap-mailbox-examine-1 mailbox) (prog1 - (and (imap-fetch-safe '("*" . "*:*") "UID") + (and (imap-fetch "*:*" "UID") (list (imap-mailbox-get-1 'uidvalidity mailbox) (apply 'max (imap-message-map (lambda (uid prop) uid) 'UID)))) @@ -1959,12 +1875,7 @@ (defun imap-send-command-1 (cmdstr) (setq cmdstr (concat cmdstr imap-client-eol)) - (and imap-log - (with-current-buffer (get-buffer-create imap-log-buffer) - (imap-disable-multibyte) - (buffer-disable-undo) - (goto-char (point-max)) - (insert cmdstr))) + (imap-log cmdstr) (process-send-string imap-process cmdstr)) (defun imap-send-command (command &optional buffer) @@ -2002,13 +1913,7 @@ (stream imap-stream) (eol imap-client-eol)) (with-current-buffer cmd - (and imap-log - (with-current-buffer (get-buffer-create - imap-log-buffer) - (imap-disable-multibyte) - (buffer-disable-undo) - (goto-char (point-max)) - (insert-buffer-substring cmd))) + (imap-log cmd) (process-send-region process (point-min) (point-max))) (process-send-string process imap-client-eol)))) @@ -2084,12 +1989,7 @@ (with-current-buffer (process-buffer proc) (goto-char (point-max)) (insert string) - (and imap-log - (with-current-buffer (get-buffer-create imap-log-buffer) - (imap-disable-multibyte) - (buffer-disable-undo) - (goto-char (point-max)) - (insert string))) + (imap-log string) (let (end) (goto-char (point-min)) (while (setq end (imap-find-next-line)) @@ -2992,106 +2892,6 @@ (imap-forward) (nreverse body))))) -(when imap-debug ; (untrace-all) - (require 'trace) - (buffer-disable-undo (get-buffer-create imap-debug-buffer)) - (mapc (lambda (f) (trace-function-background f imap-debug-buffer)) - '( - imap-utf7-encode - imap-utf7-decode - imap-error-text - imap-kerberos4s-p - imap-kerberos4-open - imap-ssl-p - imap-ssl-open - imap-network-p - imap-network-open - imap-interactive-login - imap-kerberos4a-p - imap-kerberos4-auth - imap-cram-md5-p - imap-cram-md5-auth - imap-login-p - imap-login-auth - imap-anonymous-p - imap-anonymous-auth - imap-open-1 - imap-open - imap-opened - imap-ping-server - imap-authenticate - imap-close - imap-capability - imap-namespace - imap-send-command-wait - imap-mailbox-put - imap-mailbox-get - imap-mailbox-map-1 - imap-mailbox-map - imap-current-mailbox - imap-current-mailbox-p-1 - imap-current-mailbox-p - imap-mailbox-select-1 - imap-mailbox-select - imap-mailbox-examine-1 - imap-mailbox-examine - imap-mailbox-unselect - imap-mailbox-expunge - imap-mailbox-close - imap-mailbox-create-1 - imap-mailbox-create - imap-mailbox-delete - imap-mailbox-rename - imap-mailbox-lsub - imap-mailbox-list - imap-mailbox-subscribe - imap-mailbox-unsubscribe - imap-mailbox-status - imap-mailbox-acl-get - imap-mailbox-acl-set - imap-mailbox-acl-delete - imap-current-message - imap-list-to-message-set - imap-fetch-asynch - imap-fetch - imap-fetch-safe - imap-message-put - imap-message-get - imap-message-map - imap-search - imap-message-flag-permanent-p - imap-message-flags-set - imap-message-flags-del - imap-message-flags-add - imap-message-copyuid-1 - imap-message-copyuid - imap-message-copy - imap-message-appenduid-1 - imap-message-appenduid - imap-message-append - imap-body-lines - imap-envelope-from - imap-send-command-1 - imap-send-command - imap-wait-for-tag - imap-sentinel - imap-find-next-line - imap-arrival-filter - imap-parse-greeting - imap-parse-response - imap-parse-resp-text - imap-parse-resp-text-code - imap-parse-data-list - imap-parse-fetch - imap-parse-status - imap-parse-acl - imap-parse-flag-list - imap-parse-envelope - imap-parse-body-extension - imap-parse-body - ))) - (provide 'imap) -;; arch-tag: 27369ed6-33e4-482f-96f1-8bb906ba70f7 ;;; imap.el ends here
--- a/lisp/net/netrc.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/net/netrc.el Wed Sep 08 12:55:57 2010 +0900 @@ -160,9 +160,9 @@ (defaults (or defaults '(nil))) info) (if (listp mode) - (setq info - (mapcar - (lambda (mode-element) + (setq info + (mapcar + (lambda (mode-element) (netrc-machine-user-or-password mode-element authinfo-list @@ -223,5 +223,4 @@ (provide 'netrc) -;; arch-tag: af9929cc-2d12-482f-936e-eb4366f9fa55 ;;; netrc.el ends here
--- a/lisp/net/ntlm.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/net/ntlm.el Wed Sep 08 12:55:57 2010 +0900 @@ -27,9 +27,9 @@ ;; This library is a direct translation of the Samba release 2.2.0 ;; implementation of Windows NT and LanManager compatible password ;; encryption. -;; +;; ;; Interface functions: -;; +;; ;; ntlm-build-auth-request ;; This will return a binary string, which should be used in the ;; base64 encoded form and it is the caller's responsibility to encode @@ -40,7 +40,7 @@ ;; (which will be a binary string) as the first argument and to ;; encode the returned string with base64. The second argument user ;; should be given in user@domain format. -;; +;; ;; ntlm-get-password-hashes ;; ;; @@ -534,5 +534,4 @@ (provide 'ntlm) -;; arch-tag: 348ace18-f8e2-4176-8fe9-d9ab4e96f296 ;;; ntlm.el ends here
--- a/lisp/net/rcirc.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/net/rcirc.el Wed Sep 08 12:55:57 2010 +0900 @@ -1085,7 +1085,7 @@ (goto-char (point-max)) (when (not (equal 0 (- (point) rcirc-prompt-end-marker))) ;; delete a trailing newline - (when (bolp) + (when (eq (point) (point-at-bol)) (delete-char -1)) (let ((input (buffer-substring-no-properties rcirc-prompt-end-marker (point)))) @@ -2151,12 +2151,13 @@ (rcirc-send-string process (format "PRIVMSG %s :\C-aACTION %s\C-a" target args))) -(defun rcirc-add-or-remove (set &optional elt) - (if (and elt (not (string= "" elt))) - (if (member-ignore-case elt set) - (delete elt set) - (cons elt set)) - set)) +(defun rcirc-add-or-remove (set &rest elements) + (dolist (elt elements) + (if (and elt (not (string= "" elt))) + (setq set (if (member-ignore-case elt set) + (delete elt set) + (cons elt set))))) + set) (defun-rcirc-command ignore (nick) "Manage the ignore list. @@ -2164,7 +2165,9 @@ nicks when no NICK is given. When listing ignored nicks, the ones added to the list automatically are marked with an asterisk." (interactive "sToggle ignoring of nick: ") - (setq rcirc-ignore-list (rcirc-add-or-remove rcirc-ignore-list nick)) + (setq rcirc-ignore-list + (apply #'rcirc-add-or-remove rcirc-ignore-list + (split-string nick nil t))) (rcirc-print process nil "IGNORE" target (mapconcat (lambda (nick) @@ -2176,14 +2179,18 @@ (defun-rcirc-command bright (nick) "Manage the bright nick list." (interactive "sToggle emphasis of nick: ") - (setq rcirc-bright-nicks (rcirc-add-or-remove rcirc-bright-nicks nick)) + (setq rcirc-bright-nicks + (apply #'rcirc-add-or-remove rcirc-bright-nicks + (split-string nick nil t))) (rcirc-print process nil "BRIGHT" target (mapconcat 'identity rcirc-bright-nicks " "))) (defun-rcirc-command dim (nick) "Manage the dim nick list." (interactive "sToggle deemphasis of nick: ") - (setq rcirc-dim-nicks (rcirc-add-or-remove rcirc-dim-nicks nick)) + (setq rcirc-dim-nicks + (apply #'rcirc-add-or-remove rcirc-dim-nicks + (split-string nick nil t))) (rcirc-print process nil "DIM" target (mapconcat 'identity rcirc-dim-nicks " "))) @@ -2192,7 +2199,9 @@ Mark KEYWORD, unmark KEYWORD if already marked, or list marked keywords when no KEYWORD is given." (interactive "sToggle highlighting of keyword: ") - (setq rcirc-keywords (rcirc-add-or-remove rcirc-keywords keyword)) + (setq rcirc-keywords + (apply #'rcirc-add-or-remove rcirc-keywords + (split-string keyword nil t))) (rcirc-print process nil "KEYWORD" target (mapconcat 'identity rcirc-keywords " ")))
--- a/lisp/net/sasl-cram.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/net/sasl-cram.el Wed Sep 08 12:55:57 2010 +0900 @@ -47,5 +47,4 @@ (provide 'sasl-cram) -;; arch-tag: 46cb281b-975a-4fe0-a39f-3018691b1b05 ;;; sasl-cram.el ends here
--- a/lisp/net/sasl-digest.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/net/sasl-digest.el Wed Sep 08 12:55:57 2010 +0900 @@ -95,10 +95,10 @@ (md5-binary (concat (encode-hex-string - (md5-binary (concat (md5-binary + (md5-binary (concat (md5-binary (concat username ":" realm ":" passphrase)) ":" nonce ":" cnonce - (if authzid + (if authzid (concat ":" authzid))))) ":" nonce ":" (format "%08x" nonce-count) ":" cnonce ":" qop ":" @@ -154,5 +154,4 @@ (provide 'sasl-digest) -;; arch-tag: 786e02ed-1bc4-4b3c-bf34-96c27e31084d ;;; sasl-digest.el ends here
--- a/lisp/net/sasl-ntlm.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/net/sasl-ntlm.el Wed Sep 08 12:55:57 2010 +0900 @@ -63,5 +63,4 @@ (provide 'sasl-ntlm) -;; arch-tag: 1d9164c1-1df0-418f-b7ab-360157fd05dc ;;; sasl-ntlm.el ends here
--- a/lisp/net/sasl.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/net/sasl.el Wed Sep 08 12:55:57 2010 +0900 @@ -267,5 +267,4 @@ (provide 'sasl) -;; arch-tag: 8b3326fa-4978-4fda-93e2-cb2c6255f887 ;;; sasl.el ends here
--- a/lisp/net/tls.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/net/tls.el Wed Sep 08 12:55:57 2010 +0900 @@ -298,5 +298,4 @@ (provide 'tls) -;; arch-tag: 5596d1c4-facc-4bc4-94a9-9863b928d7ac ;;; tls.el ends here
--- a/lisp/password-cache.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/password-cache.el Wed Sep 08 12:55:57 2010 +0900 @@ -134,5 +134,4 @@ (provide 'password-cache) -;; arch-tag: ab160494-16c8-4c68-a4a1-73eebf6686e5 ;;; password-cache.el ends here
--- a/lisp/pgg-def.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/pgg-def.el Wed Sep 08 12:55:57 2010 +0900 @@ -95,5 +95,4 @@ (provide 'pgg-def) -;; arch-tag: c425f3ab-ed75-4055-bb46-431a418c94b7 ;;; pgg-def.el ends here
--- a/lisp/pgg-gpg.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/pgg-gpg.el Wed Sep 08 12:55:57 2010 +0900 @@ -407,5 +407,4 @@ (provide 'pgg-gpg) -;; arch-tag: 2aa5d5d8-93a0-4865-9312-33e29830e000 ;;; pgg-gpg.el ends here
--- a/lisp/pgg-parse.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/pgg-parse.el Wed Sep 08 12:55:57 2010 +0900 @@ -519,5 +519,4 @@ (provide 'pgg-parse) -;; arch-tag: 16c2eb82-1313-4a7c-a70f-420709b5b43e ;;; pgg-parse.el ends here
--- a/lisp/pgg-pgp.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/pgg-pgp.el Wed Sep 08 12:55:57 2010 +0900 @@ -254,5 +254,4 @@ (provide 'pgg-pgp) -;; arch-tag: 076b7801-37b2-49a6-97c3-218fdecde33c ;;; pgg-pgp.el ends here
--- a/lisp/pgg-pgp5.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/pgg-pgp5.el Wed Sep 08 12:55:57 2010 +0900 @@ -255,5 +255,4 @@ (provide 'pgg-pgp5) -;; arch-tag: 3dbd1073-6b3a-466c-9f55-5c587ffa6d7b ;;; pgg-pgp5.el ends here
--- a/lisp/pgg.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/pgg.el Wed Sep 08 12:55:57 2010 +0900 @@ -602,5 +602,4 @@ (provide 'pgg) -;; arch-tag: 9cc705dd-1e6a-4c90-8dce-c3561f9a2cf4 ;;; pgg.el ends here
--- a/lisp/play/cookie1.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/play/cookie1.el Wed Sep 08 12:55:57 2010 +0900 @@ -138,7 +138,7 @@ (vec (cookie-snarf phrase-file startmsg endmsg)) (i (length vec))) - (while (> (setq i (1- i)) 0) + (while (>= (setq i (1- i)) 0) (setq alist (cons (list (aref vec i)) alist))) (put sym 'completion-alist alist)))) nil require-match nil nil))
--- a/lisp/proced.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/proced.el Wed Sep 08 12:55:57 2010 +0900 @@ -2,7 +2,7 @@ ;; Copyright (C) 2008, 2009, 2010 Free Software Foundation, Inc. -;; Author: Roland Winkler <Roland.Winkler@physik.uni-erlangen.de> +;; Author: Roland Winkler <winkler@gnu.org> ;; Keywords: Processes, Unix ;; This file is part of GNU Emacs.
--- a/lisp/progmodes/compile.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/progmodes/compile.el Wed Sep 08 12:55:57 2010 +0900 @@ -227,10 +227,6 @@ "^[-[:alnum:]_/ ]+: \\(?:\\(?:[sS]evere\\|[eE]rror\\|[wW]arnin\\(g\\)\\|[iI]nf\\(o\\)\\)[0-9 ]*: \\)?\ \\([^,\" \n\t]+\\)\\(?:, line\\|:\\) \\([0-9]+\\):" 3 4 nil (1 . 2)) - (ruby - "^[\t ]*\\(?:from \\)?\ -\\([^\(\n][^[:space:]\n]*\\):\\([1-9][0-9]*\\)\\(:in `.*'\\)?.*$" 1 2) - (java "^\\(?:[ \t]+at \\|==[0-9]+== +\\(?:at\\|b\\(y\\)\\)\\).+(\\([^()\n]+\\):\\([0-9]+\\))$" 2 3 nil (1)) @@ -241,6 +237,10 @@ nil 1 nil 2 0 (2 (compilation-face '(3)))) + (gcc-include + "^\\(?:In file included \\| \\|\t\\)from \ +\\(.+\\):\\([0-9]+\\)\\(?:\\(:\\)\\|\\(,\\|$\\)\\)?" 1 2 nil (3 . 4)) + (gnu ;; The first line matches the program name for @@ -264,7 +264,7 @@ ;; can be composed of any non-newline char, but it also rules out some ;; valid but unlikely cases, such as a trailing space or a space ;; followed by a -. - "^\\(?:[[:alpha:]][-[:alnum:].]+: ?\\)?\ + "^\\(?:[[:alpha:]][-[:alnum:].]+: ?\\|[ \t]+\\(?:in \\|from \\)\\)?\ \\([0-9]*[^0-9\n]\\(?:[^\n ]\\| [^-/\n]\\)*?\\): ?\ \\([0-9]+\\)\\(?:\\([.:]\\)\\([0-9]+\\)\\)?\ \\(?:-\\([0-9]+\\)?\\(?:\\.\\([0-9]+\\)\\)?\\)?:\ @@ -273,12 +273,6 @@ \[0-9]?\\(?:[^0-9\n]\\|$\\)\\|[0-9][0-9][0-9]\\)" 1 (2 . 5) (4 . 6) (7 . 8)) - ;; The `gnu' style above can incorrectly match gcc's "In file - ;; included from" message, so we process that first. -- cyd - (gcc-include - "^\\(?:In file included\\| \\) from \ -\\(.+\\):\\([0-9]+\\)\\(?:\\(:\\)\\|\\(,\\)\\)?" 1 2 nil (3 . 4)) - (lcc "^\\(?:E\\|\\(W\\)\\), \\([^(\n]+\\)(\\([0-9]+\\),[ \t]*\\([0-9]+\\)" 2 3 4 (1))
--- a/lisp/progmodes/octave-mod.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/progmodes/octave-mod.el Wed Sep 08 12:55:57 2010 +0900 @@ -161,8 +161,8 @@ (list ;; Fontify all builtin keywords. (cons (concat "\\<\\(" - (mapconcat 'identity octave-reserved-words "\\|") - (mapconcat 'identity octave-text-functions "\\|") + (regexp-opt (append octave-reserved-words + octave-text-functions)) "\\)\\>") 'font-lock-keyword-face) ;; Fontify all builtin operators. @@ -193,10 +193,19 @@ ((eq (nth 3 state) ?\') ;; A '..' string. (save-excursion - (when (and (or (looking-at "\\('\\)") - (re-search-forward "[^\\]\\(?:\\\\\\\\\\)*\\('\\)" - nil t)) - (not (eobp))) + (when (re-search-forward "\\(?:\\=\\|[^']\\)\\(?:''\\)*\\('\\)[^']" + nil t) + (goto-char (1- (point))) + ;; Remove any syntax-table property we may have applied to + ;; some of the (doubled) single quotes within the string. + ;; Since these are the only chars on which we place properties, + ;; we take a shortcut and just remove all properties. + (remove-text-properties (1+ (nth 8 state)) (match-beginning 1) + '(syntax-table nil)) + (when (eq (char-before (match-beginning 1)) ?\\) + ;; Backslash cannot escape a single quote. + (put-text-property (1- (match-beginning 1)) (match-beginning 1) + 'syntax-table (string-to-syntax "."))) (put-text-property (match-beginning 1) (match-end 1) 'syntax-table (string-to-syntax "\"'")))))) @@ -223,13 +232,10 @@ (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-n" 'octave-forward-block) - (define-key map "\C-c\M-\C-p" 'octave-backward-block) - (define-key map "\C-c\M-\C-u" 'octave-backward-up-block) - (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]" 'octave-close-block) - (define-key map "\C-c/" 'octave-close-block) + (define-key map "\C-c]" 'smie-close-block) + (define-key map "\C-c/" 'smie-close-block) (define-key map "\C-c\C-f" 'octave-insert-defun) (define-key map "\C-c\C-h" 'octave-help) (define-key map "\C-c\C-il" 'octave-send-line) @@ -261,12 +267,8 @@ ["End of Continuation" octave-end-of-line t] ["Split Line at Point" octave-indent-new-comment-line t]) ("Blocks" - ["Next Block" octave-forward-block t] - ["Previous Block" octave-backward-block t] - ["Down Block" octave-down-block t] - ["Up Block" octave-backward-up-block t] ["Mark Block" octave-mark-block t] - ["Close Block" octave-close-block t]) + ["Close Block" smie-close-block t]) ("Functions" ["Indent Function" octave-indent-defun t] ["Insert Function" octave-insert-defun t]) @@ -349,35 +351,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 "\\|") - "\\)\\>")) -(defvar octave-block-end-regexp - (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 - '(("do" . ("until")) - ("for" . ("end" "endfor")) - ("function" . ("end" "endfunction")) - ("if" . ("else" "elseif" "end" "endif")) - ("switch" . ("case" "otherwise" "end" "endswitch")) - ("try" . ("catch" "end" "end_try_catch")) - ("unwind_protect" . ("unwind_protect_cleanup" "end" "end_unwind_protect")) - ("while" . ("end" "endwhile"))) - "Alist with Octave's matching block keywords. -Has Octave's begin keywords as keys and a list of the matching else or -end keywords as associated values.") - (defvar octave-block-comment-start (concat (make-string 2 octave-comment-char) " ") "String to insert to start a new Octave comment on an empty line.") @@ -386,8 +359,11 @@ "Extra indentation applied to Octave continuation lines." :type 'integer :group 'octave) +(eval-and-compile + (defconst octave-continuation-marker-regexp "\\\\\\|\\.\\.\\.")) (defvar octave-continuation-regexp - "[^#%\n]*\\(\\\\\\|\\.\\.\\.\\)\\s-*\\(\\s<.*\\)?$") + (concat "[^#%\n]*\\(" octave-continuation-marker-regexp + "\\)\\s-*\\(\\s<.*\\)?$")) (defcustom octave-continuation-string "\\" "Character string used for Octave continuation lines. Normally \\." :type 'string @@ -425,6 +401,149 @@ :group 'octave) +;;; SMIE indentation + +(require 'smie) + +(defconst octave-operator-table + '((assoc ";" "\n") (assoc ",") ; The doc claims they have equal precedence!? + (right "=" "+=" "-=" "*=" "/=") + (assoc "&&") (assoc "||") ; The doc claims they have equal precedence!? + (assoc "&") (assoc "|") ; The doc claims they have equal precedence!? + (nonassoc "<" "<=" "==" ">=" ">" "!=" "~=") + (nonassoc ":") ;No idea what this is. + (assoc "+" "-") + (assoc "*" "/" "\\" ".\\" ".*" "./") + (nonassoc "'" ".'") + (nonassoc "++" "--" "!" "~") ;And unary "+" and "-". + (right "^" "**" ".^" ".**") + ;; It's not really an operator, but for indentation purposes it + ;; could be convenient to treat it as one. + (assoc "..."))) + +(defconst octave-smie-bnf-table + '((atom) + ;; We can't distinguish the first element in a sequence with + ;; precedence grammars, so we can't distinguish the condition + ;; if the `if' from the subsequent body, for example. + ;; This has to be done later in the indentation rules. + (exp (exp "\n" exp) + ;; We need to mention at least one of the operators in this part + ;; of the grammar: if the BNF and the operator table have + ;; no overlap, SMIE can't know how they relate. + (exp ";" exp) + ("try" exp "catch" exp "end_try_catch") + ("try" exp "catch" exp "end") + ("unwind_protect" exp + "unwind_protect_cleanup" exp "end_unwind_protect") + ("unwind_protect" exp "unwind_protect_cleanup" exp "end") + ("for" exp "endfor") + ("for" exp "end") + ("do" exp "until" atom) + ("while" exp "endwhile") + ("while" exp "end") + ("if" exp "endif") + ("if" exp "else" exp "endif") + ("if" exp "elseif" exp "else" exp "endif") + ("if" exp "elseif" exp "elseif" exp "else" exp "endif") + ("if" exp "elseif" exp "elseif" exp "else" exp "end") + ("switch" exp "case" exp "endswitch") + ("switch" exp "case" exp "otherwise" exp "endswitch") + ("switch" exp "case" exp "case" exp "otherwise" exp "endswitch") + ("switch" exp "case" exp "case" exp "otherwise" exp "end") + ("function" exp "endfunction") + ("function" exp "end")) + ;; (fundesc (atom "=" atom)) + )) + +(defconst octave-smie-closer-alist + (smie-bnf-closer-alist octave-smie-bnf-table)) + +(defconst octave-smie-op-levels + (smie-prec2-levels + (smie-merge-prec2s + (smie-bnf-precedence-table + octave-smie-bnf-table + '((assoc "\n" ";"))) + + (smie-precs-precedence-table + (append octave-operator-table + '((nonassoc " -dummy- "))) ;Bogus anchor at the end. + )))) + +;; Tokenizing needs to be refined so that ";;" is treated as two +;; tokens and also so as to recognize the \n separator (and +;; corresponding continuation lines). + +(defconst octave-operator-regexp + (regexp-opt (apply 'append (mapcar 'cdr octave-operator-table)))) + +(defun octave-smie-backward-token () + (let ((pos (point))) + (forward-comment (- (point))) + (cond + ((and (not (eq (char-before) ?\;)) ;Coalesce ";" and "\n". + (> pos (line-end-position)) + (if (looking-back octave-continuation-marker-regexp (- (point) 3)) + (progn + (goto-char (match-beginning 0)) + (forward-comment (- (point))) + nil) + t) + ;; Ignore it if it's within parentheses. + (let ((ppss (syntax-ppss))) + (not (and (nth 1 ppss) + (eq ?\( (char-after (nth 1 ppss))))))) + (skip-chars-forward " \t") + ;; Why bother distinguishing \n and ;? + ";") ;;"\n" + ((and (looking-back octave-operator-regexp (- (point) 3) 'greedy) + ;; Don't mistake a string quote for a transpose. + (not (looking-back "\\s\"" (1- (point))))) + (goto-char (match-beginning 0)) + (match-string-no-properties 0)) + (t + (smie-default-backward-token))))) + +(defun octave-smie-forward-token () + (skip-chars-forward " \t") + (when (looking-at (eval-when-compile + (concat "\\(" octave-continuation-marker-regexp + "\\)[ \t]*\\($\\|[%#]\\)"))) + (goto-char (match-end 1)) + (forward-comment 1)) + (cond + ((and (looking-at "$\\|[%#]") + ;; Ignore it if it's within parentheses. + (prog1 (let ((ppss (syntax-ppss))) + (not (and (nth 1 ppss) + (eq ?\( (char-after (nth 1 ppss)))))) + (forward-comment (point-max)))) + ;; Why bother distinguishing \n and ;? + ";") ;;"\n" + ((looking-at ";[ \t]*\\($\\|[%#]\\)") + ;; Combine the ; with the subsequent \n. + (goto-char (match-beginning 1)) + (forward-comment 1) + ";") + ((and (looking-at octave-operator-regexp) + ;; Don't mistake a string quote for a transpose. + (not (looking-at "\\s\""))) + (goto-char (match-end 0)) + (match-string-no-properties 0)) + (t + (smie-default-forward-token)))) + +(defconst octave-smie-indent-rules + '((";" + (:parent ("function" "if" "while" "else" "elseif" "for" "otherwise" + "case" "try" "catch" "unwind_protect" "unwind_protect_cleanup") + ;; FIXME: don't hardcode 2. + (+ parent octave-block-offset)) + ;; (:parent "switch" 4) ;For (invalid) code between switch and case. + 0) + ((:before . "case") octave-block-offset))) + ;;;###autoload (define-derived-mode octave-mode prog-mode "Octave" "Major mode for editing Octave code. @@ -511,7 +630,36 @@ including a reproducible test case and send the message." (setq local-abbrev-table octave-abbrev-table) - (set (make-local-variable 'indent-line-function) 'octave-indent-line) + (smie-setup octave-smie-op-levels octave-smie-indent-rules) + (set (make-local-variable 'smie-indent-basic) 'octave-block-offset) + (set (make-local-variable 'smie-backward-token-function) + 'octave-smie-backward-token) + (set (make-local-variable 'smie-forward-token-function) + 'octave-smie-forward-token) + (set (make-local-variable 'forward-sexp-function) + 'smie-forward-sexp-command) + (set (make-local-variable 'smie-closer-alist) octave-smie-closer-alist) + ;; Only needed for interactive calls to blink-matching-open. + (set (make-local-variable 'blink-matching-check-function) + #'smie-blink-matching-check) + + (when octave-blink-matching-block + (add-hook 'post-self-insert-hook #'smie-blink-matching-open 'append 'local) + (set (make-local-variable 'smie-blink-matching-triggers) + (append smie-blink-matching-triggers '(\;) + ;; Rather than wait for SPC or ; to blink, try to blink as + ;; soon as we type the last char of a block ender. + ;; But strip ?d from this list so that we don't blink twice + ;; when the user writes "endif" (once at "end" and another + ;; time at "endif"). + (delq ?d (delete-dups + (mapcar (lambda (kw) + (aref (cdr kw) (1- (length (cdr kw))))) + smie-closer-alist)))))) + + ;; FIXME: maybe we should use (cons ?\; electric-indent-chars) + ;; since only ; is really octave-specific. + (set (make-local-variable 'electric-indent-chars) '(?\; ?\s ?\n)) (set (make-local-variable 'comment-start) octave-comment-start) (set (make-local-variable 'comment-end) "") @@ -579,36 +727,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 @@ -620,108 +744,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. @@ -823,177 +845,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")))) - -(defun octave-close-block () - "Close the current Octave block on a separate line. -An error is signaled if no block to close is found." - (interactive) - (let (bb-keyword) - (condition-case nil - (progn - (save-excursion - (octave-backward-up-block 1) - (setq bb-keyword (buffer-substring-no-properties - (match-beginning 1) (match-end 1)))) - (if (save-excursion - (beginning-of-line) - (looking-at "^\\s-*$")) - (indent-according-to-mode) - (octave-reindent-then-newline-and-indent)) - (insert (car (reverse - (assoc bb-keyword - octave-block-match-alist)))) - (octave-reindent-then-newline-and-indent) - t) - (error (message "No block to close found"))))) - -(defun octave-blink-matching-block-open () - "Blink the matching Octave begin block keyword. -If point is right after an Octave else or end type block keyword, move -cursor momentarily to the corresponding begin keyword. -Signal an error if the keywords are incompatible." - (interactive) - (let (bb-keyword bb-arg eb-keyword pos eol) - (if (and (octave-not-in-string-or-comment-p) - (looking-at "\\>") - (save-excursion - (skip-syntax-backward "w") - (octave-looking-at-kw octave-block-else-or-end-regexp))) - (save-excursion - (cond - ((match-end 1) - (setq eb-keyword - (buffer-substring-no-properties - (match-beginning 1) (match-end 1))) - (octave-backward-up-block 1)) - ((match-end 2) - (setq eb-keyword - (buffer-substring-no-properties - (match-beginning 2) (match-end 2))) - (octave-backward-block))) - (setq pos (match-end 0) - bb-keyword - (buffer-substring-no-properties - (match-beginning 0) pos) - pos (+ pos 1) - eol (line-end-position) - bb-arg - (save-excursion - (save-restriction - (goto-char pos) - (while (and (skip-syntax-forward "^<" eol) - (octave-in-string-p) - (not (forward-char 1)))) - (skip-syntax-backward " ") - (buffer-substring-no-properties pos (point))))) - (if (member eb-keyword - (cdr (assoc bb-keyword octave-block-match-alist))) - (progn - (message "Matches `%s %s'" bb-keyword bb-arg) - (if (pos-visible-in-window-p) - (sit-for blink-matching-delay))) - (error "Block keywords `%s' and `%s' do not match" - bb-keyword eb-keyword)))))) + (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-beginning-of-defun (&optional arg) "Move backward to the beginning of an Octave function. @@ -1081,81 +943,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 @@ -1191,9 +1045,6 @@ If Abbrev mode is on, expand abbrevs first." ;; FIXME: None of this is Octave-specific. (interactive) - (if abbrev-mode (expand-abbrev)) - (if octave-blink-matching-block - (octave-blink-matching-block-open)) (reindent-then-newline-and-indent)) (defun octave-electric-semi () @@ -1202,14 +1053,12 @@ Reindent the line if `octave-auto-indent' is non-nil. Insert a newline if `octave-auto-newline' is non-nil." (interactive) + (setq last-command-event ?\;) (if (not (octave-not-in-string-or-comment-p)) - (insert ";") - (if abbrev-mode (expand-abbrev)) - (if octave-blink-matching-block - (octave-blink-matching-block-open)) + (self-insert-command 1) (if octave-auto-indent (indent-according-to-mode)) - (insert ";") + (self-insert-command 1) (if octave-auto-newline (newline-and-indent)))) @@ -1224,9 +1073,6 @@ (progn (indent-according-to-mode) (self-insert-command 1)) - (if abbrev-mode (expand-abbrev)) - (if octave-blink-matching-block - (octave-blink-matching-block-open)) (if (and octave-auto-indent (save-excursion (skip-syntax-backward " ")
--- a/lisp/progmodes/python.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/progmodes/python.el Wed Sep 08 12:55:57 2010 +0900 @@ -782,7 +782,7 @@ '(("else" "if" "elif" "while" "for" "try" "except") ("elif" "if" "elif") ("except" "try" "except") - ("finally" "try" "except")) + ("finally" "else" "try" "except")) "Alist of keyword matches. The car of an element is a keyword introducing a statement which can close a block opened by a keyword in the cdr.") @@ -2285,6 +2285,7 @@ (eval-when-compile ;; Define a user-level skeleton and add it to the abbrev table. (defmacro def-python-skeleton (name &rest elements) + (declare (indent 2)) (let* ((name (symbol-name name)) (function (intern (concat "python-insert-" name)))) `(progn @@ -2297,7 +2298,6 @@ (define-skeleton ,function ,(format "Insert Python \"%s\" template." name) ,@elements))))) -(put 'def-python-skeleton 'lisp-indent-function 2) ;; From `skeleton-further-elements' set below: ;; `<': outdent a level;
--- a/lisp/ps-print.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/ps-print.el Wed Sep 08 12:55:57 2010 +0900 @@ -13,7 +13,6 @@ ;; Keywords: wp, print, PostScript ;; Version: 7.3.5 ;; X-URL: http://www.emacswiki.org/cgi-bin/wiki/ViniciusJoseLatorre -;; Package: ps-print (defconst ps-print-version "7.3.5" "ps-print.el, v 7.3.5 <2009/12/23 vinicius>
--- a/lisp/select.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/select.el Wed Sep 08 12:55:57 2010 +0900 @@ -174,36 +174,6 @@ (symbolp data) (integerp data))) -;;; Cut Buffer support - -(declare-function x-get-cut-buffer-internal "xselect.c") - -(defun x-get-cut-buffer (&optional which-one) - "Return the value of one of the 8 X server cut-buffers. -Optional arg WHICH-ONE should be a number from 0 to 7, defaulting to 0. -Cut buffers are considered obsolete; you should use selections instead." - (x-get-cut-buffer-internal - (if which-one - (aref [CUT_BUFFER0 CUT_BUFFER1 CUT_BUFFER2 CUT_BUFFER3 - CUT_BUFFER4 CUT_BUFFER5 CUT_BUFFER6 CUT_BUFFER7] - which-one) - 'CUT_BUFFER0))) - -(declare-function x-rotate-cut-buffers-internal "xselect.c") -(declare-function x-store-cut-buffer-internal "xselect.c") - -(defun x-set-cut-buffer (string &optional push) - "Store STRING into the X server's primary cut buffer. -If PUSH is non-nil, also rotate the cut buffers: -this means the previous value of the primary cut buffer moves to the second -cut buffer, and the second to the third, and so on (there are 8 buffers.) -Cut buffers are considered obsolete; you should use selections instead." - (or (stringp string) (signal 'wrong-type-argument (list 'stringp string))) - (if push - (x-rotate-cut-buffers-internal 1)) - (x-store-cut-buffer-internal 'CUT_BUFFER0 string)) - - ;; Functions to convert the selection into various other selection types. ;; Every selection type that Emacs handles is implemented this way, except ;; for TIMESTAMP, which is a special case.
--- a/lisp/sha1.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/sha1.el Wed Sep 08 12:55:57 2010 +0900 @@ -439,5 +439,4 @@ (provide 'sha1) -;; arch-tag: c0f9abd0-ffc1-4557-aac6-ece7f2d4c901 ;;; sha1.el ends here
--- a/lisp/simple.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/simple.el Wed Sep 08 12:55:57 2010 +0900 @@ -457,72 +457,43 @@ than the value of `fill-column' and ARG is nil." (interactive "*P") (barf-if-buffer-read-only) - ;; Inserting a newline at the end of a line produces better redisplay in - ;; try_window_id than inserting at the beginning of a line, and the textual - ;; result is the same. So, if we're at beginning of line, pretend to be at - ;; the end of the previous line. - (let ((flag (and (not (bobp)) - (bolp) - ;; Make sure no functions want to be told about - ;; the range of the changes. - (not after-change-functions) - (not before-change-functions) - ;; Make sure there are no markers here. - (not (buffer-has-markers-at (1- (point)))) - (not (buffer-has-markers-at (point))) - ;; Make sure no text properties want to know - ;; where the change was. - (not (get-char-property (1- (point)) 'modification-hooks)) - (not (get-char-property (1- (point)) 'insert-behind-hooks)) - (or (eobp) - (not (get-char-property (point) 'insert-in-front-hooks))) - ;; Make sure the newline before point isn't intangible. - (not (get-char-property (1- (point)) 'intangible)) - ;; Make sure the newline before point isn't read-only. - (not (get-char-property (1- (point)) 'read-only)) - ;; Make sure the newline before point isn't invisible. - (not (get-char-property (1- (point)) 'invisible)) - ;; Make sure the newline before point has the same - ;; properties as the char before it (if any). - (< (or (previous-property-change (point)) -2) - (- (point) 2)))) - (was-page-start (and (bolp) - (looking-at page-delimiter))) - (beforepos (point))) - (if flag (backward-char 1)) - ;; Call self-insert so that auto-fill, abbrev expansion etc. happens. - ;; Set last-command-event to tell self-insert what to insert. - (let ((last-command-event ?\n) - ;; Don't auto-fill if we have a numeric argument. - ;; Also not if flag is true (it would fill wrong line); - ;; there is no need to since we're at BOL. - (auto-fill-function (if (or arg flag) nil auto-fill-function))) - (unwind-protect - (self-insert-command (prefix-numeric-value arg)) - ;; If we get an error in self-insert-command, put point at right place. - (if flag (forward-char 1)))) - ;; Even if we did *not* get an error, keep that forward-char; - ;; all further processing should apply to the newline that the user - ;; thinks he inserted. - - ;; Mark the newline(s) `hard'. - (if use-hard-newlines - (set-hard-newline-properties - (- (point) (prefix-numeric-value arg)) (point))) - ;; If the newline leaves the previous line blank, - ;; and we have a left margin, delete that from the blank line. - (or flag - (save-excursion - (goto-char beforepos) - (beginning-of-line) - (and (looking-at "[ \t]$") - (> (current-left-margin) 0) - (delete-region (point) (progn (end-of-line) (point)))))) - ;; Indent the line after the newline, except in one case: - ;; when we added the newline at the beginning of a line - ;; which starts a page. - (or was-page-start - (move-to-left-margin nil t))) + ;; Call self-insert so that auto-fill, abbrev expansion etc. happens. + ;; Set last-command-event to tell self-insert what to insert. + (let* ((was-page-start (and (bolp) (looking-at page-delimiter))) + (beforepos (point)) + (last-command-event ?\n) + ;; Don't auto-fill if we have a numeric argument. + (auto-fill-function (if arg nil auto-fill-function)) + (postproc + ;; Do the rest in post-self-insert-hook, because we want to do it + ;; *before* other functions on that hook. + (lambda () + ;; Mark the newline(s) `hard'. + (if use-hard-newlines + (set-hard-newline-properties + (- (point) (prefix-numeric-value arg)) (point))) + ;; If the newline leaves the previous line blank, and we + ;; have a left margin, delete that from the blank line. + (save-excursion + (goto-char beforepos) + (beginning-of-line) + (and (looking-at "[ \t]$") + (> (current-left-margin) 0) + (delete-region (point) + (line-end-position)))) + ;; Indent the line after the newline, except in one case: + ;; when we added the newline at the beginning of a line which + ;; starts a page. + (or was-page-start + (move-to-left-margin nil t))))) + (unwind-protect + (progn + (add-hook 'post-self-insert-hook postproc) + (self-insert-command (prefix-numeric-value arg))) + ;; We first used let-binding to protect the hook, but that was naive + ;; since add-hook affects the symbol-default value of the variable, + ;; whereas the let-binding might only protect the buffer-local value. + (remove-hook 'post-self-insert-hook postproc))) nil) (defun set-hard-newline-properties (from to) @@ -804,15 +775,16 @@ (constrain-to-field nil orig-pos t))))) (defun beginning-of-buffer (&optional arg) - "Move point to the beginning of the buffer; leave mark at previous position. -With \\[universal-argument] prefix, do not set mark at previous position. + "Move point to the beginning of the buffer. With numeric arg N, put point N/10 of the way from the beginning. - -If the buffer is narrowed, this command uses the beginning and size -of the accessible part of the buffer. +If the buffer is narrowed, this command uses the beginning of the +accessible part of the buffer. + +If Transient Mark mode is disabled, leave mark at previous +position, unless a \\[universal-argument] prefix is supplied. Don't use this command in Lisp programs! -\(goto-char (point-min)) is faster and avoids clobbering the mark." +\(goto-char (point-min)) is faster." (interactive "^P") (or (consp arg) (region-active-p) @@ -829,15 +801,16 @@ (if (and arg (not (consp arg))) (forward-line 1))) (defun end-of-buffer (&optional arg) - "Move point to the end of the buffer; leave mark at previous position. -With \\[universal-argument] prefix, do not set mark at previous position. + "Move point to the end of the buffer. With numeric arg N, put point N/10 of the way from the end. - -If the buffer is narrowed, this command uses the beginning and size -of the accessible part of the buffer. +If the buffer is narrowed, this command uses the end of the +accessible part of the buffer. + +If Transient Mark mode is disabled, leave mark at previous +position, unless a \\[universal-argument] prefix is supplied. Don't use this command in Lisp programs! -\(goto-char (point-max)) is faster and avoids clobbering the mark." +\(goto-char (point-max)) is faster." (interactive "^P") (or (consp arg) (region-active-p) (push-mark)) (let ((size (- (point-max) (point-min)))) @@ -2927,11 +2900,8 @@ is put in the kill ring, to make the new kill available to other programs. -The function takes one or two arguments. -The first argument, TEXT, is a string containing -the text which should be made available. -The second, optional, argument PUSH, has the same meaning as the -similar argument to `x-set-cut-buffer', which see.") +The function takes one argument, TEXT, which is a string containing +the text which should be made available.") (defvar interprogram-paste-function nil "Function to call to get text cut from other programs. @@ -3048,7 +3018,7 @@ (setcdr (nthcdr (1- kill-ring-max) kill-ring) nil)))) (setq kill-ring-yank-pointer kill-ring) (if interprogram-cut-function - (funcall interprogram-cut-function string (not replace)))) + (funcall interprogram-cut-function string))) (defun kill-append (string before-p &optional yank-handler) "Append STRING to the end of the latest kill in the kill ring. @@ -5504,21 +5474,40 @@ :type 'boolean :group 'paren-blinking) +(defun blink-matching-check-mismatch (start end) + "Return whether or not START...END are matching parens. +END is the current point and START is the blink position. +START might be nil if no matching starter was found. +Returns non-nil if we find there is a mismatch." + (let* ((end-syntax (syntax-after (1- end))) + (matching-paren (and (consp end-syntax) + (eq (syntax-class end-syntax) 5) + (cdr end-syntax)))) + ;; For self-matched chars like " and $, we can't know when they're + ;; mismatched or unmatched, so we can only do it for parens. + (when matching-paren + (not (and start + (or + (eq (char-after start) matching-paren) + ;; The cdr might hold a new paren-class info rather than + ;; a matching-char info, in which case the two CDRs + ;; should match. + (eq matching-paren (cdr-safe (syntax-after start))))))))) + +(defvar blink-matching-check-function #'blink-matching-check-mismatch + "Function to check parentheses mismatches. +The function takes two arguments (START and END) where START is the +position just before the opening token and END is the position right after. +START can be nil, if it was not found. +The function should return non-nil if the two tokens do not match.") + (defun blink-matching-open () "Move cursor momentarily to the beginning of the sexp before point." (interactive) - (when (and (> (point) (point-min)) - blink-matching-paren - ;; Verify an even number of quoting characters precede the close. - (= 1 (logand 1 (- (point) - (save-excursion - (forward-char -1) - (skip-syntax-backward "/\\") - (point)))))) + (when (and (not (bobp)) + blink-matching-paren) (let* ((oldpos (point)) - (message-log-max nil) ; Don't log messages about paren matching. - (atdollar (eq (syntax-class (syntax-after (1- oldpos))) 8)) - (isdollar) + (message-log-max nil) ; Don't log messages about paren matching. (blinkpos (save-excursion (save-restriction @@ -5533,38 +5522,25 @@ (condition-case () (progn (forward-sexp -1) + ;; backward-sexp skips backward over prefix chars, + ;; so move back to the matching paren. + (while (and (< (point) (1- oldpos)) + (let ((code (car (syntax-after (point))))) + (or (eq (logand 65536 code) 6) + (eq (logand 1048576 code) 1048576)))) + (forward-char 1)) (point)) (error nil)))))) - (matching-paren - (and blinkpos - ;; Not syntax '$'. - (not (setq isdollar - (eq (syntax-class (syntax-after blinkpos)) 8))) - (let ((syntax (syntax-after blinkpos))) - (and (consp syntax) - (eq (syntax-class syntax) 4) - (cdr syntax)))))) + (mismatch (funcall blink-matching-check-function blinkpos oldpos))) (cond - ;; isdollar is for: - ;; http://lists.gnu.org/archive/html/emacs-devel/2007-10/msg00871.html - ((not (or (and isdollar blinkpos) - (and atdollar (not blinkpos)) ; see below - (eq matching-paren (char-before oldpos)) - ;; The cdr might hold a new paren-class info rather than - ;; a matching-char info, in which case the two CDRs - ;; should match. - (eq matching-paren (cdr (syntax-after (1- oldpos)))))) - (if (minibufferp) - (minibuffer-message " [Mismatched parentheses]") - (message "Mismatched parentheses"))) - ((not blinkpos) - (or blink-matching-paren-distance - ;; Don't complain when `$' with no blinkpos, because it - ;; could just be the first one typed in the buffer. - atdollar + (mismatch + (if blinkpos (if (minibufferp) - (minibuffer-message " [Unmatched parenthesis]") - (message "Unmatched parenthesis")))) + (minibuffer-message " [Mismatched parentheses]") + (message "Mismatched parentheses")) + (if (minibufferp) + (minibuffer-message " [Unmatched parenthesis]") + (message "Unmatched parenthesis")))) ((pos-visible-in-window-p blinkpos) ;; Matching open within window, temporarily move to blinkpos but only ;; if `blink-matching-paren-on-screen' is non-nil. @@ -5607,7 +5583,29 @@ (message "Matches %s" (substring-no-properties open-paren-line-string))))))))) -(setq blink-paren-function 'blink-matching-open) +(defvar blink-paren-function 'blink-matching-open + "Function called, if non-nil, whenever a close parenthesis is inserted. +More precisely, a char with closeparen syntax is self-inserted.") + +(defun blink-paren-post-self-insert-function () + (when (and (eq (char-before) last-command-event) ; Sanity check. + (memq (char-syntax last-command-event) '(?\) ?\$)) + blink-paren-function + (not executing-kbd-macro) + (not noninteractive) + ;; Verify an even number of quoting characters precede the close. + (= 1 (logand 1 (- (point) + (save-excursion + (forward-char -1) + (skip-syntax-backward "/\\") + (point)))))) + (funcall blink-paren-function))) + +(add-hook 'post-self-insert-hook #'blink-paren-post-self-insert-function + ;; Most likely, this hook is nil, so this arg doesn't matter, + ;; but I use it as a reminder that this function usually + ;; likes to be run after others since it does `sit-for'. + 'append) ;; This executes C-g typed while Emacs is waiting for a command. ;; Quitting out of a program does not go through here;
--- a/lisp/subr.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/subr.el Wed Sep 08 12:55:57 2010 +0900 @@ -1630,6 +1630,7 @@ load-elt (and loads (car loads))))) load-elt)) +(put 'eval-after-load 'lisp-indent-function 1) (defun eval-after-load (file form) "Arrange that, if FILE is ever loaded, FORM will be run at that time. If FILE is already loaded, evaluate FORM right now. @@ -2713,7 +2714,7 @@ "Create a new buffer, evaluate BODY there, and write the buffer to FILE. The value returned is the value of the last form in BODY. See also `with-temp-buffer'." - (declare (debug t)) + (declare (indent 1) (debug t)) (let ((temp-file (make-symbol "temp-file")) (temp-buffer (make-symbol "temp-buffer"))) `(let ((,temp-file ,file) @@ -2735,7 +2736,7 @@ MESSAGE is written to the message log buffer if `message-log-max' is non-nil. If MESSAGE is nil, the echo area and message log buffer are unchanged. Use a MESSAGE of \"\" to temporarily clear the echo area." - (declare (debug t)) + (declare (debug t) (indent 1)) (let ((current-message (make-symbol "current-message")) (temp-message (make-symbol "with-temp-message"))) `(let ((,temp-message ,message) @@ -2765,7 +2766,7 @@ (kill-buffer ,temp-buffer))))))) (defmacro with-silent-modifications (&rest body) - "Execute BODY, pretending it does not modifies the buffer. + "Execute BODY, pretending it does not modify the buffer. If BODY performs real modifications to the buffer's text, other than cosmetic ones, undo data may become corrupted. Typically used around modifications of text-properties which do not really @@ -3227,7 +3228,7 @@ The syntax table of the current buffer is saved, BODY is evaluated, and the saved table is restored, even in case of an abnormal exit. Value is what BODY returns." - (declare (debug t)) + (declare (debug t) (indent 1)) (let ((old-table (make-symbol "table")) (old-buffer (make-symbol "buffer"))) `(let ((,old-table (syntax-table))
--- a/lisp/term.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/term.el Wed Sep 08 12:55:57 2010 +0900 @@ -1231,8 +1231,7 @@ (if (featurep 'xemacs) (term-send-raw-string (or (condition-case () (x-get-selection) (error ())) - (x-get-cutbuffer) - (error "No selection or cut buffer available"))) + (error "No selection available"))) ;; Give temporary modes such as isearch a chance to turn off. (run-hooks 'mouse-leave-buffer-hook) (setq this-command 'yank)
--- a/lisp/term/ns-win.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/term/ns-win.el Wed Sep 08 12:55:57 2010 +0900 @@ -293,7 +293,7 @@ (unless (terminal-parameter frame 'x-setup-function-keys) (with-selected-frame frame (setq interprogram-cut-function 'x-select-text - interprogram-paste-function 'x-cut-buffer-or-selection-value) + interprogram-paste-function 'x-selection-value) (let ((map (copy-keymap ns-alternatives-map))) (set-keymap-parent map (keymap-parent local-function-key-map)) (set-keymap-parent local-function-key-map map)) @@ -1015,23 +1015,21 @@ ;; We keep track of the last text selected here, so we can check the ;; current selection against it, and avoid passing back our own text -;; from x-cut-buffer-or-selection-value. +;; from x-selection-value. (defvar ns-last-selected-text nil) -(defun x-select-text (text &optional push) +(defun x-select-text (text) "Select TEXT, a string, according to the window system. -On X, put TEXT in the primary X selection. For backward -compatibility with older X applications, set the value of X cut -buffer 0 as well, and if the optional argument PUSH is non-nil, -rotate the cut buffers. If `x-select-enable-clipboard' is -non-nil, copy the text to the X clipboard as well. +On X, if `x-select-enable-clipboard' is non-nil, copy TEXT to the +clipboard. If `x-select-enable-primary' is non-nil, put TEXT in +the primary selection. On Windows, make TEXT the current selection. If `x-select-enable-clipboard' is non-nil, copy the text to the -clipboard as well. The argument PUSH is ignored. +clipboard as well. -On Nextstep, put TEXT in the pasteboard; PUSH is ignored." +On Nextstep, put TEXT in the pasteboard." ;; Don't send the pasteboard too much text. ;; It becomes slow, and if really big it causes errors. (ns-set-pasteboard text) @@ -1040,11 +1038,10 @@ ;; Return the value of the current Nextstep selection. For ;; compatibility with older Nextstep applications, this checks cut ;; buffer 0 before retrieving the value of the primary selection. -(defun x-cut-buffer-or-selection-value () +(defun x-selection-value () (let (text) - ;; Consult the selection, then the cut buffer. Treat empty strings - ;; as if they were unset. + ;; Consult the selection. Treat empty strings as if they were unset. (or text (setq text (ns-get-pasteboard))) (if (string= text "") (setq text nil))
--- a/lisp/term/pc-win.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/term/pc-win.el Wed Sep 08 12:55:57 2010 +0900 @@ -192,11 +192,11 @@ ;; From lisp/term/w32-win.el ; -;;;; Selections and cut buffers +;;;; Selections ; ;;; We keep track of the last text selected here, so we can check the ;;; current selection against it, and avoid passing back our own text -;;; from x-cut-buffer-or-selection-value. +;;; from x-selection-value. (defvar x-last-selected-text nil) (defcustom x-select-enable-clipboard t @@ -209,27 +209,24 @@ :type 'boolean :group 'killing) -(defun x-select-text (text &optional push) +(defun x-select-text (text) "Select TEXT, a string, according to the window system. -On X, put TEXT in the primary X selection. For backward -compatibility with older X applications, set the value of X cut -buffer 0 as well, and if the optional argument PUSH is non-nil, -rotate the cut buffers. If `x-select-enable-clipboard' is -non-nil, copy the text to the X clipboard as well. +On X, if `x-select-enable-clipboard' is non-nil, copy TEXT to the +clipboard. If `x-select-enable-primary' is non-nil, put TEXT in +the primary selection. On Windows, make TEXT the current selection. If `x-select-enable-clipboard' is non-nil, copy the text to the -clipboard as well. The argument PUSH is ignored. +clipboard as well. -On Nextstep, put TEXT in the pasteboard; PUSH is ignored." +On Nextstep, put TEXT in the pasteboard." (if x-select-enable-clipboard (w16-set-clipboard-data text)) (setq x-last-selected-text text)) ;;; Return the value of the current selection. -;;; Consult the selection, then the cut buffer. Treat empty strings -;;; as if they were unset. +;;; Consult the selection. Treat empty strings as if they were unset. (defun x-get-selection-value () (if x-select-enable-clipboard (let (text)
--- a/lisp/term/x-win.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/term/x-win.el Wed Sep 08 12:55:57 2010 +0900 @@ -1192,32 +1192,19 @@ ;; #x0dde THAI MAIHANAKAT Thai -;;;; Selections and cut buffers +;;;; Selections ;; We keep track of the last text selected here, so we can check the ;; current selection against it, and avoid passing back our own text -;; from x-cut-buffer-or-selection-value. We track all three +;; from x-selection-value. We track both ;; separately in case another X application only sets one of them -;; (say the cut buffer) we aren't fooled by the PRIMARY or -;; CLIPBOARD selection staying the same. +;; we aren't fooled by the PRIMARY or CLIPBOARD selection staying the same. (defvar x-last-selected-text-clipboard nil "The value of the CLIPBOARD X selection last time we selected or pasted text.") (defvar x-last-selected-text-primary nil "The value of the PRIMARY X selection last time we selected or pasted text.") -(defvar x-last-selected-text-cut nil - "The value of the X cut buffer last time we selected or pasted text. -The actual text stored in the X cut buffer is what encoded from this value.") -(defvar x-last-selected-text-cut-encoded nil - "The value of the X cut buffer last time we selected or pasted text. -This is the actual text stored in the X cut buffer.") -(defvar x-last-cut-buffer-coding 'iso-latin-1 - "The coding we last used to encode/decode the text from the X cut buffer") - -(defvar x-cut-buffer-max 20000 ; Note this value is overridden below. - "Max number of characters to put in the cut buffer. -It is said that overlarge strings are slow to put into the cut buffer.") (defcustom x-select-enable-clipboard t "Non-nil means cutting and pasting uses the clipboard. @@ -1232,29 +1219,20 @@ :group 'killing :version "24.1") -(defun x-select-text (text &optional push) +(defun x-select-text (text) "Select TEXT, a string, according to the window system. -If `x-select-enable-clipboard' is non-nil, copy TEXT to the + +On X, if `x-select-enable-clipboard' is non-nil, copy TEXT to the clipboard. If `x-select-enable-primary' is non-nil, put TEXT in -the primary selection. For backward compatibility with older X -applications, this function also sets the value of X cut buffer -0, and, if the optional argument PUSH is non-nil, rotates the cut -buffers." +the primary selection. + +On Windows, make TEXT the current selection. If +`x-select-enable-clipboard' is non-nil, copy the text to the +clipboard as well. + +On Nextstep, put TEXT in the pasteboard." ;; With multi-tty, this function may be called from a tty frame. (when (eq (framep (selected-frame)) 'x) - ;; Don't send the cut buffer too much text. - ;; It becomes slow, and if really big it causes errors. - (cond ((>= (length text) x-cut-buffer-max) - (x-set-cut-buffer "" push) - (setq x-last-selected-text-cut "" - x-last-selected-text-cut-encoded "")) - (t - (setq x-last-selected-text-cut text - x-last-cut-buffer-coding 'iso-latin-1 - x-last-selected-text-cut-encoded - ;; ICCCM says cut buffer always contain ISO-Latin-1 - (encode-coding-string text 'iso-latin-1)) - (x-set-cut-buffer x-last-selected-text-cut-encoded push))) (when x-select-enable-primary (x-set-selection 'PRIMARY text) (setq x-last-selected-text-primary text)) @@ -1282,7 +1260,7 @@ ;; The return value is already decoded. If x-get-selection causes an ;; error, this function return nil. -(defun x-selection-value (type) +(defun x-selection-value-internal (type) (let ((request-type (or x-select-request-type '(UTF8_STRING COMPOUND_TEXT STRING))) text) @@ -1300,17 +1278,16 @@ text)) ;; Return the value of the current X selection. -;; Consult the selection, and the cut buffer. Treat empty strings -;; as if they were unset. +;; Consult the selection. Treat empty strings as if they were unset. ;; If this function is called twice and finds the same text, ;; it returns nil the second time. This is so that a single ;; selection won't be added to the kill ring over and over. -(defun x-cut-buffer-or-selection-value () +(defun x-selection-value () ;; With multi-tty, this function may be called from a tty frame. (when (eq (framep (selected-frame)) 'x) - (let (clip-text primary-text cut-text) + (let (clip-text primary-text) (when x-select-enable-clipboard - (setq clip-text (x-selection-value 'CLIPBOARD)) + (setq clip-text (x-selection-value-internal 'CLIPBOARD)) (if (string= clip-text "") (setq clip-text nil)) ;; Check the CLIPBOARD selection for 'newness', is it different @@ -1329,7 +1306,7 @@ (t (setq x-last-selected-text-clipboard clip-text))))) (when x-select-enable-primary - (setq primary-text (x-selection-value 'PRIMARY)) + (setq primary-text (x-selection-value-internal 'PRIMARY)) ;; Check the PRIMARY selection for 'newness', is it different ;; from what we remebered them to be last time we did a ;; cut/paste operation. @@ -1346,69 +1323,35 @@ (t (setq x-last-selected-text-primary primary-text))))) - (setq cut-text (x-get-cut-buffer 0)) - - ;; Check the x cut buffer for 'newness', is it different - ;; from what we remebered them to be last time we did a - ;; cut/paste operation. - (setq cut-text - (let ((next-coding (or next-selection-coding-system 'iso-latin-1))) - (cond ;; check cut buffer - ((or (not cut-text) (string= cut-text "")) - (setq x-last-selected-text-cut nil)) - ;; This short cut doesn't work because x-get-cut-buffer - ;; always returns a newly created string. - ;; ((eq cut-text x-last-selected-text-cut) nil) - ((and (string= cut-text x-last-selected-text-cut-encoded) - (eq x-last-cut-buffer-coding next-coding)) - ;; See the comment above. No need of this recording. - ;; Record the newer string, - ;; so subsequent calls can use the `eq' test. - ;; (setq x-last-selected-text-cut cut-text) - nil) - (t - (setq x-last-selected-text-cut-encoded cut-text - x-last-cut-buffer-coding next-coding - x-last-selected-text-cut - ;; ICCCM says cut buffer always contain ISO-Latin-1, but - ;; use next-selection-coding-system if not nil. - (decode-coding-string - cut-text next-coding)))))) - ;; As we have done one selection, clear this now. (setq next-selection-coding-system nil) ;; At this point we have recorded the current values for the - ;; selection from clipboard (if we are supposed to) primary, - ;; and cut buffer. So return the first one that has changed + ;; selection from clipboard (if we are supposed to) and primary. + ;; So return the first one that has changed ;; (which is the first non-null one). ;; ;; NOTE: There will be cases where more than one of these has ;; changed and the new values differ. This indicates that ;; something like the following has happened since the last time ;; we looked at the selections: Application X set all the - ;; selections, then Application Y set only one or two of them (say - ;; just the cut-buffer). In this case since we don't have + ;; selections, then Application Y set only one of them. + ;; In this case since we don't have ;; timestamps there is no way to know what the 'correct' value to ;; return is. The nice thing to do would be to tell the user we ;; saw multiple possible selections and ask the user which was the ;; one they wanted. - ;; This code is still a big improvement because now the user can - ;; futz with the current selection and get emacs to pay attention - ;; to the cut buffer again (previously as soon as clipboard or - ;; primary had been set the cut buffer would essentially never be - ;; checked again). - (or clip-text primary-text cut-text) + (or clip-text primary-text) ))) ;; Arrange for the kill and yank functions to set and check the clipboard. (setq interprogram-cut-function 'x-select-text) -(setq interprogram-paste-function 'x-cut-buffer-or-selection-value) +(setq interprogram-paste-function 'x-selection-value) (defun x-clipboard-yank () "Insert the clipboard contents, or the last stretch of killed text." (interactive "*") - (let ((clipboard-text (x-selection-value 'CLIPBOARD)) + (let ((clipboard-text (x-selection-value-internal 'CLIPBOARD)) (x-select-enable-clipboard t)) (if (and clipboard-text (> (length clipboard-text) 0)) (kill-new clipboard-text)) @@ -1465,9 +1408,6 @@ ;; are the initial display. (eq initial-window-system 'x)) - (setq x-cut-buffer-max (min (- (/ (x-server-max-request-size) 2) 100) - x-cut-buffer-max)) - ;; Create the default fontset. (create-default-fontset)
--- a/lisp/textmodes/bibtex.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/textmodes/bibtex.el Wed Sep 08 12:55:57 2010 +0900 @@ -9,7 +9,7 @@ ;; Mike Newton <newton@gumby.cs.caltech.edu> ;; Aaron Larson <alarson@src.honeywell.com> ;; Dirk Herrmann <D.Herrmann@tu-bs.de> -;; Maintainer: Roland Winkler <roland.winkler@physik.uni-erlangen.de> +;; Maintainer: Roland Winkler <winkler@gnu.org> ;; Keywords: BibTeX, LaTeX, TeX ;; This file is part of GNU Emacs.
--- a/lisp/textmodes/dns-mode.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/textmodes/dns-mode.el Wed Sep 08 12:55:57 2010 +0900 @@ -227,5 +227,4 @@ (provide 'dns-mode) -;; arch-tag: 6a179f0a-072f-49db-8b01-37b8f23998c0 ;;; dns-mode.el ends here
--- a/lisp/textmodes/ispell.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/textmodes/ispell.el Wed Sep 08 12:55:57 2010 +0900 @@ -221,10 +221,10 @@ (let (ver mver) (if (string-match "[0-9]+" version start-ver) (setq start-ver (match-end 0) - ver (string-to-number (substring version (match-beginning 0) (match-end 0))))) + ver (string-to-number (match-string 0 version)))) (if (string-match "[0-9]+" minver start-mver) (setq start-mver (match-end 0) - mver (string-to-number (substring minver (match-beginning 0) (match-end 0))))) + mver (string-to-number (match-string 0 minver)))) (if (or ver mver) (progn @@ -310,7 +310,9 @@ may produce undesired results." :type '(choice (const exclusive) (const :tag "off" nil) (const :tag "on" t)) :group 'ispell) -;;;###autoload(put 'ispell-check-comments 'safe-local-variable (lambda (a) (memq a '(nil t exclusive)))) +;;;###autoload +(put 'ispell-check-comments 'safe-local-variable + (lambda (a) (memq a '(nil t exclusive)))) (defcustom ispell-query-replace-choices nil "*Corrections made throughout region when non-nil. @@ -514,7 +516,8 @@ :type '(choice string (const :tag "default" nil)) :group 'ispell) -;;;###autoload(put 'ispell-local-dictionary 'safe-local-variable 'string-or-null-p) +;;;###autoload +(put 'ispell-local-dictionary 'safe-local-variable 'string-or-null-p) (make-variable-buffer-local 'ispell-local-dictionary) @@ -738,8 +741,8 @@ contain the same character set as casechars and otherchars in the LANGUAGE.aff file \(e.g., english.aff\).") -(defvar ispell-really-aspell nil) ; Non-nil if aspell extensions should be used -(defvar ispell-really-hunspell nil) ; Non-nil if hunspell extensions should be used +(defvar ispell-really-aspell nil) ; Non-nil if we can use aspell extensions. +(defvar ispell-really-hunspell nil) ; Non-nil if we can use hunspell extensions. (defvar ispell-encoding8-command nil "Command line option prefix to select UTF-8 if supported, nil otherwise. If UTF-8 if supported by spellchecker and is selectable from the command line @@ -962,7 +965,8 @@ (setq found (nconc found (list dict))))) (setq ispell-aspell-dictionary-alist found) ;; Add a default entry - (let ((default-dict '(nil "[[:alpha:]]" "[^[:alpha:]]" "[']" nil ("-B") nil utf-8))) + (let ((default-dict + '(nil "[[:alpha:]]" "[^[:alpha:]]" "[']" nil ("-B") nil utf-8))) (push default-dict ispell-aspell-dictionary-alist)))) (defvar ispell-aspell-data-dir nil @@ -1026,7 +1030,8 @@ (defun ispell-aspell-add-aliases (alist) "Find aspell's dictionary aliases and add them to dictionary ALIST. Return the new dictionary alist." - (let ((aliases (file-expand-wildcards + (let ((aliases + (file-expand-wildcards (concat (or ispell-aspell-dict-dir (setq ispell-aspell-dict-dir (ispell-get-aspell-config-value "dict-dir"))) @@ -1168,7 +1173,8 @@ `(menu-item ,(purecopy "Complete Word") ispell-complete-word :help ,(purecopy "Complete word at cursor using dictionary"))) (define-key ispell-menu-map [ispell-complete-word-interior-frag] - `(menu-item ,(purecopy "Complete Word Fragment") ispell-complete-word-interior-frag + `(menu-item ,(purecopy "Complete Word Fragment") + ispell-complete-word-interior-frag :help ,(purecopy "Complete word fragment at cursor"))))) ;;;###autoload @@ -1185,7 +1191,8 @@ `(menu-item ,(purecopy "Spell-Check Word") ispell-word :help ,(purecopy "Spell-check word at cursor"))) (define-key ispell-menu-map [ispell-comments-and-strings] - `(menu-item ,(purecopy "Spell-Check Comments") ispell-comments-and-strings + `(menu-item ,(purecopy "Spell-Check Comments") + ispell-comments-and-strings :help ,(purecopy "Spell-check only comments and strings"))))) ;;;###autoload @@ -1334,9 +1341,6 @@ (defvar ispell-process-directory nil "The directory where `ispell-process' was started.") -(defvar ispell-process-buffer-name nil - "The buffer where `ispell-process' was started.") - (defvar ispell-filter nil "Output filter from piped calls to Ispell.") @@ -1400,7 +1404,8 @@ (ispell-dictionary-keyword forward-line) (ispell-pdict-keyword forward-line) (ispell-parsing-keyword forward-line) - (,(purecopy "^---*BEGIN PGP [A-Z ]*--*") . ,(purecopy "^---*END PGP [A-Z ]*--*")) + (,(purecopy "^---*BEGIN PGP [A-Z ]*--*") + . ,(purecopy "^---*END PGP [A-Z ]*--*")) ;; assume multiline uuencoded file? "\nM.*$"? (,(purecopy "^begin [0-9][0-9][0-9] [^ \t]+$") . ,(purecopy "\nend\n")) (,(purecopy "^%!PS-Adobe-[123].0") . ,(purecopy "\n%%EOF\n")) @@ -1880,9 +1885,10 @@ ;; setup the *Choices* buffer with valid data. (with-current-buffer (get-buffer-create ispell-choices-buffer) (setq mode-line-format - (concat "-- %b -- word: " word - " -- dict: " (or ispell-current-dictionary "default") - " -- prog: " (file-name-nondirectory ispell-program-name))) + (concat + "-- %b -- word: " word + " -- dict: " (or ispell-current-dictionary "default") + " -- prog: " (file-name-nondirectory ispell-program-name))) ;; XEmacs: no need for horizontal scrollbar in choices window (with-no-warnings (and (fboundp 'set-specifier) @@ -2280,8 +2286,9 @@ (unless (file-readable-p lookup-dict) (error "lookup-words error: Unreadable or missing plain word-list %s." lookup-dict)) - (error (concat "lookup-words error: No plain word-list found at system default " - "locations. Customize `ispell-alternate-dictionary' to set yours."))) + (error (concat "lookup-words error: No plain word-list found at system" + "default locations. " + "Customize `ispell-alternate-dictionary' to set yours."))) (let* ((process-connection-type ispell-use-ptys-p) (wild-p (string-match "\\*" word)) @@ -2332,16 +2339,16 @@ results)) -;;; "ispell-filter" is a list of output lines from the generating function. -;;; Each full line (ending with \n) is a separate item on the list. -;;; "output" can contain multiple lines, part of a line, or both. -;;; "start" and "end" are used to keep bounds on lines when "output" contains -;;; multiple lines. -;;; "ispell-filter-continue" is true when we have received only part of a -;;; line as output from a generating function ("output" did not end with \n) -;;; THIS FUNCTION WILL FAIL IF THE PROCESS OUTPUT DOESN'T END WITH \n! -;;; This is the case when a process dies or fails. The default behavior -;;; in this case treats the next input received as fresh input. +;; "ispell-filter" is a list of output lines from the generating function. +;; Each full line (ending with \n) is a separate item on the list. +;; "output" can contain multiple lines, part of a line, or both. +;; "start" and "end" are used to keep bounds on lines when "output" contains +;; multiple lines. +;; "ispell-filter-continue" is true when we have received only part of a +;; line as output from a generating function ("output" did not end with \n) +;; THIS FUNCTION WILL FAIL IF THE PROCESS OUTPUT DOESN'T END WITH \n! +;; This is the case when a process dies or fails. The default behavior +;; in this case treats the next input received as fresh input. (defun ispell-filter (process output) "Output filter function for ispell, grep, and look." @@ -2573,37 +2580,35 @@ (defun ispell-start-process () "Start the ispell process, with support for no asynchronous processes. Keeps argument list for future ispell invocations for no async support." - (let ((default-directory default-directory) - args) - (unless (and (file-directory-p default-directory) - (file-readable-p default-directory)) - ;; Defend against bad `default-directory'. - (setq default-directory (expand-file-name "~/"))) - ;; Local dictionary becomes the global dictionary in use. - (setq ispell-current-dictionary - (or ispell-local-dictionary ispell-dictionary)) - (setq ispell-current-personal-dictionary - (or ispell-local-pdict ispell-personal-dictionary)) - (setq args (ispell-get-ispell-args)) - (if (and ispell-current-dictionary ; use specified dictionary - (not (member "-d" args))) ; only define if not overridden - (setq args - (append (list "-d" ispell-current-dictionary) args))) - (if ispell-current-personal-dictionary ; use specified pers dict - (setq args - (append args - (list "-p" - (expand-file-name ispell-current-personal-dictionary))))) - - ;; If we are using recent aspell or hunspell, make sure we use the right encoding - ;; for communication. ispell or older aspell/hunspell does not support this - (if ispell-encoding8-command - (setq args - (append args - (list - (concat ispell-encoding8-command - (symbol-name (ispell-get-coding-system))))))) - (setq args (append args ispell-extra-args)) + ;; Local dictionary becomes the global dictionary in use. + (setq ispell-current-dictionary + (or ispell-local-dictionary ispell-dictionary)) + (setq ispell-current-personal-dictionary + (or ispell-local-pdict ispell-personal-dictionary)) + (let* ((default-directory + (if (and (file-directory-p default-directory) + (file-readable-p default-directory)) + default-directory + ;; Defend against bad `default-directory'. + (expand-file-name "~/"))) + (orig-args (ispell-get-ispell-args)) + (args + (append + (if (and ispell-current-dictionary ; Not for default dict (nil) + (not (member "-d" orig-args))) ; Only define if not overridden. + (list "-d" ispell-current-dictionary)) + orig-args + (if ispell-current-personal-dictionary ; Use specified pers dict. + (list "-p" + (expand-file-name ispell-current-personal-dictionary))) + ;; If we are using recent aspell or hunspell, make sure we use the + ;; right encoding for communication. ispell or older aspell/hunspell + ;; does not support this. + (if ispell-encoding8-command + (list + (concat ispell-encoding8-command + (symbol-name (ispell-get-coding-system))))) + ispell-extra-args))) ;; Initially we don't know any buffer's local words. (setq ispell-buffer-local-name nil) @@ -2612,9 +2617,11 @@ (let ((process-connection-type ispell-use-ptys-p)) (apply 'start-process "ispell" nil ispell-program-name - "-a" ; accept single input lines - (if ispell-really-hunspell "" "-m") ; make root/affix combos not in dict - args)) ; hunspell -m option means different + "-a" ; Accept single input lines. + ;; Make root/affix combos not in dict. + ;; hunspell -m option means different. + (if ispell-really-hunspell "" "-m") + args)) (setq ispell-cmd-args args ispell-output-buffer (generate-new-buffer " *ispell-output*") ispell-session-buffer (generate-new-buffer " *ispell-session*")) @@ -2622,79 +2629,107 @@ t))) - (defun ispell-init-process () "Check status of Ispell process and start if necessary." - (if (and ispell-process - (eq (ispell-process-status) 'run) - ;; Unless we are using an explicit personal dictionary, - ;; ensure we're in the same default directory! - ;; Restart check for personal dictionary is done in - ;; `ispell-internal-change-dictionary', called from `ispell-buffer-local-dict' - (or (or ispell-local-pdict ispell-personal-dictionary) - (equal ispell-process-directory (expand-file-name default-directory)))) - (setq ispell-filter nil ispell-filter-continue nil) - ;; may need to restart to select new personal dictionary. - (ispell-kill-ispell t) - (message "Starting new Ispell process [%s] ..." - (or ispell-local-dictionary ispell-dictionary "default")) - (sit-for 0) - (setq ispell-library-directory (ispell-check-version) - ispell-process (ispell-start-process) - ispell-filter nil - ispell-filter-continue nil) - ;; When spellchecking minibuffer contents, make sure ispell process - ;; is not restarted every time the minibuffer is killed. - (if (window-minibuffer-p) - (if (fboundp 'minibuffer-selected-window) - ;; Assign ispell process to parent buffer - (setq ispell-process-directory (expand-file-name default-directory) - ispell-process-buffer-name (window-buffer (minibuffer-selected-window))) - ;; Force `ispell-process-directory' to $HOME and use a dummy name - (setq ispell-process-directory (expand-file-name "~/") - ispell-process-buffer-name " * Minibuffer-has-spellcheck-enabled")) - ;; Not in a minibuffer - (setq ispell-process-directory (expand-file-name default-directory) - ispell-process-buffer-name (buffer-name))) - (if ispell-async-processp - (set-process-filter ispell-process 'ispell-filter)) - ;; protect against bogus binding of `enable-multibyte-characters' in XEmacs - (if (and (or (featurep 'xemacs) - (and (boundp 'enable-multibyte-characters) - enable-multibyte-characters)) - (fboundp 'set-process-coding-system)) - (set-process-coding-system ispell-process (ispell-get-coding-system) - (ispell-get-coding-system))) - ;; Get version ID line - (ispell-accept-output 3) - ;; get more output if filter empty? - (if (null ispell-filter) (ispell-accept-output 3)) - (cond ((null ispell-filter) - (error "%s did not output version line" ispell-program-name)) - ((and - (stringp (car ispell-filter)) - (if (string-match "warning: " (car ispell-filter)) - (progn - (ispell-accept-output 3) ; was warn msg. - (stringp (car ispell-filter))) - (null (cdr ispell-filter))) - (string-match "^@(#) " (car ispell-filter))) - ;; got the version line as expected (we already know it's the right - ;; version, so don't bother checking again.) - nil) - (t - ;; Otherwise, it must be an error message. Show the user. - ;; But first wait to see if some more output is going to arrive. - ;; Otherwise we get cool errors like "Can't open ". - (sleep-for 1) - (ispell-accept-output 3) - (error "%s" (mapconcat 'identity ispell-filter "\n")))) - (setq ispell-filter nil) ; Discard version ID line - (let ((extended-char-mode (ispell-get-extended-character-mode))) - (if extended-char-mode ; ~ extended character mode - (ispell-send-string (concat extended-char-mode "\n")))) - (if ispell-async-processp - (set-process-query-on-exit-flag ispell-process nil)))) + (let* (;; Basename of dictionary used by the spell-checker + (dict-bname (or (car (cdr (member "-d" (ispell-get-ispell-args)))) + ispell-current-dictionary)) + ;; Use "~/" as default-directory unless using Ispell with per-dir + ;; personal dictionaries and not in a minibuffer under XEmacs + (default-directory + (if (or ispell-really-aspell + ispell-really-hunspell + ;; Protect against bad default-directory + (not (and (file-directory-p default-directory) + (file-readable-p default-directory))) + ;; Ispell and per-dir personal dicts available + (not (or (file-readable-p (concat default-directory + ".ispell_words")) + (file-readable-p (concat default-directory + ".ispell_" + (or dict-bname + "default"))))) + ;; Ispell, in a minibuffer, and XEmacs + (and (window-minibuffer-p) + (not (fboundp 'minibuffer-selected-window)))) + (expand-file-name "~/") + (expand-file-name default-directory)))) + ;; Check if process needs restart + (if (and ispell-process + (eq (ispell-process-status) 'run) + ;; Unless we are using an explicit personal dictionary, ensure + ;; we're in the same default directory! Restart check for + ;; personal dictionary is done in + ;; `ispell-internal-change-dictionary', called from + ;; `ispell-buffer-local-dict' + (or (or ispell-local-pdict ispell-personal-dictionary) + (equal ispell-process-directory default-directory))) + (setq ispell-filter nil ispell-filter-continue nil) + ;; may need to restart to select new personal dictionary. + (ispell-kill-ispell t) + (message "Starting new Ispell process [%s] ..." + (or ispell-local-dictionary ispell-dictionary "default")) + (sit-for 0) + (setq ispell-library-directory (ispell-check-version) + ispell-process (ispell-start-process) + ispell-filter nil + ispell-filter-continue nil + ispell-process-directory default-directory) + + ;; Kill ispell process when killing its associated buffer if using Ispell + ;; per-directory personal dictionaries. + (unless (equal ispell-process-directory (expand-file-name "~/")) + (with-current-buffer + (if (and (window-minibuffer-p) + (fboundp 'minibuffer-selected-window)) ;; E.g. XEmacs. + ;; When spellchecking minibuffer contents, assign ispell + ;; process to parent buffer if known (not known for XEmacs). + ;; Use (buffer-name) otherwise. + (window-buffer (minibuffer-selected-window)) + (current-buffer)) + (add-hook 'kill-buffer-hook (lambda () (ispell-kill-ispell t)) + nil 'local))) + + (if ispell-async-processp + (set-process-filter ispell-process 'ispell-filter)) + ;; protect against bogus binding of `enable-multibyte-characters' in + ;; XEmacs. + (if (and (or (featurep 'xemacs) + (and (boundp 'enable-multibyte-characters) + enable-multibyte-characters)) + (fboundp 'set-process-coding-system)) + (set-process-coding-system ispell-process (ispell-get-coding-system) + (ispell-get-coding-system))) + ;; Get version ID line + (ispell-accept-output 3) + ;; get more output if filter empty? + (if (null ispell-filter) (ispell-accept-output 3)) + (cond ((null ispell-filter) + (error "%s did not output version line" ispell-program-name)) + ((and + (stringp (car ispell-filter)) + (if (string-match "warning: " (car ispell-filter)) + (progn + (ispell-accept-output 3) ; was warn msg. + (stringp (car ispell-filter))) + (null (cdr ispell-filter))) + (string-match "^@(#) " (car ispell-filter))) + ;; got the version line as expected (we already know it's the right + ;; version, so don't bother checking again.) + nil) + (t + ;; Otherwise, it must be an error message. Show the user. + ;; But first wait to see if some more output is going to arrive. + ;; Otherwise we get cool errors like "Can't open ". + (sleep-for 1) + (ispell-accept-output 3) + (error "%s" (mapconcat 'identity ispell-filter "\n")))) + (setq ispell-filter nil) ; Discard version ID line + (let ((extended-char-mode (ispell-get-extended-character-mode))) + (if extended-char-mode ; ~ extended character mode + (ispell-send-string (concat extended-char-mode "\n")))) + (if ispell-async-processp + (set-process-query-on-exit-flag ispell-process nil))))) ;;;###autoload (defun ispell-kill-ispell (&optional no-error) @@ -2716,17 +2751,10 @@ (kill-buffer ispell-session-buffer) (setq ispell-output-buffer nil ispell-session-buffer nil)) - (setq ispell-process-buffer-name nil) (setq ispell-process nil) (message "Ispell process killed") nil)) -;; Kill ispell process when killing its associated buffer -(add-hook 'kill-buffer-hook - '(lambda () - (if (equal ispell-process-buffer-name (buffer-name)) - (ispell-kill-ispell t)))) - ;;; ispell-change-dictionary is set in some people's hooks. Maybe this should ;;; call ispell-init-process rather than wait for a spell checking command? @@ -2823,9 +2851,10 @@ (set-marker skip-region-start (- (point) (length key))) (goto-char reg-start))) (let (message-log-max) - (message "Continuing spelling check using %s with %s dictionary..." - (file-name-nondirectory ispell-program-name) - (or ispell-current-dictionary "default"))) + (message + "Continuing spelling check using %s with %s dictionary..." + (file-name-nondirectory ispell-program-name) + (or ispell-current-dictionary "default"))) (set-marker rstart reg-start) (set-marker ispell-region-end reg-end) (while (and (not ispell-quit) @@ -3090,9 +3119,9 @@ (sit-for 2))))) -;;; Grab the next line of data. -;;; Returns a string with the line data (defun ispell-get-line (start end in-comment) + "Grab the next line of data. +Returns a string with the line data." (let ((ispell-casechars (ispell-get-casechars)) string) (cond ; LOOK AT THIS LINE AND SKIP OR PROCESS @@ -3119,7 +3148,8 @@ (point) (+ (point) len)) coding))))) -;;; Avoid error messages when compiling for these dynamic variables. +;; Avoid error messages when compiling for these dynamic variables. +;; FIXME: dynamically scoped vars should have an "ispell-" prefix. (defvar start) (defvar end) @@ -3254,10 +3284,12 @@ ;; (length (car poss))))) )) (if (not ispell-quit) + ;; FIXME: remove redundancy with identical code above. (let (message-log-max) - (message "Continuing spelling check using %s with %s dictionary..." - (file-name-nondirectory ispell-program-name) - (or ispell-current-dictionary "default")))) + (message + "Continuing spelling check using %s with %s dictionary..." + (file-name-nondirectory ispell-program-name) + (or ispell-current-dictionary "default")))) (sit-for 0) (setq start (marker-position line-start) end (marker-position line-end)) @@ -3330,7 +3362,7 @@ ;;; Interactive word completion. -;;; Forces "previous-word" processing. Do we want to make this selectable? +;; Forces "previous-word" processing. Do we want to make this selectable? ;;;###autoload (defun ispell-complete-word (&optional interior-frag)
--- a/lisp/textmodes/nroff-mode.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/textmodes/nroff-mode.el Wed Sep 08 12:55:57 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/lisp/w32-fns.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/w32-fns.el Wed Sep 08 12:55:57 2010 +0900 @@ -425,40 +425,32 @@ 'w32-charset-info-alist "21.1") -;;;; Selections and cut buffers +;;;; Selections ;; We keep track of the last text selected here, so we can check the ;; current selection against it, and avoid passing back our own text -;; from x-cut-buffer-or-selection-value. +;; from x-selection-value. (defvar x-last-selected-text nil) -;; It is said that overlarge strings are slow to put into the cut buffer. -;; Note this value is overridden below. -(defvar x-cut-buffer-max 20000 - "Max number of characters to put in the cut buffer.") - -(defun x-select-text (text &optional push) +(defun x-select-text (text) "Select TEXT, a string, according to the window system. -On X, put TEXT in the primary X selection. For backward -compatibility with older X applications, set the value of X cut -buffer 0 as well, and if the optional argument PUSH is non-nil, -rotate the cut buffers. If `x-select-enable-clipboard' is -non-nil, copy the text to the X clipboard as well. +On X, if `x-select-enable-clipboard' is non-nil, copy TEXT to the +clipboard. If `x-select-enable-primary' is non-nil, put TEXT in +the primary selection. On Windows, make TEXT the current selection. If `x-select-enable-clipboard' is non-nil, copy the text to the -clipboard as well. The argument PUSH is ignored. +clipboard as well. -On Nextstep, put TEXT in the pasteboard; PUSH is ignored." +On Nextstep, put TEXT in the pasteboard." (if x-select-enable-clipboard (w32-set-clipboard-data text)) (setq x-last-selected-text text)) (defun x-get-selection-value () "Return the value of the current selection. -Consult the selection, then the cut buffer. Treat empty strings as if -they were unset." +Consult the selection. Treat empty strings as if they were unset." (if x-select-enable-clipboard (let (text) ;; Don't die if x-get-selection signals an error. @@ -476,7 +468,7 @@ (t (setq x-last-selected-text text)))))) -(defalias 'x-cut-buffer-or-selection-value 'x-get-selection-value) +(defalias 'x-selection-value 'x-get-selection-value) ;; Arrange for the kill and yank functions to set and check the clipboard. (setq interprogram-cut-function 'x-select-text)
--- a/lisp/window.el Wed Sep 01 11:03:05 2010 +0900 +++ b/lisp/window.el Wed Sep 08 12:55:57 2010 +0900 @@ -55,6 +55,7 @@ its normal operation could make a different buffer current. The order of recently selected windows and the buffer list ordering are not altered by this macro (unless they are altered in BODY)." + (declare (indent 0) (debug t)) `(let ((save-selected-window-window (selected-window)) ;; It is necessary to save all of these, because calling ;; select-window changes frame-selected-window for whatever
--- a/src/ChangeLog Wed Sep 01 11:03:05 2010 +0900 +++ b/src/ChangeLog Wed Sep 08 12:55:57 2010 +0900 @@ -1,8 +1,111 @@ +2010-09-05 Juanma Barranquero <lekktu@gmail.com> + + * biditype.h: Regenerate. + +2010-09-04 Andreas Schwab <schwab@linux-m68k.org> + + * nsimage.m (ns_load_image): Check argument types. + + * image.c: Remove all uses of gcpro. + (xpm_load): Check all lisp types. + (pbm_load): Likewise. + (png_load): Likewise. + (jpeg_load): Likewise. + (tiff_load): Likewise. + (gif_load): Likewise. + (imagemagick_load_image): Likewise. + (imagemagick_load): Likewise. + (svg_load): Likewise. + (gs_load): Likewise. + +2010-09-04 Eli Zaretskii <eliz@gnu.org> + + * w32uniscribe.c (uniscribe_shape): Update commentary. Don't + try to reorder grapheme clusters, since LGSTRING should always + hold them in the logical order. + (uniscribe_encode_char, uniscribe_shape): Force ScriptShape to + return glyph codes in the logical order. + +2010-09-04 Andreas Schwab <schwab@linux-m68k.org> + + * image.c (imagemagick_image_p): Replace bcopy by memcpy. + (imagemagick_load_image): Fix type mismatch. + (Fimagemagick_types): Likewise. Doc fix. + +2010-09-02 Jan Djärv <jan.h.d@swipnet.se> + + * xterm.h (struct dpyinfo): Remove cut_buffers_initialized. + + * xterm.c (x_term_init): Don't set dpyinfo->cut_buffers_initialized. + + * xselect.c: Remove declaration of cut-buffer objects and functions. + (symbol_to_x_atom): Remove mapping to XA_CUT_BUFFERn. + (x_atom_to_symbol): Remove mapping to QCUT_BUFFERn. + (Fx_get_cut_buffer_internal, Fx_store_cut_buffer_internal) + (Fx_rotate_cut_buffers_internal): Remove. + (syms_of_xselect): Remove defsubr of above. + Remove intern of QCUT_BUFFERn. + +2010-09-01 Stefan Monnier <monnier@iro.umontreal.ca> + + * cmds.c (Vblink_paren_function): Remove. + (internal_self_insert): Make it insert N chars at a time. + Don't call blink-paren-function. + (Fself_insert_command): Adjust accordingly. + (syms_of_cmds): Don't declare blink-paren-function. + +2010-08-31 Kenichi Handa <handa@m17n.org> + + * dispextern.h (FACE_FOR_CHAR): Use an ASCII face for 8-bit + characters. + + * term.c (encode_terminal_code): Fix the previous change. + (produce_glyphs): Don't set it->char_to_display here. Don't + handle unibyte-display-via-language-environment here. + (produce_special_glyphs): Set temp_it.char_to_display before + calling produce_glyphs. + + * xdisp.c (get_next_display_element): Set it->char_to_display + here. Convert all 8-bit bytes from unibyte buffer/string to 8-bit + characters. + (get_overlay_arrow_glyph_row): Set it.char_to_display too before + calling PRODUCE_GLYPHS. + (append_space_for_newline): Save and store it->char_to_display. + Set it->char_to_display before calling PRODUCE_GLYPHS. + (extend_face_to_end_of_line): Set it->char_to_display before + calling PRODUCE_GLYPHS. + (get_glyph_face_and_encoding): Set the glyph code an 8-bit + character to its byte value. + (get_char_glyph_code): New function. + (produce_stretch_glyph): Set it2.char_to_display too before + calling x_produce_glyphs. + (x_produce_glyphs): Simplify by using the same code for ASCII and + non-ASCII characters. Don't set it->char_to_display here. Don't + handle unibyte-display-via-language-environment here. For a + charater of no glyph, use font->space_width instead of FONT_WIDTH. + +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. + 2010-08-30 Kenichi Handa <handa@m17n.org> * composite.c (composition_update_it): Fix computing of cmp_it->width. +2010-08-29 Kenichi Handa <handa@m17n.org> + + * term.c (encode_terminal_code): Encode byte chars to the + correspnding bytes. + 2010-08-29 Jan Djärv <jan.h.d@swipnet.se> * nsterm.m (ns_draw_window_cursor): Draw BAR_CURSOR correct for R2L.
--- a/src/biditype.h Wed Sep 01 11:03:05 2010 +0900 +++ b/src/biditype.h Wed Sep 08 12:55:57 2010 +0900 @@ -83,7 +83,8 @@ { 0x0671, 0x06D5, STRONG_AL }, { 0x06D6, 0x06DC, WEAK_NSM }, { 0x06DD, 0x06DD, WEAK_AN }, - { 0x06DE, 0x06E4, WEAK_NSM }, + { 0x06DE, 0x06DE, NEUTRAL_ON }, + { 0x06DF, 0x06E4, WEAK_NSM }, { 0x06E5, 0x06E6, STRONG_AL }, { 0x06E7, 0x06E8, WEAK_NSM }, { 0x06E9, 0x06E9, NEUTRAL_ON }, @@ -271,7 +272,7 @@ { 0x2080, 0x2089, WEAK_EN }, { 0x208A, 0x208B, WEAK_ES }, { 0x208C, 0x208E, NEUTRAL_ON }, - { 0x20A0, 0x20B8, WEAK_ET }, + { 0x20A0, 0x20B9, WEAK_ET }, { 0x20D0, 0x20F0, WEAK_NSM }, { 0x2100, 0x2101, NEUTRAL_ON }, { 0x2103, 0x2106, NEUTRAL_ON },
--- a/src/cmds.c Wed Sep 01 11:03:05 2010 +0900 +++ b/src/cmds.c Wed Sep 08 12:55:57 2010 +0900 @@ -32,7 +32,7 @@ #include "dispextern.h" #include "frame.h" -Lisp_Object Qkill_forward_chars, Qkill_backward_chars, Vblink_paren_function; +Lisp_Object Qkill_forward_chars, Qkill_backward_chars; /* A possible value for a buffer's overwrite-mode variable. */ Lisp_Object Qoverwrite_mode_binary; @@ -304,36 +304,16 @@ { int character = translate_char (Vtranslation_table_for_input, XINT (last_command_event)); - if (XINT (n) >= 2 && NILP (current_buffer->overwrite_mode)) - { - XSETFASTINT (n, XFASTINT (n) - 2); - /* The first one might want to expand an abbrev. */ - internal_self_insert (character, 1); - /* The bulk of the copies of this char can be inserted simply. - We don't have to handle a user-specified face specially - because it will get inherited from the first char inserted. */ - Finsert_char (make_number (character), n, Qt); - /* The last one might want to auto-fill. */ - internal_self_insert (character, 0); - } - else - while (XINT (n) > 0) - { - int val; - /* Ok since old and new vals both nonneg */ - XSETFASTINT (n, XFASTINT (n) - 1); - val = internal_self_insert (character, XFASTINT (n) != 0); - if (val == 2) - nonundocount = 0; - frame_make_pointer_invisible (); - } + int val = internal_self_insert (character, XFASTINT (n)); + if (val == 2) + nonundocount = 0; + frame_make_pointer_invisible (); } return Qnil; } -/* Insert character C. If NOAUTOFILL is nonzero, don't do autofill - even if it is enabled. +/* Insert N times character C If this insertion is suitable for direct output (completely simple), return 0. A value of 1 indicates this *might* not have been simple. @@ -343,12 +323,12 @@ static Lisp_Object Qpost_self_insert_hook, Vpost_self_insert_hook; static int -internal_self_insert (int c, int noautofill) +internal_self_insert (int c, int n) { int hairy = 0; Lisp_Object tem; register enum syntaxcode synt; - Lisp_Object overwrite, string; + Lisp_Object overwrite; /* Length of multi-byte form of C. */ int len; /* Working buffer and pointer for multi-byte form of C. */ @@ -391,32 +371,22 @@ /* This is the character after point. */ int c2 = FETCH_CHAR (PT_BYTE); - /* Column the cursor should be placed at after this insertion. - The correct value should be calculated only when necessary. */ - int target_clm = 0; - /* Overwriting in binary-mode always replaces C2 by C. Overwriting in textual-mode doesn't always do that. It inserts newlines in the usual way, and inserts any character at end of line or before a tab if it doesn't use the whole width of the tab. */ - if (EQ (overwrite, Qoverwrite_mode_binary) - || (c != '\n' - && c2 != '\n' - && ! (c2 == '\t' - && XINT (current_buffer->tab_width) > 0 - && XFASTINT (current_buffer->tab_width) < 20 - && (target_clm = ((int) current_column () /* iftc */ - + XINT (Fchar_width (make_number (c)))), - target_clm % XFASTINT (current_buffer->tab_width))))) + if (EQ (overwrite, Qoverwrite_mode_binary)) + chars_to_delete = n; + else if (c != '\n' && c2 != '\n') { int pos = PT; int pos_byte = PT_BYTE; + /* Column the cursor should be placed at after this insertion. + The correct value should be calculated only when necessary. */ + int target_clm = ((int) current_column () /* iftc */ + + n * XINT (Fchar_width (make_number (c)))); - if (target_clm == 0) - chars_to_delete = 1; - else - { /* The actual cursor position after the trial of moving to column TARGET_CLM. It is greater than TARGET_CLM if the TARGET_CLM is middle of multi-column @@ -428,14 +398,18 @@ chars_to_delete = PT - pos; if (actual_clm > target_clm) - { - /* We will delete too many columns. Let's fill columns + { /* We will delete too many columns. Let's fill columns by spaces so that the remaining text won't move. */ + EMACS_INT actual = PT_BYTE; + DEC_POS (actual); + if (FETCH_CHAR (actual) == '\t') + /* Rather than add spaces, let's just keep the tab. */ + chars_to_delete--; + else spaces_to_insert = actual_clm - target_clm; } - } + SET_PT_BOTH (pos, pos_byte); - hairy = 2; } hairy = 2; } @@ -474,16 +448,30 @@ if (chars_to_delete) { - string = make_string_from_bytes (str, 1, len); + int mc = ((NILP (current_buffer->enable_multibyte_characters) + && SINGLE_BYTE_CHAR_P (c)) + ? UNIBYTE_TO_CHAR (c) : c); + Lisp_Object string = Fmake_string (make_number (n), make_number (mc)); + if (spaces_to_insert) { tem = Fmake_string (make_number (spaces_to_insert), make_number (' ')); - string = concat2 (tem, string); + string = concat2 (string, tem); } replace_range (PT, PT + chars_to_delete, string, 1, 1, 1); - Fforward_char (make_number (1 + spaces_to_insert)); + Fforward_char (make_number (n + spaces_to_insert)); + } + else if (n > 1) + { + USE_SAFE_ALLOCA; + unsigned char *strn, *p; + SAFE_ALLOCA (strn, unsigned char*, n * len); + for (p = strn; n > 0; n--, p += len) + memcpy (p, str, len); + insert_and_inherit (strn, p - strn); + SAFE_FREE (); } else insert_and_inherit (str, len); @@ -491,7 +479,6 @@ if ((CHAR_TABLE_P (Vauto_fill_chars) ? !NILP (CHAR_TABLE_REF (Vauto_fill_chars, c)) : (c == ' ' || c == '\n')) - && !noautofill && !NILP (current_buffer->auto_fill_function)) { Lisp_Object tem; @@ -509,13 +496,6 @@ hairy = 2; } - if ((synt == Sclose || synt == Smath) - && !NILP (Vblink_paren_function) && INTERACTIVE - && !noautofill) - { - call0 (Vblink_paren_function); - hairy = 2; - } /* Run hooks for electric keys. */ call1 (Vrun_hooks, Qpost_self_insert_hook); @@ -547,11 +527,6 @@ This run is run after inserting the charater. */); Vpost_self_insert_hook = Qnil; - DEFVAR_LISP ("blink-paren-function", &Vblink_paren_function, - doc: /* Function called, if non-nil, whenever a close parenthesis is inserted. -More precisely, a char with closeparen syntax is self-inserted. */); - Vblink_paren_function = Qnil; - defsubr (&Sforward_point); defsubr (&Sforward_char); defsubr (&Sbackward_char);
--- a/src/dispextern.h Wed Sep 01 11:03:05 2010 +0900 +++ b/src/dispextern.h Wed Sep 08 12:55:57 2010 +0900 @@ -1718,7 +1718,7 @@ This macro is only meaningful for multibyte character CHAR. */ #define FACE_FOR_CHAR(F, FACE, CHAR, POS, OBJECT) \ - (ASCII_CHAR_P (CHAR) \ + ((ASCII_CHAR_P (CHAR) || CHAR_BYTE8_P (CHAR)) \ ? (FACE)->ascii_face->id \ : face_for_char ((F), (FACE), (CHAR), (POS), (OBJECT))) @@ -2275,9 +2275,11 @@ composition. */ struct composition_it cmp_it; - /* The character to display, possibly translated to multibyte - if unibyte_display_via_language_environment is set. This - is set after produce_glyphs has been called. */ + /* The character to display, possibly translated to multibyte if + multibyte_p is zero or unibyte_display_via_language_environment + is set. This is set after get_next_display_element has been + called. If we are setting it->C directly before calling + PRODUCE_GLYPHS, this should be set beforehand too. */ int char_to_display; /* If what == IT_IMAGE, the id of the image to display. */
--- a/src/image.c Wed Sep 01 11:03:05 2010 +0900 +++ b/src/image.c Wed Sep 08 12:55:57 2010 +0900 @@ -1735,7 +1735,6 @@ struct image_cache *c; struct image *img; unsigned hash; - struct gcpro gcpro1; EMACS_TIME now; /* F must be a window-system frame, and SPEC must be a valid image @@ -1745,8 +1744,6 @@ c = FRAME_IMAGE_CACHE (f); - GCPRO1 (spec); - /* Look up SPEC in the hash table of the image cache. */ hash = sxhash (spec, 0); img = search_image_cache (f, spec, hash); @@ -1838,8 +1835,6 @@ EMACS_GET_TIME (now); img->timestamp = EMACS_SECS (now); - UNGCPRO; - /* Value is the image id. */ return img->id; } @@ -2179,16 +2174,13 @@ x_find_image_file (Lisp_Object file) { Lisp_Object file_found, search_path; - struct gcpro gcpro1, gcpro2; int fd; - file_found = Qnil; /* TODO I think this should use something like image-load-path instead. Unfortunately, that can contain non-string elements. */ search_path = Fcons (Fexpand_file_name (build_string ("images"), Vdata_directory), Vx_bitmap_file_path); - GCPRO2 (file_found, search_path); /* Try to find FILE in data-directory/images, then x-bitmap-file-path. */ fd = openp (search_path, file, Qnil, &file_found, Qnil); @@ -2201,7 +2193,6 @@ close (fd); } - UNGCPRO; return file_found; } @@ -2875,14 +2866,11 @@ Lisp_Object file; unsigned char *contents; int size; - struct gcpro gcpro1; file = x_find_image_file (file_name); - GCPRO1 (file); if (!STRINGP (file)) { image_error ("Cannot find image file `%s'", file_name, Qnil); - UNGCPRO; return 0; } @@ -2890,12 +2878,10 @@ if (contents == NULL) { image_error ("Error loading XBM image `%s'", img->spec, Qnil); - UNGCPRO; return 0; } success_p = xbm_load_image (f, img, contents, contents + size); - UNGCPRO; } else { @@ -3456,12 +3442,31 @@ CONSP (tail); ++i, tail = XCDR (tail)) { - Lisp_Object name = XCAR (XCAR (tail)); - Lisp_Object color = XCDR (XCAR (tail)); - xpm_syms[i].name = (char *) alloca (SCHARS (name) + 1); - strcpy (xpm_syms[i].name, SDATA (name)); - xpm_syms[i].value = (char *) alloca (SCHARS (color) + 1); - strcpy (xpm_syms[i].value, SDATA (color)); + Lisp_Object name; + Lisp_Object color; + + if (!CONSP (XCAR (tail))) + { + xpm_syms[i].name = ""; + xpm_syms[i].value = ""; + continue; + } + name = XCAR (XCAR (tail)); + color = XCDR (XCAR (tail)); + if (STRINGP (name)) + { + xpm_syms[i].name = (char *) alloca (SCHARS (name) + 1); + strcpy (xpm_syms[i].name, SDATA (name)); + } + else + xpm_syms[i].name = ""; + if (STRINGP (color)) + { + xpm_syms[i].value = (char *) alloca (SCHARS (color) + 1); + strcpy (xpm_syms[i].value, SDATA (color)); + } + else + xpm_syms[i].value = ""; } } @@ -3487,6 +3492,9 @@ if (!STRINGP (file)) { image_error ("Cannot find image file `%s'", specified_file, Qnil); +#ifdef ALLOC_XPM_COLORS + xpm_free_color_cache (); +#endif return 0; } @@ -3505,6 +3513,14 @@ else { Lisp_Object buffer = image_spec_value (img->spec, QCdata, NULL); + if (!STRINGP (buffer)) + { + image_error ("Invalid image data `%s'", buffer, Qnil); +#ifdef ALLOC_XPM_COLORS + xpm_free_color_cache (); +#endif + return 0; + } #ifdef HAVE_NTGUI /* XpmCreatePixmapFromBuffer is not available in the Windows port of libxpm. But XpmCreateImageFromBuffer almost does what we want. */ @@ -4071,14 +4087,11 @@ Lisp_Object file; unsigned char *contents; int size; - struct gcpro gcpro1; file = x_find_image_file (file_name); - GCPRO1 (file); if (!STRINGP (file)) { image_error ("Cannot find image file `%s'", file_name, Qnil); - UNGCPRO; return 0; } @@ -4086,19 +4099,22 @@ if (contents == NULL) { image_error ("Error loading XPM image `%s'", img->spec, Qnil); - UNGCPRO; return 0; } success_p = xpm_load_image (f, img, contents, contents + size); xfree (contents); - UNGCPRO; } else { Lisp_Object data; data = image_spec_value (img->spec, QCdata, NULL); + if (!STRINGP (data)) + { + image_error ("Invalid image data `%s'", data, Qnil); + return 0; + } success_p = xpm_load_image (f, img, SDATA (data), SDATA (data) + SBYTES (data)); } @@ -5090,14 +5106,11 @@ XImagePtr ximg; Lisp_Object file, specified_file; enum {PBM_MONO, PBM_GRAY, PBM_COLOR} type; - struct gcpro gcpro1; unsigned char *contents = NULL; unsigned char *end, *p; int size; specified_file = image_spec_value (img->spec, QCfile, NULL); - file = Qnil; - GCPRO1 (file); if (STRINGP (specified_file)) { @@ -5105,7 +5118,6 @@ if (!STRINGP (file)) { image_error ("Cannot find image file `%s'", specified_file, Qnil); - UNGCPRO; return 0; } @@ -5113,7 +5125,6 @@ if (contents == NULL) { image_error ("Error reading `%s'", file, Qnil); - UNGCPRO; return 0; } @@ -5124,6 +5135,11 @@ { Lisp_Object data; data = image_spec_value (img->spec, QCdata, NULL); + if (!STRINGP (data)) + { + image_error ("Invalid image data `%s'", data, Qnil); + return 0; + } p = SDATA (data); end = p + SBYTES (data); } @@ -5134,7 +5150,6 @@ image_error ("Not a PBM image: `%s'", img->spec, Qnil); error: xfree (contents); - UNGCPRO; return 0; } @@ -5336,7 +5351,6 @@ img->width = width; img->height = height; */ - UNGCPRO; xfree (contents); return 1; } @@ -5576,7 +5590,6 @@ Lisp_Object specified_data; int x, y, i; XImagePtr ximg, mask_img = NULL; - struct gcpro gcpro1; png_struct *png_ptr = NULL; png_info *info_ptr = NULL, *end_info = NULL; FILE *volatile fp = NULL; @@ -5593,8 +5606,6 @@ /* Find out what file to load. */ specified_file = image_spec_value (img->spec, QCfile, NULL); specified_data = image_spec_value (img->spec, QCdata, NULL); - file = Qnil; - GCPRO1 (file); if (NILP (specified_data)) { @@ -5602,7 +5613,6 @@ if (!STRINGP (file)) { image_error ("Cannot find image file `%s'", specified_file, Qnil); - UNGCPRO; return 0; } @@ -5611,7 +5621,6 @@ if (!fp) { image_error ("Cannot open image file `%s'", file, Qnil); - UNGCPRO; return 0; } @@ -5620,13 +5629,18 @@ || fn_png_sig_cmp (sig, 0, sizeof sig)) { image_error ("Not a PNG file: `%s'", file, Qnil); - UNGCPRO; fclose (fp); return 0; } } else { + if (!STRINGP (specified_data)) + { + image_error ("Invalid image data `%s'", specified_data, Qnil); + return 0; + } + /* Read from memory. */ tbr.bytes = SDATA (specified_data); tbr.len = SBYTES (specified_data); @@ -5637,7 +5651,6 @@ || fn_png_sig_cmp (tbr.bytes, 0, sizeof sig)) { image_error ("Not a PNG image: `%s'", img->spec, Qnil); - UNGCPRO; return 0; } @@ -5653,7 +5666,6 @@ if (!png_ptr) { if (fp) fclose (fp); - UNGCPRO; return 0; } @@ -5663,7 +5675,6 @@ { fn_png_destroy_read_struct (&png_ptr, NULL, NULL); if (fp) fclose (fp); - UNGCPRO; return 0; } @@ -5673,7 +5684,6 @@ { fn_png_destroy_read_struct (&png_ptr, &info_ptr, NULL); if (fp) fclose (fp); - UNGCPRO; return 0; } @@ -5687,7 +5697,6 @@ xfree (pixels); xfree (rows); if (fp) fclose (fp); - UNGCPRO; return 0; } @@ -5912,7 +5921,6 @@ x_destroy_x_image (mask_img); } - UNGCPRO; return 1; } @@ -6313,13 +6321,10 @@ int rc; unsigned long *colors; int width, height; - struct gcpro gcpro1; /* Open the JPEG file. */ specified_file = image_spec_value (img->spec, QCfile, NULL); specified_data = image_spec_value (img->spec, QCdata, NULL); - file = Qnil; - GCPRO1 (file); if (NILP (specified_data)) { @@ -6327,7 +6332,6 @@ if (!STRINGP (file)) { image_error ("Cannot find image file `%s'", specified_file, Qnil); - UNGCPRO; return 0; } @@ -6335,10 +6339,14 @@ if (fp == NULL) { image_error ("Cannot open `%s'", file, Qnil); - UNGCPRO; return 0; } } + else if (!STRINGP (specified_data)) + { + image_error ("Invalid image data `%s'", specified_data, Qnil); + return 0; + } /* Customize libjpeg's error handling to call my_error_exit when an error is detected. This function will perform a longjmp. @@ -6367,8 +6375,6 @@ /* Free pixmap and colors. */ x_clear_image (f, img); - - UNGCPRO; return 0; } @@ -6466,7 +6472,6 @@ /* Put the image into the pixmap. */ x_put_x_image (f, ximg, img->pixmap, width, height); x_destroy_x_image (ximg); - UNGCPRO; return 1; } @@ -6741,14 +6746,11 @@ uint32 *buf; int rc, rc2; XImagePtr ximg; - struct gcpro gcpro1; tiff_memory_source memsrc; Lisp_Object image; specified_file = image_spec_value (img->spec, QCfile, NULL); specified_data = image_spec_value (img->spec, QCdata, NULL); - file = Qnil; - GCPRO1 (file); fn_TIFFSetErrorHandler (tiff_error_handler); fn_TIFFSetWarningHandler (tiff_warning_handler); @@ -6760,7 +6762,6 @@ if (!STRINGP (file)) { image_error ("Cannot find image file `%s'", specified_file, Qnil); - UNGCPRO; return 0; } @@ -6770,12 +6771,17 @@ if (tiff == NULL) { image_error ("Cannot open `%s'", file, Qnil); - UNGCPRO; return 0; } } else { + if (!STRINGP (specified_data)) + { + image_error ("Invalid image data `%s'", specified_data, Qnil); + return 0; + } + /* Memory source! */ memsrc.bytes = SDATA (specified_data); memsrc.len = SBYTES (specified_data); @@ -6794,7 +6800,6 @@ if (!tiff) { image_error ("Cannot open memory source for `%s'", img->spec, Qnil); - UNGCPRO; return 0; } } @@ -6808,7 +6813,6 @@ image_error ("Invalid image number `%s' in image `%s'", image, img->spec); fn_TIFFClose (tiff); - UNGCPRO; return 0; } } @@ -6822,7 +6826,6 @@ { image_error ("Invalid image size (see `max-image-size')", Qnil, Qnil); fn_TIFFClose (tiff); - UNGCPRO; return 0; } @@ -6844,7 +6847,6 @@ { image_error ("Error reading TIFF image `%s'", img->spec, Qnil); xfree (buf); - UNGCPRO; return 0; } @@ -6852,7 +6854,6 @@ if (!x_create_x_image_and_pixmap (f, width, height, 0, &ximg, &img->pixmap)) { xfree (buf); - UNGCPRO; return 0; } @@ -6893,7 +6894,6 @@ x_destroy_x_image (ximg); xfree (buf); - UNGCPRO; return 1; } @@ -7099,7 +7099,6 @@ ColorMapObject *gif_color_map; unsigned long pixel_colors[256]; GifFileType *gif; - struct gcpro gcpro1; Lisp_Object image; int ino, image_height, image_width; gif_memory_source memsrc; @@ -7107,8 +7106,6 @@ specified_file = image_spec_value (img->spec, QCfile, NULL); specified_data = image_spec_value (img->spec, QCdata, NULL); - file = Qnil; - GCPRO1 (file); if (NILP (specified_data)) { @@ -7116,7 +7113,6 @@ if (!STRINGP (file)) { image_error ("Cannot find image file `%s'", specified_file, Qnil); - UNGCPRO; return 0; } @@ -7126,12 +7122,17 @@ if (gif == NULL) { image_error ("Cannot open `%s'", file, Qnil); - UNGCPRO; return 0; } } else { + if (!STRINGP (specified_data)) + { + image_error ("Invalid image data `%s'", specified_data, Qnil); + return 0; + } + /* Read from memory! */ current_gif_memory_src = &memsrc; memsrc.bytes = SDATA (specified_data); @@ -7143,7 +7144,6 @@ if (!gif) { image_error ("Cannot open memory source `%s'", img->spec, Qnil); - UNGCPRO; return 0; } } @@ -7153,7 +7153,6 @@ { image_error ("Invalid image size (see `max-image-size')", Qnil, Qnil); fn_DGifCloseFile (gif); - UNGCPRO; return 0; } @@ -7163,7 +7162,6 @@ { image_error ("Error reading `%s'", img->spec, Qnil); fn_DGifCloseFile (gif); - UNGCPRO; return 0; } @@ -7174,7 +7172,6 @@ image_error ("Invalid image number `%s' in image `%s'", image, img->spec); fn_DGifCloseFile (gif); - UNGCPRO; return 0; } @@ -7196,7 +7193,6 @@ { image_error ("Invalid image size (see `max-image-size')", Qnil, Qnil); fn_DGifCloseFile (gif); - UNGCPRO; return 0; } @@ -7204,7 +7200,6 @@ if (!x_create_x_image_and_pixmap (f, width, height, 0, &ximg, &img->pixmap)) { fn_DGifCloseFile (gif); - UNGCPRO; return 0; } @@ -7323,7 +7318,6 @@ x_put_x_image (f, ximg, img->pixmap, width, height); x_destroy_x_image (ximg); - UNGCPRO; return 1; } @@ -7389,9 +7383,9 @@ {":heuristic-mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, {":mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, {":background", IMAGE_STRING_OR_NIL_VALUE, 0}, - {":height", IMAGE_INTEGER_VALUE, 0}, - {":width", IMAGE_INTEGER_VALUE, 0}, - {":rotation", IMAGE_NUMBER_VALUE, 0}, + {":height", IMAGE_INTEGER_VALUE, 0}, + {":width", IMAGE_INTEGER_VALUE, 0}, + {":rotation", IMAGE_NUMBER_VALUE, 0}, {":crop", IMAGE_DONT_CHECK_VALUE_TYPE, 0} }; /* Free X resources of imagemagick image IMG which is used on frame F. */ @@ -7413,7 +7407,7 @@ imagemagick_image_p (Lisp_Object object) { struct image_keyword fmt[IMAGEMAGICK_LAST]; - bcopy (imagemagick_format, fmt, sizeof fmt); + memcpy (fmt, imagemagick_format, sizeof fmt); if (!parse_image_spec (object, fmt, IMAGEMAGICK_LAST, Qimagemagick)) return 0; @@ -7440,7 +7434,7 @@ imagemagick_load_image (/* Pointer to emacs frame structure. */ struct frame *f, /* Pointer to emacs image structure. */ - struct image *img, + struct image *img, /* String containing the IMAGEMAGICK data to be parsed. */ unsigned char *contents, @@ -7450,8 +7444,8 @@ contents/size. */ unsigned char *filename) { - size_t width; - size_t height; + unsigned long width; + unsigned long height; MagickBooleanType status; @@ -7463,52 +7457,52 @@ int y; MagickWand *image_wand; - MagickWand *ping_wand; + MagickWand *ping_wand; PixelIterator *iterator; PixelWand **pixels; MagickPixelPacket pixel; Lisp_Object image; - Lisp_Object value; + Lisp_Object value; Lisp_Object crop, geometry; long ino; int desired_width, desired_height; double rotation; int imagemagick_rendermethod; - int pixelwidth; + int pixelwidth; ImageInfo *image_info; ExceptionInfo *exception; Image * im_image; - + /* Handle image index for image types who can contain more than one image. Interface :index is same as for GIF. First we "ping" the image to see how many sub-images it contains. Pinging is faster than loading the image to find out things about it. */ image = image_spec_value (img->spec, QCindex, NULL); ino = INTEGERP (image) ? XFASTINT (image) : 0; - ping_wand=NewMagickWand(); - MagickSetResolution(ping_wand, 2, 2); + ping_wand = NewMagickWand (); + MagickSetResolution (ping_wand, 2, 2); if (filename != NULL) { - status = MagickPingImage(ping_wand, filename); + status = MagickPingImage (ping_wand, filename); } else { - status = MagickPingImageBlob(ping_wand, contents, size); - } - - if (ino >= MagickGetNumberImages(ping_wand)) - { - image_error ("Invalid image number `%s' in image `%s'", - image, img->spec); - UNGCPRO; - return 0; - } + status = MagickPingImageBlob (ping_wand, contents, size); + } + + if (ino >= MagickGetNumberImages (ping_wand)) + { + image_error ("Invalid image number `%s' in image `%s'", + image, img->spec); + DestroyMagickWand (ping_wand); + return 0; + } if (MagickGetNumberImages(ping_wand) > 1) img->data.lisp_val = Fcons (Qcount, - Fcons (make_number (MagickGetNumberImages(ping_wand)), + Fcons (make_number (MagickGetNumberImages (ping_wand)), img->data.lisp_val)); DestroyMagickWand (ping_wand); @@ -7517,21 +7511,21 @@ if (filename != NULL) { - image_info=CloneImageInfo((ImageInfo *) NULL); - (void) strcpy(image_info->filename, filename); - image_info -> number_scenes = 1; - image_info -> scene = ino; - exception=AcquireExceptionInfo(); - - im_image = ReadImage (image_info, exception); - CatchException(exception); - - image_wand = NewMagickWandFromImage(im_image); + image_info = CloneImageInfo ((ImageInfo *) NULL); + (void) strcpy (image_info->filename, filename); + image_info->number_scenes = 1; + image_info->scene = ino; + exception = AcquireExceptionInfo (); + + im_image = ReadImage (image_info, exception); + CatchException (exception); + + image_wand = NewMagickWandFromImage (im_image); } else { - image_wand = NewMagickWand(); - status = MagickReadImageBlob(image_wand, contents, size); + image_wand = NewMagickWand (); + status = MagickReadImageBlob (image_wand, contents, size); } image_error ("im read failed", Qnil, Qnil); if (status == MagickFalse) goto imagemagick_error; @@ -7552,44 +7546,56 @@ if(desired_width != -1 && desired_height == -1) { /* w known, calculate h. */ - desired_height = ( (double)desired_width / width ) * height; + desired_height = (double) desired_width / width * height; } if(desired_width == -1 && desired_height != -1) { /* h known, calculate w. */ - desired_width = ( (double)desired_height / height ) * width; - } + desired_width = (double) desired_height / height * width; + } if(desired_width != -1 && desired_height != -1) { - status = MagickScaleImage(image_wand, desired_width, desired_height); - if (status == MagickFalse) { - image_error ("Imagemagick scale failed", Qnil, Qnil); - goto imagemagick_error; - } + status = MagickScaleImage (image_wand, desired_width, desired_height); + if (status == MagickFalse) + { + image_error ("Imagemagick scale failed", Qnil, Qnil); + goto imagemagick_error; + } } /* crop behaves similar to image slicing in Emacs but is more memory - efficient */ - crop = image_spec_value (img->spec, QCcrop, NULL); - - if(CONSP (crop)) - { - /* - after some testing, it seems MagickCropImage is the fastest - crop function in ImageMagick. This crop function seems to do + efficient. */ + crop = image_spec_value (img->spec, QCcrop, NULL); + + if (CONSP (crop) && INTEGERP (XCAR (crop))) + { + /* After some testing, it seems MagickCropImage is the fastest + crop function in ImageMagick. This crop function seems to do less copying than the alternatives, but it still reads the entire image into memory before croping, which is aparently - difficult to avoid when using imagemagick. */ - - int w,h,x,y; - w=XFASTINT(XCAR(crop)); - h=XFASTINT(XCAR(XCDR(crop))); - x=XFASTINT(XCAR(XCDR(XCDR(crop)))); - y=XFASTINT(XCAR(XCDR(XCDR(XCDR(crop))))); - MagickCropImage(image_wand, w,h, x,y); - } - + difficult to avoid when using imagemagick. */ + + int w, h, x, y; + w = XFASTINT (XCAR (crop)); + crop = XCDR (crop); + if (CONSP (crop) && INTEGERP (XCAR (crop))) + { + h = XFASTINT (XCAR (crop)); + crop = XCDR (crop); + if (CONSP (crop) && INTEGERP (XCAR (crop))) + { + x = XFASTINT (XCAR (crop)); + crop = XCDR (crop); + if (CONSP (crop) && INTEGERP (XCAR (crop))) + { + y = XFASTINT (XCAR (crop)); + MagickCropImage (image_wand, w, h, x, y); + } + } + } + } + /* Furthermore :rotation. we need background color and angle for rotation. */ /* @@ -7599,11 +7605,11 @@ value = image_spec_value (img->spec, QCrotation, NULL); if (FLOATP (value)) { - PixelWand* background = NewPixelWand(); + PixelWand* background = NewPixelWand (); PixelSetColor (background, "#ffffff");/*TODO remove hardcode*/ - + rotation = extract_float (value); - + status = MagickRotateImage (image_wand, background, rotation); DestroyPixelWand (background); if (status == MagickFalse) @@ -7612,23 +7618,23 @@ goto imagemagick_error; } } - + /* Finaly we are done manipulating the image, figure out resulting width, height, and then transfer ownerwship to Emacs. */ height = MagickGetImageHeight (image_wand); width = MagickGetImageWidth (image_wand); if (status == MagickFalse) { - image_error ("Imagemagick image get size failed", Qnil, Qnil); + image_error ("Imagemagick image get size failed", Qnil, Qnil); goto imagemagick_error; } - + if (! check_image_size (f, width, height)) { image_error ("Invalid image size (see `max-image-size')", Qnil, Qnil); goto imagemagick_error; } - + /* We can now get a valid pixel buffer from the imagemagick file, if all went ok. */ @@ -7644,24 +7650,24 @@ image_error("Imagemagick X bitmap allocation failure", Qnil, Qnil); goto imagemagick_error; } - + /* Copy imagegmagick image to x with primitive yet robust pixel pusher loop. This has been tested a lot with many different images. */ - + /* Copy pixels from the imagemagick image structure to the x image map. */ iterator = NewPixelIterator (image_wand); - if ((iterator == (PixelIterator *) NULL)) + if (iterator == (PixelIterator *) NULL) { image_error ("Imagemagick pixel iterator creation failed", Qnil, Qnil); goto imagemagick_error; } - for (y = 0; y < (long) MagickGetImageHeight(image_wand); y++) + for (y = 0; y < (long) MagickGetImageHeight (image_wand); y++) { pixels = PixelGetNextIteratorRow (iterator, &width); - if ((pixels == (PixelWand **) NULL)) + if (pixels == (PixelWand **) NULL) break; for (x = 0; x < (long) width; x++) { @@ -7685,12 +7691,13 @@ char* exportdepth = imagedepth <= 8 ? "I" : "BGRP";/*"RGBP";*/ /* Try to create a x pixmap to hold the imagemagick pixmap. */ if (!x_create_x_image_and_pixmap (f, width, height, imagedepth, - &ximg, &img->pixmap)){ - image_error("Imagemagick X bitmap allocation failure", Qnil, Qnil); - goto imagemagick_error; - } - - + &ximg, &img->pixmap)) + { + image_error("Imagemagick X bitmap allocation failure", Qnil, Qnil); + goto imagemagick_error; + } + + /* Oddly, the below code doesnt seem to work:*/ /* switch(ximg->bitmap_unit){ */ /* case 8: */ @@ -7711,20 +7718,20 @@ seems about 3 times as fast as pixel pushing(not carefully measured) */ pixelwidth = CharPixel;/*??? TODO figure out*/ -#ifdef HAVE_MAGICKEXPORTIMAGEPIXELS - MagickExportImagePixels(image_wand, - 0, 0, - width, height, - exportdepth, - pixelwidth, - /*&(img->pixmap));*/ - ximg->data); +#ifdef HAVE_MAGICKEXPORTIMAGEPIXELS + MagickExportImagePixels (image_wand, + 0, 0, + width, height, + exportdepth, + pixelwidth, + /*&(img->pixmap));*/ + ximg->data); #else - image_error("You dont have MagickExportImagePixels, upgrade ImageMagick!", - Qnil, Qnil); -#endif - } - + image_error ("You dont have MagickExportImagePixels, upgrade ImageMagick!", + Qnil, Qnil); +#endif + } + #ifdef COLOR_TABLE_SUPPORT /* Remember colors allocated for this image. */ @@ -7770,20 +7777,14 @@ if (STRINGP (file_name)) { Lisp_Object file; - unsigned char *contents; - int size; - struct gcpro gcpro1; file = x_find_image_file (file_name); - GCPRO1 (file); if (!STRINGP (file)) { image_error ("Cannot find image file `%s'", file_name, Qnil); - UNGCPRO; return 0; } - success_p = imagemagick_load_image (f, img, 0, 0, SDATA(file_name)); - UNGCPRO; + success_p = imagemagick_load_image (f, img, 0, 0, SDATA (file)); } /* Else its not a file, its a lisp object. Load the image from a lisp object rather than a file. */ @@ -7792,6 +7793,11 @@ Lisp_Object data; data = image_spec_value (img->spec, QCdata, NULL); + if (!STRINGP (data)) + { + image_error ("Invalid image data `%s'", data, Qnil); + return 0; + } success_p = imagemagick_load_image (f, img, SDATA (data), SBYTES (data), NULL); } @@ -7823,16 +7829,16 @@ -DEFUN ("imagemagick-types", Fimagemagick_types, Simagemagick_types, 0, 0, 0, +DEFUN ("imagemagick-types", Fimagemagick_types, Simagemagick_types, 0, 0, 0, doc: /* Return image file types supported by ImageMagick. - Since ImageMagick recognizes a lot of file-types that clash with Emacs, - such as .c, we want to be able to alter the list at the lisp level. */) +Since ImageMagick recognizes a lot of file-types that clash with Emacs, +such as .c, we want to be able to alter the list at the lisp level. */) (void) { Lisp_Object typelist = Qnil; - size_t numf; + unsigned long numf; ExceptionInfo ex; - char** imtypes = GetMagickList ("*", &numf, &ex); + char **imtypes = GetMagickList ("*", &numf, &ex); int i; Lisp_Object Qimagemagicktype; for (i = 0; i < numf; i++) @@ -7842,7 +7848,7 @@ } return typelist; } - + #endif /* defined (HAVE_IMAGEMAGICK) */ @@ -8038,14 +8044,11 @@ Lisp_Object file; unsigned char *contents; int size; - struct gcpro gcpro1; file = x_find_image_file (file_name); - GCPRO1 (file); if (!STRINGP (file)) { image_error ("Cannot find image file `%s'", file_name, Qnil); - UNGCPRO; return 0; } @@ -8054,13 +8057,11 @@ if (contents == NULL) { image_error ("Error loading SVG image `%s'", img->spec, Qnil); - UNGCPRO; return 0; } /* If the file was slurped into memory properly, parse it. */ success_p = svg_load_image (f, img, contents, size); xfree (contents); - UNGCPRO; } /* Else its not a file, its a lisp object. Load the image from a lisp object rather than a file. */ @@ -8069,6 +8070,11 @@ Lisp_Object data; data = image_spec_value (img->spec, QCdata, NULL); + if (!STRINGP (data)) + { + image_error ("Invalid image data `%s'", data, Qnil); + return 0; + } success_p = svg_load_image (f, img, SDATA (data), SBYTES (data)); } @@ -8368,7 +8374,6 @@ { char buffer[100]; Lisp_Object window_and_pixmap_id = Qnil, loader, pt_height, pt_width; - struct gcpro gcpro1, gcpro2; Lisp_Object frame; double in_width, in_height; Lisp_Object pixel_colors = Qnil; @@ -8378,10 +8383,10 @@ = 1/72 in, xdpi and ydpi are stored in the frame's X display info. */ pt_width = image_spec_value (img->spec, QCpt_width, NULL); - in_width = XFASTINT (pt_width) / 72.0; + in_width = INTEGERP (pt_width) ? XFASTINT (pt_width) / 72.0 : 0; img->width = in_width * FRAME_X_DISPLAY_INFO (f)->resx; pt_height = image_spec_value (img->spec, QCpt_height, NULL); - in_height = XFASTINT (pt_height) / 72.0; + in_height = INTEGERP (pt_height) ? XFASTINT (pt_height) / 72.0 : 0; img->height = in_height * FRAME_X_DISPLAY_INFO (f)->resy; if (!check_image_size (f, img->width, img->height)) @@ -8410,8 +8415,6 @@ if successful. We do not record_unwind_protect here because other places in redisplay like calling window scroll functions don't either. Let the Lisp loader use `unwind-protect' instead. */ - GCPRO2 (window_and_pixmap_id, pixel_colors); - sprintf (buffer, "%lu %lu", (unsigned long) FRAME_X_WINDOW (f), (unsigned long) img->pixmap); @@ -8432,7 +8435,6 @@ make_number (img->height), window_and_pixmap_id, pixel_colors); - UNGCPRO; return PROCESSP (img->data.lisp_val); } @@ -8622,12 +8624,13 @@ #endif #if defined (HAVE_IMAGEMAGICK) - if (EQ (type, Qimagemagick)){ - /* MagickWandGenesis() initalizes the imagemagick library. */ - MagickWandGenesis(); - return CHECK_LIB_AVAILABLE (&imagemagick_type, init_imagemagick_functions, - libraries); - } + if (EQ (type, Qimagemagick)) + { + /* MagickWandGenesis() initalizes the imagemagick library. */ + MagickWandGenesis (); + return CHECK_LIB_AVAILABLE (&imagemagick_type, init_imagemagick_functions, + libraries); + } #endif #ifdef HAVE_GHOSTSCRIPT @@ -8786,7 +8789,7 @@ staticpro (&Qimagemagick); ADD_IMAGE_TYPE (Qimagemagick); #endif - + #if defined (HAVE_RSVG) Qsvg = intern_c_string ("svg"); staticpro (&Qsvg); @@ -8803,9 +8806,9 @@ #endif /* HAVE_RSVG */ defsubr (&Sinit_image_library); -#ifdef HAVE_IMAGEMAGICK +#ifdef HAVE_IMAGEMAGICK defsubr (&Simagemagick_types); -#endif +#endif defsubr (&Sclear_image_cache); defsubr (&Simage_flush); defsubr (&Simage_size); @@ -8836,10 +8839,10 @@ The function `clear-image-cache' disregards this variable. */); Vimage_cache_eviction_delay = make_number (300); -#ifdef HAVE_IMAGEMAGICK +#ifdef HAVE_IMAGEMAGICK DEFVAR_LISP ("imagemagick-render-type", &Vimagemagick_render_type, doc: /* Choose between ImageMagick render methods. */); -#endif +#endif }
--- a/src/keyboard.c Wed Sep 01 11:03:05 2010 +0900 +++ b/src/keyboard.c Wed Sep 08 12:55:57 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));
--- a/src/marker.c Wed Sep 01 11:03:05 2010 +0900 +++ b/src/marker.c Wed Sep 08 12:55:57 2010 +0900 @@ -806,16 +806,18 @@ return i; } -DEFUN ("copy-marker", Fcopy_marker, Scopy_marker, 1, 2, 0, +DEFUN ("copy-marker", Fcopy_marker, Scopy_marker, 0, 2, 0, doc: /* Return a new marker pointing at the same place as MARKER. If argument is a number, makes a new marker pointing at that position in the current buffer. +If MARKER is not specified, the new marker does not point anywhere. The optional argument TYPE specifies the insertion type of the new marker; see `marker-insertion-type'. */) (register Lisp_Object marker, Lisp_Object type) { register Lisp_Object new; + if (!NILP (marker)) CHECK_TYPE (INTEGERP (marker) || MARKERP (marker), Qinteger_or_marker_p, marker); new = Fmake_marker ();
--- a/src/nsimage.m Wed Sep 01 11:03:05 2010 +0900 +++ b/src/nsimage.m Wed Sep 08 12:55:57 2010 +0900 @@ -83,19 +83,21 @@ ns_load_image (struct frame *f, struct image *img, Lisp_Object spec_file, Lisp_Object spec_data) { - EmacsImage *eImg; + EmacsImage *eImg = nil; NSSize size; NSTRACE (ns_load_image); - if (NILP (spec_data)) + if (STRINGP (spec_file)) { eImg = [EmacsImage allocInitFromFile: spec_file]; } - else + else if (STRINGP (spec_data)) { - NSData *data = [NSData dataWithBytes: SDATA (spec_data) - length: SBYTES (spec_data)]; + NSData *data; + + data = [NSData dataWithBytes: SDATA (spec_data) + length: SBYTES (spec_data)]; eImg = [[EmacsImage alloc] initWithData: data]; [eImg setPixmapData]; }
--- a/src/term.c Wed Sep 01 11:03:05 2010 +0900 +++ b/src/term.c Wed Sep 08 12:55:57 2010 +0900 @@ -689,7 +689,8 @@ encode_terminal_src_size); buf = encode_terminal_src + nbytes; } - if (char_charset (c, charset_list, NULL)) + if (CHAR_BYTE8_P (c) + || char_charset (c, charset_list, NULL)) { /* Store the multibyte form of C at BUF. */ buf += CHAR_STRING (c, buf); @@ -1614,18 +1615,15 @@ goto done; } - /* Maybe translate single-byte characters to multibyte. */ - it->char_to_display = it->c; - - if (it->c >= 040 && it->c < 0177) + if (it->char_to_display >= 040 && it->char_to_display < 0177) { it->pixel_width = it->nglyphs = 1; if (it->glyph_row) append_glyph (it); } - else if (it->c == '\n') + else if (it->char_to_display == '\n') it->pixel_width = it->nglyphs = 0; - else if (it->c == '\t') + else if (it->char_to_display == '\t') { int absolute_x = (it->current_x + it->continuation_lines_width); @@ -1656,32 +1654,19 @@ it->pixel_width = nspaces; it->nglyphs = nspaces; } - else if (CHAR_BYTE8_P (it->c)) + else if (CHAR_BYTE8_P (it->char_to_display)) { - if (unibyte_display_via_language_environment - && (it->c >= 0240)) - { - it->char_to_display = BYTE8_TO_CHAR (it->c); - it->pixel_width = CHAR_WIDTH (it->char_to_display); - it->nglyphs = it->pixel_width; - if (it->glyph_row) - append_glyph (it); - } - else - { - /* Coming here means that it->c is from display table, thus - we must send the raw 8-bit byte as is to the terminal. - Although there's no way to know how many columns it - occupies on a screen, it is a good assumption that a - single byte code has 1-column width. */ - it->pixel_width = it->nglyphs = 1; - if (it->glyph_row) - append_glyph (it); - } + /* Coming here means that we must send the raw 8-bit byte as is + to the terminal. Although there's no way to know how many + columns it occupies on a screen, it is a good assumption that + a single byte code has 1-column width. */ + it->pixel_width = it->nglyphs = 1; + if (it->glyph_row) + append_glyph (it); } else { - it->pixel_width = CHAR_WIDTH (it->c); + it->pixel_width = CHAR_WIDTH (it->char_to_display); it->nglyphs = it->pixel_width; if (it->glyph_row) @@ -1917,7 +1902,7 @@ else abort (); - temp_it.c = GLYPH_CHAR (glyph); + temp_it.c = temp_it.char_to_display = GLYPH_CHAR (glyph); temp_it.face_id = GLYPH_FACE (glyph); temp_it.len = CHAR_BYTES (temp_it.c);
--- a/src/w32uniscribe.c Wed Sep 01 11:03:05 2010 +0900 +++ b/src/w32uniscribe.c Wed Sep 08 12:55:57 2010 +0900 @@ -180,17 +180,18 @@ /* Uniscribe implementation of shape for font backend. - Shape text in LGSTRING. See the docstring of `font-make-gstring' - for the format of LGSTRING. If the (N+1)th element of LGSTRING - is nil, input of shaping is from the 1st to (N)th elements. In - each input glyph, FROM, TO, CHAR, and CODE are already set. + Shape text in LGSTRING. See the docstring of + `composition-get-gstring' for the format of LGSTRING. If the + (N+1)th element of LGSTRING is nil, input of shaping is from the + 1st to (N)th elements. In each input glyph, FROM, TO, CHAR, and + CODE are already set. This function updates all fields of the input glyphs. If the output glyphs (M) are more than the input glyphs (N), (N+1)th through (M)th elements of LGSTRING are updated possibly by making a new glyph object and storing it in LGSTRING. If (M) is greater - than the length of LGSTRING, nil should be return. In that case, - this function is called again with the larger LGSTRING. */ + than the length of LGSTRING, nil should be returned. In that case, + this function is called again with a larger LGSTRING. */ static Lisp_Object uniscribe_shape (Lisp_Object lgstring) { @@ -217,6 +218,9 @@ max_glyphs = nchars = LGSTRING_GLYPH_LEN (lgstring); done_glyphs = 0; chars = (wchar_t *) alloca (nchars * sizeof (wchar_t)); + /* FIXME: This loop assumes that characters in the input LGSTRING + are all inside the BMP. Need to encode characters beyond the BMP + as UTF-16. */ for (i = 0; i < nchars; i++) { /* lgstring can be bigger than the number of characters in it, in @@ -248,9 +252,6 @@ return Qnil; } - /* TODO: When we get BIDI support, we need to call ScriptLayout here. - Requires that we know the surrounding context. */ - glyphs = alloca (max_glyphs * sizeof (WORD)); clusters = alloca (nchars * sizeof (WORD)); attributes = alloca (max_glyphs * sizeof (SCRIPT_VISATTR)); @@ -259,8 +260,12 @@ for (i = 0; i < nitems; i++) { - int nglyphs, nchars_in_run, rtl = items[i].a.fRTL ? -1 : 1; + int nglyphs, nchars_in_run; nchars_in_run = items[i+1].iCharPos - items[i].iCharPos; + /* Force ScriptShape to generate glyphs in the same order as + they are in the input LGSTRING, which is in the logical + order. */ + items[i].a.fLogicalOrder = 1; /* Context may be NULL here, in which case the cache should be used without needing to select the font. */ @@ -321,7 +326,7 @@ { int j, nclusters, from, to; - from = rtl > 0 ? 0 : nchars_in_run - 1; + from = 0; to = from; for (j = 0; j < nglyphs; j++) @@ -342,22 +347,19 @@ gl = glyphs[j]; LGLYPH_SET_CODE (lglyph, gl); - /* Detect clusters, for linking codes back to characters. */ + /* Detect clusters, for linking codes back to + characters. */ if (attributes[j].fClusterStart) { - while (from >= 0 && from < nchars_in_run - && clusters[from] < j) - from += rtl; - if (from < 0) - from = to = 0; - else if (from >= nchars_in_run) + while (from < nchars_in_run && clusters[from] < j) + from++; + if (from >= nchars_in_run) from = to = nchars_in_run - 1; else { int k; - to = rtl > 0 ? nchars_in_run - 1 : 0; - for (k = from + rtl; k >= 0 && k < nchars_in_run; - k += rtl) + to = nchars_in_run - 1; + for (k = from + 1; k < nchars_in_run; k++) { if (clusters[k] > j) { @@ -486,6 +488,10 @@ SCRIPT_VISATTR attrs[2]; int nglyphs; + /* Force ScriptShape to generate glyphs in the logical + order. */ + items[0].a.fLogicalOrder = 1; + result = ScriptShape (context, &(uniscribe_font->cache), ch, len, 2, &(items[0].a), glyphs, clusters, attrs, &nglyphs);
--- a/src/xdisp.c Wed Sep 01 11:03:05 2010 +0900 +++ b/src/xdisp.c Wed Sep 08 12:55:57 2010 +0900 @@ -5762,10 +5762,23 @@ struct charset *unibyte = CHARSET_FROM_ID (charset_unibyte); enum { char_is_other = 0, char_is_nbsp, char_is_soft_hyphen } nbsp_or_shy = char_is_other; - int decoded = it->c; + int c = it->c; /* This is the character to display. */ + + if (! it->multibyte_p && ! ASCII_CHAR_P (c)) + { + xassert (SINGLE_BYTE_CHAR_P (c)); + if (unibyte_display_via_language_environment) + { + c = DECODE_CHAR (unibyte, c); + if (c < 0) + c = BYTE8_TO_CHAR (it->c); + } + else + c = BYTE8_TO_CHAR (it->c); + } if (it->dp - && (dv = DISP_CHAR_VECTOR (it->dp, it->c), + && (dv = DISP_CHAR_VECTOR (it->dp, c), VECTORP (dv))) { struct Lisp_Vector *v = XVECTOR (dv); @@ -5791,21 +5804,10 @@ goto get_next; } - if (unibyte_display_via_language_environment - && !ASCII_CHAR_P (it->c)) - decoded = DECODE_CHAR (unibyte, it->c); - - if (it->c >= 0x80 && ! NILP (Vnobreak_char_display)) - { - if (it->multibyte_p) - nbsp_or_shy = (it->c == 0xA0 ? char_is_nbsp - : it->c == 0xAD ? char_is_soft_hyphen - : char_is_other); - else if (unibyte_display_via_language_environment) - nbsp_or_shy = (decoded == 0xA0 ? char_is_nbsp - : decoded == 0xAD ? char_is_soft_hyphen - : char_is_other); - } + if (! ASCII_CHAR_P (c) && ! NILP (Vnobreak_char_display)) + nbsp_or_shy = (c == 0xA0 ? char_is_nbsp + : c == 0xAD ? char_is_soft_hyphen + : char_is_other); /* Translate control characters into `\003' or `^C' form. Control characters coming from a display table entry are @@ -5813,27 +5815,23 @@ the translation. This could easily be changed but I don't believe that it is worth doing. - If it->multibyte_p is nonzero, non-printable non-ASCII - characters are also translated to octal form. - - If it->multibyte_p is zero, eight-bit characters that - don't have corresponding multibyte char code are also + NBSP and SOFT-HYPEN are property translated too. + + Non-printable characters and raw-byte characters are also translated to octal form. */ - if ((it->c < ' ' + if (((c < ' ' || c == 127) /* ASCII control chars */ ? (it->area != TEXT_AREA /* In mode line, treat \n, \t like other crl chars. */ - || (it->c != '\t' + || (c != '\t' && it->glyph_row && (it->glyph_row->mode_line_p || it->avoid_cursor_p)) - || (it->c != '\n' && it->c != '\t')) + || (c != '\n' && c != '\t')) : (nbsp_or_shy - || (it->multibyte_p - ? ! CHAR_PRINTABLE_P (it->c) - : (! unibyte_display_via_language_environment - ? it->c >= 0x80 - : (decoded >= 0x80 && decoded < 0xA0)))))) - { - /* IT->c is a control character which must be displayed + || CHAR_BYTE8_P (c) + || ! CHAR_PRINTABLE_P (c)))) + { + /* C is a control character, NBSP, SOFT-HYPEN, raw-byte, + or a non-printable character which must be displayed either as '\003' or as `^C' where the '\\' and '^' can be defined in the display table. Fill IT->ctl_chars with glyphs for what we have to @@ -5845,7 +5843,7 @@ /* Handle control characters with ^. */ - if (it->c < 128 && it->ctl_arrow_p) + if (ASCII_CHAR_P (c) && it->ctl_arrow_p) { int g; @@ -5878,7 +5876,7 @@ } XSETINT (it->ctl_chars[0], g); - XSETINT (it->ctl_chars[1], it->c ^ 0100); + XSETINT (it->ctl_chars[1], c ^ 0100); ctl_len = 2; goto display_control; } @@ -5893,7 +5891,7 @@ face_id = merge_faces (it->f, Qnobreak_space, 0, it->face_id); - it->c = ' '; + c = ' '; XSETINT (it->ctl_chars[0], ' '); ctl_len = 1; goto display_control; @@ -5939,7 +5937,6 @@ if (EQ (Vnobreak_char_display, Qt) && nbsp_or_shy == char_is_soft_hyphen) { - it->c = '-'; XSETINT (it->ctl_chars[0], '-'); ctl_len = 1; goto display_control; @@ -5951,55 +5948,25 @@ if (nbsp_or_shy) { XSETINT (it->ctl_chars[0], escape_glyph); - it->c = (nbsp_or_shy == char_is_nbsp ? ' ' : '-'); - XSETINT (it->ctl_chars[1], it->c); + c = (nbsp_or_shy == char_is_nbsp ? ' ' : '-'); + XSETINT (it->ctl_chars[1], c); ctl_len = 2; goto display_control; } { - unsigned char str[MAX_MULTIBYTE_LENGTH]; - int len; - int i; - - /* Set IT->ctl_chars[0] to the glyph for `\\'. */ - if (CHAR_BYTE8_P (it->c)) - { - str[0] = CHAR_TO_BYTE8 (it->c); - len = 1; - } - else if (it->c < 256) - { - str[0] = it->c; - len = 1; - } - else - { - /* It's an invalid character, which shouldn't - happen actually, but due to bugs it may - happen. Let's print the char as is, there's - not much meaningful we can do with it. */ - str[0] = it->c; - str[1] = it->c >> 8; - str[2] = it->c >> 16; - str[3] = it->c >> 24; - len = 4; - } - + char str[10]; + int len, i; + + if (CHAR_BYTE8_P (c)) + /* Display \200 instead of \17777600. */ + c = CHAR_TO_BYTE8 (c); + len = sprintf (str, "%03o", c); + + XSETINT (it->ctl_chars[0], escape_glyph); for (i = 0; i < len; i++) - { - int g; - XSETINT (it->ctl_chars[i * 4], escape_glyph); - /* Insert three more glyphs into IT->ctl_chars for - the octal display of the character. */ - g = ((str[i] >> 6) & 7) + '0'; - XSETINT (it->ctl_chars[i * 4 + 1], g); - g = ((str[i] >> 3) & 7) + '0'; - XSETINT (it->ctl_chars[i * 4 + 2], g); - g = (str[i] & 7) + '0'; - XSETINT (it->ctl_chars[i * 4 + 3], g); - } - ctl_len = len * 4; + XSETINT (it->ctl_chars[i + 1], str[i]); + ctl_len = len + 1; } display_control: @@ -6014,6 +5981,11 @@ it->ellipsis_p = 0; goto get_next; } + it->char_to_display = c; + } + else if (success_p) + { + it->char_to_display = it->c; } } @@ -6040,7 +6012,8 @@ : STRINGP (it->string) ? IT_STRING_CHARPOS (*it) : IT_CHARPOS (*it)); - it->face_id = FACE_FOR_CHAR (it->f, face, it->c, pos, it->string); + it->face_id = FACE_FOR_CHAR (it->f, face, it->char_to_display, pos, + it->string); } } #endif @@ -16481,15 +16454,19 @@ /* Get the next character. */ if (multibyte_p) - it.c = string_char_and_length (p, &it.len); - else - it.c = *p, it.len = 1; + it.c = it.char_to_display = string_char_and_length (p, &it.len); + else + { + it.c = it.char_to_display = *p, it.len = 1; + if (! ASCII_CHAR_P (it.c)) + it.char_to_display = BYTE8_TO_CHAR (it.c); + } p += it.len; /* Get its face. */ ilisp = make_number (p - arrow_string); face = Fget_text_property (ilisp, Qface, overlay_arrow_string); - it.face_id = compute_char_face (f, it.c, face); + it.face_id = compute_char_face (f, it.char_to_display, face); /* Compute its width, get its glyphs. */ n_glyphs_before = it.glyph_row->used[TEXT_AREA]; @@ -16721,6 +16698,7 @@ append_space_for_newline has been called. */ enum display_element_type saved_what = it->what; int saved_c = it->c, saved_len = it->len; + int saved_char_to_display = it->char_to_display; int saved_x = it->current_x; int saved_face_id = it->face_id; struct text_pos saved_pos; @@ -16733,7 +16711,7 @@ it->what = IT_CHARACTER; memset (&it->position, 0, sizeof it->position); it->object = make_number (0); - it->c = ' '; + it->c = it->char_to_display = ' '; it->len = 1; if (default_face_p) @@ -16754,6 +16732,7 @@ it->face_id = saved_face_id; it->len = saved_len; it->c = saved_c; + it->char_to_display = saved_char_to_display; return 1; } } @@ -16886,7 +16865,7 @@ it->what = IT_CHARACTER; memset (&it->position, 0, sizeof it->position); it->object = make_number (0); - it->c = ' '; + it->c = it->char_to_display = ' '; it->len = 1; /* The last row's blank glyphs should get the default face, to avoid painting the rest of the window with the region face, @@ -20490,7 +20469,12 @@ if (face->font) { - unsigned code = face->font->driver->encode_char (face->font, glyph->u.ch); + unsigned code; + + if (CHAR_BYTE8_P (glyph->u.ch)) + code = CHAR_TO_BYTE8 (glyph->u.ch); + else + code = face->font->driver->encode_char (face->font, glyph->u.ch); if (code != FONT_INVALID_CODE) STORE_XCHAR2B (char2b, (code >> 8), (code & 0xFF)); @@ -20505,6 +20489,26 @@ } +/* Get glyph code of character C in FONT in the two-byte form CHAR2B. + Retunr 1 if FONT has a glyph for C, otherwise return 0. */ + +static INLINE int +get_char_glyph_code (int c, struct font *font, XChar2b *char2b) +{ + unsigned code; + + if (CHAR_BYTE8_P (c)) + code = CHAR_TO_BYTE8 (c); + else + code = font->driver->encode_char (font, c); + + if (code == FONT_INVALID_CODE) + return 0; + STORE_XCHAR2B (char2b, (code >> 8), (code & 0xFF)); + return 1; +} + + /* Fill glyph string S with composition components specified by S->cmp. BASE_FACE is the base face of the composition. @@ -21909,10 +21913,14 @@ { int maxlen = ((IT_BYTEPOS (*it) >= GPT ? ZV : GPT) - IT_BYTEPOS (*it)); - it2.c = STRING_CHAR_AND_LENGTH (p, it2.len); - } - else - it2.c = *p, it2.len = 1; + it2.c = it2.char_to_display = STRING_CHAR_AND_LENGTH (p, it2.len); + } + else + { + it2.c = it2.char_to_display = *p, it2.len = 1; + if (! ASCII_CHAR_P (it2.c)) + it2.char_to_display = BYTE8_TO_CHAR (it2.c); + } it2.glyph_row = NULL; it2.what = IT_CHARACTER; @@ -22082,49 +22090,12 @@ if (it->what == IT_CHARACTER) { XChar2b char2b; - struct font *font; struct face *face = FACE_FROM_ID (it->f, it->face_id); - struct font_metrics *pcm; - int font_not_found_p; + struct font *font = face->font; + int font_not_found_p = font == NULL; + struct font_metrics *pcm = NULL; int boff; /* baseline offset */ - /* We may change it->multibyte_p upon unibyte<->multibyte - conversion. So, save the current value now and restore it - later. - - Note: It seems that we don't have to record multibyte_p in - struct glyph because the character code itself tells whether - or not the character is multibyte. Thus, in the future, we - must consider eliminating the field `multibyte_p' in the - struct glyph. */ - int saved_multibyte_p = it->multibyte_p; - - /* Maybe translate single-byte characters to multibyte, or the - other way. */ - it->char_to_display = it->c; - if (!ASCII_BYTE_P (it->c) - && ! it->multibyte_p) - { - if (SINGLE_BYTE_CHAR_P (it->c) - && unibyte_display_via_language_environment) - { - struct charset *unibyte = CHARSET_FROM_ID (charset_unibyte); - - /* get_next_display_element assures that this decoding - never fails. */ - it->char_to_display = DECODE_CHAR (unibyte, it->c); - it->multibyte_p = 1; - it->face_id = FACE_FOR_CHAR (it->f, face, it->char_to_display, - -1, Qnil); - face = FACE_FROM_ID (it->f, it->face_id); - } - } - - /* Get font to use. Encode IT->char_to_display. */ - get_char_face_and_encoding (it->f, it->char_to_display, it->face_id, - &char2b, it->multibyte_p, 0); - font = face->font; - - font_not_found_p = font == NULL; + if (font_not_found_p) { /* When no suitable font found, display an empty box based @@ -22144,16 +22115,12 @@ boff = VCENTER_BASELINE_OFFSET (font, it->f) - boff; } - if (it->char_to_display >= ' ' - && (!it->multibyte_p || it->char_to_display < 128)) - { - /* Either unibyte or ASCII. */ + if (it->char_to_display != '\n' && it->char_to_display != '\t') + { int stretched_p; it->nglyphs = 1; - pcm = get_per_char_metric (it->f, font, &char2b); - if (it->override_ascent >= 0) { it->ascent = it->override_ascent; @@ -22166,6 +22133,15 @@ it->descent = FONT_DESCENT (font) - boff; } + if (! font_not_found_p + && get_char_glyph_code (it->char_to_display, font, &char2b)) + { + pcm = get_per_char_metric (it->f, font, &char2b); + if (pcm->width == 0 + && pcm->rbearing == 0 && pcm->lbearing == 0) + pcm = NULL; + } + if (pcm) { it->phys_ascent = pcm->ascent + boff; @@ -22177,7 +22153,7 @@ it->glyph_not_available_p = 1; it->phys_ascent = it->ascent; it->phys_descent = it->descent; - it->pixel_width = FONT_WIDTH (font); + it->pixel_width = font->space_width; } if (it->constrain_row_ascent_descent_p) @@ -22351,7 +22327,7 @@ } } } - else if (it->char_to_display == '\t') + else /* i.e. (it->char_to_display == '\t') */ { if (font->space_width > 0) { @@ -22382,85 +22358,6 @@ it->nglyphs = 1; } } - else - { - /* A multi-byte character. Assume that the display width of the - character is the width of the character multiplied by the - width of the font. */ - - /* If we found a font, this font should give us the right - metrics. If we didn't find a font, use the frame's - default font and calculate the width of the character by - multiplying the width of font by the width of the - character. */ - - pcm = get_per_char_metric (it->f, font, &char2b); - - if (font_not_found_p || !pcm) - { - int char_width = CHAR_WIDTH (it->char_to_display); - - if (char_width == 0) - /* This is a non spacing character. But, as we are - going to display an empty box, the box must occupy - at least one column. */ - char_width = 1; - it->glyph_not_available_p = 1; - it->pixel_width = font->space_width * char_width; - it->phys_ascent = FONT_BASE (font) + boff; - it->phys_descent = FONT_DESCENT (font) - boff; - } - else - { - it->pixel_width = pcm->width; - it->phys_ascent = pcm->ascent + boff; - it->phys_descent = pcm->descent - boff; - if (it->glyph_row - && (pcm->lbearing < 0 - || pcm->rbearing > pcm->width)) - it->glyph_row->contains_overlapping_glyphs_p = 1; - } - it->nglyphs = 1; - it->ascent = FONT_BASE (font) + boff; - it->descent = FONT_DESCENT (font) - boff; - if (face->box != FACE_NO_BOX) - { - int thick = face->box_line_width; - - if (thick > 0) - { - it->ascent += thick; - it->descent += thick; - } - else - thick = - thick; - - if (it->start_of_box_run_p) - it->pixel_width += thick; - if (it->end_of_box_run_p) - it->pixel_width += thick; - } - - /* If face has an overline, add the height of the overline - (1 pixel) and a 1 pixel margin to the character height. */ - if (face->overline_p) - it->ascent += overline_margin; - - take_vertical_position_into_account (it); - - if (it->ascent < 0) - it->ascent = 0; - if (it->descent < 0) - it->descent = 0; - - if (it->glyph_row) - append_glyph (it); - if (it->pixel_width == 0) - /* We assure that all visible glyphs have at least 1-pixel - width. */ - it->pixel_width = 1; - } - it->multibyte_p = saved_multibyte_p; } else if (it->what == IT_COMPOSITION && it->cmp_it.ch < 0) { @@ -22556,7 +22453,7 @@ } else { - width = FONT_WIDTH (font); + width = font->space_width; ascent = FONT_BASE (font); descent = FONT_DESCENT (font); lbearing = 0;
--- a/src/xselect.c Wed Sep 01 11:03:05 2010 +0900 +++ b/src/xselect.c Wed Sep 08 12:55:57 2010 +0900 @@ -83,8 +83,6 @@ unsigned char **, Atom *, unsigned *, int *, int *); static Lisp_Object clean_local_selection_data (Lisp_Object); -static void initialize_cut_buffers (Display *, Window); - /* Printing traces to stderr. */ @@ -105,8 +103,6 @@ #endif -#define CUT_BUFFER_SUPPORT - Lisp_Object QSECONDARY, QSTRING, QINTEGER, QCLIPBOARD, QTIMESTAMP, QTEXT, QDELETE, QMULTIPLE, QINCR, QEMACS_TMP, QTARGETS, QATOM, QNULL, QATOM_PAIR; @@ -116,11 +112,6 @@ Lisp_Object Qcompound_text_with_extensions; -#ifdef CUT_BUFFER_SUPPORT -Lisp_Object QCUT_BUFFER0, QCUT_BUFFER1, QCUT_BUFFER2, QCUT_BUFFER3, - QCUT_BUFFER4, QCUT_BUFFER5, QCUT_BUFFER6, QCUT_BUFFER7; -#endif - static Lisp_Object Vx_lost_selection_functions; static Lisp_Object Vx_sent_selection_functions; static Lisp_Object Qforeign_selection; @@ -270,16 +261,6 @@ if (EQ (sym, QEMACS_TMP)) return dpyinfo->Xatom_EMACS_TMP; if (EQ (sym, QTARGETS)) return dpyinfo->Xatom_TARGETS; if (EQ (sym, QNULL)) return dpyinfo->Xatom_NULL; -#ifdef CUT_BUFFER_SUPPORT - if (EQ (sym, QCUT_BUFFER0)) return XA_CUT_BUFFER0; - if (EQ (sym, QCUT_BUFFER1)) return XA_CUT_BUFFER1; - if (EQ (sym, QCUT_BUFFER2)) return XA_CUT_BUFFER2; - if (EQ (sym, QCUT_BUFFER3)) return XA_CUT_BUFFER3; - if (EQ (sym, QCUT_BUFFER4)) return XA_CUT_BUFFER4; - if (EQ (sym, QCUT_BUFFER5)) return XA_CUT_BUFFER5; - if (EQ (sym, QCUT_BUFFER6)) return XA_CUT_BUFFER6; - if (EQ (sym, QCUT_BUFFER7)) return XA_CUT_BUFFER7; -#endif if (!SYMBOLP (sym)) abort (); TRACE1 (" XInternAtom %s", (char *) SDATA (SYMBOL_NAME (sym))); @@ -315,24 +296,6 @@ return QINTEGER; case XA_ATOM: return QATOM; -#ifdef CUT_BUFFER_SUPPORT - case XA_CUT_BUFFER0: - return QCUT_BUFFER0; - case XA_CUT_BUFFER1: - return QCUT_BUFFER1; - case XA_CUT_BUFFER2: - return QCUT_BUFFER2; - case XA_CUT_BUFFER3: - return QCUT_BUFFER3; - case XA_CUT_BUFFER4: - return QCUT_BUFFER4; - case XA_CUT_BUFFER5: - return QCUT_BUFFER5; - case XA_CUT_BUFFER6: - return QCUT_BUFFER6; - case XA_CUT_BUFFER7: - return QCUT_BUFFER7; -#endif } dpyinfo = x_display_info_for_display (dpy); @@ -2258,195 +2221,6 @@ } -#ifdef CUT_BUFFER_SUPPORT - -/* Ensure that all 8 cut buffers exist. ICCCM says we gotta... */ -static void -initialize_cut_buffers (Display *display, Window window) -{ - unsigned char *data = (unsigned char *) ""; - BLOCK_INPUT; -#define FROB(atom) XChangeProperty (display, window, atom, XA_STRING, 8, \ - PropModeAppend, data, 0) - FROB (XA_CUT_BUFFER0); - FROB (XA_CUT_BUFFER1); - FROB (XA_CUT_BUFFER2); - FROB (XA_CUT_BUFFER3); - FROB (XA_CUT_BUFFER4); - FROB (XA_CUT_BUFFER5); - FROB (XA_CUT_BUFFER6); - FROB (XA_CUT_BUFFER7); -#undef FROB - UNBLOCK_INPUT; -} - - -#define CHECK_CUT_BUFFER(symbol) \ - do { CHECK_SYMBOL ((symbol)); \ - if (!EQ((symbol), QCUT_BUFFER0) && !EQ((symbol), QCUT_BUFFER1) \ - && !EQ((symbol), QCUT_BUFFER2) && !EQ((symbol), QCUT_BUFFER3) \ - && !EQ((symbol), QCUT_BUFFER4) && !EQ((symbol), QCUT_BUFFER5) \ - && !EQ((symbol), QCUT_BUFFER6) && !EQ((symbol), QCUT_BUFFER7)) \ - signal_error ("Doesn't name a cut buffer", (symbol)); \ - } while (0) - -DEFUN ("x-get-cut-buffer-internal", Fx_get_cut_buffer_internal, - Sx_get_cut_buffer_internal, 1, 1, 0, - doc: /* Returns the value of the named cut buffer (typically CUT_BUFFER0). */) - (Lisp_Object buffer) -{ - Window window; - Atom buffer_atom; - unsigned char *data = NULL; - int bytes; - Atom type; - int format; - unsigned long size; - Lisp_Object ret; - Display *display; - struct x_display_info *dpyinfo; - struct frame *sf = SELECTED_FRAME (); - - check_x (); - - if (! FRAME_X_P (sf)) - return Qnil; - - display = FRAME_X_DISPLAY (sf); - dpyinfo = FRAME_X_DISPLAY_INFO (sf); - window = RootWindow (display, 0); /* Cut buffers are on screen 0 */ - CHECK_CUT_BUFFER (buffer); - buffer_atom = symbol_to_x_atom (dpyinfo, display, buffer); - - x_get_window_property (display, window, buffer_atom, &data, &bytes, - &type, &format, &size, 0); - - if (!data || !format) - { - xfree (data); - return Qnil; - } - - if (format != 8 || type != XA_STRING) - signal_error ("Cut buffer doesn't contain 8-bit data", - list2 (x_atom_to_symbol (display, type), - make_number (format))); - - ret = (bytes ? make_unibyte_string ((char *) data, bytes) : Qnil); - /* Use xfree, not XFree, because x_get_window_property - calls xmalloc itself. */ - xfree (data); - return ret; -} - - -DEFUN ("x-store-cut-buffer-internal", Fx_store_cut_buffer_internal, - Sx_store_cut_buffer_internal, 2, 2, 0, - doc: /* Sets the value of the named cut buffer (typically CUT_BUFFER0). */) - (Lisp_Object buffer, Lisp_Object string) -{ - Window window; - Atom buffer_atom; - unsigned char *data; - int bytes; - int bytes_remaining; - int max_bytes; - Display *display; - struct frame *sf = SELECTED_FRAME (); - - check_x (); - - if (! FRAME_X_P (sf)) - return Qnil; - - display = FRAME_X_DISPLAY (sf); - window = RootWindow (display, 0); /* Cut buffers are on screen 0 */ - - max_bytes = SELECTION_QUANTUM (display); - if (max_bytes > MAX_SELECTION_QUANTUM) - max_bytes = MAX_SELECTION_QUANTUM; - - CHECK_CUT_BUFFER (buffer); - CHECK_STRING (string); - buffer_atom = symbol_to_x_atom (FRAME_X_DISPLAY_INFO (sf), - display, buffer); - data = (unsigned char *) SDATA (string); - bytes = SBYTES (string); - bytes_remaining = bytes; - - if (! FRAME_X_DISPLAY_INFO (sf)->cut_buffers_initialized) - { - initialize_cut_buffers (display, window); - FRAME_X_DISPLAY_INFO (sf)->cut_buffers_initialized = 1; - } - - BLOCK_INPUT; - - /* Don't mess up with an empty value. */ - if (!bytes_remaining) - XChangeProperty (display, window, buffer_atom, XA_STRING, 8, - PropModeReplace, data, 0); - - while (bytes_remaining) - { - int chunk = (bytes_remaining < max_bytes - ? bytes_remaining : max_bytes); - XChangeProperty (display, window, buffer_atom, XA_STRING, 8, - (bytes_remaining == bytes - ? PropModeReplace - : PropModeAppend), - data, chunk); - data += chunk; - bytes_remaining -= chunk; - } - UNBLOCK_INPUT; - return string; -} - - -DEFUN ("x-rotate-cut-buffers-internal", Fx_rotate_cut_buffers_internal, - Sx_rotate_cut_buffers_internal, 1, 1, 0, - doc: /* Rotate the values of the cut buffers by N steps. -Positive N means shift the values forward, negative means backward. */) - (Lisp_Object n) -{ - Window window; - Atom props[8]; - Display *display; - struct frame *sf = SELECTED_FRAME (); - - check_x (); - - if (! FRAME_X_P (sf)) - return Qnil; - - display = FRAME_X_DISPLAY (sf); - window = RootWindow (display, 0); /* Cut buffers are on screen 0 */ - CHECK_NUMBER (n); - if (XINT (n) == 0) - return n; - if (! FRAME_X_DISPLAY_INFO (sf)->cut_buffers_initialized) - { - initialize_cut_buffers (display, window); - FRAME_X_DISPLAY_INFO (sf)->cut_buffers_initialized = 1; - } - - props[0] = XA_CUT_BUFFER0; - props[1] = XA_CUT_BUFFER1; - props[2] = XA_CUT_BUFFER2; - props[3] = XA_CUT_BUFFER3; - props[4] = XA_CUT_BUFFER4; - props[5] = XA_CUT_BUFFER5; - props[6] = XA_CUT_BUFFER6; - props[7] = XA_CUT_BUFFER7; - BLOCK_INPUT; - XRotateWindowProperties (display, window, props, 8, XINT (n)); - UNBLOCK_INPUT; - return n; -} - -#endif - /*********************************************************************** Drag and drop support ***********************************************************************/ @@ -2850,12 +2624,6 @@ defsubr (&Sx_selection_owner_p); defsubr (&Sx_selection_exists_p); -#ifdef CUT_BUFFER_SUPPORT - defsubr (&Sx_get_cut_buffer_internal); - defsubr (&Sx_store_cut_buffer_internal); - defsubr (&Sx_rotate_cut_buffers_internal); -#endif - defsubr (&Sx_get_atom_name); defsubr (&Sx_send_client_message); defsubr (&Sx_register_dnd_atom); @@ -2937,17 +2705,6 @@ Qcompound_text_with_extensions = intern_c_string ("compound-text-with-extensions"); staticpro (&Qcompound_text_with_extensions); -#ifdef CUT_BUFFER_SUPPORT - QCUT_BUFFER0 = intern_c_string ("CUT_BUFFER0"); staticpro (&QCUT_BUFFER0); - QCUT_BUFFER1 = intern_c_string ("CUT_BUFFER1"); staticpro (&QCUT_BUFFER1); - QCUT_BUFFER2 = intern_c_string ("CUT_BUFFER2"); staticpro (&QCUT_BUFFER2); - QCUT_BUFFER3 = intern_c_string ("CUT_BUFFER3"); staticpro (&QCUT_BUFFER3); - QCUT_BUFFER4 = intern_c_string ("CUT_BUFFER4"); staticpro (&QCUT_BUFFER4); - QCUT_BUFFER5 = intern_c_string ("CUT_BUFFER5"); staticpro (&QCUT_BUFFER5); - QCUT_BUFFER6 = intern_c_string ("CUT_BUFFER6"); staticpro (&QCUT_BUFFER6); - QCUT_BUFFER7 = intern_c_string ("CUT_BUFFER7"); staticpro (&QCUT_BUFFER7); -#endif - Qforeign_selection = intern_c_string ("foreign-selection"); staticpro (&Qforeign_selection); }
--- a/src/xterm.c Wed Sep 01 11:03:05 2010 +0900 +++ b/src/xterm.c Wed Sep 08 12:55:57 2010 +0900 @@ -10124,8 +10124,6 @@ dpyinfo->Xatom_net_wm_name = XInternAtom (dpyinfo->display, "_NET_WM_NAME", False); - dpyinfo->cut_buffers_initialized = 0; - dpyinfo->x_dnd_atoms_size = 8; dpyinfo->x_dnd_atoms_length = 0; dpyinfo->x_dnd_atoms = xmalloc (sizeof (*dpyinfo->x_dnd_atoms)
--- a/src/xterm.h Wed Sep 01 11:03:05 2010 +0900 +++ b/src/xterm.h Wed Sep 08 12:55:57 2010 +0900 @@ -299,8 +299,6 @@ /* Atom used in XEmbed client messages. */ Atom Xatom_XEMBED; - int cut_buffers_initialized; /* Whether we're sure they all exist */ - /* The frame (if any) which has the X window that has keyboard focus. Zero if none. This is examined by Ffocus_frame in xfns.c. Note that a mere EnterNotify event can set this; if you need to know the
--- a/test/ChangeLog Wed Sep 01 11:03:05 2010 +0900 +++ b/test/ChangeLog Wed Sep 08 12:55:57 2010 +0900 @@ -1,6 +1,10 @@ +2010-08-30 Stefan Monnier <monnier@iro.umontreal.ca> + + * indent/octave.m: New file. + 2010-08-08 Ulf Jasper <ulf.jasper@web.de> - * icalendar-testsuite.el (icalendar-testsuite-run): Added internal tests. + * icalendar-testsuite.el (icalendar-testsuite-run): Add internal tests. (icalendar-testsuite--trim, icalendar-testsuite--compare-strings) (icalendar-testsuite--run-internal-tests): New. (icalendar-testsuite--test-convert-ordinary-to-ical) @@ -13,7 +17,7 @@ (icalendar-testsuite--do-test-cycle): Use icalendar-testsuite--compare-strings (icalendar-testsuite--run-import-tests): Comment added. (icalendar-testsuite--run-import-tests) - (icalendar-testsuite--run-real-world-tests): Fixed expected results. + (icalendar-testsuite--run-real-world-tests): Fix expected results. 2010-06-25 Chong Yidong <cyd@stupidchicken.com>
--- a/test/indent/Makefile Wed Sep 01 11:03:05 2010 +0900 +++ b/test/indent/Makefile Wed Sep 08 12:55:57 2010 +0900 @@ -8,8 +8,8 @@ # - mark the places where the indentation is known to be incorrect, # and allow either ignoring those errors or not. %.test: % - -$(RM) $<.test + -$(RM) $<.new $(EMACS) --batch $< \ --eval '(indent-region (point-min) (point-max) nil)' \ - --eval '(write-region (point-min) (point-max) "$<.test")' - diff -u -B $< $<.test + --eval '(write-region (point-min) (point-max) "$<.new")' + diff -u -B $< $<.new
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/test/indent/octave.m Wed Sep 08 12:55:57 2010 +0900 @@ -0,0 +1,2318 @@ +## -*- octave -*- + +function res = tcomp (fn) + %% res = tcomp (fn) + %% imports components and rearranges them. + + if nargin ~= 1 + print_usage() + endif + + data = dlmread(fn, 3, 0); + + x = data(:,2:end); + y = 'hello'; + z = y'; + + cnty = repmat(x(:,1)(:), 10, 1); + + pop = x(:,1:10)(:); + bir = x(:,11:20)(:); + dth = x(:,21:30)(:); + imig = x(:,31:40)(:); + dmig = x(:,41:50)(:); + gq = x(:,51:60)(:); + + yrs = repmat(2000:2009, 39, 1)(:); + + res = [yrs, cnty, pop, bir, dth, imig, dmig, gq]; + +endfunction + +## Copyright (C) 2005, 2006, 2007, 2008, 2009 S�ren Hauberg +## +## This file is part of Octave. +## +## Octave 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. +## +## Octave 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 Octave; see the file COPYING. If not, see +## <http://www.gnu.org/licenses/>. + +## -*- texinfo -*- +## @deftypefn {Command} pkg @var{command} @var{pkg_name} +## @deftypefnx {Command} pkg @var{command} @var{option} @var{pkg_name} +## This command interacts with the package manager. Different actions will +## be taken depending on the value of @var{command}. +## +## @table @samp +## @item install +## Install named packages. For example, +## @example +## pkg install image-1.0.0.tar.gz +## @end example +## @noindent +## installs the package found in the file @file{image-1.0.0.tar.gz}. +## +## The @var{option} variable can contain options that affect the manner +## in which a package is installed. These options can be one or more of +## +## @table @code +## @item -nodeps +## The package manager will disable the dependency checking. That way it +## is possible to install a package even if it depends on another package +## that's not installed on the system. @strong{Use this option with care.} +## +## @item -noauto +## The package manager will not automatically load the installed package +## when starting Octave, even if the package requests that it is. +## +## @item -auto +## The package manager will automatically load the installed package when +## starting Octave, even if the package requests that it isn't. +## +## @item -local +## A local installation is forced, even if the user has system privileges. +## +## @item -global +## A global installation is forced, even if the user doesn't normally have +## system privileges +## +## @item -verbose +## The package manager will print the output of all of the commands that are +## performed. +## @end table +## +## @item uninstall +## Uninstall named packages. For example, +## @example +## pkg uninstall image +## @end example +## @noindent +## removes the @code{image} package from the system. If another installed +## package depends on the @code{image} package an error will be issued. +## The package can be uninstalled anyway by using the @code{-nodeps} option. +## @item load +## Add named packages to the path. After loading a package it is +## possible to use the functions provided by the package. For example, +## @example +## pkg load image +## @end example +## @noindent +## adds the @code{image} package to the path. It is possible to load all +## installed packages at once with the command +## @example +## pkg load all +## @end example +## @item unload +## Removes named packages from the path. After unloading a package it is +## no longer possible to use the functions provided by the package. +## This command behaves like the @code{load} command. +## @item list +## Show a list of the currently installed packages. By requesting one or two +## output argument it is possible to get a list of the currently installed +## packages. For example, +## @example +## installed_packages = pkg list; +## @end example +## @noindent +## returns a cell array containing a structure for each installed package. +## The command +## @example +## [@var{user_packages}, @var{system_packages}] = pkg list +## @end example +## @noindent +## splits the list of installed packages into those who are installed by +## the current user, and those installed by the system administrator. +## @item describe +## Show a short description of the named installed packages, with the option +## '-verbose' also list functions provided by the package, e.g.: +## @example +## pkg describe -verbose all +## @end example +## @noindent +## will describe all installed packages and the functions they provide. +## If one output is requested a cell of structure containing the +## description and list of functions of each package is returned as +## output rather than printed on screen: +## @example +## desc = pkg ("describe", "secs1d", "image") +## @end example +## @noindent +## If any of the requested packages is not installed, pkg returns an +## error, unless a second output is requested: +## @example +## [ desc, flag] = pkg ("describe", "secs1d", "image") +## @end example +## @noindent +## @var{flag} will take one of the values "Not installed", "Loaded" or +## "Not loaded" for each of the named packages. +## @item prefix +## Set the installation prefix directory. For example, +## @example +## pkg prefix ~/my_octave_packages +## @end example +## @noindent +## sets the installation prefix to @file{~/my_octave_packages}. +## Packages will be installed in this directory. +## +## It is possible to get the current installation prefix by requesting an +## output argument. For example, +## @example +## p = pkg prefix +## @end example +## +## The location in which to install the architecture dependent files can be +## independent specified with an addition argument. For example +## +## @example +## pkg prefix ~/my_octave_packages ~/my_arch_dep_pkgs +## @end example +## @item local_list +## Set the file in which to look for information on the locally +## installed packages. Locally installed packages are those that are +## typically available only to the current user. For example +## @example +## pkg local_list ~/.octave_packages +## @end example +## It is possible to get the current value of local_list with the following +## @example +## pkg local_list +## @end example +## @item global_list +## Set the file in which to look for, for information on the globally +## installed packages. Globally installed packages are those that are +## typically available to all users. For example +## @example +## pkg global_list /usr/share/octave/octave_packages +## @end example +## It is possible to get the current value of global_list with the following +## @example +## pkg global_list +## @end example +## @item rebuild +## Rebuilds the package database from the installed directories. This can +## be used in cases where for some reason the package database is corrupted. +## It can also take the @code{-auto} and @code{-noauto} options to allow the +## autoloading state of a package to be changed. For example +## +## @example +## pkg rebuild -noauto image +## @end example +## +## will remove the autoloading status of the image package. +## @item build +## Builds a binary form of a package or packages. The binary file produced +## will itself be an Octave package that can be installed normally with +## @code{pkg}. The form of the command to build a binary package is +## +## @example +## pkg build builddir image-1.0.0.tar.gz @dots{} +## @end example +## +## @noindent +## where @code{builddir} is the name of a directory where the temporary +## installation will be produced and the binary packages will be found. +## The options @code{-verbose} and @code{-nodeps} are respected, while +## the other options are ignored. +## @end table +## @end deftypefn + +function [local_packages, global_packages] = pkg (varargin) + ## Installation prefix (FIXME: what should these be on windows?) + persistent user_prefix = false; + persistent prefix = -1; + persistent archprefix = -1; + persistent local_list = tilde_expand (fullfile ("~", ".octave_packages")); + persistent global_list = fullfile (OCTAVE_HOME (), "share", "octave", + "octave_packages"); + mlock (); + + global_install = issuperuser (); + + if (prefix == -1) + if (global_install) + prefix = fullfile (OCTAVE_HOME (), "share", "octave", "packages"); + archprefix = fullfile (octave_config_info ("libexecdir"), + "octave", "packages"); + else + prefix = fullfile ("~", "octave"); + archprefix = prefix; + endif + prefix = tilde_expand (prefix); + archprefix = tilde_expand (archprefix); + endif + + available_actions = {"list", "install", "uninstall", "load", ... + "unload", "prefix", "local_list", ... + "global_list", "rebuild", "build","describe"}; + ## Handle input + if (length (varargin) == 0 || ! iscellstr (varargin)) + print_usage (); + endif + files = {}; + deps = true; + auto = 0; + action = "none"; + verbose = false; + for i = 1:length (varargin) + switch (varargin{i}) + case "-nodeps" + deps = false; + case "-noauto" + auto = -1; + case "-auto" + auto = 1; + case "-verbose" + verbose = true; + case "-local" + global_install = false; + if (! user_prefix) + prefix = tilde_expand (fullfile ("~", "octave")); + archprefix = prefix; + endif + case "-global" + global_install = true; + if (! user_prefix) + prefix = fullfile (OCTAVE_HOME (), "share", "octave", "packages"); + archprefix = fullfile (octave_config_info ("libexecdir"), + "octave", "packages"); + endif + case available_actions + if (strcmp (action, "none")) + action = varargin{i}; + else + error ("more than one action specified"); + endif + otherwise + files{end+1} = varargin{i}; + endswitch + endfor + + ## Take action + switch (action) + case "list" + if (nargout == 0) + installed_packages (local_list, global_list); + elseif (nargout == 1) + local_packages = installed_packages (local_list, global_list); + elseif (nargout == 2) + [local_packages, global_packages] = installed_packages (local_list, + global_list); + else + error ("too many output arguments requested"); + endif + + case "install" + if (length (files) == 0) + error ("you must specify at least one filename when calling 'pkg install'"); + endif + install (files, deps, auto, prefix, archprefix, verbose, local_list, + global_list, global_install); + + case "uninstall" + if (length (files) == 0) + error ("you must specify at least one package when calling 'pkg uninstall'"); + endif + uninstall (files, deps, verbose, local_list, + global_list, global_install); + + case "load" + if (length (files) == 0) + error ("you must specify at least one package, 'all' or 'auto' when calling 'pkg load'"); + endif + load_packages (files, deps, local_list, global_list); + + case "unload" + if (length (files) == 0) + error ("you must specify at least one package or 'all' when calling 'pkg unload'"); + endif + unload_packages (files, deps, local_list, global_list); + + case "prefix" + if (length (files) == 0 && nargout == 0) + printf ("Installation prefix: %s\n", prefix); + printf ("Architecture dependent prefix: %s\n", archprefix); + elseif (length (files) == 0 && nargout >= 1) + local_packages = prefix; + global_packages = archprefix; + elseif (length (files) >= 1 && nargout <= 2 && ischar (files{1})) + prefix = files{1}; + prefix = absolute_pathname (prefix); + local_packages = prefix; + user_prefix = true; + if (length (files) >= 2 && ischar (files{2})) + archprefix = files{2}; + try + archprefix = absolute_pathname (archprefix); + catch + mkdir (archprefix); + warning ("creating the directory %s\n", archprefix); + archprefix = absolute_pathname (archprefix); + end_try_catch + global_packages = archprefix; + endif + else + error ("you must specify a prefix directory, or request an output argument"); + endif + + case "local_list" + if (length (files) == 0 && nargout == 0) + disp (local_list); + elseif (length (files) == 0 && nargout == 1) + local_packages = local_list; + elseif (length (files) == 1 && nargout == 0 && ischar (files{1})) + try + local_list = absolute_pathname (files{1}); + catch + ## Force file to be created + fclose (fopen (files{1}, "wt")); + local_list = absolute_pathname (files{1}); + end_try_catch + else + error ("you must specify a local_list file, or request an output argument"); + endif + + case "global_list" + if (length (files) == 0 && nargout == 0) + disp(global_list); + elseif (length (files) == 0 && nargout == 1) + local_packages = global_list; + elseif (length (files) == 1 && nargout == 0 && ischar (files{1})) + try + global_list = absolute_pathname (files{1}); + catch + ## Force file to be created + fclose (fopen (files{1}, "wt")); + global_list = absolute_pathname (files{1}); + end_try_catch + else + error ("you must specify a global_list file, or request an output argument"); + endif + + case "rebuild" + if (global_install) + global_packages = rebuild (prefix, archprefix, global_list, files, + auto, verbose); + global_packages = save_order (global_packages); + save (global_list, "global_packages"); + if (nargout > 0) + local_packages = global_packages; + endif + else + local_packages = rebuild (prefix, archprefix, local_list, files, auto, + verbose); + local_packages = save_order (local_packages); + save (local_list, "local_packages"); + if (nargout == 0) + clear ("local_packages"); + endif + endif + + case "build" + if (length (files) < 2) + error ("you must specify at least the build directory and one filename\nwhen calling 'pkg build'"); + endif + build (files, deps, auto, verbose); + + case "describe" + if (length (files) == 0) + error ("you must specify at least one package or 'all' when calling 'pkg describe'"); + endif + ## FIXME: the name of the output variables is inconsistent + ## with their content + switch (nargout) + case 0 + describe (files, verbose, local_list, global_list); + case 1 + pkg_desc_list = describe (files, verbose, local_list, ... + global_list); + local_packages = pkg_desc_list; + case 2 + [pkg_desc_list, flag] = describe (files, verbose, local_list, ... + global_list); + local_packages = pkg_desc_list; + global_packages = flag; + otherwise + error ("you can request at most two outputs when calling 'pkg describe'"); + endswitch + + otherwise + error ("you must specify a valid action for 'pkg'. See 'help pkg' for details"); + endswitch +endfunction + +function descriptions = rebuild (prefix, archprefix, list, files, auto, verbose) + if (isempty (files)) + [dirlist, err, msg] = readdir (prefix); + if (err) + error ("couldn't read directory %s: %s", prefix, msg); + endif + ## the two first entries of dirlist are "." and ".." + dirlist([1,2]) = []; + else + old_descriptions = installed_packages (list, list); + wd = pwd (); + unwind_protect + cd (prefix); + dirlist = glob (cellfun(@(x) cstrcat(x, '-*'), files, 'UniformOutput', 0)); + unwind_protect_cleanup + cd (wd); + end_unwind_protect + endif + descriptions = {}; + for k = 1:length (dirlist) + descfile = fullfile (prefix, dirlist{k}, "packinfo", "DESCRIPTION"); + if (verbose) + printf ("recreating package description from %s\n", dirlist{k}); + endif + if (exist (descfile, "file")) + desc = get_description (descfile); + desc.dir = fullfile (prefix, dirlist{k}); + desc.archprefix = fullfile (archprefix, cstrcat (desc.name, "-", + desc.version)); + if (auto != 0) + if (exist (fullfile (desc.dir, "packinfo", ".autoload"), "file")) + unlink (fullfile (desc.dir, "packinfo", ".autoload")); + endif + if (auto < 0) + desc.autoload = 0; + elseif (auto > 0) + desc.autoload = 1; + fclose (fopen (fullfile (desc.dir, "packinfo", ".autoload"), "wt")); + endif + else + if (exist (fullfile (desc.dir, "packinfo", ".autoload"), "file")) + desc.autoload = 1; + else + desc.autoload = 0; + endif + endif + descriptions{end + 1} = desc; + elseif (verbose) + warning ("directory %s is not a valid package", dirlist{k}); + endif + endfor + + if (! isempty (files)) + ## We are rebuilding for a particular package(s) so we should take + ## care to keep the other untouched packages in the descriptions + descriptions = {descriptions{:}, old_descriptions{:}}; + + dup = []; + for i = 1:length (descriptions) + if (find (dup, i)) + continue; + endif + for j = (i+1):length (descriptions) + if (find (dup, j)) + continue; + endif + if (strcmp (descriptions{i}.name, descriptions{j}.name)) + dup = [dup, j]; + endif + endfor + endfor + if (! isempty (dup)) + descriptions (dup) = []; + endif + endif +endfunction + +function build (files, handle_deps, autoload, verbose) + if (length (files) < 1) + error ("insufficient number of files"); + endif + builddir = files{1}; + if (! exist (builddir, "dir")) + warning ("creating build directory %s", builddir); + [status, msg] = mkdir (builddir); + if (status != 1) + error ("could not create installation directory: %s", msg); + endif + endif + builddir = absolute_pathname (builddir); + installdir = fullfile (builddir, "install"); + if (! exist (installdir, "dir")) + [status, msg] = mkdir (installdir); + if (status != 1) + error ("could not create installation directory: %s", msg); + endif + endif + files(1) = []; + buildlist = fullfile (builddir, "octave_packages"); + install (files, handle_deps, autoload, installdir, installdir, verbose, + buildlist, "", false); + unwind_protect + repackage (builddir, buildlist); + unwind_protect_cleanup + unload_packages ({"all"}, handle_deps, buildlist, ""); + if (exist (installdir, "dir")) + rm_rf (installdir); + endif + if (exist (buildlist, "file")) + unlink (buildlist); + endif + end_unwind_protect +endfunction + +function install (files, handle_deps, autoload, prefix, archprefix, verbose, + local_list, global_list, global_install) + + ## Check that the directory in prefix exist. If it doesn't: create it! + if (! exist (prefix, "dir")) + warning ("creating installation directory %s", prefix); + [status, msg] = mkdir (prefix); + if (status != 1) + error ("could not create installation directory: %s", msg); + endif + endif + + ## Get the list of installed packages. + [local_packages, global_packages] = installed_packages (local_list, + global_list); + + installed_pkgs_lst = {local_packages{:}, global_packages{:}}; + + if (global_install) + packages = global_packages; + else + packages = local_packages; + endif + + ## Uncompress the packages and read the DESCRIPTION files. + tmpdirs = packdirs = descriptions = {}; + try + ## Warn about non existent files. + for i = 1:length (files) + if (isempty (glob(files{i}))) + warning ("file %s does not exist", files{i}); + endif + endfor + + ## Unpack the package files and read the DESCRIPTION files. + files = glob (files); + packages_to_uninstall = []; + for i = 1:length (files) + tgz = files{i}; + + if (exist (tgz, "file")) + ## Create a temporary directory. + tmpdir = tmpnam (); + tmpdirs{end+1} = tmpdir; + if (verbose) + printf ("mkdir (%s)\n", tmpdir); + endif + [status, msg] = mkdir (tmpdir); + if (status != 1) + error ("couldn't create temporary directory: %s", msg); + endif + + ## Uncompress the package. + if (verbose) + printf ("untar (%s, %s)\n", tgz, tmpdir); + endif + untar (tgz, tmpdir); + + ## Get the name of the directories produced by tar. + [dirlist, err, msg] = readdir (tmpdir); + if (err) + error ("couldn't read directory produced by tar: %s", msg); + endif + + if (length (dirlist) > 3) + error ("bundles of packages are not allowed") + endif + endif + + ## The filename pointed to an uncompressed package to begin with. + if (exist (tgz, "dir")) + dirlist = {".", "..", tgz}; + endif + + if (exist (tgz, "file") || exist (tgz, "dir")) + ## The two first entries of dirlist are "." and "..". + if (exist (tgz, "file")) + packdir = fullfile (tmpdir, dirlist{3}); + else + packdir = fullfile (pwd(), dirlist{3}); + endif + packdirs{end+1} = packdir; + + ## Make sure the package contains necessary files. + verify_directory (packdir); + + ## Read the DESCRIPTION file. + filename = fullfile (packdir, "DESCRIPTION"); + desc = get_description (filename); + + ## Verify that package name corresponds with filename. + [dummy, nm] = fileparts (tgz); + if ((length (nm) >= length (desc.name)) + && ! strcmp (desc.name, nm(1:length(desc.name)))) + error ("package name '%s' doesn't correspond to its filename '%s'", + desc.name, nm); + endif + + ## Set default installation directory. + desc.dir = fullfile (prefix, cstrcat (desc.name, "-", desc.version)); + + ## Set default architectire dependent installation directory. + desc.archprefix = fullfile (archprefix, cstrcat (desc.name, "-", + desc.version)); + + ## Save desc. + descriptions{end+1} = desc; + + ## Are any of the new packages already installed? + ## If so we'll remove the old version. + for j = 1:length (packages) + if (strcmp (packages{j}.name, desc.name)) + packages_to_uninstall(end+1) = j; + endif + endfor + endif + endfor + catch + ## Something went wrong, delete tmpdirs. + for i = 1:length (tmpdirs) + rm_rf (tmpdirs{i}); + endfor + rethrow (lasterror ()); + end_try_catch + + ## Check dependencies. + if (handle_deps) + ok = true; + error_text = ""; + for i = 1:length (descriptions) + desc = descriptions{i}; + idx2 = complement (i, 1:length(descriptions)); + if (global_install) + ## Global installation is not allowed to have dependencies on locally + ## installed packages. + idx1 = complement (packages_to_uninstall, + 1:length(global_packages)); + pseudo_installed_packages = {global_packages{idx1}, ... + descriptions{idx2}}; + else + idx1 = complement (packages_to_uninstall, + 1:length(local_packages)); + pseudo_installed_packages = {local_packages{idx1}, ... + global_packages{:}, ... + descriptions{idx2}}; + endif + bad_deps = get_unsatisfied_deps (desc, pseudo_installed_packages); + ## Are there any unsatisfied dependencies? + if (! isempty (bad_deps)) + ok = false; + for i = 1:length (bad_deps) + dep = bad_deps{i}; + error_text = cstrcat (error_text, " ", desc.name, " needs ", + dep.package, " ", dep.operator, " ", + dep.version, "\n"); + endfor + endif + endfor + + ## Did we find any unsatisfied dependencies? + if (! ok) + error ("the following dependencies where unsatisfied:\n %s", error_text); + endif + endif + + ## Prepare each package for installation. + try + for i = 1:length (descriptions) + desc = descriptions{i}; + pdir = packdirs{i}; + prepare_installation (desc, pdir); + configure_make (desc, pdir, verbose); + endfor + catch + ## Something went wrong, delete tmpdirs. + for i = 1:length (tmpdirs) + rm_rf (tmpdirs{i}); + endfor + rethrow (lasterror ()); + end_try_catch + + ## Uninstall the packages that will be replaced. + try + for i = packages_to_uninstall + if (global_install) + uninstall ({global_packages{i}.name}, false, verbose, local_list, + global_list, global_install); + else + uninstall ({local_packages{i}.name}, false, verbose, local_list, + global_list, global_install); + endif + endfor + catch + ## Something went wrong, delete tmpdirs. + for i = 1:length (tmpdirs) + rm_rf (tmpdirs{i}); + endfor + rethrow (lasterror ()); + end_try_catch + + ## Install each package. + try + for i = 1:length (descriptions) + desc = descriptions{i}; + pdir = packdirs{i}; + copy_files (desc, pdir, global_install); + create_pkgadddel (desc, pdir, "PKG_ADD", global_install); + create_pkgadddel (desc, pdir, "PKG_DEL", global_install); + finish_installation (desc, pdir, global_install); + generate_lookfor_cache (desc); + endfor + catch + ## Something went wrong, delete tmpdirs. + for i = 1:length (tmpdirs) + rm_rf (tmpdirs{i}); + endfor + for i = 1:length (descriptions) + rm_rf (descriptions{i}.dir); + rm_rf (getarchdir (descriptions{i})); + endfor + rethrow (lasterror ()); + end_try_catch + + ## Check if the installed directory is empty. If it is remove it + ## from the list. + for i = length (descriptions):-1:1 + if (dirempty (descriptions{i}.dir, {"packinfo", "doc"}) && + dirempty (getarchdir (descriptions{i}))) + warning ("package %s is empty\n", descriptions{i}.name); + rm_rf (descriptions{i}.dir); + rm_rf (getarchdir (descriptions{i})); + descriptions(i) = []; + endif + endfor + + ## If the package requested that it is autoloaded, or the installer + ## requested that it is, then mark the package as autoloaded. + for i = length (descriptions):-1:1 + if (autoload > 0 || (autoload == 0 && isautoload (descriptions(i)))) + fclose (fopen (fullfile (descriptions{i}.dir, "packinfo", + ".autoload"), "wt")); + descriptions{i}.autoload = 1; + endif + endfor + + ## Add the packages to the package list. + try + if (global_install) + idx = complement (packages_to_uninstall, 1:length(global_packages)); + global_packages = save_order ({global_packages{idx}, descriptions{:}}); + save (global_list, "global_packages"); + installed_pkgs_lst = {local_packages{:}, global_packages{:}}; + else + idx = complement (packages_to_uninstall, 1:length(local_packages)); + local_packages = save_order ({local_packages{idx}, descriptions{:}}); + save (local_list, "local_packages"); + installed_pkgs_lst = {local_packages{:}, global_packages{:}}; + endif + catch + ## Something went wrong, delete tmpdirs. + for i = 1:length (tmpdirs) + rm_rf (tmpdirs{i}); + endfor + for i = 1:length (descriptions) + rm_rf (descriptions{i}.dir); + endfor + if (global_install) + printf ("error: couldn't append to %s\n", global_list); + else + printf ("error: couldn't append to %s\n", local_list); + endif + rethrow (lasterror ()); + end_try_catch + + ## All is well, let's clean up. + for i = 1:length (tmpdirs) + [status, msg] = rm_rf (tmpdirs{i}); + if (status != 1) + warning ("couldn't clean up after my self: %s\n", msg); + endif + endfor + + ## Add the newly installed packages to the path, so the user + ## can begin using them. Only load them if they are marked autoload. + if (length (descriptions) > 0) + idx = []; + for i = 1:length (descriptions) + if (isautoload (descriptions(i))) + nm = descriptions{i}.name; + for j = 1:length (installed_pkgs_lst) + if (strcmp (nm, installed_pkgs_lst{j}.name)) + idx (end + 1) = j; + break; + endif + endfor + endif + endfor + load_packages_and_dependencies (idx, handle_deps, installed_pkgs_lst, + global_install); + endif +endfunction + +function uninstall (pkgnames, handle_deps, verbose, local_list, + global_list, global_install) + ## Get the list of installed packages. + [local_packages, global_packages] = installed_packages(local_list, + global_list); + if (global_install) + installed_pkgs_lst = {local_packages{:}, global_packages{:}}; + else + installed_pkgs_lst = local_packages; + endif + + num_packages = length (installed_pkgs_lst); + delete_idx = []; + for i = 1:num_packages + cur_name = installed_pkgs_lst{i}.name; + if (any (strcmp (cur_name, pkgnames))) + delete_idx(end+1) = i; + endif + endfor + + ## Are all the packages that should be uninstalled already installed? + if (length (delete_idx) != length (pkgnames)) + if (global_install) + ## Try again for a locally installed package. + installed_pkgs_lst = local_packages; + + num_packages = length (installed_pkgs_lst); + delete_idx = []; + for i = 1:num_packages + cur_name = installed_pkgs_lst{i}.name; + if (any (strcmp (cur_name, pkgnames))) + delete_idx(end+1) = i; + endif + endfor + if (length (delete_idx) != length (pkgnames)) + ## FIXME: We should have a better error message. + warning ("some of the packages you want to uninstall are not installed"); + endif + else + ## FIXME: We should have a better error message. + warning ("some of the packages you want to uninstall are not installed"); + endif + endif + + ## Compute the packages that will remain installed. + idx = complement (delete_idx, 1:num_packages); + remaining_packages = {installed_pkgs_lst{idx}}; + + ## Check dependencies. + if (handle_deps) + error_text = ""; + for i = 1:length (remaining_packages) + desc = remaining_packages{i}; + bad_deps = get_unsatisfied_deps (desc, remaining_packages); + + ## Will the uninstallation break any dependencies? + if (! isempty (bad_deps)) + for i = 1:length (bad_deps) + dep = bad_deps{i}; + error_text = cstrcat (error_text, " ", desc.name, " needs ", + dep.package, " ", dep.operator, " ", + dep.version, "\n"); + endfor + endif + endfor + + if (! isempty (error_text)) + error ("the following dependencies where unsatisfied:\n %s", error_text); + endif + endif + + ## Delete the directories containing the packages. + for i = delete_idx + desc = installed_pkgs_lst{i}; + ## If an 'on_uninstall.m' exist, call it! + if (exist (fullfile (desc.dir, "packinfo", "on_uninstall.m"), "file")) + wd = pwd (); + cd (fullfile (desc.dir, "packinfo")); + on_uninstall (desc); + cd (wd); + endif + ## Do the actual deletion. + if (desc.loaded) + rmpath (desc.dir); + if (exist (getarchdir (desc))) + rmpath (getarchdir (desc)); + endif + endif + if (exist (desc.dir, "dir")) + [status, msg] = rm_rf (desc.dir); + if (status != 1) + error ("couldn't delete directory %s: %s", desc.dir, msg); + endif + [status, msg] = rm_rf (getarchdir (desc)); + if (status != 1) + error ("couldn't delete directory %s: %s", getarchdir (desc), msg); + endif + if (dirempty (desc.archprefix)) + rm_rf (desc.archprefix); + endif + else + warning ("directory %s previously lost", desc.dir); + endif + endfor + + ## Write a new ~/.octave_packages. + if (global_install) + if (length (remaining_packages) == 0) + unlink (global_list); + else + global_packages = save_order (remaining_packages); + save (global_list, "global_packages"); + endif + else + if (length (remaining_packages) == 0) + unlink (local_list); + else + local_packages = save_order (remaining_packages); + save (local_list, "local_packages"); + endif + endif + +endfunction + +function [pkg_desc_list, flag] = describe (pkgnames, verbose, + local_list, global_list) + + ## Get the list of installed packages. + installed_pkgs_lst = installed_packages(local_list, global_list); + num_packages = length (installed_pkgs_lst); + + + describe_all = false; + if (any (strcmp ("all", pkgnames))) + describe_all = true; + flag(1:num_packages) = {"Not Loaded"}; + num_pkgnames = num_packages; + else + num_pkgnames = length (pkgnames); + flag(1:num_pkgnames) = {"Not installed"}; + endif + + for i = 1:num_packages + curr_name = installed_pkgs_lst{i}.name; + if (describe_all) + name_pos = i; + else + name_pos = find(strcmp (curr_name, pkgnames)); + endif + + if (! isempty (name_pos)) + if (installed_pkgs_lst{i}.loaded) + flag{name_pos} = "Loaded"; + else + flag{name_pos} = "Not loaded"; + endif + + pkg_desc_list{name_pos}.name = installed_pkgs_lst{i}.name; + pkg_desc_list{name_pos}.version = installed_pkgs_lst{i}.version; + pkg_desc_list{name_pos}.description = installed_pkgs_lst{i}.description; + pkg_desc_list{name_pos}.provides = parse_pkg_idx (installed_pkgs_lst{i}.dir); + + endif + endfor + + non_inst = find (strcmp (flag, "Not installed")); + if (! isempty (non_inst)) + if (nargout < 2) + non_inst_str = sprintf (" %s ", pkgnames{non_inst}); + error ("some packages are not installed: %s", non_inst_str); + else + pkg_desc_list{non_inst} = struct ("name", {}, "description", + {}, "provides", {}); + endif + endif + + if (nargout == 0) + for i = 1:num_pkgnames + print_package_description (pkg_desc_list{i}.name, + pkg_desc_list{i}.version, + pkg_desc_list{i}.provides, + pkg_desc_list{i}.description, + flag{i}, verbose); + endfor + endif + +endfunction + +## AUXILIARY FUNCTIONS + +## Read an INDEX file. +function [pkg_idx_struct] = parse_pkg_idx (packdir) + + index_file = fullfile (packdir, "packinfo", "INDEX"); + + if (! exist (index_file, "file")) + error ("could not find any INDEX file in directory %s, try 'pkg rebuild all' to generate missing INDEX files", packdir); + endif + + + [fid, msg] = fopen (index_file, "r"); + if (fid == -1) + error ("the INDEX file %s could not be read: %s", + index_file, msg); + endif + + cat_num = 1; + pkg_idx_struct{1}.category = "Uncategorized"; + pkg_idx_struct{1}.functions = {}; + + line = fgetl (fid); + while (isempty (strfind (line, ">>")) && ! feof (fid)) + line = fgetl (fid); + endwhile + + while (! feof (fid) || line != -1) + if (! any (! isspace (line)) || line(1) == "#" || any (line == "=")) + ## Comments, blank lines or comments about unimplemented + ## functions: do nothing + ## FIXME: probably comments and pointers to external functions + ## could be treated better when printing to screen? + elseif (! isempty (strfind (line, ">>"))) + ## Skip package name and description as they are in DESCRIPTION + ## already. + elseif (! isspace (line(1))) + ## Category. + if (! isempty (pkg_idx_struct{cat_num}.functions)) + pkg_idx_struct{++cat_num}.functions = {}; + endif + pkg_idx_struct{cat_num}.category = deblank (line); + else + ## Function names. + while (any (! isspace (line))) + [fun_name, line] = strtok (line); + pkg_idx_struct{cat_num}.functions{end+1} = deblank (fun_name); + endwhile + endif + line = fgetl (fid); + endwhile + fclose (fid); +endfunction + +function print_package_description (pkg_name, pkg_ver, pkg_idx_struct, + pkg_desc, status, verbose) + + printf ("---\nPackage name:\n\t%s\n", pkg_name); + printf ("Version:\n\t%s\n", pkg_ver); + printf ("Short description:\n\t%s\n", pkg_desc); + printf ("Status:\n\t%s\n", status); + if (verbose) + printf ("---\nProvides:\n"); + for i = 1:length(pkg_idx_struct) + if (! isempty (pkg_idx_struct{i}.functions)) + printf ("%s\n", pkg_idx_struct{i}.category); + for j = 1:length(pkg_idx_struct{i}.functions) + printf ("\t%s\n", pkg_idx_struct{i}.functions{j}); + endfor + endif + endfor + endif + +endfunction + + +function pth = absolute_pathname (pth) + [status, msg, msgid] = fileattrib (pth); + if (status != 1) + error ("could not find the file or path %s", pth); + else + pth = msg.Name; + endif +endfunction + +function repackage (builddir, buildlist) + packages = installed_packages (buildlist, buildlist); + + wd = pwd(); + for i = 1 : length(packages) + pack = packages{i}; + unwind_protect + cd (builddir); + mkdir (pack.name); + mkdir (fullfile (pack.name, "inst")); + copyfile (fullfile (pack.dir, "*"), fullfile (pack.name, "inst")); + movefile (fullfile (pack.name, "inst","packinfo", "*"), pack.name); + if (exist (fullfile (pack.name, "inst","packinfo", ".autoload"), "file")) + unlink (fullfile (pack.name, "inst","packinfo", ".autoload")); + endif + rmdir (fullfile (pack.name, "inst", "packinfo")); + if (exist (fullfile (pack.name, "inst", "doc"), "dir")) + movefile (fullfile (pack.name, "inst", "doc"), pack.name); + endif + if (exist (fullfile (pack.name, "inst", "bin"), "dir")) + movefile (fullfile (pack.name, "inst", "bin"), pack.name); + endif + archdir = fullfile (pack.archprefix, cstrcat (pack.name, "-", + pack.version), getarch ()); + if (exist (archdir, "dir")) + if (exist (fullfile (pack.name, "inst", "PKG_ADD"), "file")) + unlink (fullfile (pack.name, "inst", "PKG_ADD")); + endif + if (exist (fullfile (pack.name, "inst", "PKG_DEL"), "file")) + unlink (fullfile (pack.name, "inst", "PKG_DEL")); + endif + if (exist (fullfile (archdir, "PKG_ADD"), "file")) + movefile (fullfile (archdir, "PKG_ADD"), + fullfile (pack.name, "PKG_ADD")); + endif + if (exist (fullfile (archdir, "PKG_DEL"), "file")) + movefile (fullfile (archdir, "PKG_DEL"), + fullfile (pack.name, "PKG_DEL")); + endif + else + if (exist (fullfile (pack.name, "inst", "PKG_ADD"), "file")) + movefile (fullfile (pack.name, "inst", "PKG_ADD"), + fullfile (pack.name, "PKG_ADD")); + endif + if (exist (fullfile (pack.name, "inst", "PKG_DEL"), "file")) + movefile (fullfile (pack.name, "inst", "PKG_DEL"), + fullfile (pack.name, "PKG_DEL")); + endif + endif + tfile = cstrcat (pack.name, "-", pack.version, ".tar"); + tar (tfile, pack.name); + try + gzip (tfile); + unlink (tfile); + catch + warning ("failed to compress %s", tfile); + end_try_catch + unwind_protect_cleanup + if (exist (pack.name, "dir")) + rm_rf (pack.name); + endif + cd (wd); + end_unwind_protect + endfor +endfunction + +function auto = isautoload (desc) + auto = false; + if (isfield (desc{1}, "autoload")) + a = desc{1}.autoload; + if ((isnumeric (a) && a > 0) + || (ischar (a) && (strcmpi (a, "true") + || strcmpi (a, "on") + || strcmpi (a, "yes") + || strcmpi (a, "1")))) + auto = true; + endif + endif +endfunction + +function prepare_installation (desc, packdir) + ## Is there a pre_install to call? + if (exist (fullfile (packdir, "pre_install.m"), "file")) + wd = pwd (); + try + cd (packdir); + pre_install (desc); + cd (wd); + catch + cd (wd); + rethrow (lasterror ()); + end_try_catch + endif + + ## If the directory "inst" doesn't exist, we create it. + inst_dir = fullfile (packdir, "inst"); + if (! exist (inst_dir, "dir")) + [status, msg] = mkdir (inst_dir); + if (status != 1) + rm_rf (desc.dir); + error ("the 'inst' directory did not exist and could not be created: %s", + msg); + endif + endif +endfunction + +function configure_make (desc, packdir, verbose) + ## Perform ./configure, make, make install in "src". + if (exist (fullfile (packdir, "src"), "dir")) + src = fullfile (packdir, "src"); + ## Configure. + if (exist (fullfile (src, "configure"), "file")) + flags = ""; + if (isempty (getenv ("CC"))) + flags = cstrcat (flags, " CC=\"", octave_config_info ("CC"), "\""); + endif + if (isempty (getenv ("CXX"))) + flags = cstrcat (flags, " CXX=\"", octave_config_info ("CXX"), "\""); + endif + if (isempty (getenv ("AR"))) + flags = cstrcat (flags, " AR=\"", octave_config_info ("AR"), "\""); + endif + if (isempty (getenv ("RANLIB"))) + flags = cstrcat (flags, " RANLIB=\"", octave_config_info ("RANLIB"), "\""); + endif + [status, output] = shell (strcat ("cd '", src, "'; ./configure --prefix=\"", + desc.dir, "\"", flags)); + if (status != 0) + rm_rf (desc.dir); + error ("the configure script returned the following error: %s", output); + elseif (verbose) + printf("%s", output); + endif + + endif + + ## Make. + if (exist (fullfile (src, "Makefile"), "file")) + [status, output] = shell (cstrcat ("export INSTALLDIR=\"", desc.dir, + "\"; make -C '", src, "'")); + if (status != 0) + rm_rf (desc.dir); + error ("'make' returned the following error: %s", output); + elseif (verbose) + printf("%s", output); + endif + endif + + ## Copy files to "inst" and "inst/arch" (this is instead of 'make + ## install'). + files = fullfile (src, "FILES"); + instdir = fullfile (packdir, "inst"); + archdir = fullfile (packdir, "inst", getarch ()); + + ## Get file names. + if (exist (files, "file")) + [fid, msg] = fopen (files, "r"); + if (fid < 0) + error ("couldn't open %s: %s", files, msg); + endif + filenames = char (fread (fid))'; + fclose (fid); + if (filenames(end) == "\n") + filenames(end) = []; + endif + filenames = split_by (filenames, "\n"); + delete_idx = []; + for i = 1:length (filenames) + if (! all (isspace (filenames{i}))) + filenames{i} = fullfile (src, filenames{i}); + else + delete_idx(end+1) = i; + endif + endfor + filenames(delete_idx) = []; + else + m = dir (fullfile (src, "*.m")); + oct = dir (fullfile (src, "*.oct")); + mex = dir (fullfile (src, "*.mex")); + + filenames = cellfun (@(x) fullfile (src, x), + {m.name, oct.name, mex.name}, + "UniformOutput", false); + endif + + ## Split into architecture dependent and independent files. + if (isempty (filenames)) + idx = []; + else + idx = cellfun (@is_architecture_dependent, filenames); + endif + archdependent = filenames (idx); + archindependent = filenames (!idx); + + ## Copy the files. + if (! all (isspace ([filenames{:}]))) + if (! exist (instdir, "dir")) # fixindent + mkdir (instdir); + endif + if (! all (isspace ([archindependent{:}]))) + if (verbose) + printf ("copyfile"); + printf (" %s", archindependent{:}); + printf ("%s\n", instdir); + endif + [status, output] = copyfile (archindependent, instdir); + if (status != 1) + rm_rf (desc.dir); + error ("Couldn't copy files from 'src' to 'inst': %s", output); + endif + endif + if (! all (isspace ([archdependent{:}]))) + if (verbose) + printf ("copyfile"); + printf (" %s", archdependent{:}); + printf (" %s\n", archdir); + endif + if (! exist (archdir, "dir")) + mkdir (archdir); + endif + [status, output] = copyfile (archdependent, archdir); + if (status != 1) + rm_rf (desc.dir); + error ("Couldn't copy files from 'src' to 'inst': %s", output); + endif + endif + endif + endif +endfunction + +function pkg = extract_pkg (nm, pat) + fid = fopen (nm, "rt"); + pkg = ""; + if (fid >= 0) + while (! feof (fid)) + ln = fgetl (fid); + if (ln > 0) + t = regexp (ln, pat, "tokens"); + if (! isempty (t)) + pkg = cstrcat (pkg, "\n", t{1}{1}); + endif + endif + endwhile + if (! isempty (pkg)) + pkg = cstrcat (pkg, "\n"); + endif + fclose (fid); + endif +endfunction + +function create_pkgadddel (desc, packdir, nm, global_install) + instpkg = fullfile (desc.dir, nm); + instfid = fopen (instpkg, "wt"); + ## If it is exists, most of the PKG_* file should go into the + ## architecture dependent directory so that the autoload/mfilename + ## commands work as expected. The only part that doesn't is the + ## part in the main directory. + archdir = fullfile (getarchprefix (desc), cstrcat (desc.name, "-", + desc.version), getarch ()); + if (exist (getarchdir (desc, global_install), "dir")) + archpkg = fullfile (getarchdir (desc, global_install), nm); + archfid = fopen (archpkg, "at"); + else + archpkg = instpkg; + archfid = instfid; + endif + + if (archfid >= 0 && instfid >= 0) + ## Search all dot-m files for PKG commands. + lst = dir (fullfile (packdir, "inst", "*.m")); + for i = 1:length (lst) + nam = fullfile (packdir, "inst", lst(i).name); + fwrite (instfid, extract_pkg (nam, ['^[#%][#%]* *' nm ': *(.*)$'])); + endfor # fixindent + + ## Search all C++ source files for PKG commands. + lst = dir (fullfile (packdir, "src", "*.cc")); # fixindent + for i = 1:length (lst) + nam = fullfile (packdir, "src", lst(i).name); + fwrite (archfid, extract_pkg (nam, ['^//* *' nm ': *(.*)$'])); + fwrite (archfid, extract_pkg (nam, ['^/\** *' nm ': *(.*) *\*/$'])); + endfor + + ## Add developer included PKG commands. + packdirnm = fullfile (packdir, nm); + if (exist (packdirnm, "file")) + fid = fopen (packdirnm, "rt"); + if (fid >= 0) + while (! feof (fid)) + ln = fgets (fid); + if (ln > 0) + fwrite (archfid, ln); + endif + endwhile + fclose (fid); + endif + endif + + ## If the files is empty remove it. + fclose (instfid); + t = dir (instpkg); + if (t.bytes <= 0) + unlink (instpkg); + endif + + if (instfid != archfid) + fclose (archfid); + t = dir (archpkg); + if (t.bytes <= 0) + unlink (archpkg); + endif + endif + endif # fixindent +endfunction # fixindent + +function copy_files (desc, packdir, global_install) # fixindent + ## Create the installation directory. + if (! exist (desc.dir, "dir")) + [status, output] = mkdir (desc.dir); + if (status != 1) + error ("couldn't create installation directory %s : %s", + desc.dir, output); + endif + endif + + octfiledir = getarchdir (desc); + + ## Copy the files from "inst" to installdir. + instdir = fullfile (packdir, "inst"); + if (! dirempty (instdir)) + [status, output] = copyfile (fullfile (instdir, "*"), desc.dir); + if (status != 1) + rm_rf (desc.dir); + error ("couldn't copy files to the installation directory"); + endif + if (exist (fullfile (desc.dir, getarch ()), "dir") && + ! strcmp (fullfile (desc.dir, getarch ()), octfiledir)) + if (! exist (octfiledir, "dir")) + ## Can be required to create upto three levels of dirs. + octm1 = fileparts (octfiledir); + if (! exist (octm1, "dir")) + octm2 = fileparts (octm1); + if (! exist (octm2, "dir")) + octm3 = fileparts (octm2); + if (! exist (octm3, "dir")) + [status, output] = mkdir (octm3); + if (status != 1) + rm_rf (desc.dir); + error ("couldn't create installation directory %s : %s", + octm3, output); + endif + endif + [status, output] = mkdir (octm2); + if (status != 1) + rm_rf (desc.dir); + error ("couldn't create installation directory %s : %s", + octm2, output); + endif + endif + [status, output] = mkdir (octm1); + if (status != 1) + rm_rf (desc.dir); + error ("couldn't create installation directory %s : %s", + octm1, output); + endif + endif + [status, output] = mkdir (octfiledir); + if (status != 1) + rm_rf (desc.dir); + error ("couldn't create installation directory %s : %s", + octfiledir, output); + endif + endif + [status, output] = movefile (fullfile (desc.dir, getarch (), "*"), + octfiledir); + rm_rf (fullfile (desc.dir, getarch ())); + + if (status != 1) + rm_rf (desc.dir); + rm_rf (octfiledir); + error ("couldn't copy files to the installation directory"); + endif + endif + + endif + + ## Create the "packinfo" directory. + packinfo = fullfile (desc.dir, "packinfo"); + [status, msg] = mkdir (packinfo); + if (status != 1) + rm_rf (desc.dir); + rm_rf (octfiledir); + error ("couldn't create packinfo directory: %s", msg); + endif + + ## Copy DESCRIPTION. + [status, output] = copyfile (fullfile (packdir, "DESCRIPTION"), packinfo); + if (status != 1) + rm_rf (desc.dir); + rm_rf (octfiledir); + error ("couldn't copy DESCRIPTION: %s", output); + endif + + ## Copy COPYING. + [status, output] = copyfile (fullfile (packdir, "COPYING"), packinfo); + if (status != 1) + rm_rf (desc.dir); + rm_rf (octfiledir); + error ("couldn't copy COPYING: %s", output); + endif + + ## If the file ChangeLog exists, copy it. + changelog_file = fullfile (packdir, "ChangeLog"); + if (exist (changelog_file, "file")) + [status, output] = copyfile (changelog_file, packinfo); + if (status != 1) + rm_rf (desc.dir); + rm_rf (octfiledir); + error ("couldn't copy ChangeLog file: %s", output); + endif + endif + + ## Is there an INDEX file to copy or should we generate one? + index_file = fullfile (packdir, "INDEX"); + if (exist(index_file, "file")) + [status, output] = copyfile (index_file, packinfo); + if (status != 1) + rm_rf (desc.dir); + rm_rf (octfiledir); + error ("couldn't copy INDEX file: %s", output); + endif + else + try + write_index (desc, fullfile (packdir, "inst"), + fullfile (packinfo, "INDEX"), global_install); + catch + rm_rf (desc.dir); + rm_rf (octfiledir); + rethrow (lasterror ()); + end_try_catch + endif + + ## Is there an 'on_uninstall.m' to install? + fon_uninstall = fullfile (packdir, "on_uninstall.m"); + if (exist (fon_uninstall, "file")) + [status, output] = copyfile (fon_uninstall, packinfo); + if (status != 1) + rm_rf (desc.dir); + rm_rf (octfiledir); + error ("couldn't copy on_uninstall.m: %s", output); + endif + endif + + ## Is there a doc/ directory that needs to be installed? + docdir = fullfile (packdir, "doc"); + if (exist (docdir, "dir") && ! dirempty (docdir)) + [status, output] = copyfile (docdir, desc.dir); + endif + + ## Is there a bin/ directory that needs to be installed? + ## FIXME: Need to treat architecture dependent files in bin/ + bindir = fullfile (packdir, "bin"); + if (exist (bindir, "dir") && ! dirempty (bindir)) + [status, output] = copyfile (bindir, desc.dir); + endif +endfunction + +function finish_installation (desc, packdir, global_install) + ## Is there a post-install to call? + if (exist (fullfile (packdir, "post_install.m"), "file")) + wd = pwd (); + try + cd (packdir); + post_install (desc); + cd (wd); + catch + cd (wd); + rm_rf (desc.dir); + rm_rf (getarchdir (desc), global_install); + rethrow (lasterror ()); + end_try_catch + endif +endfunction + +function generate_lookfor_cache (desc) + dirs = split_by (genpath (desc.dir), pathsep ()); + for i = 1 : length (dirs) + gen_doc_cache (fullfile (dirs{i}, "doc-cache"), dirs{i}); + endfor +endfunction + +## Make sure the package contains the essential files. +function verify_directory (dir) + needed_files = {"COPYING", "DESCRIPTION"}; + for f = needed_files + if (! exist (fullfile (dir, f{1}), "file")) + error ("package is missing file: %s", f{1}); + endif + endfor +endfunction + +## Parse the DESCRIPTION file. +function desc = get_description (filename) + [fid, msg] = fopen (filename, "r"); + if (fid == -1) + error ("the DESCRIPTION file %s could not be read: %s", filename, msg); + endif + + desc = struct (); + + line = fgetl (fid); + while (line != -1) + if (line(1) == "#") + ## Comments, do nothing. + elseif (isspace(line(1))) + ## Continuation lines + if (exist ("keyword", "var") && isfield (desc, keyword)) + desc.(keyword) = cstrcat (desc.(keyword), " ", rstrip(line)); + endif + else + ## Keyword/value pair + colon = find (line == ":"); + if (length (colon) == 0) + disp ("skipping line"); + else + colon = colon(1); + keyword = tolower (strip (line(1:colon-1))); + value = strip (line (colon+1:end)); + if (length (value) == 0) + fclose (fid); + error ("the keyword %s has an empty value", desc.keywords{end}); + endif + desc.(keyword) = value; + endif + endif + line = fgetl (fid); + endwhile + fclose (fid); + + ## Make sure all is okay. + needed_fields = {"name", "version", "date", "title", ... + "author", "maintainer", "description"}; + for f = needed_fields + if (! isfield (desc, f{1})) + error ("description is missing needed field %s", f{1}); + endif + endfor + desc.version = fix_version (desc.version); + if (isfield (desc, "depends")) + desc.depends = fix_depends (desc.depends); + else + desc.depends = ""; + endif + desc.name = tolower (desc.name); +endfunction + +## Make sure the version string v is a valid x.y.z version string +## Examples: "0.1" => "0.1.0", "monkey" => error(...). +function out = fix_version (v) + dots = find (v == "."); + if (length (dots) == 1) + major = str2num (v(1:dots-1)); + minor = str2num (v(dots+1:end)); + if (length (major) != 0 && length (minor) != 0) + out = sprintf ("%d.%d.0", major, minor); + return; + endif + elseif (length (dots) == 2) + major = str2num (v(1:dots(1)-1)); + minor = str2num (v(dots(1)+1:dots(2)-1)); + rev = str2num (v(dots(2)+1:end)); + if (length (major) != 0 && length (minor) != 0 && length (rev) != 0) + out = sprintf ("%d.%d.%d", major, minor, rev); + return; + endif + endif + error ("bad version string: %s", v); +endfunction + +## Make sure the depends field is of the right format. +## This function returns a cell of structures with the following fields: +## package, version, operator +function deps_cell = fix_depends (depends) + deps = split_by (tolower (depends), ","); + deps_cell = cell (1, length (deps)); + + ## For each dependency. + for i = 1:length (deps) + dep = deps{i}; + lpar = find (dep == "("); + rpar = find (dep == ")"); + ## Does the dependency specify a version + ## Example: package(>= version). + if (length (lpar) == 1 && length (rpar) == 1) + package = tolower (strip (dep(1:lpar-1))); + sub = dep(lpar(1)+1:rpar(1)-1); + parts = strsplit (sub, " ", true); + if (length (parts) != 2) + error ("incorrect syntax for dependency `%s' in the DESCRIPTION file\n", + dep); + endif + operator = parts{1}; + if (! any (strcmp (operator, {">", ">=", "<=", "<", "=="}))) + error ("unsupported operator: %s", operator); + endif + version = fix_version (parts{2}); + + ## If no version is specified for the dependency + ## we say that the version should be greater than + ## or equal to "0.0.0". + else + package = tolower (strip (dep)); + operator = ">="; + version = "0.0.0"; + endif + deps_cell{i} = struct ("package", package, "operator", operator, + "version", version); + endfor +endfunction + +## Strip the text of spaces from the right +## Example: " hello world " => " hello world" +## FIXME -- is this the same as deblank? +function text = rstrip (text) + chars = find (! isspace (text)); + if (length (chars) > 0) + ## FIXME: shouldn't it be text = text(1:chars(end)); + text = text (chars(1):end); + else + text = ""; + endif +endfunction + +## Strip the text of spaces from the left and the right. +## Example: " hello world " => "hello world" +function text = strip (text) + chars = find (! isspace (text)); + if (length (chars) > 0) + text = text(chars(1):chars(end)); + else + text = ""; + endif +endfunction + +## Split the text into a cell array of strings by sep. +## Example: "A, B" => {"A", "B"} (with sep = ",") +function out = split_by (text, sep) + out = strtrim (strsplit (text, sep)); +endfunction + +## Create an INDEX file for a package that doesn't provide one. +## 'desc' describes the package. +## 'dir' is the 'inst' directory in temporary directory. +## 'index_file' is the name (including path) of resulting INDEX file. +function write_index (desc, dir, index_file, global_install) + ## Get names of functions in dir + [files, err, msg] = readdir (dir); + if (err) + error ("couldn't read directory %s: %s", dir, msg); + endif + + ## Check for architecture dependent files. + tmpdir = getarchdir (desc); + if (exist (tmpdir, "dir")) + [files2, err, msg] = readdir (tmpdir); + if (err) + error ("couldn't read directory %s: %s", tmpdir, msg); + endif + files = [files; files2]; + endif + + functions = {}; + for i = 1:length (files) + file = files{i}; + lf = length (file); + if (lf > 2 && strcmp (file(end-1:end), ".m")) + functions{end+1} = file(1:end-2); + elseif (lf > 4 && strcmp (file(end-3:end), ".oct")) + functions{end+1} = file(1:end-4); + endif + endfor + + ## Does desc have a categories field? + if (! isfield (desc, "categories")) + error ("the DESCRIPTION file must have a Categories field, when no INDEX file is given"); + endif + categories = split_by (desc.categories, ","); + if (length (categories) < 1) + error ("the Category field is empty"); + endif + + ## Write INDEX. + fid = fopen (index_file, "w"); + if (fid == -1) + error ("couldn't open %s for writing.", index_file); + endif + fprintf (fid, "%s >> %s\n", desc.name, desc.title); + fprintf (fid, "%s\n", categories{1}); + fprintf (fid, " %s\n", functions{:}); + fclose (fid); +endfunction + +function bad_deps = get_unsatisfied_deps (desc, installed_pkgs_lst) + bad_deps = {}; + + ## For each dependency. + for i = 1:length (desc.depends) + dep = desc.depends{i}; + + ## Is the current dependency Octave? + if (strcmp (dep.package, "octave")) + if (! compare_versions (OCTAVE_VERSION, dep.version, dep.operator)) + bad_deps{end+1} = dep; + endif + ## Is the current dependency not Octave? + else + ok = false; + for i = 1:length (installed_pkgs_lst) + cur_name = installed_pkgs_lst{i}.name; + cur_version = installed_pkgs_lst{i}.version; + if (strcmp (dep.package, cur_name) + && compare_versions (cur_version, dep.version, dep.operator)) + ok = true; + break; + endif + endfor + if (! ok) + bad_deps{end+1} = dep; + endif + endif + endfor +endfunction + +function [out1, out2] = installed_packages (local_list, global_list) + ## Get the list of installed packages. + try + local_packages = load (local_list).local_packages; + catch + local_packages = {}; + end_try_catch + try + global_packages = load (global_list).global_packages; + catch + global_packages = {}; + end_try_catch + installed_pkgs_lst = {local_packages{:}, global_packages{:}}; + + ## Eliminate duplicates in the installed package list. + ## Locally installed packages take precedence. + dup = []; + for i = 1:length (installed_pkgs_lst) + if (find (dup, i)) + continue; + endif + for j = (i+1):length (installed_pkgs_lst) + if (find (dup, j)) + continue; + endif + if (strcmp (installed_pkgs_lst{i}.name, installed_pkgs_lst{j}.name)) + dup = [dup, j]; + endif + endfor + endfor + if (! isempty(dup)) + installed_pkgs_lst(dup) = []; + endif + + ## Now check if the package is loaded. + tmppath = strrep (path(), "\\", "/"); + for i = 1:length (installed_pkgs_lst) + if (findstr (tmppath, strrep (installed_pkgs_lst{i}.dir, "\\", "/"))) + installed_pkgs_lst{i}.loaded = true; + else + installed_pkgs_lst{i}.loaded = false; + endif + endfor + for i = 1:length (local_packages) + if (findstr (tmppath, strrep (local_packages{i}.dir, "\\", "/"))) + local_packages{i}.loaded = true; + else + local_packages{i}.loaded = false; + endif + endfor + for i = 1:length (global_packages) + if (findstr (tmppath, strrep (global_packages{i}.dir, "\\", "/"))) + global_packages{i}.loaded = true; + else + global_packages{i}.loaded = false; + endif + endfor + + ## Should we return something? + if (nargout == 2) + out1 = local_packages; + out2 = global_packages; + return; + elseif (nargout == 1) + out1 = installed_pkgs_lst; + return; + endif + + ## We shouldn't return something, so we'll print something. + num_packages = length (installed_pkgs_lst); + if (num_packages == 0) + printf ("no packages installed.\n"); + return; + endif + + ## Compute the maximal lengths of name, version, and dir. + h1 = "Package Name"; + h2 = "Version"; + h3 = "Installation directory"; + max_name_length = length (h1); + max_version_length = length (h2); + names = cell (num_packages, 1); + for i = 1:num_packages + max_name_length = max (max_name_length, + length (installed_pkgs_lst{i}.name)); + max_version_length = max (max_version_length, + length (installed_pkgs_lst{i}.version)); + names{i} = installed_pkgs_lst{i}.name; + endfor + max_dir_length = terminal_size()(2) - max_name_length - ... + max_version_length - 7; + if (max_dir_length < 20) + max_dir_length = Inf; + endif + + h1 = postpad (h1, max_name_length + 1, " "); + h2 = postpad (h2, max_version_length, " ");; + + ## Print a header. + header = sprintf("%s | %s | %s\n", h1, h2, h3); + printf (header); + tmp = sprintf (repmat ("-", 1, length(header)-1)); + tmp(length(h1)+2) = "+"; + tmp(length(h1)+length(h2)+5) = "+"; + printf ("%s\n", tmp); + + ## Print the packages. + format = sprintf ("%%%ds %%1s| %%%ds | %%s\n", max_name_length, + max_version_length); + [dummy, idx] = sort (names); + for i = 1:num_packages + cur_name = installed_pkgs_lst{idx(i)}.name; + cur_version = installed_pkgs_lst{idx(i)}.version; + cur_dir = installed_pkgs_lst{idx(i)}.dir; + if (length (cur_dir) > max_dir_length) + first_char = length (cur_dir) - max_dir_length + 4; + first_filesep = strfind (cur_dir(first_char:end), filesep()); + if (! isempty (first_filesep)) + cur_dir = cstrcat ("...", + cur_dir((first_char + first_filesep(1) - 1):end)); + else + cur_dir = cstrcat ("...", cur_dir(first_char:end)); + endif + endif + if (installed_pkgs_lst{idx(i)}.loaded) + cur_loaded = "*"; + else + cur_loaded = " "; + endif + printf (format, cur_name, cur_loaded, cur_version, cur_dir); + endfor +endfunction + +function load_packages (files, handle_deps, local_list, global_list) + installed_pkgs_lst = installed_packages (local_list, global_list); + num_packages = length (installed_pkgs_lst); + + ## Read package names and installdirs into a more convenient format. + pnames = pdirs = cell (1, num_packages); + for i = 1:num_packages + pnames{i} = installed_pkgs_lst{i}.name; + pdirs{i} = installed_pkgs_lst{i}.dir; + endfor + + ## Load all. + if (length (files) == 1 && strcmp (files{1}, "all")) + idx = [1:length(installed_pkgs_lst)]; + ## Load auto. + elseif (length (files) == 1 && strcmp (files{1}, "auto")) + idx = []; + for i = 1:length (installed_pkgs_lst) + if (exist (fullfile (pdirs{i}, "packinfo", ".autoload"), "file")) + idx (end + 1) = i; + endif + endfor + ## Load package_name1 ... + else + idx = []; + for i = 1:length (files) + idx2 = find (strcmp (pnames, files{i})); + if (! any (idx2)) + error ("package %s is not installed", files{i}); + endif + idx (end + 1) = idx2; + endfor + endif + + ## Load the packages, but take care of the ordering of dependencies. + load_packages_and_dependencies (idx, handle_deps, installed_pkgs_lst, true); +endfunction + +function unload_packages (files, handle_deps, local_list, global_list) + installed_pkgs_lst = installed_packages (local_list, global_list); + num_packages = length (installed_pkgs_lst); + + ## Read package names and installdirs into a more convenient format. + pnames = pdirs = cell (1, num_packages); + for i = 1:num_packages + pnames{i} = installed_pkgs_lst{i}.name; + pdirs{i} = installed_pkgs_lst{i}.dir; + pdeps{i} = installed_pkgs_lst{i}.depends; + endfor + + ## Get the current octave path. + p = split_by (path(), pathsep ()); + + if (length (files) == 1 && strcmp (files{1}, "all")) + ## Unload all. + dirs = pdirs; + desc = installed_pkgs_lst; + else + ## Unload package_name1 ... + dirs = {}; + desc = {}; + for i = 1:length (files) + idx = strcmp (pnames, files{i}); + if (! any (idx)) + error ("package %s is not installed", files{i}); + endif + dirs{end+1} = pdirs{idx}; + desc{end+1} = installed_pkgs_lst{idx}; + endfor + endif + + ## Check for architecture dependent directories. + archdirs = {}; + for i = 1:length (dirs) + tmpdir = getarchdir (desc{i}); + if (exist (tmpdir, "dir")) + archdirs{end+1} = dirs{i}; + archdirs{end+1} = tmpdir; + else + archdirs{end+1} = dirs{i}; + endif + endfor + + ## Unload the packages. + for i = 1:length (archdirs) + d = archdirs{i}; + idx = strcmp (p, d); + if (any (idx)) + rmpath (d); + ## FIXME: We should also check if we need to remove items from + ## EXEC_PATH. + endif + endfor +endfunction + +function [status_out, msg_out] = rm_rf (dir) + if (exist (dir)) + crr = confirm_recursive_rmdir (); + unwind_protect + confirm_recursive_rmdir (false); + [status, msg] = rmdir (dir, "s"); + unwind_protect_cleanup + confirm_recursive_rmdir (crr); + end_unwind_protect + else + status = 1; + msg = ""; + endif + if (nargout > 0) + status_out = status; + endif + if (nargout > 1) + msg_out = msg; + endif +endfunction + +function emp = dirempty (nm, ign) + if (exist (nm, "dir")) + if (nargin < 2) + ign = {".", ".."}; + else + ign = [{".", ".."}, ign]; + endif + l = dir (nm); + for i = 1:length (l) + found = false; + for j = 1:length (ign) + if (strcmp (l(i).name, ign{j})) + found = true; + break; + endif + endfor + if (! found) + emp = false; + return + endif + endfor + emp = true; + else + emp = true; + endif +endfunction + +function arch = getarch () + persistent _arch = cstrcat (octave_config_info("canonical_host_type"), ... + "-", octave_config_info("api_version")); + arch = _arch; +endfunction + +function archprefix = getarchprefix (desc, global_install) + if ((nargin == 2 && global_install) || (nargin < 2 && issuperuser ())) + archprefix = fullfile (octave_config_info ("libexecdir"), "octave", + "packages", cstrcat(desc.name, "-", desc.version)); + else + archprefix = desc.dir; + endif +endfunction + +function archdir = getarchdir (desc) + archdir = fullfile (desc.archprefix, getarch()); +endfunction + +function s = issuperuser () + if ((ispc () && ! isunix ()) || (geteuid() == 0)) + s = true; + else + s = false; + endif +endfunction + +function [status, output] = shell (cmd) + persistent have_sh; + + cmd = strrep (cmd, "\\", "/"); + if (ispc () && ! isunix ()) + if (isempty(have_sh)) + if (system("sh.exe -c \"exit\"")) + have_sh = false; + else + have_sh = true; + endif + endif + if (have_sh) + [status, output] = system (cstrcat ("sh.exe -c \"", cmd, "\"")); + else + error ("Can not find the command shell") + endif + else + [status, output] = system (cmd); + endif +endfunction + +function newdesc = save_order (desc) + newdesc = {}; + for i = 1 : length(desc) + deps = desc{i}.depends; + if (isempty (deps) || (length (deps) == 1 && + strcmp(deps{1}.package, "octave"))) + newdesc {end + 1} = desc{i}; + else + tmpdesc = {}; + for k = 1 : length (deps) + for j = 1 : length (desc) + if (strcmp (desc{j}.name, deps{k}.package)) + tmpdesc{end+1} = desc{j}; + break; + endif + endfor + endfor + if (! isempty (tmpdesc)) + newdesc = {newdesc{:}, save_order(tmpdesc){:}, desc{i}}; + else + newdesc{end+1} = desc{i}; + endif + endif + endfor + ## Eliminate the duplicates. + idx = []; + for i = 1 : length (newdesc) + for j = (i + 1) : length (newdesc) + if (strcmp (newdesc{i}.name, newdesc{j}.name)) + idx (end + 1) = j; + endif + endfor + endfor + newdesc(idx) = []; +endfunction + +function load_packages_and_dependencies (idx, handle_deps, installed_pkgs_lst, + global_install) + idx = load_package_dirs (idx, [], handle_deps, installed_pkgs_lst); + dirs = {}; + execpath = EXEC_PATH (); + for i = idx; + ndir = installed_pkgs_lst{i}.dir; + dirs{end+1} = ndir; + if (exist (fullfile (dirs{end}, "bin"), "dir")) + execpath = cstrcat (fullfile (dirs{end}, "bin"), ":", execpath); + endif + tmpdir = getarchdir (installed_pkgs_lst{i}); + if (exist (tmpdir, "dir")) + dirs{end + 1} = tmpdir; + if (exist (fullfile (dirs{end}, "bin"), "dir")) + execpath = cstrcat (fullfile (dirs{end}, "bin"), ":", execpath); + endif + endif + endfor + + ## Load the packages. + if (length (dirs) > 0) + addpath (dirs{:}); + endif + + ## Add the binaries to exec_path. + if (! strcmp (EXEC_PATH, execpath)) + EXEC_PATH (execpath); + endif +endfunction + +function idx = load_package_dirs (lidx, idx, handle_deps, installed_pkgs_lst) + for i = lidx + if (isfield (installed_pkgs_lst{i}, "loaded") && + installed_pkgs_lst{i}.loaded) + continue; + else + if (handle_deps) + deps = installed_pkgs_lst{i}.depends; + if ((length (deps) > 1) || (length (deps) == 1 && + ! strcmp(deps{1}.package, "octave"))) + tmplidx = []; + for k = 1 : length (deps) + for j = 1 : length (installed_pkgs_lst) + if (strcmp (installed_pkgs_lst{j}.name, deps{k}.package)) + tmplidx (end + 1) = j; + break; + endif + endfor + endfor + idx = load_package_dirs (tmplidx, idx, handle_deps, + installed_pkgs_lst); + endif + endif + if (isempty (find(idx == i))) + idx (end + 1) = i; + endif + endif + endfor +endfunction + +function dep = is_architecture_dependent (nm) + persistent archdepsuffix = {".oct",".mex",".a",".lib",".so",".so.*",".dll","dylib"}; + + dep = false; + for i = 1 : length (archdepsuffix) + ext = archdepsuffix{i}; + if (ext(end) == "*") + isglob = true; + ext(end) = []; + else + isglob = false; + endif + pos = findstr (nm, ext); + if (pos) + if (! isglob && (length(nm) - pos(end) != length(ext) - 1)) + continue; + endif + dep = true; + break; + endif + endfor +endfunction