# HG changeset patch # User cvs # Date 1186987760 -7200 # Node ID 0293115a14e91d20fba091dde9afe5fc6ee3d748 # Parent ad457d5f7d045598e58a3dd7bd44098974f5cc32 Import from CVS: tag r19-15b91 diff -r ad457d5f7d04 -r 0293115a14e9 CHANGES-beta --- a/CHANGES-beta Mon Aug 13 08:48:43 2007 +0200 +++ b/CHANGES-beta Mon Aug 13 08:49:20 2007 +0200 @@ -1,4 +1,15 @@ -*- indented-text -*- +to 19.15 beta91 +-- Gnus-5.4.9 Courtesy of Lars Magne Ingebrigtsen +-- Custom-1.20 Courtesy of Per Abrahamsen +-- Widget-1.20 Courtesy of Per Abrahamsen +-- iso-acc.el updated courtesy of Alexandre Oliva +-- tm-7.103 +-- w3-3.0.52 +-- html 3.2 final dtd added +-- Miscellaneous bug fixes +-- ps-print.el-3.05 Courtesy of Jacques Duthen Prestataire + to 19.15 beta90 -- ediff-2.64 -- viper-2.92 diff -r ad457d5f7d04 -r 0293115a14e9 configure --- a/configure Mon Aug 13 08:48:43 2007 +0200 +++ b/configure Mon Aug 13 08:49:20 2007 +0200 @@ -2077,7 +2077,7 @@ machine=iris4d opsys=irix4-0 ;; mips-sgi-irix6* ) - machine=iris4d opsys=irix6-0 NON_GNU_CPP=/lib/cpp + machine=iris4d opsys=irix6-0 ;; mips-sgi-irix5.[3-9]* ) machine=iris4d opsys=irix5-3 @@ -5138,6 +5138,14 @@ || [ "${with_dialogs}" = "motif" ]; then with_motif='yes' fi +if [ "${with_menubars}" = "athena" ] || [ "${with_scrollbars}" = "athena" ] \ + || [ "${with_dialogs}" = "athena" ]; then + with_athena='yes' +fi +if [ "${with_menubars}" = "athena3d" ] || [ "${with_scrollbars}" = "athena3d" ] \ + || [ "${with_dialogs}" = "athena3d" ]; then + with_athena='yes' +fi # Finish ensuring that we have values for the various toolkit items. if [ "x${with_menubars}" = "x" ] || [ "${with_menubars}" = "athena" ]; then @@ -7309,6 +7317,20 @@ } fi +if [ "${with_athena}" = "yes" ] ; then + +{ +test -n "$verbose" && \ +echo " defining LWLIB_USES_ATHENA" +echo "#define" LWLIB_USES_ATHENA "1" >> confdefs.h +DEFS="$DEFS -DLWLIB_USES_ATHENA=1" +ac_sed_defs="${ac_sed_defs}\${ac_dA}LWLIB_USES_ATHENA\${ac_dB}LWLIB_USES_ATHENA\${ac_dC}1\${ac_dD} +\${ac_uA}LWLIB_USES_ATHENA\${ac_uB}LWLIB_USES_ATHENA\${ac_uC}1\${ac_uD} +\${ac_eA}LWLIB_USES_ATHENA\${ac_eB}LWLIB_USES_ATHENA\${ac_eC}1\${ac_eD} +" +} + +fi if [ "${with_menubars}" = "lucid" ] ; then { diff -r ad457d5f7d04 -r 0293115a14e9 configure.in --- a/configure.in Mon Aug 13 08:48:43 2007 +0200 +++ b/configure.in Mon Aug 13 08:49:20 2007 +0200 @@ -1693,6 +1693,9 @@ ;; ## Data General AViiON Machines + i586-dg-dgux5.4R4* | i586-dg-dgux5.4.4* ) + machine=aviion opsys=dgux5-4r4 + ;; m88k-dg-dgux5.4R3* | m88k-dg-dgux5.4.3* ) machine=aviion opsys=dgux5-4r3 ;; @@ -2082,7 +2085,7 @@ machine=iris4d opsys=irix4-0 ;; mips-sgi-irix6* ) - machine=iris4d opsys=irix6-0 NON_GNU_CPP=/lib/cpp + machine=iris4d opsys=irix6-0 ;; mips-sgi-irix5.[3-9]* ) machine=iris4d opsys=irix5-3 @@ -3570,6 +3573,14 @@ || [ "${with_dialogs}" = "motif" ]; then with_motif='yes' fi +if [ "${with_menubars}" = "athena" ] || [ "${with_scrollbars}" = "athena" ] \ + || [ "${with_dialogs}" = "athena" ]; then + with_athena='yes' +fi +if [ "${with_menubars}" = "athena3d" ] || [ "${with_scrollbars}" = "athena3d" ] \ + || [ "${with_dialogs}" = "athena3d" ]; then + with_athena='yes' +fi # Finish ensuring that we have values for the various toolkit items. if [ "x${with_menubars}" = "x" ] || [ "${with_menubars}" = "athena" ]; then @@ -4097,6 +4108,9 @@ if [ "${with_motif}" = "yes" ] ; then ] AC_DEFINE(LWLIB_USES_MOTIF) [ fi +if [ "${with_athena}" = "yes" ] ; then + ] AC_DEFINE(LWLIB_USES_ATHENA) [ +fi if [ "${with_menubars}" = "lucid" ] ; then ] AC_DEFINE(LWLIB_MENUBARS_LUCID) [ ] AC_DEFINE(HAVE_MENUBARS) [ diff -r ad457d5f7d04 -r 0293115a14e9 etc/gnus-tut.txt --- a/etc/gnus-tut.txt Mon Aug 13 08:48:43 2007 +0200 +++ b/etc/gnus-tut.txt Mon Aug 13 08:49:20 2007 +0200 @@ -186,7 +186,7 @@ these, or change these, you'll have to re-write your code. Old hilit19 code does not work at all. In fact, you should probably -remove all hihit code from all the Gnus hooks +remove all hilit code from all the Gnus hooks (`gnus-group-prepare-hook', `gnus-summary-prepare-hook' and `gnus-summary-article-hook'). (Well, at the very least the first two.) Gnus provides various integrated functions for highlighting, @@ -272,7 +272,7 @@ Message-ID: If you want to report a bug, please type `M-x gnus-bug'. This will -give me a precice overview of your Gnus and Emacs version numbers, +give me a precise overview of your Gnus and Emacs version numbers, along with a look at all Gnus variables you have changed. Du not expect a reply back, but your bug should be fixed in the next diff -r ad457d5f7d04 -r 0293115a14e9 etc/sample.emacs --- a/etc/sample.emacs Mon Aug 13 08:48:43 2007 +0200 +++ b/etc/sample.emacs Mon Aug 13 08:49:20 2007 +0200 @@ -38,34 +38,34 @@ ;; and such. ;; Make F1 invoke help -(global-set-key 'f1 'help-command) +(global-set-key [f1] 'help-command) ;; Make F2 be `undo' -(global-set-key 'f2 'undo) +(global-set-key [f2] 'undo) ;; Make F3 be `find-file' ;; Note: it does not currently work to say ;; (global-set-key 'f3 "\C-x\C-f") ;; The reason is that macros can't do interactive things properly. ;; This is an extremely longstanding bug in Emacs. Eventually, ;; it will be fixed. (Hopefully ..) -(global-set-key 'f3 'find-file) +(global-set-key [f3] 'find-file) ;; Make F4 be "mark", F5 be "copy", F6 be "paste" ;; Note that you can set a key sequence either to a command or to another ;; key sequence. -(global-set-key 'f4 'set-mark-command) -(global-set-key 'f5 "\M-w") -(global-set-key 'f6 "\C-y") +(global-set-key [f4] 'set-mark-command) +(global-set-key [f5] "\M-w") +(global-set-key [f6] "\C-y") ;; Shift-F4 is "pop mark off of stack" (global-set-key '(shift f4) (lambda () (interactive) (set-mark-command t))) ;; Make F7 be `save-buffer' -(global-set-key 'f7 'save-buffer) +(global-set-key [f7] 'save-buffer) ;; Make F8 be "start macro", F9 be "end macro", F10 be "execute macro" -(global-set-key 'f8 'start-kbd-macro) -(global-set-key 'f9 'end-kbd-macro) -(global-set-key 'f10 'call-last-kbd-macro) +(global-set-key [f8] 'start-kbd-macro) +(global-set-key [f9] 'end-kbd-macro) +(global-set-key [f10] 'call-last-kbd-macro) ;; Here's an alternative binding if you don't use keyboard macros: ;; Make F8 be `save-buffer' followed by `delete-window'. @@ -98,21 +98,6 @@ ;; When running ispell, consider all 1-3 character words as correct. (setq ispell-extra-args '("-W" "3")) - ;; Change the way the buffer name is displayed in the - ;; modeline. The variable for this is called - ;; 'modeline-buffer-identification but was called - ;; 'mode-line-buffer-identification in older XEmacsen. - (if (boundp 'modeline-buffer-identification) - ;; Note that if you want to put more than one form in the - ;; `THEN' clause of an IF-THEN-ELSE construct, you have to - ;; surround the forms with `progn'. You don't have to - ;; do this for the `ELSE' clauses. - (progn - (setq-default modeline-buffer-identification '("XEmacs: %17b")) - (setq modeline-buffer-identification '("XEmacs: %17b"))) - (setq-default mode-line-buffer-identification '("XEmacs: %17b")) - (setq mode-line-buffer-identification '("XEmacs: %17b"))) - (cond ((or (not (fboundp 'device-type)) (equal (device-type) 'x)) ;; Code which applies only when running emacs under X goes here. diff -r ad457d5f7d04 -r 0293115a14e9 etc/sgml/HTML32.dtd --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/etc/sgml/HTML32.dtd Mon Aug 13 08:49:20 2007 +0200 @@ -0,0 +1,598 @@ + + + + + ... + + -- + > + + + + + + + + + + + + + + + + + + + + + + +]]> + + + + + + +%ISOlat1; + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +]]> + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +]]> + + + + + + diff -r ad457d5f7d04 -r 0293115a14e9 etc/toolbar/ediff-A-up.xbm --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/etc/toolbar/ediff-A-up.xbm Mon Aug 13 08:49:20 2007 +0200 @@ -0,0 +1,6 @@ +#define ediff-A-up_width 15 +#define ediff-A-up_height 15 +static char ediff-A-up_bits[] = { + 0x00,0x80,0x00,0x80,0x00,0x80,0xc0,0x81,0xe0,0x83,0x60,0x83,0x70,0x87,0x30, + 0x86,0x38,0x8e,0xf8,0x8f,0x18,0x8c,0x18,0x8c,0x00,0x80,0x00,0x80,0x00,0x80 + }; diff -r ad457d5f7d04 -r 0293115a14e9 etc/toolbar/ediff-A-up.xpm --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/etc/toolbar/ediff-A-up.xpm Mon Aug 13 08:49:20 2007 +0200 @@ -0,0 +1,24 @@ +/* XPM */ +static char *ediff_A[] = { +/* width height num_colors chars_per_pixel */ +" 15 15 2 1", +/* colors */ +". c blue", +"# c Gray75 s backgroundToolBarColor", +/* pixels */ +"###############", +"###############", +"###############", +"######...######", +"#####.....#####", +"#####..#..#####", +"####...#...####", +"####..###..####", +"###...###...###", +"###.........###", +"###..#####..###", +"###..#####..###", +"###############", +"###############", +"###############", +}; \ No newline at end of file diff -r ad457d5f7d04 -r 0293115a14e9 etc/toolbar/ediff-A-xx.xpm --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/etc/toolbar/ediff-A-xx.xpm Mon Aug 13 08:49:20 2007 +0200 @@ -0,0 +1,24 @@ +/* XPM */ +static char *ediff_A[] = { +/* width height num_colors chars_per_pixel */ +" 15 15 2 1", +/* colors */ +". c gray60", +"# c Gray75 s backgroundToolBarColor", +/* pixels */ +"###############", +"###############", +"###############", +"######...######", +"#####.....#####", +"#####..#..#####", +"####...#...####", +"####..###..####", +"###...###...###", +"###.........###", +"###..#####..###", +"###..#####..###", +"###############", +"###############", +"###############", +}; \ No newline at end of file diff -r ad457d5f7d04 -r 0293115a14e9 etc/toolbar/ediff-B-up.xbm --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/etc/toolbar/ediff-B-up.xbm Mon Aug 13 08:49:20 2007 +0200 @@ -0,0 +1,6 @@ +#define ediff-B-up_width 15 +#define ediff-B-up_height 15 +static char ediff-B-up_bits[] = { + 0x00,0x80,0x00,0x80,0xf8,0x81,0xf8,0x83,0x38,0x87,0x38,0x86,0xf8,0x83,0xf8, + 0x87,0x38,0x8e,0x38,0x8c,0x38,0x8e,0xf8,0x87,0xf8,0x83,0x00,0x80,0x00,0x80 + }; diff -r ad457d5f7d04 -r 0293115a14e9 etc/toolbar/ediff-B-up.xpm --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/etc/toolbar/ediff-B-up.xpm Mon Aug 13 08:49:20 2007 +0200 @@ -0,0 +1,25 @@ +/* XPM */ +static char *ediff-B-up[] = { +/* width height num_colors chars_per_pixel */ +" 15 15 2 1", +/* colors */ +". c blue", +"# c Gray75 s backgroundToolBarColor", +/* pixels */ +"###############", +"###############", +"###......######", +"###.......#####", +"###...##...####", +"###...###..####", +"###.......#####", +"###........####", +"###...###...###", +"###...####..###", +"###...###...###", +"###........####", +"###.......#####", +"###############", +"###############", +"###############" +}; \ No newline at end of file diff -r ad457d5f7d04 -r 0293115a14e9 etc/toolbar/ediff-B-xx.xpm --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/etc/toolbar/ediff-B-xx.xpm Mon Aug 13 08:49:20 2007 +0200 @@ -0,0 +1,25 @@ +/* XPM */ +static char *ediff-B-up[] = { +/* width height num_colors chars_per_pixel */ +" 15 15 2 1", +/* colors */ +". c gray60", +"# c Gray75 s backgroundToolBarColor", +/* pixels */ +"###############", +"###############", +"###......######", +"###.......#####", +"###...##...####", +"###...###..####", +"###.......#####", +"###........####", +"###...###...###", +"###...####..###", +"###...###...###", +"###........####", +"###.......#####", +"###############", +"###############", +"###############" +}; \ No newline at end of file diff -r ad457d5f7d04 -r 0293115a14e9 etc/toolbar/ediff-help.xbm --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/etc/toolbar/ediff-help.xbm Mon Aug 13 08:49:20 2007 +0200 @@ -0,0 +1,6 @@ +#define ediff-help_width 15 +#define ediff-help_height 15 +static char ediff-help_bits[] = { + 0x00,0x80,0xf0,0x83,0x0c,0x86,0xe4,0x8c,0x74,0x8d,0xb4,0x8c,0x58,0x86,0x20, + 0x83,0xa0,0x83,0xa0,0x81,0xc0,0x80,0x20,0x83,0x20,0x83,0xc0,0x81,0x00,0x80 + }; diff -r ad457d5f7d04 -r 0293115a14e9 etc/toolbar/ediff-help.xpm --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/etc/toolbar/ediff-help.xpm Mon Aug 13 08:49:20 2007 +0200 @@ -0,0 +1,26 @@ +/* XPM */ +static char *help[] = { +/* width height num_colors chars_per_pixel */ +" 15 15 3 1", +/* colors */ +". c #000000", +"b c Gray75 s backgroundToolBarColor", +"c c #ffff00", +/* pixels */ +"bbbbbbbbbbbbbbb", +"bbbb......bbbbb", +"bbb.ccccc..bbbb", +"bb.cc...cc..bbb", +"bb.c..bb.c..bbb", +"bb.c..b.cc..bbb", +"bbb..b.cc..bbbb", +"bbbbb.cc..bbbbb", +"bbbbb.c..bbbbbb", +"bbbbb.c..bbbbbb", +"bbbbbb..bbbbbbb", +"bbbbb.cc..bbbbb", +"bbbbb.cc..bbbbb", +"bbbbbb...bbbbbb", +"bbbbbbbbbbbbbbb" +"bbbbbbbbbbbbbbb" +}; diff -r ad457d5f7d04 -r 0293115a14e9 etc/toolbar/ediff-next.xbm --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/etc/toolbar/ediff-next.xbm Mon Aug 13 08:49:20 2007 +0200 @@ -0,0 +1,6 @@ +#define ediff-next_width 15 +#define ediff-next_height 15 +static char ediff-next_bits[] = { + 0x00,0x80,0x80,0x80,0x80,0x83,0x80,0x82,0xfe,0x8c,0x02,0x8a,0xfa,0xb7,0xfa, + 0xbf,0xfa,0x9f,0xfe,0x8f,0xfe,0x87,0x80,0x83,0x80,0x81,0x80,0x80,0x00,0x80 + }; diff -r ad457d5f7d04 -r 0293115a14e9 etc/toolbar/ediff-next.xpm --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/etc/toolbar/ediff-next.xpm Mon Aug 13 08:49:20 2007 +0200 @@ -0,0 +1,25 @@ +/* XPM */ +static char * file[] = { +/* width height num_colors chars_per_pixel */ +"15 15 5 1", +" c Gray75 s backgroundToolBarColor", +". c black", +"X c white", +"o c black", +"O c black", +" ", +" . ", +" .. ", +" .X. ", +" .......XX. ", +" .XXXXXXXoX. ", +" .XooooooooX. ", +" .Xoooooooooo. ", +" .XooooooooO. ", +" .oOOOOOOoO. ", +" .......OO. ", +" .O. ", +" .. ", +" . ", +" ", +}; diff -r ad457d5f7d04 -r 0293115a14e9 etc/toolbar/ediff-prev.xbm --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/etc/toolbar/ediff-prev.xbm Mon Aug 13 08:49:20 2007 +0200 @@ -0,0 +1,6 @@ +#define ediff-prev_width 15 +#define ediff-prev_height 15 +static char ediff-prev_bits[] = { + 0x00,0x80,0x00,0x81,0x80,0x81,0x40,0x81,0x20,0xbf,0x50,0xa0,0xe8,0xaf,0xfc, + 0xaf,0xf8,0xaf,0xf0,0xbf,0xe0,0xbf,0xc0,0x81,0x80,0x81,0x00,0x81,0x00,0x80 + }; diff -r ad457d5f7d04 -r 0293115a14e9 etc/toolbar/ediff-prev.xpm --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/etc/toolbar/ediff-prev.xpm Mon Aug 13 08:49:20 2007 +0200 @@ -0,0 +1,23 @@ +/* XPM */ +static char * left-arrow_xpm[] = { +/* width height num_colors chars_per_pixel */ +"15 15 3 1", +" c Gray75 s backgroundToolBarColor", +". c black", +"X c white", +" ", +" . ", +" .. ", +" .X. ", +" .XX...... ", +" .X.XXXXXX. ", +" .X.......X. ", +" ..........X. ", +" .........X. ", +" .......... ", +" ......... ", +" ... ", +" .. ", +" . ", +" ", +}; diff -r ad457d5f7d04 -r 0293115a14e9 etc/toolbar/ediff-quit.xbm --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/etc/toolbar/ediff-quit.xbm Mon Aug 13 08:49:20 2007 +0200 @@ -0,0 +1,6 @@ +#define ediff-quit_width 15 +#define ediff-quit_height 15 +static char ediff-quit_bits[] = { + 0x00,0x80,0x06,0xb0,0x1e,0x98,0x3c,0x8c,0x70,0x82,0xe0,0x83,0xc0,0x81,0xe0, + 0x83,0x70,0x86,0x38,0x8c,0x1c,0x88,0x1c,0x90,0x08,0x80,0x00,0x80,0x00,0x80 + }; diff -r ad457d5f7d04 -r 0293115a14e9 etc/toolbar/ediff-quit.xpm --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/etc/toolbar/ediff-quit.xpm Mon Aug 13 08:49:20 2007 +0200 @@ -0,0 +1,26 @@ +/* XPM */ +static char *delete[] = { +/* width height num_colors chars_per_pixel */ +" 15 15 4 1", +/* colors */ +". c #808080", +"# c #800000", +"a c #ffffff", +"b c #c0c0c0", +/* pixels */ +"bbbbbbbbbbbbbbb", +"b##abbbbbbbb##a", +"b####abbbbb##ab", +"bb####abbb##abb", +"bbbb###ab#abbbb", +"bbbbb#####abbbb", +"bbbbbb###abbbbb", +"bbbbb#####abbbb", +"bbbb###ab##abbb", +"bbb###abbb##abb", +"bb###abbbbb#abb", +"bb###abbbbbb#ab", +"bbb#abbbbbbbbbb", +"bbb#abbbbbbbbbb", +"bbbbbbbbbbbbbbb", +}; diff -r ad457d5f7d04 -r 0293115a14e9 etc/toolbar/ediff-refine.xbm --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/etc/toolbar/ediff-refine.xbm Mon Aug 13 08:49:20 2007 +0200 @@ -0,0 +1,6 @@ +#define ediff-refine_width 15 +#define ediff-refine_height 15 +static char ediff-refine_bits[] = { + 0x00,0x80,0x80,0x80,0x84,0x90,0x8c,0x98,0x98,0x8c,0xf0,0x87,0xe0,0x83,0xe0, + 0x83,0xe0,0x83,0xf0,0x87,0x98,0x8c,0x8c,0x98,0x84,0x90,0x80,0x80,0x00,0x80 + }; diff -r ad457d5f7d04 -r 0293115a14e9 etc/toolbar/ediff-refine.xpm --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/etc/toolbar/ediff-refine.xpm Mon Aug 13 08:49:20 2007 +0200 @@ -0,0 +1,24 @@ +/* XPM */ +static char *help[] = { +/* width height num_colors chars_per_pixel */ +" 15 15 2 1", +/* colors */ +"# c #000000", +"a c Gray75 s backgroundToolBarColor", +/* pixels */ +"aaaaaaaaaaaaaaa", +"aaaaaaa#aaaaaaa", +"aa#aaaa#aaaa#aa", +"aa##aaa#aaa##aa", +"aaa##aa#aa##aaa", +"aaaa#######aaaa", +"aaaaa#####aaaaa", +"aaaaa#####aaaaa", +"aaaaa#####aaaaa", +"aaaa#######aaaa", +"aaa##aa#aa##aaa", +"aa##aaa#aaa##aa", +"aa#aaaa#aaaa#aa", +"aaaaaaa#aaaaaaa", +"aaaaaaaaaaaaaaa", +}; \ No newline at end of file diff -r ad457d5f7d04 -r 0293115a14e9 etc/toolbar/ediff-save-xx.xbm --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/etc/toolbar/ediff-save-xx.xbm Mon Aug 13 08:49:20 2007 +0200 @@ -0,0 +1,6 @@ +#define disk-xx_width 15 +#define disk-xx_height 15 +static char disk-xx_bits[] = { + 0x00,0x00,0x0a,0x28,0x00,0x00,0x0a,0x28,0x00,0x00,0x0a,0x28,0x00,0x00,0xfa, + 0x2f,0x00,0x00,0x02,0x20,0x00,0x00,0x0a,0x29,0x00,0x00,0xf8,0x3f,0x00,0x00 + }; diff -r ad457d5f7d04 -r 0293115a14e9 etc/toolbar/ediff-save-xx.xpm --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/etc/toolbar/ediff-save-xx.xpm Mon Aug 13 08:49:20 2007 +0200 @@ -0,0 +1,25 @@ +/* XPM */ +static char * disk[] = { +"15 15 5 1", +"X c Gray75 s backgroundToolBarColor", +"o c Gray60", +"O c Gray60", +"+ c Gray90", +"@ c Gray40", +"XXXXXXXXXXXXXXX", +"XXXXXXXXXXXXXXX", +"XoooooooooooooX", +"XoOo+++++++oOoX", +"XoOo+++++++oOoX", +"XoOo+++++++oOoX", +"XoOo+++++++oOoX", +"XoOoooooooooOoX", +"XoOOOOOOOOOOOoX", +"XoOoooooooooOoX", +"XoOo@@@@o++oOoX", +"XoOo@@@@o++oOoX", +"XoOo@@@@o++oOoX", +"XXooooooooooooX", +"XXXXXXXXXXXXXXX", +"XXXXXXXXXXXXXXX" +}; diff -r ad457d5f7d04 -r 0293115a14e9 etc/toolbar/ediff-save.xbm --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/etc/toolbar/ediff-save.xbm Mon Aug 13 08:49:20 2007 +0200 @@ -0,0 +1,6 @@ +#define disk-up_width 15 +#define disk-up_height 15 +static char disk-up_bits[] = { + 0x00,0x00,0xfe,0x3f,0x0a,0x28,0x0a,0x28,0x0a,0x38,0x0a,0x28,0x0a,0x28,0xfa, + 0x2f,0x02,0x20,0xfa,0x2f,0x0a,0x29,0x0a,0x29,0x0c,0x29,0xf8,0x3f,0x00,0x00 + }; diff -r ad457d5f7d04 -r 0293115a14e9 etc/toolbar/ediff-save.xpm --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/etc/toolbar/ediff-save.xpm Mon Aug 13 08:49:20 2007 +0200 @@ -0,0 +1,25 @@ +/* XPM */ +static char * disk[] = { +"15 15 5 1", +"X c Gray75 s backgroundToolBarColor", +"o c black", +"O c Gray60", +"+ c Gray90", +"@ c Gray40", +"XXXXXXXXXXXXXXX", +"XXXXXXXXXXXXXXX", +"XoooooooooooooX", +"XoOo+++++++oOoX", +"XoOo+++++++oOoX", +"XoOo+++++++oOoX", +"XoOo+++++++oOoX", +"XoOoooooooooOoX", +"XoOOOOOOOOOOOoX", +"XoOoooooooooOoX", +"XoOo@@@@o++oOoX", +"XoOo@@@@o++oOoX", +"XoOo@@@@o++oOoX", +"XXooooooooooooX", +"XXXXXXXXXXXXXXX", +"XXXXXXXXXXXXXXX" +}; diff -r ad457d5f7d04 -r 0293115a14e9 etc/toolbar/ediff-toggle-split-up.xbm --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/etc/toolbar/ediff-toggle-split-up.xbm Mon Aug 13 08:49:20 2007 +0200 @@ -0,0 +1,6 @@ +#define ediff-toggle-split-up_width 15 +#define ediff-toggle-split-up_height 15 +static char ediff-toggle-split-up_bits[] = { + 0x00,0x80,0xfe,0x87,0xfe,0x87,0x00,0x80,0x00,0xb0,0x7e,0xb0,0x1e,0xb0,0x1e, + 0xb0,0x3e,0xb2,0x72,0xb3,0xe2,0xb3,0xc0,0xb3,0xc0,0xb3,0xf0,0xb7,0x00,0x80 + }; diff -r ad457d5f7d04 -r 0293115a14e9 etc/toolbar/ediff-toggle-split-up.xpm --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/etc/toolbar/ediff-toggle-split-up.xpm Mon Aug 13 08:49:20 2007 +0200 @@ -0,0 +1,25 @@ +/* XPM */ +static char *ediff-toggle-split-up[] = { +/* width height num_colors chars_per_pixel */ +" 15 15 3 1", +/* colors */ +"# c #000000", +"a c firebrick", +"f c Gray75 s backgroundToolBarColor", +/* pixels */ +"fffffffffffffff", +"faaaaaaaaaaffff", +"faaaaaaaaaaffff", +"fffffffffffffff", +"ffffffffffffaaf", +"f######fffffaaf", +"f####fffffffaaf", +"f####fffffffaaf", +"f#####fff#ffaaf", +"f#ff###ff#ffaaf", +"f#fff#####ffaaf", +"ffffff####ffaaf", +"ffffff####ffaaf", +"ffff######ffaaf", +"fffffffffffffff", +}; diff -r ad457d5f7d04 -r 0293115a14e9 etc/toolbar/ediff-update.xbm --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/etc/toolbar/ediff-update.xbm Mon Aug 13 08:49:20 2007 +0200 @@ -0,0 +1,6 @@ +#define ediff-update_width 15 +#define ediff-update_height 15 +static char ediff-update_bits[] = { + 0x00,0x80,0x78,0x80,0xcc,0x99,0x04,0x9b,0x04,0x9c,0x04,0x9e,0x0c,0x9f,0x00, + 0x80,0x7c,0x98,0x3c,0x90,0x1c,0x90,0x6c,0x90,0xcc,0x99,0x00,0x8f,0x00,0x80 + }; diff -r ad457d5f7d04 -r 0293115a14e9 etc/toolbar/ediff-update.xpm --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/etc/toolbar/ediff-update.xpm Mon Aug 13 08:49:20 2007 +0200 @@ -0,0 +1,25 @@ +/* XPM */ +static char *update[] = { +/* width height num_colors chars_per_pixel */ +" 15 15 3 1", +/* colors */ +". c #000000", +"a c #000080", +"c c Gray75 s backgroundToolBarColor", +/* pixels */ +"ccccccccccccccc", +"ccc.aaacccccccc", +"cc.acccaacccacc", +"ccaccccccacaacc", +"ccacccccccaaacc", +"ccaccccccaaaacc", +"cc.accccaaaaacc", +"ccccccccccccccc", +"ccaaaaacccca.cc", +"ccaaaaccccccacc", +"ccaaacccccccacc", +"ccaacaccccccacc", +"ccacccaaccca.cc", +"ccccccccaaa.ccc", +"ccccccccccccccc", +}; \ No newline at end of file diff -r ad457d5f7d04 -r 0293115a14e9 etc/w3/stylesheet --- a/etc/w3/stylesheet Mon Aug 13 08:48:43 2007 +0200 +++ b/etc/w3/stylesheet Mon Aug 13 08:49:20 2007 +0200 @@ -1,11 +1,36 @@ -/* File: default.css +/****************************************************************************** +** File: default.css ** Purpose: Default Stylesheet for Emacs-W3 -** Info: Copyright (c) 1995 William M. Perry +** Info: Copyright (c) 1995 - 1996 William M. Perry +** Copyright (c) 1997 Free Software Foundation, Inc. ** Created: William M. Perry , Aug-31-1995 ** Maintainer: William M. Perry ** ** This contains the top level fallback default styles for Emacs-w3 -*/ +** +****************************************************************************** +** +** To specify device-dependent styles, you must mark a section with +** @media devicetype { ... } +** If you are not using 'devicetype', then anything within the { ... } +** is ignored. +** +** These sections are currently defined by +** http://www.w3.org/pub/WWW/Style/Group/WD-PRINT-961220 +** +** print - output for paged opaque material, and for documents viewed +** on screen in print preview mode +** screen - a continuous presentation of computer screens +** projector - paged presentation for projected presentations +** braille - for braille tactile feedback devices +** speech - aural presentation +** all - the default value, applies to all output devices +** +** There are a few special Emacs-W3 sections +** +** emacs - only include this chunk if you are using Emacs 19 +** xemacs - only include this chunk if you are using XEmacs +******************************************************************************/ /* ** Headers @@ -14,7 +39,7 @@ h1,h2,h3, h4,h5,h6 { display: block; - font-family : utopia charter times itc-zapf-chancery inja; + font-family : serif; font-weight : bold; } @@ -23,57 +48,74 @@ ** we only use them under XEmacs. Hopefully, this will change soon. */ -:xemacs: - h1 { font-size : 24pt } - h2 { font-size : 18pt } - h3 { font-size : 16pt } - h4 { font-size : 14pt } - h5 { font-size : 12pt } - h6 { font-size : 10pt } +@media xemacs { + h1 { font-size : +12pt } + h2 { font-size : +6pt } + h3 { font-size : +4pt } + h5 { font-size : -2pt } + h6 { font-size : -4pt } +/* +** Emacs-19 also doesn't handle how Emacs-W3 changes this type of font +** very well, so lets only do it under XEmacs for now. Emacs-19 can only +** do monospaced fonts anyway, so its redundant. +*/ + pre,xmp, + plaintext { font-family: monospace } +key,code,tt { font-family: monospace } +} // @media xemacs /* ** Best we can do under Emacs-19 is use the default font and try to make ** the headers stand out somehow. */ -:emacs: +@media emacs { h1,h2,h3, -h4,h5,h6 { font-style: small-caps; text-decoration: underline } +h4,h5,h6 { + font-style: small-caps; + text-decoration: underline; + color: blue; + } -:normal: +strong,em { color: red } + dfn { font-style: italic } + s,strike { color: green } + +} // @media emacs + p { display: block } + pre,xmp { display: block; white-space: pre; } +blockquote{ display: block; margin-left: 5; margin-right: 5; } /* ** List formatting instructions */ - dl,ul,ol { - display: block; - margin-left: 5em - } + ul { display: block; } + ol { display: block; } + dl { display: block; } + dir { display: block; } + menu { display: block; } + dt { font-weight: bold; display: list-item } + dd { display: list-item; margin-left: 5; } + li { display: list-item; margin-left: 5; } + ul li { list-style: circle; } + ol li { list-style: decimal; } - li { display: list-item } - dt { font-weight: bold; display: block } - dd { insert-before: 3em; display: list-item } - -/* -** All items that require fixed-width fonts -*/ - - pre,xmp, - plaintext { font-family: monospace; display: block } -key,code,tt { font-family: monospace } +/* These are to make nested list items look better */ +ul ul,ol ul,ol ol,ul ol { display: line; } /* ** All logical emphasis tags, the way god intended */ - strong,em { font-weight: bold } - dfn { font-style: italic } + div { display: line; } + strong,em { font-weight: bold } + dfn { font-style: italic } s,strike { text-decoration: line-through } - sub { text-position: sub } - sup { text-position: sup } - secret { text-transform: rot13 } + sub { text-position: sub } + sup { text-position: sup } + secret { text-transform: rot13 } /* ** Physical emphasis - spawn of evil @@ -82,13 +124,12 @@ i { font-style: italic } u { text-decoration: underline } blink { text-decoration: blink } - + center { display: line; text-align: center; } /* ** Various and sundry */ - br { display: list-item } - hr { display: list-item } - hr[SRC] { replace: {SRC} } + br { display: line } + hr { display: line; text-align: center; } /* @@ -96,34 +137,39 @@ */ a { cursor: hand2 } -a.link { color: #FF0000 } -a.visited { color: #B22222 } -a.active { color: #FF0000 } +a:link { color: #FF0000 } +a:visited { color: #B22222 } +a:active { color: #FF0000 } + +/* +** Table formatting +*/ +table { display: block; } + th { display: block; font-weight: bold; text-align: center; } + td { display: block; text-align: left; } +caption { display: block; text-align: center; } /* ** Various other character-level formatting issues */ - address { align : right } -abstract { font-style : bold & italic ; align : indent } - quote { font-style : italic ; align : indent } + address { text-align: right; display: line; } +abstract { font-style: bold & italic ; text-align : indent } + quote { font-style: italic ; text-align : indent } /* ** Now for monochrome defaults -** Anything up to the next :xxx: media descriptor is only used if -** you are on that type of media. */ -:mono: - a.link { color: black; text-decoration: underline } -a.visited { color: black; text-decoration: underline } - a.active { color: white } - +@media mono { + a:link { color: black; text-decoration: underline } +a:visited { color: black; text-decoration: underline } + a:active { color: white } +} // @media mono /* ** All the TTY specific formatting */ -:tty: - +@media tty { /* ** First, handle some stuff for generic TTYs to emulate our old ** behaviour with w3-delimit-links and a subset of w3-delimit-emphasis @@ -135,20 +181,19 @@ insert-after: * } -a.visited{ - insert.before: "{{"; - insert.after: "}}" +a:visited{ + insert-before: "{{"; + insert-after: "}}" } -a.link { - insert.before: "[["; - insert.after: "]]" +a:link { + insert-before: "[["; + insert-after: "]]" } +} // @media tty -/* End Generic TTY */ -:ansi-tty: - +@media ansi-tty { /* ** Now comes the cool TTY stuff. You will need to be using XEmacs 19.14 ** or later (or Emacs 19.30 under DOS) in order to get any benefit from @@ -172,6 +217,38 @@ h1,h2,h3, h4,h5,h6 { color : cyan } -a.visited { color : magenta } - a.link { color : red } - a.active { color : yellow } +a:visited { color : magenta } + a:link { color : red } + a:active { color : yellow } +} // @media ansi-tty + +@media speech { +h1,h2,h3, +h4,h5,h6 { voice-family: paul; stress: 2; richness: 9; } + h1 { pitch: 1; pitch-range: 9; } + h2 { pitch: 2; pitch-range: 8; } + h3 { pitch: 3; pitch-range: 7; } + h4 { pitch: 4; pitch-range: 6; } + h5 { pitch: 5; pitch-range: 5; } + h6 { pitch: 6; pitch-range: 4; } + +li,dt,dd { pitch: 6; richness: 6; } + dt { stress: 8; } + +pre,xmp,plaintext,key,code,tt { pitch: 1; + pitch-range: 1; + stress: 1; + richness: 8; + } + em { pitch: 6; pitch-range: 6; stress: 6; richness: 5; } + strong { pitch: 6; pitch-range: 6; stress: 9; richness: 9; } + dfn { pitch: 7; pitch-range: 6; stress: 6; } +s,strike { richness: 0; } + i { pitch: 6; pitch-range: 6; stress: 6; richness: 5 } + b { pitch: 6; pitch-range: 6; stress: 9; richness: 9; } + u { richness: 0; } + a:link { voice-family: harry; } +a:visited { voice-family: betty;} + a:active { voice-family: betty; pitch-range: 8; pitch: 8 } + +} // @media speech diff -r ad457d5f7d04 -r 0293115a14e9 info/dir --- a/info/dir Mon Aug 13 08:48:43 2007 +0200 +++ b/info/dir Mon Aug 13 08:49:20 2007 +0200 @@ -49,12 +49,13 @@ * Ange-FTP:: Making the entire network accessible as a pseudo-filesystem. * CC-MODE:: Mode for editing C, C++, and Objective-C code. * CL:: A Common Lisp compatibility package for Emacs-Lisp. +* Custom:: Customization Library for Emacs * Dired:: Manual for Tree Dired. * Ediff:: A Visual Interface to Unix Diff and Patch Utilities. * External-Widget:: Use XEmacs as a text widget inside of another program. * Forms:: A package for editing databases by filling in forms. -* GNUS:: An NNTP-based newsreader for XEmacs. +* Gnus:: A netnews and mail reader for XEmacs. * Hyperbole:: A programmable information management and hypertext system. * ILISP:: Multi-dialect inferior LISP interface. * Ispell:: Interactive spelling corrector. @@ -77,6 +78,7 @@ * Vhdl-mode:: A major mode for editing VHDL files. * VM:: View Mail, a replacement for Rmail. * W3:: A browser for the World Wide Web global hypertext system. +* Widget:: An Emacs Lisp widget library * tm-en:: Tools for Mime (English version) * tm-mh-e-en:: Tools for Mime for MH-E (English version) * gnus-mime-en::Tools for Mime for Gnus (English version) diff -r ad457d5f7d04 -r 0293115a14e9 lib-src/tm-au --- a/lib-src/tm-au Mon Aug 13 08:48:43 2007 +0200 +++ b/lib-src/tm-au Mon Aug 13 08:49:20 2007 +0200 @@ -1,7 +1,23 @@ #!/bin/sh - # -# $Id: tm-au,v 1.3 1997/01/11 22:09:59 steve Exp $ +# $Id: tm-au,v 1.4 1997/02/02 05:04:53 steve Exp $ # +# Copyright 1994,1995,1996,1997 Free Software Foundation, Inc. + +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 2, or (at your option) +# any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with GNU Emacs; see the file COPYING. If not, write to the +# Free Software Foundation, Inc., 59 Temple Place - Suite 330, +# Boston, MA 02111-1307, USA. PATH=${PATH:-/usr/bin:/bin}:`dirname $0 2>/dev/null`; export PATH @@ -22,14 +38,15 @@ echo "$2; $3 ->" tmdecode $3 $1 $filename if [ "$AUDIOSERVER" = "" ]; then - if [ `uname` = "IRIX" ]; then - sfplay $filename - else - cat $filename > /dev/audio - fi + case "`uname`" in + IRIX ) sfplay $filename ;; + OSF1 ) decsound -play $filename ;; + * ) cat $filename > /dev/audio ;; + esac else - autool -v 40 $filename + autool -v 40 $filename fi + trap 'rm -f $filename' 0 1 2 3 13 15 ;; "extract") diff -r ad457d5f7d04 -r 0293115a14e9 lib-src/tm-file --- a/lib-src/tm-file Mon Aug 13 08:48:43 2007 +0200 +++ b/lib-src/tm-file Mon Aug 13 08:49:20 2007 +0200 @@ -1,7 +1,23 @@ #!/bin/sh - # -# $Id: tm-file,v 1.3 1997/01/11 22:09:59 steve Exp $ +# $Id: tm-file,v 1.4 1997/02/02 05:04:53 steve Exp $ # +# Copyright 1994,1995,1996,1997 Free Software Foundation, Inc. + +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 2, or (at your option) +# any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with GNU Emacs; see the file COPYING. If not, write to the +# Free Software Foundation, Inc., 59 Temple Place - Suite 330, +# Boston, MA 02111-1307, USA. PATH=${PATH:-/usr/bin:/bin}:`dirname $0 2>/dev/null`; export PATH diff -r ad457d5f7d04 -r 0293115a14e9 lib-src/tm-html --- a/lib-src/tm-html Mon Aug 13 08:48:43 2007 +0200 +++ b/lib-src/tm-html Mon Aug 13 08:49:20 2007 +0200 @@ -1,7 +1,23 @@ #!/bin/sh # -# $Id: tm-html,v 1.3 1997/01/11 22:09:59 steve Exp $ +# $Id: tm-html,v 1.4 1997/02/02 05:04:53 steve Exp $ # +# Copyright 1994,1995,1996,1997 Free Software Foundation, Inc. + +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 2, or (at your option) +# any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with GNU Emacs; see the file COPYING. If not, write to the +# Free Software Foundation, Inc., 59 Temple Place - Suite 330, +# Boston, MA 02111-1307, USA. PATH=${PATH:-/usr/bin:/bin}:`dirname $0 2>/dev/null`; export PATH diff -r ad457d5f7d04 -r 0293115a14e9 lib-src/tm-image --- a/lib-src/tm-image Mon Aug 13 08:48:43 2007 +0200 +++ b/lib-src/tm-image Mon Aug 13 08:49:20 2007 +0200 @@ -1,6 +1,6 @@ #!/bin/sh - # -# $Id: tm-image,v 1.2 1996/12/29 00:14:55 steve Exp $ +# $Id: tm-image,v 1.3 1997/02/02 05:04:53 steve Exp $ # # Copyright 1994, 1995, 1996 Free Software Foundation, Inc. @@ -19,6 +19,8 @@ # Free Software Foundation, Inc., 59 Temple Place - Suite 330, # Boston, MA 02111-1307, USA. +PATH=${PATH:-/usr/bin:/bin}:`dirname $0 2>/dev/null`; export PATH + if [ "$TM_TMP_DIR" = "" ]; then TM_TMP_DIR=/tmp export TM_TMP_DIR diff -r ad457d5f7d04 -r 0293115a14e9 lib-src/tm-mpeg --- a/lib-src/tm-mpeg Mon Aug 13 08:48:43 2007 +0200 +++ b/lib-src/tm-mpeg Mon Aug 13 08:49:20 2007 +0200 @@ -1,6 +1,6 @@ #!/bin/sh - # -# $Id: tm-mpeg,v 1.3 1997/01/11 22:09:59 steve Exp $ +# $Id: tm-mpeg,v 1.4 1997/02/02 05:04:53 steve Exp $ # # Copyright 1994, 1995, 1996 Free Software Foundation, Inc. diff -r ad457d5f7d04 -r 0293115a14e9 lib-src/tm-plain --- a/lib-src/tm-plain Mon Aug 13 08:48:43 2007 +0200 +++ b/lib-src/tm-plain Mon Aug 13 08:49:20 2007 +0200 @@ -1,7 +1,25 @@ #!/bin/sh - # -# $Id: tm-plain,v 1.2 1996/12/29 00:14:55 steve Exp $ +# $Id: tm-plain,v 1.3 1997/02/02 05:04:53 steve Exp $ # +# Copyright 1994,1995,1996,1997 Free Software Foundation, Inc. + +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 2, or (at your option) +# any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with GNU Emacs; see the file COPYING. If not, write to the +# Free Software Foundation, Inc., 59 Temple Place - Suite 330, +# Boston, MA 02111-1307, USA. + +PATH=${PATH:-/usr/bin:/bin}:`dirname $0 2>/dev/null`; export PATH if [ "$TM_TMP_DIR" = "" ]; then TM_TMP_DIR=/tmp diff -r ad457d5f7d04 -r 0293115a14e9 lib-src/tm-ps --- a/lib-src/tm-ps Mon Aug 13 08:48:43 2007 +0200 +++ b/lib-src/tm-ps Mon Aug 13 08:49:20 2007 +0200 @@ -1,6 +1,6 @@ #!/bin/sh - # -# $Id: tm-ps,v 1.3 1997/01/11 22:10:00 steve Exp $ +# $Id: tm-ps,v 1.4 1997/02/02 05:04:54 steve Exp $ # # Copyright 1994, 1995, 1996 Free Software Foundation, Inc. diff -r ad457d5f7d04 -r 0293115a14e9 lib-src/tmdecode --- a/lib-src/tmdecode Mon Aug 13 08:48:43 2007 +0200 +++ b/lib-src/tmdecode Mon Aug 13 08:49:20 2007 +0200 @@ -1,6 +1,6 @@ #!/bin/sh - # -# $Id: tmdecode,v 1.3 1997/01/11 22:10:00 steve Exp $ +# $Id: tmdecode,v 1.4 1997/02/02 05:04:54 steve Exp $ # # Copyright 1994, 1995, 1996 Free Software Foundation, Inc. diff -r ad457d5f7d04 -r 0293115a14e9 lib-src/update-elc.sh --- a/lib-src/update-elc.sh Mon Aug 13 08:48:43 2007 +0200 +++ b/lib-src/update-elc.sh Mon Aug 13 08:49:20 2007 +0200 @@ -111,15 +111,10 @@ \!/site-init.el$!d \!/version.el$!d \!/sunpro/sunpro-load.el$!d -\!/tm/!d -\!/tl/!d -\!/mel/!d -\!/viper/!d \!/vm/!d \!/w3/!d \!/hyperbole/!d \!/oobr/!d -\!/ediff/!d \!/egg/!d \!/its/!d \!/mule/!d diff -r ad457d5f7d04 -r 0293115a14e9 lisp/bytecomp/byte-optimize.el --- a/lisp/bytecomp/byte-optimize.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/bytecomp/byte-optimize.el Mon Aug 13 08:49:20 2007 +0200 @@ -19,8 +19,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Synched up with: FSF 19.30. diff -r ad457d5f7d04 -r 0293115a14e9 lisp/bytecomp/bytecomp-runtime.el --- a/lisp/bytecomp/bytecomp-runtime.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/bytecomp/bytecomp-runtime.el Mon Aug 13 08:49:20 2007 +0200 @@ -23,8 +23,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Synched up with: FSF 19.30. diff -r ad457d5f7d04 -r 0293115a14e9 lisp/bytecomp/bytecomp.el --- a/lisp/bytecomp/bytecomp.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/bytecomp/bytecomp.el Mon Aug 13 08:49:20 2007 +0200 @@ -23,8 +23,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Synched up with: FSF 19.30. diff -r ad457d5f7d04 -r 0293115a14e9 lisp/bytecomp/disass.el --- a/lisp/bytecomp/disass.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/bytecomp/disass.el Mon Aug 13 08:49:20 2007 +0200 @@ -20,8 +20,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Synched up with: FSF 19.28. diff -r ad457d5f7d04 -r 0293115a14e9 lisp/calendar/appt.el --- a/lisp/calendar/appt.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/calendar/appt.el Mon Aug 13 08:49:20 2007 +0200 @@ -18,8 +18,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; 29-nov-89 created by Neil Mager . ;;; 23-feb-91 hacked upon by Jamie Zawinski . diff -r ad457d5f7d04 -r 0293115a14e9 lisp/calendar/cal-dst.el --- a/lisp/calendar/cal-dst.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/calendar/cal-dst.el Mon Aug 13 08:49:20 2007 +0200 @@ -20,8 +20,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Commentary: diff -r ad457d5f7d04 -r 0293115a14e9 lisp/calendar/cal-french.el --- a/lisp/calendar/cal-french.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/calendar/cal-french.el Mon Aug 13 08:49:20 2007 +0200 @@ -19,8 +19,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Commentary: diff -r ad457d5f7d04 -r 0293115a14e9 lisp/calendar/cal-mayan.el --- a/lisp/calendar/cal-mayan.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/calendar/cal-mayan.el Mon Aug 13 08:49:20 2007 +0200 @@ -20,8 +20,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Commentary: diff -r ad457d5f7d04 -r 0293115a14e9 lisp/calendar/cal-xemacs.el --- a/lisp/calendar/cal-xemacs.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/calendar/cal-xemacs.el Mon Aug 13 08:49:20 2007 +0200 @@ -22,8 +22,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Commentary: diff -r ad457d5f7d04 -r 0293115a14e9 lisp/calendar/calendar.el --- a/lisp/calendar/calendar.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/calendar/calendar.el Mon Aug 13 08:49:20 2007 +0200 @@ -22,8 +22,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Commentary: diff -r ad457d5f7d04 -r 0293115a14e9 lisp/calendar/diary-ins.el --- a/lisp/calendar/diary-ins.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/calendar/diary-ins.el Mon Aug 13 08:49:20 2007 +0200 @@ -18,8 +18,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Commentary: diff -r ad457d5f7d04 -r 0293115a14e9 lisp/calendar/diary-lib.el --- a/lisp/calendar/diary-lib.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/calendar/diary-lib.el Mon Aug 13 08:49:20 2007 +0200 @@ -18,8 +18,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Commentary: diff -r ad457d5f7d04 -r 0293115a14e9 lisp/calendar/holidays.el --- a/lisp/calendar/holidays.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/calendar/holidays.el Mon Aug 13 08:49:20 2007 +0200 @@ -18,8 +18,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Commentary: diff -r ad457d5f7d04 -r 0293115a14e9 lisp/calendar/lunar.el --- a/lisp/calendar/lunar.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/calendar/lunar.el Mon Aug 13 08:49:20 2007 +0200 @@ -19,8 +19,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Commentary: diff -r ad457d5f7d04 -r 0293115a14e9 lisp/calendar/solar.el --- a/lisp/calendar/solar.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/calendar/solar.el Mon Aug 13 08:49:20 2007 +0200 @@ -20,8 +20,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Commentary: diff -r ad457d5f7d04 -r 0293115a14e9 lisp/cl/cl-extra.el --- a/lisp/cl/cl-extra.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/cl/cl-extra.el Mon Aug 13 08:49:20 2007 +0200 @@ -928,4 +928,6 @@ (run-hooks 'cl-extra-load-hook) +(provide 'cl-extra) + ;;; cl-extra.el ends here diff -r ad457d5f7d04 -r 0293115a14e9 lisp/comint/comint.el --- a/lisp/comint/comint.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/comint/comint.el Mon Aug 13 08:49:20 2007 +0200 @@ -19,8 +19,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Synched up with: FSF 19.30. diff -r ad457d5f7d04 -r 0293115a14e9 lisp/comint/gud.el --- a/lisp/comint/gud.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/comint/gud.el Mon Aug 13 08:49:20 2007 +0200 @@ -21,8 +21,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Commentary: diff -r ad457d5f7d04 -r 0293115a14e9 lisp/comint/history.el --- a/lisp/comint/history.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/comint/history.el Mon Aug 13 08:49:20 2007 +0200 @@ -15,8 +15,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Synched up with: Not in FSF diff -r ad457d5f7d04 -r 0293115a14e9 lisp/comint/inf-lisp.el --- a/lisp/comint/inf-lisp.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/comint/inf-lisp.el Mon Aug 13 08:49:20 2007 +0200 @@ -17,8 +17,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Synched up with: FSF 19.30. diff -r ad457d5f7d04 -r 0293115a14e9 lisp/comint/kermit.el --- a/lisp/comint/kermit.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/comint/kermit.el Mon Aug 13 08:49:20 2007 +0200 @@ -19,8 +19,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Synched up with: FSF 19.30. diff -r ad457d5f7d04 -r 0293115a14e9 lisp/comint/shell.el --- a/lisp/comint/shell.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/comint/shell.el Mon Aug 13 08:49:20 2007 +0200 @@ -19,8 +19,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Synched up with: FSF 19.30. diff -r ad457d5f7d04 -r 0293115a14e9 lisp/comint/telnet.el --- a/lisp/comint/telnet.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/comint/telnet.el Mon Aug 13 08:49:20 2007 +0200 @@ -68,7 +68,7 @@ (defvar telnet-count 0 "Number of output strings read from the telnet process while looking for the initial password.") -(make-variable-buffer-local 'telnet-count) +;; (make-variable-buffer-local 'telnet-count) (defvar telnet-program "telnet" "Program to run to open a telnet connection.") @@ -254,7 +254,6 @@ (if port (concat " " port) "") "\n")) (setq comint-input-sender 'telnet-simple-send) - (setq telnet-count telnet-initial-count) ;; run last so that hooks can change things. (telnet-mode)))) @@ -273,6 +272,7 @@ mode-name "Telnet" comint-prompt-regexp telnet-prompt-pattern) (use-local-map telnet-mode-map) + (set (make-local-variable 'telnet-count) telnet-initial-count) (run-hooks 'telnet-mode-hook)) ;;;###autoload (add-hook 'same-window-regexps "\\*rsh-[^-]*\\*\\(\\|<[0-9]*>\\)") @@ -288,7 +288,6 @@ (require 'shell) (let ((name (concat "rsh-" host))) (pop-to-buffer (make-comint name remote-shell-program nil host)) - (setq telnet-count telnet-initial-count) ;; ;; SunOS doesn't print "unix" in its rsh login banner, so let's get a ;; reasonable default here. There do exist non-Unix machines which @@ -303,8 +302,10 @@ ;; antisocial than echoing a password, and more likely than connecting ;; to a non-Unix rsh host these days... ;; - ;; (set-process-filter (get-process name) 'telnet-initial-filter) - (set-process-filter (get-process name) 'telnet-filter) + ;; I disagree with the above. -sb + ;; + (set-process-filter (get-process name) 'telnet-initial-filter) + ;; (set-process-filter (get-process name) 'telnet-filter) ;; run last so that hooks can change things. (telnet-mode))) diff -r ad457d5f7d04 -r 0293115a14e9 lisp/dired/dired-chmod.el --- a/lisp/dired/dired-chmod.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/dired/dired-chmod.el Mon Aug 13 08:49:20 2007 +0200 @@ -17,8 +17,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; To turn this on do: ;;; (require 'dired-chmod) diff -r ad457d5f7d04 -r 0293115a14e9 lisp/dired/dired-vms.el --- a/lisp/dired/dired-vms.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/dired/dired-vms.el Mon Aug 13 08:49:20 2007 +0200 @@ -14,8 +14,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;; Id: dired-vms.el,v 1.17 1991/09/09 16:54:03 sk RelBeta diff -r ad457d5f7d04 -r 0293115a14e9 lisp/dired/dired-x.el --- a/lisp/dired/dired-x.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/dired/dired-x.el Mon Aug 13 08:49:20 2007 +0200 @@ -19,8 +19,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;; LISPDIR ENTRY for the Elisp Archive =============================== ;; LCD Archive Entry: diff -r ad457d5f7d04 -r 0293115a14e9 lisp/dired/dired-xemacs-highlight.el --- a/lisp/dired/dired-xemacs-highlight.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/dired/dired-xemacs-highlight.el Mon Aug 13 08:49:20 2007 +0200 @@ -21,8 +21,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Synched up with: Not synched with FSF. diff -r ad457d5f7d04 -r 0293115a14e9 lisp/dired/dired.el --- a/lisp/dired/dired.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/dired/dired.el Mon Aug 13 08:49:20 2007 +0200 @@ -16,8 +16,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;; Rewritten in 1990/1991 to add tree features, file marking and ;; sorting by Sebastian Kremer . @@ -844,7 +845,9 @@ case-fold-search nil buffer-read-only t selective-display t ; for subdirectory hiding - modeline-buffer-identification '("Dired: %17b")) + modeline-buffer-identification + (list (cons modeline-buffer-id-left-extent "Dired: ") + (cons modeline-buffer-id-right-extent "%17b"))) (set (make-local-variable 'revert-buffer-function) (function dired-revert)) (set (make-local-variable 'page-delimiter) diff -r ad457d5f7d04 -r 0293115a14e9 lisp/dired/find-dired.el --- a/lisp/dired/find-dired.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/dired/find-dired.el Mon Aug 13 08:49:20 2007 +0200 @@ -19,8 +19,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Synched up with: FSF 19.30. diff -r ad457d5f7d04 -r 0293115a14e9 lisp/ediff/Makefile --- a/lisp/ediff/Makefile Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/ediff/Makefile Mon Aug 13 08:49:20 2007 +0200 @@ -27,12 +27,10 @@ # --------- ONLY AUTHORIZED PERSONNEL BEYOND THIS POINT!!! ------------ EDIFF = ediff-init.el ediff-help.el ediff-diff.el ediff-merg.el \ ediff-wind.el ediff-util.el ediff-mult.el ediff-vers.el \ - ediff-ptch.el ediff.el ediff-hook.el -# ediff-tbar.el + ediff-ptch.el ediff.el ediff-hook.el ediff-tbar.el EDIFFelc = ediff-init.elc ediff-help.elc ediff-diff.elc ediff-merg.elc \ ediff-wind.elc ediff-util.elc ediff-mult.elc ediff-vers.elc \ - ediff-ptch.elc ediff.elc ediff-hook.elc -# ediff-tbar.elc + ediff-ptch.elc ediff.elc ediff-hook.elc ediff-tbar.elc all: hello elc goodbye dvi info diff -r ad457d5f7d04 -r 0293115a14e9 lisp/ediff/README --- a/lisp/ediff/README Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/ediff/README Mon Aug 13 08:49:20 2007 +0200 @@ -1,6 +1,6 @@ **** EDIFF -- a comprehensive interface to diff for Emacs 19 and XEmacs 19 -**** This version of Ediff requires *at least* Emacs 19.30 or XEmacs 19.14 +**** This version of Ediff requires *at least* Emacs 19.34 or XEmacs 19.14 This directory: @@ -20,8 +20,9 @@ ediff-mult.el -- Ediff Emacs Lisp code ediff-vers.el -- Ediff Emacs Lisp code ediff-ptch.el -- Ediff Emacs Lisp code -ediff-tbar.el -- Ediff Emacs Lisp code -- this one only for XEmacs +ediff-tbar.el -- Ediff Emacs Lisp code -- for XEmacs only ediff-hook.el -- Ediff Emacs Lisp code +toolbar/ -- Ediff toolbar icons -- for XEmacs only To install Ediff do: @@ -57,42 +58,17 @@ for Emacs 18). An even better thing would be to edit Makefile directly as indicated in the comments there. -For manual installation, copy ediff*.elc into a directory on your load-path. - -For more details, read documentation at the beginning of the file ediff.el - -To install on-line documentation, you need to install the Info files -by copying - -ediff.info* - -into your Info directory (which is emacs-root-dir/info, -if emacs-root-dir is the root directory of the installation). - -Then edit the file +4. Under XEmacs, copy the icons in the `toolbar' directory into + the-directory-where-xemacs-installed/etc/toolbar/ -emacs-root-dir/info/dir - -to include the root menu item for Ediff (check how other menu -items look like in this file). - -In Emacs, this item should look like this: - -* Ediff: (ediff.info). A Visual Interface to Unix Diff and Patch Utilities - -In XEmacs, it looks like: - -* Ediff:: A Visual Interface to Unix Diff and Patch Utilities - - -Normally, all Ediff menus and autoloads are already defined in Emacs, so u +Normally, all Ediff menus and autoloads are already defined in Emacs, so you don't need to define anything in your .emacs to run Ediff. However, if it was announced that this distribution of Ediff contains -new features, you may have to put +new features, you may need to put (require 'ediff-hook) in your .emacs to take advantage of these new features. This doesn't load -Ediff, but readies it for any taks u assign to it. When this version of -Ediff gets installed in the standard Emacs distribution, you may remove +Ediff, but readies Emacs for the things to come. When this version of +Ediff gets installed in the standard Emacs distribution, you can remove the above require-statement (but leaving it in does no harm). diff -r ad457d5f7d04 -r 0293115a14e9 lisp/ediff/ediff-diff.el --- a/lisp/ediff/ediff-diff.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/ediff/ediff-diff.el Mon Aug 13 08:49:20 2007 +0200 @@ -1,6 +1,6 @@ ;;; ediff-diff.el --- diff-related utilities -;; Copyright (C) 1994, 1995, 1996 Free Software Foundation, Inc. +;; Copyright (C) 1994, 1995, 1996, 1997 Free Software Foundation, Inc. ;; Author: Michael Kifer @@ -29,7 +29,7 @@ (defvar ediff-default-variant) (eval-when-compile - (let ((load-path (cons "." load-path))) + (let ((load-path (cons (expand-file-name ".") load-path))) (or (featurep 'ediff-init) (load "ediff-init.el" nil nil 'nosuffix)) (or (featurep 'ediff-util) diff -r ad457d5f7d04 -r 0293115a14e9 lisp/ediff/ediff-help.el --- a/lisp/ediff/ediff-help.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/ediff/ediff-help.el Mon Aug 13 08:49:20 2007 +0200 @@ -1,6 +1,6 @@ ;;; ediff-help.el --- Code related to the contents of Ediff help buffers -;; Copyright (C) 1996 Free Software Foundation, Inc. +;; Copyright (C) 1996, 1997 Free Software Foundation, Inc. ;; Author: Michael Kifer @@ -29,7 +29,7 @@ (defvar ediff-multiframe) (eval-when-compile - (let ((load-path (cons "." load-path))) + (let ((load-path (cons (expand-file-name ".") load-path))) (or (featurep 'ediff-init) (load "ediff-init.el" nil nil 'nosuffix)) )) diff -r ad457d5f7d04 -r 0293115a14e9 lisp/ediff/ediff-hook.el --- a/lisp/ediff/ediff-hook.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/ediff/ediff-hook.el Mon Aug 13 08:49:20 2007 +0200 @@ -1,6 +1,6 @@ ;;; ediff-hook.el --- setup for Ediff's menus and autoloads -;; Copyright (C) 1995, 1996 Free Software Foundation, Inc. +;; Copyright (C) 1995, 1996, 1997 Free Software Foundation, Inc. ;; Author: Michael Kifer @@ -25,6 +25,8 @@ ;;; These must be placed in menu-bar.el in Emacs ;; +;; (define-key menu-bar-tools-menu [ediff-misc] +;; '("Ediff Miscellanea" . menu-bar-ediff-misc-menu)) ;; (define-key menu-bar-tools-menu [epatch] ;; '("Apply Patch" . menu-bar-epatch-menu)) ;; (define-key menu-bar-tools-menu [ediff-merge] @@ -36,6 +38,7 @@ (defvar ediff-menu) (defvar ediff-merge-menu) (defvar epatch-menu) +(defvar ediff-misc-menu) ;; end pacifier ;; allow menus to be set up without ediff-wind.el being loaded @@ -43,32 +46,16 @@ (defun ediff-xemacs-init-menus () - (setq ediff-window-setup-function - (if (console-on-window-system-p) - 'ediff-setup-windows-multiframe - 'ediff-setup-windows-plain)) (if (featurep 'menubar) (progn - (add-menu-button - '("Tools") - ["Use separate frame for Ediff control buffer" - ediff-toggle-multiframe - :style toggle - :selected (eq ediff-window-setup-function 'ediff-setup-windows-multiframe)] - "00-Browser...") - ;;(add-menu-button - ;; '("Tools") - ;; ["Use a toolbar with Ediff control buffer" - ;; ediff-toggle-use-toolbar - ;; :style toggle - ;; :selected (ediff-use-toolbar-p)] - ;; "00-Browser...") (add-submenu '("Tools") ediff-menu "OO-Browser...") (add-submenu '("Tools") ediff-merge-menu "OO-Browser...") (add-submenu '("Tools") epatch-menu "OO-Browser...") + (add-submenu + '("Tools") ediff-misc-menu "OO-Browser...") (add-menu-button '("Tools") ["-------" nil nil] "OO-Browser...") @@ -95,9 +82,6 @@ "---" ["Regions Word-by-word..." ediff-regions-wordwise t] ["Regions Line-by-line..." ediff-regions-linewise t] - "---" - ["List Ediff Sessions..." ediff-show-registry t] - ["Ediff Manual..." ediff-documentation t] )) (defvar ediff-merge-menu '("Merge" @@ -117,17 +101,28 @@ ["Directory Revisions..." ediff-merge-directory-revisions t] ["Directory Revisions with Ancestor..." ediff-merge-directory-revisions-with-ancestor t] - "---" - ["List Ediff Sessions..." ediff-show-registry t] - ["Ediff Manual..." ediff-documentation t] )) (defvar epatch-menu '("Apply Patch" ["To a file..." ediff-patch-file t] ["To a buffer..." ediff-patch-buffer t] - "---" + )) + (defvar ediff-misc-menu + '("Ediff Miscellanea" + ["Ediff Manual..." ediff-documentation t] ["List Ediff Sessions..." ediff-show-registry t] - ["Ediff Manual..." ediff-documentation t] + ["Use separate frame for Ediff control buffer..." + ediff-toggle-multiframe + :style toggle + :selected (if (and (featurep 'ediff-util) + (boundp 'ediff-window-setup-function)) + (eq ediff-window-setup-function + 'ediff-setup-windows-multiframe))] + ["Use a toolbar with Ediff control buffer" + ediff-toggle-use-toolbar + :style toggle + :selected (if (featurep 'ediff-tbar) + (ediff-use-toolbar-p))] )) ;; put these menus before Object-Oriented-Browser in Tools menu @@ -139,6 +134,10 @@ ;; Emacs--only if menu-bar is loaded ((featurep 'menu-bar) ;; initialize menu bar keymaps + (defvar menu-bar-ediff-misc-menu + (make-sparse-keymap "Ediff Miscellanea")) + (fset 'menu-bar-ediff-misc-menu + (symbol-value 'menu-bar-ediff-misc-menu)) (defvar menu-bar-epatch-menu (make-sparse-keymap "Apply Patch")) (fset 'menu-bar-epatch-menu (symbol-value 'menu-bar-epatch-menu)) (defvar menu-bar-ediff-merge-menu (make-sparse-keymap "Merge")) @@ -148,14 +147,6 @@ (fset 'menu-bar-ediff-menu (symbol-value 'menu-bar-ediff-menu)) ;; define ediff-menu - (define-key menu-bar-ediff-menu [ediff-doc] - '("Ediff Manual..." . ediff-documentation)) - (define-key menu-bar-ediff-menu [emultiframe] - '("Toggle separate control buffer frame..." - . ediff-toggle-multiframe)) - (define-key menu-bar-ediff-menu [eregistry] - '("List Ediff Sessions..." . ediff-show-registry)) - (define-key menu-bar-ediff-menu [separator-ediff-manual] '("--")) (define-key menu-bar-ediff-menu [window] '("This Window and Next Window" . compare-windows)) (define-key menu-bar-ediff-menu [ediff-windows-linewise] @@ -188,15 +179,6 @@ '("Two Files..." . ediff-files)) ;; define merge menu - (define-key menu-bar-ediff-merge-menu [ediff-doc2] - '("Ediff Manual..." . ediff-documentation)) - (define-key menu-bar-ediff-merge-menu [emultiframe2] - '("Toggle separate control buffer frame..." - . ediff-toggle-multiframe)) - (define-key menu-bar-ediff-merge-menu [eregistry2] - '("List Ediff Sessions..." . ediff-show-registry)) - (define-key - menu-bar-ediff-merge-menu [separator-ediff-merge-manual] '("--")) (define-key menu-bar-ediff-merge-menu [ediff-merge-dir-revisions-with-ancestor] '("Directory Revisions with Ancestor..." @@ -230,18 +212,20 @@ '("Files..." . ediff-merge-files)) ;; define epatch menu - (define-key menu-bar-epatch-menu [ediff-doc3] - '("Ediff Manual..." . ediff-documentation)) - (define-key menu-bar-epatch-menu [emultiframe3] - '("Toggle separate control buffer frame..." - . ediff-toggle-multiframe)) - (define-key menu-bar-epatch-menu [eregistry3] - '("List Ediff Sessions..." . ediff-show-registry)) - (define-key menu-bar-epatch-menu [separator-epatch] '("--")) (define-key menu-bar-epatch-menu [ediff-patch-buffer] '("To a Buffer..." . ediff-patch-buffer)) (define-key menu-bar-epatch-menu [ediff-patch-file] - '("To a File..." . ediff-patch-file))) + '("To a File..." . ediff-patch-file)) + + ;; define ediff miscellanea + (define-key menu-bar-ediff-misc-menu [emultiframe] + '("Toggle use of separate control buffer frame..." + . ediff-toggle-multiframe)) + (define-key menu-bar-ediff-misc-menu [eregistry] + '("List Ediff Sessions..." . ediff-show-registry)) + (define-key menu-bar-ediff-misc-menu [ediff-doc] + '("Ediff Manual..." . ediff-documentation)) + ) ) ; cond @@ -345,13 +329,11 @@ "ediff-util" "Toggle the use of separate frame for Ediff control buffer." t) - (condition-case nil - (if (string-match "XEmacs" emacs-version) - (autoload 'ediff-toggle-use-toolbar - "ediff-tbar" - "Toggle the use of Ediff toolbar." - t)) - (error)) + (autoload 'ediff-toggle-use-toolbar + "ediff-util" + "Toggle the use of Ediff toolbar." + t) + ) ; if purify-flag diff -r ad457d5f7d04 -r 0293115a14e9 lisp/ediff/ediff-init.el --- a/lisp/ediff/ediff-init.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/ediff/ediff-init.el Mon Aug 13 08:49:20 2007 +0200 @@ -1,6 +1,6 @@ ;;; ediff-init.el --- Macros, variables, and defsubsts used by Ediff -;; Copyright (C) 1994, 1995, 1996 Free Software Foundation, Inc. +;; Copyright (C) 1994, 1995, 1996, 1997 Free Software Foundation, Inc. ;; Author: Michael Kifer @@ -32,6 +32,10 @@ (defvar ediff-mouse-pixel-threshold) (defvar ediff-whitespace) (defvar ediff-multiframe) + +(and noninteractive + (eval-when-compile + (load "ange-ftp" 'noerror))) ;; end pacifier ;; Is it XEmacs? @@ -90,7 +94,7 @@ (ediff-defvar-local ediff-buffer-C nil "") ;; Ancestor buffer (ediff-defvar-local ediff-ancestor-buffer nil "") -;; The control buffer of ediff. +;; The Ediff control buffer (ediff-defvar-local ediff-control-buffer nil "") ;;; Macros @@ -625,8 +629,8 @@ ;;;; warn if it is a wrong version of emacs -;;(if (or (ediff-check-version '< 19 29 'emacs) -;; (ediff-check-version '< 19 12 'xemacs)) +;;(if (or (ediff-check-version '< 19 35 'emacs) +;; (ediff-check-version '< 19 15 'xemacs)) ;; (progn ;; (with-output-to-temp-buffer ediff-msg-buffer ;; (switch-to-buffer ediff-msg-buffer) @@ -635,9 +639,9 @@ ;; ;;This version of Ediff requires ;; -;;\t Emacs 19.29 and higher +;;\t Emacs 19.35 and higher ;;\t OR -;;\t XEmacs 19.12 and higher +;;\t XEmacs 19.15 and higher ;; ;;It is unlikely to work under Emacs version %s ;;that you are using... " emacs-version)) diff -r ad457d5f7d04 -r 0293115a14e9 lisp/ediff/ediff-merg.el --- a/lisp/ediff/ediff-merg.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/ediff/ediff-merg.el Mon Aug 13 08:49:20 2007 +0200 @@ -1,6 +1,6 @@ ;;; ediff-merg.el --- merging utilities -;; Copyright (C) 1994, 1995, 1996 Free Software Foundation, Inc. +;; Copyright (C) 1994, 1995, 1996, 1997 Free Software Foundation, Inc. ;; Author: Michael Kifer @@ -33,7 +33,7 @@ (defvar ediff-window-config-saved) (eval-when-compile - (let ((load-path (cons "." load-path))) + (let ((load-path (cons (expand-file-name ".") load-path))) (or (featurep 'ediff-init) (load "ediff-init.el" nil nil 'nosuffix)) (or (featurep 'ediff-util) diff -r ad457d5f7d04 -r 0293115a14e9 lisp/ediff/ediff-mult.el --- a/lisp/ediff/ediff-mult.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/ediff/ediff-mult.el Mon Aug 13 08:49:20 2007 +0200 @@ -1,6 +1,6 @@ ;;; ediff-mult.el --- support for multi-file/multi-buffer processing in Ediff -;; Copyright (C) 1995, 1996 Free Software Foundation, Inc. +;; Copyright (C) 1995, 1996, 1997 Free Software Foundation, Inc. ;; Author: Michael Kifer @@ -667,7 +667,8 @@ " `=':\tmark identical files in each session\n\n")) (if (and (stringp regexp) (> (length regexp) 0)) - (insert (format "Filter-through regular expression: %s\n" regexp))) + (insert + (format "\n*** Filter-through regular expression: %s\n" regexp))) (if (and ediff-autostore-merges (ediff-merge-metajob) (stringp merge-autostore-dir)) (insert (format @@ -821,7 +822,8 @@ DEL: previous line\n\n") (if (and (stringp regexp) (> (length regexp) 0)) - (insert (format "Filter-through regular expression: %s\n" regexp))) + (insert + (format "\n*** Filter-through regular expression: %s\n" regexp))) (insert "\n") (insert (format "\n%-27s%-26s" (ediff-truncate-string-left diff -r ad457d5f7d04 -r 0293115a14e9 lisp/ediff/ediff-ptch.el --- a/lisp/ediff/ediff-ptch.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/ediff/ediff-ptch.el Mon Aug 13 08:49:20 2007 +0200 @@ -1,6 +1,6 @@ ;;; ediff-ptch.el --- Ediff's patch support -;; Copyright (C) 1996 Free Software Foundation, Inc. +;; Copyright (C) 1996, 1997 Free Software Foundation, Inc. ;; Author: Michael Kifer @@ -34,13 +34,11 @@ (defvar ediff-shell) (eval-when-compile - (let ((load-path (cons "." load-path))) + (let ((load-path (cons (expand-file-name ".") load-path))) (or (featurep 'ediff-init) (load "ediff-init.el" nil nil 'nosuffix)) (or (featurep 'ediff) (load "ediff.el" nil nil 'nosuffix)) - (or (featurep 'ange-ftp) - (load "ange-ftp" 'noerror)) )) ;; end pacifier diff -r ad457d5f7d04 -r 0293115a14e9 lisp/ediff/ediff-tbar.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/ediff/ediff-tbar.el Mon Aug 13 08:49:20 2007 +0200 @@ -0,0 +1,371 @@ +;;; ediff-tbar.el --- A toolbar for Ediff control buffer + +;; Copyright (C) 1996, 1997 Free Software Foundation, Inc. + +;; Author: Marc Paquette + +;; 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 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Code: + +(provide 'ediff-tbar) + +;; compiler pacifier +(defvar toolbar-icon-directory) + +(eval-when-compile + (let ((load-path (cons (expand-file-name ".") load-path))) + (or (featurep 'ediff-init) + (load "ediff-init.el" nil nil 'nosuffix)) + (or (featurep 'ediff-util) + (load "ediff-util.el" nil nil 'nosuffix)) + )) +;; end pacifier + +(require 'ediff-init) + +(defvar ediff-use-toolbar-p nil + "If t, Ediff will use a toolbar for the control frame. +This has an effect only if your emacs supports Toolbars. +Currently, XEmacs does, but not Emacs. +Do not change the value of this variable interactively. +This should be done only via the menu bar or by executing +`ediff-toggle-use-toolbar'.") + +(defvar ediff-toolbar-height 21 + "The height of the Ediff toolbar. +The value must match the actual size of the toolbar icons.") + +(defvar ediff-toolbar-width 200.0 + "The width of the Ediff toolbar. +The value must match the actual width of the toolbar. +Here's an example: + There are 10 buttons, each 15 pixels large, and the shadows occupy 2 + pixels each side, and the last button is right-justified (so we reserve + about 30 pixels for fill space) = 200 pixels.") + +(defun ediff-has-toolbar-support-p () + (and ediff-xemacs-p + (featurep 'toolbar) + (console-on-window-system-p))) + +(defun ediff-use-toolbar-p () + (and (ediff-has-toolbar-support-p) ;Can it do it ? + ediff-use-toolbar-p)) ;Does the user want it ? + +;; Here the toolbar width is not the same width talked about in XEmacs +;; lispref info documentation : it is the minimal width needed by +;; ediff's toolbar to display all buttons, for an horizontal toolbar. +;; Ideally, we would query the toolbar for the width of each button +;; and add them, but I didn't find query functions in the doc on +;; toolbars. Therefore, I use a static number of pixels that should +;; be adjusted if the toolbar gets more or loses some buttons. --marcpa +(defun ediff-compute-toolbar-width () + (if (not (ediff-use-toolbar-p)) + 0 + (ceiling (/ ediff-toolbar-width (font-instance-width (face-font-instance 'default)))))) + +(defvar ediff-toolbar-next-icon + (if (featurep 'toolbar) + (toolbar-make-button-list + (expand-file-name + (if (featurep 'xpm) "ediff-next.xpm" "ediff-next.xbm") + toolbar-icon-directory))) + "Next difference icon in toolbar.") + +(defvar ediff-toolbar-previous-icon + (if (featurep 'toolbar) + (toolbar-make-button-list + (expand-file-name + (if (featurep 'xpm) "ediff-prev.xpm" "ediff-prev.xbm") + toolbar-icon-directory))) + "Previous difference icon in toolbar.") + +(defvar ediff-toolbar-A-icon + (if (featurep 'toolbar) + (toolbar-make-button-list + (expand-file-name + ;; UP + (if (featurep 'xpm) "ediff-A-up.xpm" "ediff-A-up.xbm") + toolbar-icon-directory) + (expand-file-name + ;; DOWN + (if (featurep 'xpm) "ediff-A-up.xpm" "ediff-A-up.xbm") + toolbar-icon-directory) + (expand-file-name + ;; DISABLED + (if (featurep 'xpm) "ediff-A-xx.xpm" "ediff-A-up.xbm") + toolbar-icon-directory) + )) + "Select diff A icon in toolbar.") + +(defvar ediff-toolbar-B-icon + (if (featurep 'toolbar) + (toolbar-make-button-list + (expand-file-name + ;; UP + (if (featurep 'xpm) "ediff-B-up.xpm" "ediff-B-up.xbm") + toolbar-icon-directory) + (expand-file-name + ;; DOWN + (if (featurep 'xpm) "ediff-B-up.xpm" "ediff-B-up.xbm") + toolbar-icon-directory) + (expand-file-name + ;; DISABLED + (if (featurep 'xpm) "ediff-B-xx.xpm" "ediff-B-up.xbm") + toolbar-icon-directory) + )) + "Select diff B icon in toolbar.") + +(defvar ediff-toolbar-toggle-split-icon + (if (featurep 'toolbar) + (toolbar-make-button-list + (expand-file-name + ;; UP + (if (featurep 'xpm) + "ediff-toggle-split-up.xpm" "ediff-toggle-split-up.xbm") + toolbar-icon-directory) + )) + "Toggle split mode between side-to-side and one-on-top-of-another.") + +(defvar ediff-toolbar-save-icon + (if (featurep 'toolbar) + (toolbar-make-button-list + (expand-file-name + ;; UP + (if (featurep 'xpm) "ediff-save.xpm" "ediff-save.xbm") + toolbar-icon-directory) + (expand-file-name + ;; DOWN + (if (featurep 'xpm) "ediff-save.xpm" "ediff-save.xbm") + toolbar-icon-directory) + (expand-file-name + ;; DISABLED + (if (featurep 'xpm) "ediff-save-xx.xpm" "ediff-save-xx.xbm") + toolbar-icon-directory) + )) + "Save merge buffer.") + +(defvar ediff-toolbar-quit-icon + (if (featurep 'toolbar) + (toolbar-make-button-list + (expand-file-name + (if (featurep 'xpm) "ediff-quit.xpm" "ediff-quit.xbm") + toolbar-icon-directory))) + "Exit Ediff session.") + +(defvar ediff-toolbar-help-icon + (if (featurep 'toolbar) + (toolbar-make-button-list + (expand-file-name + (if (featurep 'xpm) "ediff-help.xpm" "ediff-help.xbm") + toolbar-icon-directory))) + "Show Ediff help.") + +(defvar ediff-toolbar-refresh-icon + (if (featurep 'toolbar) + (toolbar-make-button-list + (expand-file-name + (if (featurep 'xpm) "ediff-update.xpm" "ediff-update.xbm") + toolbar-icon-directory))) + "Refresh Ediff display (aka recenter).") + +(defvar ediff-toolbar-refine-icon + (if (featurep 'toolbar) + (toolbar-make-button-list + (expand-file-name + ;; UP + (if (featurep 'xpm) "ediff-refine.xpm" "ediff-refine.xbm") + toolbar-icon-directory) + )) + "Refine current difference region by computing fine diffs.") + +(defun ediff-toolbar-previous-difference () + (interactive) + (let ((ediff-grab-mouse nil)) + (ediff-previous-difference 1))) + +(defun ediff-toolbar-next-difference () + (interactive) + (let ((ediff-grab-mouse nil)) + (ediff-next-difference 1))) + +(defun ediff-toolbar-select/copy-A () + (interactive) + (let ((ediff-grab-mouse nil)) + (cond ((or (ediff-merge-job) + (ediff-merge-with-ancestor-job)) + (ediff-copy-A-to-C nil)) + (t + (ediff-copy-A-to-B nil))))) + +(defun ediff-toolbar-select/copy-B () + (interactive) + (let ((ediff-grab-mouse nil)) + (cond ((or (ediff-merge-job) + (ediff-merge-with-ancestor-job)) + (ediff-copy-B-to-C nil)) + (t + (ediff-copy-B-to-A nil))))) + +(defun ediff-toolbar-toggle-split () + (interactive) + (let ((ediff-grab-mouse nil)) + (ediff-toggle-split))) + + +(defun ediff-toolbar-save () + (interactive) + (ediff-barf-if-not-control-buffer) + (if (ediff-merge-job) + (ediff-maybe-save-and-delete-merge 'save-and-continue) + ;; 2-way or 3-way compare: save modified buffers + (mapcar (function + (lambda (type) + (let ((ebuf (ediff-get-buffer type))) + (and (ediff-buffer-live-p ebuf) + (ediff-eval-in-buffer ebuf + (and (buffer-modified-p) + (save-buffer))))))) + '(A B C)))) + + +(defun ediff-toolbar-quit () + (interactive) + (let ((ediff-grab-mouse nil)) + (ediff-quit nil))) + +(defun ediff-toolbar-help () + (interactive) + (ediff-toggle-help)) + +(defun ediff-toolbar-refresh () + "Recenter" + (interactive) + (let ((ediff-grab-mouse nil)) + (ediff-recenter))) + +(defun ediff-toolbar-refine () + "Refine current difference region by computing fine diffs." + (interactive) + (let ((ediff-grab-mouse nil)) + (ediff-make-or-kill-fine-diffs 'make-them))) + +(defun ediff-toolbar-refine-needed-p () + (and (> ediff-current-difference 0) + (> ediff-auto-refine-limit + (- (ediff-get-diff-posn 'A 'end ediff-current-difference) + (ediff-get-diff-posn 'A 'beg ediff-current-difference))))) + +(defvar ediff-toolbar + (if (featurep 'toolbar) + '([ediff-toolbar-refine-icon + ediff-toolbar-refine + t + ;;; The toolbar is not automatically refreshed (in 19.14) + ;;; when :activep changes state. + ;;(ediff-toolbar-refine-needed-p) + "Refine current difference region by computing fine diffs."] + [ediff-toolbar-previous-icon + ediff-toolbar-previous-difference + t + "Go to the previous difference."] + [ediff-toolbar-next-icon + ediff-toolbar-next-difference + t + "Advance to the next difference."] + [ediff-toolbar-A-icon + ediff-toolbar-select/copy-A + (not (ediff-3way-comparison-job)) + "Select/Copy difference A."] + [ediff-toolbar-B-icon + ediff-toolbar-select/copy-B + (not (ediff-3way-comparison-job)) + "Select/Copy difference B."] + [ediff-toolbar-save-icon + ediff-toolbar-save + t + "Save buffers modified in this session."] + [ediff-toolbar-refresh-icon + ediff-toolbar-refresh + t + "Refresh Ediff display (aka recenter)."] + [ediff-toolbar-toggle-split-icon + ediff-toolbar-toggle-split + t + "Toggle split mode between side-to-side and one-on-top-of-another."] + [ediff-toolbar-help-icon + ediff-toolbar-help + t + "Toggle short/long help."] + nil + [ediff-toolbar-quit-icon + ediff-toolbar-quit + t + "Quit this ediff session."] + ))) + +(defvar ediff-toolbar-3way + (if (featurep 'toolbar) + '([ediff-toolbar-refine-icon + ediff-toolbar-refine + t + ;;; The toolbar is not automatically refreshed (in 19.14) + ;;; when :activep changes state. + ;;(ediff-toolbar-refine-needed-p) + "Refine current difference region by computing fine diffs."] + [ediff-toolbar-previous-icon + ediff-toolbar-previous-difference + t + "Go to the previous difference."] + [ediff-toolbar-next-icon + ediff-toolbar-next-difference + t + "Advance to the next difference."] + [ediff-toolbar-save-icon + ediff-toolbar-save + t + "Save buffers modified in this session."] + [ediff-toolbar-refresh-icon + ediff-toolbar-refresh + t + "Refresh Ediff display (aka recenter)."] + [ediff-toolbar-toggle-split-icon + ediff-toolbar-toggle-split + t + "Toggle split mode between side-to-side and one-on-top-of-another."] + [ediff-toolbar-help-icon + ediff-toolbar-help + t + "Toggle short/long help."] + nil + [ediff-toolbar-quit-icon + ediff-toolbar-quit + t + "Quit this ediff session."] + ))) + + + +;;; Local Variables: +;;; eval: (put 'ediff-defvar-local 'lisp-indent-hook 'defun) +;;; eval: (put 'ediff-eval-in-buffer 'lisp-indent-hook 1) +;;; eval: (put 'ediff-eval-in-buffer 'edebug-form-spec '(form body)) +;;; End: + +;;; ediff-tbar.el ends here diff -r ad457d5f7d04 -r 0293115a14e9 lisp/ediff/ediff-util.el --- a/lisp/ediff/ediff-util.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/ediff/ediff-util.el Mon Aug 13 08:49:20 2007 +0200 @@ -1,6 +1,6 @@ ;;; ediff-util.el --- the core commands and utilities of ediff -;; Copyright (C) 1994, 1995, 1996 Free Software Foundation, Inc. +;; Copyright (C) 1994, 1995, 1996, 1997 Free Software Foundation, Inc. ;; Author: Michael Kifer @@ -29,10 +29,14 @@ (defvar ediff-patch-diagnostics) (defvar ediff-patchbufer) (defvar ediff-toolbar) +(defvar ediff-toolbar-3way) +(defvar bottom-toolbar) +(defvar bottom-toolbar-visible-p) +(defvar bottom-toolbar-height) (defvar mark-active) (eval-when-compile - (let ((load-path (cons "." load-path))) + (let ((load-path (cons (expand-file-name ".") load-path))) (or (featurep 'ediff-init) (load "ediff-init.el" nil nil 'nosuffix)) (or (featurep 'ediff-help) @@ -515,8 +519,10 @@ ediff-split-window-function (ediff-multiframe-setup-p) ediff-wide-display-p)) + + ;; In multiframe, toolbar is set in ediff-setup-control-frame (if (not (ediff-multiframe-setup-p)) - (ediff-make-bottom-toolbar)) ; checks if toolbar is requested + (ediff-make-bottom-toolbar)) ; this checks if toolbar is requested (goto-char (point-min)) (skip-chars-forward ediff-whitespace))) @@ -1181,33 +1187,21 @@ ;;;###autoload (defun ediff-toggle-multiframe () - "Switch from the multiframe display to single-frame display and back. -For a permanent change, set the variable `ediff-window-setup-function', + "Switch from multiframe display to single-frame display and back. +To change the default, set the variable `ediff-window-setup-function', which see." (interactive) - (let (set-func window-setup-func) + (let (window-setup-func) (or (ediff-window-display-p) (error "%sEmacs is not running as a window application" (if ediff-emacs-p "" "X"))) - ;;(setq set-func (if (ediff-in-control-buffer-p) 'setq 'setq-default)) - (cond ((eq ediff-window-setup-function 'ediff-setup-windows-multiframe) - ;; (eval - ;; (list - ;; set-func - ;; 'ediff-window-setup-function ''ediff-setup-windows-plain)) - (setq window-setup-func 'ediff-setup-windows-plain) - ) + (setq window-setup-func 'ediff-setup-windows-plain)) ((eq ediff-window-setup-function 'ediff-setup-windows-plain) (if (ediff-in-control-buffer-p) (ediff-kill-bottom-toolbar)) - ;;(eval - ;; (list - ;; set-func - ;; 'ediff-window-setup-function 'ediff-setup-windows-multiframe)) - (setq window-setup-func 'ediff-setup-windows-multiframe) - )) + (setq window-setup-func 'ediff-setup-windows-multiframe))) ;; change default (setq-default ediff-window-setup-function window-setup-func) @@ -1220,6 +1214,33 @@ (if (ediff-in-control-buffer-p) (ediff-recenter 'no-rehighlight)))) + +;;;###autoload +(defun ediff-toggle-use-toolbar () + "Enable or disable Ediff toolbar. +Works only in versions of Emacs that support toolbars. +To change the default, set the variable `ediff-use-toolbar-p', which see." + (interactive) + (if (featurep 'ediff-tbar) + (progn + (or (ediff-window-display-p) + (error "%sEmacs is not running as a window application" + (if ediff-emacs-p "" "X"))) + (if (ediff-use-toolbar-p) + (ediff-kill-bottom-toolbar)) + ;; do this only after killing the toolbar + (setq ediff-use-toolbar-p (not ediff-use-toolbar-p)) + + (mapcar (function (lambda(buf) + (ediff-eval-in-buffer buf + ;; force redisplay + (setq ediff-window-config-saved "") + ))) + ediff-session-registry) + (if (ediff-in-control-buffer-p) + (ediff-recenter 'no-rehighlight))))) + + ;; if was using toolbar, kill it (defun ediff-kill-bottom-toolbar () ;; Using ctl-buffer or ediff-control-window for LOCALE does not @@ -1233,13 +1254,25 @@ (set-specifier bottom-toolbar (list (selected-frame) nil)) (set-specifier bottom-toolbar-visible-p (list (selected-frame) nil))))) -;; if wants to use toolbar, make it -(defun ediff-make-bottom-toolbar () - (if (ediff-use-toolbar-p) +;; If wants to use toolbar, make it. +;; If not, zero the toolbar for XEmacs. +;; Do nothing for Emacs. +(defun ediff-make-bottom-toolbar (&optional frame) + (if (ediff-window-display-p) (progn - (set-specifier bottom-toolbar (list (selected-frame) ediff-toolbar)) - (set-specifier bottom-toolbar-visible-p (list (selected-frame) t)) - (set-specifier bottom-toolbar-height (list (selected-frame) 34))))) + (setq frame (or frame (selected-frame))) + (cond ((ediff-use-toolbar-p) ; this checks for XEmacs + (set-specifier + bottom-toolbar + (list frame (if (ediff-3way-comparison-job) + ediff-toolbar-3way ediff-toolbar))) + (set-specifier bottom-toolbar-visible-p (list frame t)) + (set-specifier bottom-toolbar-height + (list frame ediff-toolbar-height))) + (ediff-xemacs-p + (set-specifier bottom-toolbar-height (list frame 0))) + )) + )) ;; Merging @@ -2202,13 +2235,15 @@ temporarily reverses the meaning of this variable." (interactive "P") (ediff-barf-if-not-control-buffer) - (if (y-or-n-p (format "Quit this Ediff session%s? " - (if (ediff-buffer-live-p ediff-meta-buffer) - " & show containing session group" ""))) - (progn - (message "") - (ediff-really-quit reverse-default-keep-variants)) - (message ""))) + (let ((ctl-buf (current-buffer))) + (if (y-or-n-p (format "Quit this Ediff session%s? " + (if (ediff-buffer-live-p ediff-meta-buffer) + " & show containing session group" ""))) + (progn + (message "") + (set-buffer ctl-buf) + (ediff-really-quit reverse-default-keep-variants)) + (message "")))) ;; Perform the quit operations. @@ -2422,27 +2457,33 @@ (buffer-name ediff-buffer-C))))) (ediff-kill-buffer-carefully ediff-buffer-C)))) -(defun ediff-maybe-save-and-delete-merge () +(defun ediff-maybe-save-and-delete-merge (&optional save-and-continue) "Default hook to run on quitting a merge job. +This can also be used to save merge buffer in the middle of an Ediff session. + +If the optional SAVE-AND-CONTINUE argument is non-nil, save merge buffer and +continue. Otherwise: If `ediff-autostore-merges' is nil, this does nothing. If it is t, it saves the merge buffer in the file `ediff-merge-store-file' -or asks the user, if the latter is nil. It then then asks the user whether to +or asks the user, if the latter is nil. It then asks the user whether to delete the merge buffer. If `ediff-autostore-merges' is neither nil nor t, the merge buffer is saved only if this merge job is part of a group, i.e., was invoked from within `ediff-merge-directories', `ediff-merge-directory-revisions', and such." - (let ((merge-store-file ediff-merge-store-file)) + (let ((merge-store-file ediff-merge-store-file) + (ediff-autostore-merges ; fake ediff-autostore-merges, if necessary + (if save-and-continue t ediff-autostore-merges))) (if ediff-autostore-merges (cond ((stringp ediff-merge-store-file) ;; store, ask to delete - (ediff-write-merge-buffer-then-kill - ediff-buffer-C merge-store-file 'show-file)) + (ediff-write-merge-buffer-and-maybe-kill + ediff-buffer-C merge-store-file 'show-file save-and-continue)) ((eq ediff-autostore-merges t) ;; ask for file name (setq merge-store-file - (read-file-name "Save the result of the merge in: ")) - (ediff-write-merge-buffer-then-kill - ediff-buffer-C merge-store-file)) + (read-file-name "Save the merge buffer in file: ")) + (ediff-write-merge-buffer-and-maybe-kill + ediff-buffer-C merge-store-file nil save-and-continue)) ((and (ediff-buffer-live-p ediff-meta-buffer) (ediff-eval-in-buffer ediff-meta-buffer (ediff-merge-metajob))) @@ -2451,12 +2492,16 @@ ;; of the merge. ;; Ask where to save anyway--will decide what to do here later. (setq merge-store-file - (read-file-name "The result of the merge goes into: ")) - (ediff-write-merge-buffer-then-kill - ediff-buffer-C merge-store-file)))) + (read-file-name "Save the merge buffer in file: ")) + (ediff-write-merge-buffer-and-maybe-kill + ediff-buffer-C merge-store-file nil save-and-continue)))) )) -(defun ediff-write-merge-buffer-then-kill (buf file &optional show-file) +;; write merge buffer. If the optional argument save-and-continue is non-nil, +;; then don't kill the merge buffer +(defun ediff-write-merge-buffer-and-maybe-kill (buf file + &optional + show-file save-and-continue) (ediff-eval-in-buffer buf (if (or (not (file-exists-p file)) (y-or-n-p (format "File %s exists, overwrite? " file))) @@ -2466,7 +2511,9 @@ (progn (message "Merge buffer saved in: %s" file) (sit-for 2))) - (if (y-or-n-p "Merge buffer saved in file. Now kill the buffer? ") + (if (and + (not save-and-continue) + (y-or-n-p "Merge buffer saved in file. Now kill the buffer? ")) (ediff-kill-buffer-carefully buf)))))) ;; The default way of suspending Ediff. diff -r ad457d5f7d04 -r 0293115a14e9 lisp/ediff/ediff-vers.el --- a/lisp/ediff/ediff-vers.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/ediff/ediff-vers.el Mon Aug 13 08:49:20 2007 +0200 @@ -1,6 +1,6 @@ ;;; ediff-vers.el --- version control interface to Ediff -;;; Copyright (C) 1995, 1996 Free Software Foundation, Inc. +;;; Copyright (C) 1995, 1996, 1997 Free Software Foundation, Inc. ;; Author: Michael Kifer @@ -32,11 +32,12 @@ (defvar cvs-cookie-handle) (defvar ediff-temp-file-prefix) -(eval-when-compile - (load "pcl-cvs" 'noerror) - (load "rcs" 'noerror) - (load "generic-sc" 'noerror) - (load "vc" 'noerror)) +(and noninteractive + (eval-when-compile + (load "pcl-cvs" 'noerror) + (load "rcs" 'noerror) + (load "generic-sc" 'noerror) + (load "vc" 'noerror))) ;; end pacifier ;; VC.el support diff -r ad457d5f7d04 -r 0293115a14e9 lisp/ediff/ediff-wind.el --- a/lisp/ediff/ediff-wind.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/ediff/ediff-wind.el Mon Aug 13 08:49:20 2007 +0200 @@ -1,6 +1,6 @@ ;;; ediff-wind.el --- window manipulation utilities -;; Copyright (C) 1994, 1995, 1996 Free Software Foundation, Inc. +;; Copyright (C) 1994, 1995, 1996, 1997 Free Software Foundation, Inc. ;; Author: Michael Kifer @@ -38,13 +38,13 @@ (defvar ediff-diff-status) (eval-when-compile - (let ((load-path (cons "." load-path))) + (let ((load-path (cons (expand-file-name ".") load-path))) (or (featurep 'ediff-init) (load "ediff-init.el" nil nil 'nosuffix)) + (or (featurep 'ediff-util) + (load "ediff-util.el" nil nil 'nosuffix)) (or (featurep 'ediff-help) (load "ediff-help.el" nil nil 'nosuffix)) - (or (featurep 'ediff-util) - (load "ediff-util.el" nil nil 'nosuffix)) (or (featurep 'ediff-tbar) (load "ediff-tbar.el" 'noerror nil 'nosuffix)) )) @@ -878,16 +878,19 @@ fheight lines fwidth (max (+ (ediff-help-message-line-length) 2) (ediff-compute-toolbar-width)) - adjusted-parameters (append (list - ;; possibly change surrogate minibuffer - (cons 'minibuffer - (minibuffer-window - designated-minibuffer-frame)) - (cons 'width fwidth) - (cons 'height fheight)) - (funcall - ediff-control-frame-position-function - ctl-buffer fwidth fheight))) + adjusted-parameters ;;(append + (list + ;; possibly change surrogate minibuffer + (cons 'minibuffer + (minibuffer-window + designated-minibuffer-frame)) + (cons 'width fwidth) + (cons 'height fheight)) + ;;(funcall + ;;ediff-control-frame-position-function + ;;ctl-buffer fwidth fheight) + ;;) + ) (if ediff-use-long-help-message (setq adjusted-parameters (cons '(auto-raise . nil) adjusted-parameters))) @@ -896,8 +899,10 @@ ;; are changed. (if ediff-xemacs-p (progn + (set-specifier top-toolbar-height (list ctl-frame 2)) + (sit-for 0) (set-specifier top-toolbar-height (list ctl-frame 0)) - (set-specifier bottom-toolbar-height (list ctl-frame 0)) + ;;(set-specifier bottom-toolbar-height (list ctl-frame 0)) (set-specifier left-toolbar-width (list ctl-frame 0)) (set-specifier right-toolbar-width (list ctl-frame 0)) )) @@ -910,11 +915,13 @@ (if (memq system-type '(emx windows-nt windows-95)) (modify-frame-parameters ctl-frame adjusted-parameters)) + ;; make or zap toolbar (if not requested) + (ediff-make-bottom-toolbar ctl-frame) + (goto-char (point-min)) - + (modify-frame-parameters ctl-frame adjusted-parameters) (make-frame-visible ctl-frame) - (ediff-make-bottom-toolbar) ; no effect if the toolbar is not requested ;; This works around a bug in 19.25 and earlier. There, if frame gets ;; iconified, the current buffer changes to that of the frame that @@ -930,6 +937,12 @@ (raise-frame ctl-frame))) (set-window-dedicated-p (selected-window) t) + + ;; Now move the frame. We must do it separately due to an obscure bug in + ;; XEmacs + (modify-frame-parameters + ctl-frame + (funcall ediff-control-frame-position-function ctl-buffer fwidth fheight)) ;; synchronize so the cursor will move to control frame ;; per RMS suggestion @@ -955,6 +968,7 @@ (ediff-eval-in-buffer ctl-buffer (run-hooks 'ediff-after-setup-control-frame-hook)) )) + (defun ediff-destroy-control-frame (ctl-buffer) (ediff-eval-in-buffer ctl-buffer @@ -1081,9 +1095,9 @@ ;; control buffer format (setq mode-line-format - (list (if (ediff-narrow-control-frame-p) " " "-- ") - mode-line-buffer-identification - " Quick Help")) + (if (ediff-narrow-control-frame-p) + (list " " mode-line-buffer-identification) + (list "-- " mode-line-buffer-identification " Quick Help"))) ;; control buffer id (setq mode-line-buffer-identification (if (ediff-narrow-control-frame-p) diff -r ad457d5f7d04 -r 0293115a14e9 lisp/ediff/ediff.el --- a/lisp/ediff/ediff.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/ediff/ediff.el Mon Aug 13 08:49:20 2007 +0200 @@ -1,13 +1,13 @@ ;;; ediff.el --- a comprehensive visual interface to diff & patch -;; Copyright (C) 1994, 1995, 1996 Free Software Foundation, Inc. +;; Copyright (C) 1994, 1995, 1996, 1997 Free Software Foundation, Inc. ;; Author: Michael Kifer ;; Created: February 2, 1994 ;; Keywords: comparing, merging, patching, version control. (defconst ediff-version "2.64" "The current version of Ediff") -(defconst ediff-date "January 3, 1997" "Date of last update") +(defconst ediff-date "January 7, 1997" "Date of last update") ;; This file is part of GNU Emacs. @@ -109,9 +109,13 @@ (provide 'ediff) ;; Compiler pacifier +(and noninteractive + (eval-when-compile + (load-library "dired") + (load-library "info") + (load "pcl-cvs" 'noerror))) (eval-when-compile - (let ((load-path (cons "." load-path))) - (load "dired") + (let ((load-path (cons (expand-file-name ".") load-path))) (or (featurep 'ediff-init) (load "ediff-init.el" nil nil 'nosuffix)) (or (featurep 'ediff-mult) @@ -120,7 +124,6 @@ (load "ediff-ptch.el" nil nil 'nosuffix)) (or (featurep 'ediff-vers) (load "ediff-vers.el" nil nil 'nosuffix)) - (load "pcl-cvs" 'noerror) )) ;; end pacifier @@ -285,8 +288,8 @@ (ediff-eval-in-buffer (symbol-value buffer-name) (widen) ; Make sure the entire file is seen - (cond (file-magic ;; file has handler, such as jka-compr-handler or - ;; ange-ftp-hook-function--arrange for temp file + (cond (file-magic ; file has a handler, such as jka-compr-handler or + ;;; ange-ftp-hook-function--arrange for temp file (ediff-verify-file-buffer 'magic) (setq file (ediff-make-temp-file diff -r ad457d5f7d04 -r 0293115a14e9 lisp/emulators/tpu-doc.el --- a/lisp/emulators/tpu-doc.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/emulators/tpu-doc.el Mon Aug 13 08:49:20 2007 +0200 @@ -19,8 +19,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. (defconst tpu-doc-revision "!Revision: 1.6 !" "TPU-edt documentation revision number.") diff -r ad457d5f7d04 -r 0293115a14e9 lisp/energize/energize-font-lock.el --- a/lisp/energize/energize-font-lock.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/energize/energize-font-lock.el Mon Aug 13 08:49:20 2007 +0200 @@ -14,8 +14,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;; This file is preloaded, but font-lock.el is not. diff -r ad457d5f7d04 -r 0293115a14e9 lisp/energize/energize-font-size.el --- a/lisp/energize/energize-font-size.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/energize/energize-font-size.el Mon Aug 13 08:49:20 2007 +0200 @@ -14,8 +14,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. (defconst energize-x-modify-font-regexp "-\\([^-]+-[^-]+\\)-\\([^-]+\\)-\\([^-]+\\)-\\([^-]+\\)-\\([^-]+\\)-\\([^-]+\\)-\\([^-]+\\)-\\([^-]+\\)-\\([^-]+\\)-\\([^-]+\\)-\\([^-]+\\)-\\([^-]+\\)-\\([^-]+\\)" diff -r ad457d5f7d04 -r 0293115a14e9 lisp/energize/energize-uimx.el --- a/lisp/energize/energize-uimx.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/energize/energize-uimx.el Mon Aug 13 08:49:20 2007 +0200 @@ -13,8 +13,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; This file provides integration between XEmacs, Energize and UIM/X. ;;; It is not necessary to be running XEmacs as part of Energize. diff -r ad457d5f7d04 -r 0293115a14e9 lisp/eos/loaddefs-eos.el --- a/lisp/eos/loaddefs-eos.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/eos/loaddefs-eos.el Mon Aug 13 08:49:20 2007 +0200 @@ -18,8 +18,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Synched up with: Not synched with FSF. diff -r ad457d5f7d04 -r 0293115a14e9 lisp/games/spook.el --- a/lisp/games/spook.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/games/spook.el Mon Aug 13 08:49:20 2007 +0200 @@ -19,8 +19,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Synched up with: FSF 19.34. diff -r ad457d5f7d04 -r 0293115a14e9 lisp/games/yow.el --- a/lisp/games/yow.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/games/yow.el Mon Aug 13 08:49:20 2007 +0200 @@ -19,8 +19,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Synched up with: FSF 19.34. diff -r ad457d5f7d04 -r 0293115a14e9 lisp/gnus/ChangeLog --- a/lisp/gnus/ChangeLog Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/gnus/ChangeLog Mon Aug 13 08:49:20 2007 +0200 @@ -1,19 +1,4300 @@ -Fri Aug 30 02:23:23 1996 Lars Magne Ingebrigtsen - - * message.el (message-do-fcc): Set the FROM-GNUS flag. - -Sat Aug 24 23:32:02 1996 Lars Magne Ingebrigtsen - - * gnus.el (gnus-group-enter-directory): Would temporarily bind - `nneething-read-only', shadowing the proper `defvar'. - -Fri Aug 2 22:25:31 1996 Lars Magne Ingebrigtsen - - * gnus.el: Gnus v5.2.39 is released. +Sat Feb 1 14:19:54 1997 Lars Magne Ingebrigtsen + + * gnus.el: Gnus v5.4.9 is released. + +Sat Feb 1 13:30:33 1997 Hrvoje Niksic + + * gnus-start.el (gnus-gnus-to-quick-newsrc-format): Insert + "-*- emacs-lisp -*-" at the first line. + +Sat Feb 1 13:23:19 1997 Mark Borges + + * gnus-xmas.el (gnus-xmas-define): Do the right characterp thing. + +Sat Feb 1 12:28:33 1997 Lars Magne Ingebrigtsen + + * smiley.el (smiley-mouse-face): New variable. + (smiley-buffer): Use it. + + * gnus-start.el (gnus-gnus-to-quick-newsrc-format): Use gnus-prin1. + + * gnus-util.el (gnus-prin1): Bind print-level and print-length to + nil + + * gnus-art.el (gnus-button-alist): Let mailto: be less greedy. + (gnus-button-alist): Ditto with news:. + + * gnus-topic.el (gnus-topic-unmark-topic): Let groups be unmarked. + + * gnus.el (gnus-read-group): Place point at bol. + + * gnus-util.el ((fboundp 'point-at-bol)): Use the functions if + they exist. + + * gnus-msg.el (gnus-summary-supersede-article): Mark article as + canceled. + +Wed Jan 29 22:28:44 1997 Steven L Baur + + * gnus-xmas.el (gnus-xmas-define): Correct XEmacs version test to + handle v20. + +Sat Feb 1 12:19:14 1997 Katsumi Yamaoka + + * nnml.el (nnml-generate-active-info): Don't bug out. + +Sat Feb 1 00:52:03 1997 Lars Magne Ingebrigtsen + + * message.el (message-fcc-handler-function): Changed default. + (message-output): New function. + (message-do-fcc): Use it. + + * gnus-util.el (gnus-convert-article-to-rmail, + gnus-output-to-rmail): Moved here. + + * message.el (message-check-news-header-syntax): Allow trailing + periods. + (message-check-news-header-syntax): Don't allow trailing periods. + +Fri Jan 31 22:18:03 1997 Lars Magne Ingebrigtsen + + * message.el (message-resend): Rename "From ". + + * nntp.el (nntp-accept-process-output): Use nnheader-message. + +Fri Jan 31 11:51:18 1997 Katsumi Yamaoka + + * nnml.el (nnml-generate-nov-databases-1): Sort the file alist. + +Thu Jan 30 13:13:39 1997 Per Abrahamsen + + * gnus.el: More cleanup of customization groups. + +Thu Jan 30 04:33:01 1997 Sudish Joseph + + * gnus-xmas.el (gnus-xmas-define): Use `char-or-char-int-p'. + +Thu Jan 30 04:15:28 1997 Lars Magne Ingebrigtsen + + * gnus.el: Gnus v5.4.8 is released. + +Thu Jan 30 02:07:13 1997 Lars Magne Ingebrigtsen + + * message.el (message-indent-citation): Place point the right + place when indenting. + + * nnml.el (nnml-generate-active-info): Don't enter conses into + lists. + + * gnus-score.el (gnus-score-file-rank): All global score files + have low ranks. + + * nnweb.el (nnweb-possibly-change-server): Read active file. + (nnweb-dejanews-create-mapping): Respect .overview. + (nnweb-reference-create-mapping): Ditto. + (nnweb-altavista-create-mapping): Ditto. + +Wed Jan 29 04:52:31 1997 Katsumi Yamaoka + + * nnml.el (nnml-generate-nov-databases-1): Generate NOV files in + the right order. + +Tue Jan 28 23:28:49 1997 Lars Magne Ingebrigtsen + + * gnus-group.el (gnus-group-list-groups): Position point. + +Tue Jan 28 22:11:36 1997 Lars Magne Ingebrigtsen + + * gnus.el: Gnus v5.4.7 is released. + +Tue Jan 28 19:48:54 1997 Lars Magne Ingebrigtsen + + * nnmh.el (nnmh-deletable-article-p): Never allow deleting the + last article in the group. + + * nnweb.el (nnweb-definition): Accept an optional noerror + argument. + (nnweb-request-article): Don't bug out when requesting by MsgId. + + * gnus-topic.el (gnus-group-prepare-topics): Return the number of + unread articles in the buffer. + + * gnus-group.el (gnus-group-list-groups): On empty buffers, let + point go to the beginning. + (gnus-group-list-groups): Give "No news" message when using + topics. + + * gnus-topic.el (gnus-topic-goto-next-group): Let point remain + at the end of the buffer. + + * gnus-group.el (gnus-group-rename-group): Check group name + syntax. + + * gnus.el (gnus-read-group): Accept an optional default. + +Tue Jan 28 18:11:54 1997 Lars Magne Ingebrigtsen + + * gnus.el: Gnus v5.4.6 is released. + +Tue Jan 28 13:55:12 1997 Lars Magne Ingebrigtsen + + * gnus-art.el (gnus-article-check-hidden-text): Widen before doing + anything. + + * gnus.el (gnus-visual): Doc fix. + + * gnus-art.el (gnus-visible-headers): Just include "Resent-From". + +Mon Jan 27 19:40:37 1997 Paul Franklin + + * gnus-sum.el (gnus-read-header): Make sure nntp-server-buffer is + empty on failure. + +Tue Jan 28 00:33:27 1997 Lars Magne Ingebrigtsen + + * nnmail.el (nnmail-delete-incoming): Changed default. + + * gnus-topic.el (gnus-topic-mark-topic): Let groups be marked. + (gnus-topic-unmark-topic): Ditto. + + * nnmail.el (nnmail-process-babyl-mail-format): Unquote ">From ". + + * gnus-sum.el (gnus-summary-read-group): Only beep dead groups. + +Mon Jan 27 18:24:27 1997 Lars Magne Ingebrigtsen + + * nnml.el (nnml-generate-nov-databases-1): Work properly on + compressed files. + (nnml-generate-nov-file): Ditto. + + * gnus.el (gnus-article-mode-map): Don't unconditionally suppress + all the major keymaps. + + * gnus-sum.el (gnus-summary-read-group): Beep dead non-native + groups can't be entered. + +Mon Jan 27 18:03:17 1997 Lars Magne Ingebrigtsen + + * gnus.el: Gnus v5.4.5 is released. + +Mon Jan 27 17:35:21 1997 Lars Magne Ingebrigtsen + + * message.el (message-expand-group): Don't skip over ":". + + * gnus-score.el (gnus-score-find-bnews): Wouldn't find "nntp+" + score files. + + * gnus-art.el (t): Define `M-^'. + +Mon Jan 27 15:00:11 1997 Hrvoje Niksic + + * gnus-sum.el (gnus-summary-search-article): Inhibit forced + redisplay on XEmacs. + +Mon Jan 27 08:54:55 1997 Lars Magne Ingebrigtsen + + * gnus.el: Gnus v5.4.4 is released. + +Mon Jan 27 07:29:30 1997 Lars Magne Ingebrigtsen + + * nnsoup.el (nnsoup-file-name): Also find AREAS. + +Mon Jan 27 07:09:13 1997 Joev Dubach + + * message.el (message-use-followup-to): Doc fix. + +Mon Jan 27 06:59:14 1997 Lars Magne Ingebrigtsen + + * gnus-art.el (gnus-article-read-summary-keys): Don't mess up when + using pick mode. + + * gnus-undo.el (gnus-undo-mode): Set undo boundary. + + * gnus-sum.el (gnus-summary-exit-hook): Doc fix. + +Sun Jan 26 13:20:42 1997 Lars Magne Ingebrigtsen + + * gnus.el: Autoload gnus-add-configuration. + +Sun Jan 26 13:01:07 1997 Lars Magne Ingebrigtsen + + * gnus.el: Gnus v5.4.3 is released. + +Sun Jan 26 12:52:11 1997 Lars Magne Ingebrigtsen + + * gnus.el: Gnus v5.4.2 is released. + +Sun Jan 26 09:28:31 1997 Per Abrahamsen + + * gnus-group.el: Organized customization options, and moved group + definitions to `gnus.el'. + * gnus-sum.el: Ditto. + * gnus.el: Ditto. + +Sun Jan 26 07:37:40 1997 Lars Magne Ingebrigtsen + + * gnus.el: Autoload topic function. + + * gnus-topic.el (gnus-topic-set-parameters): Quote strings to + enter into dribble file. + + * gnus-salt.el (gnus-pick-setup-message): Also restore right + config on sending. + + * gnus.el (gnus-group-startup-message): Add a space to the + beginning of the version string. + +Sat Jan 25 12:17:56 1997 Lars Magne Ingebrigtsen + + * gnus.el: Gnus v5.4.1 is released. + +Sat Jan 25 10:59:31 1997 Lars Magne Ingebrigtsen + + * gnus.el: Red Gnus v0.84 is released. + +Fri Jan 24 20:31:25 1997 Paul Franklin + + * gnus-sum.el (gnus-summary-next-article): There's no + reason not to select the current article if it's what should + be selected. + +Sat Jan 25 01:03:59 1997 Per Abrahamsen + + * gnus-art.el: Organized customization options. + * gnus-sum.el: Adjusted. + * gnus-cite.el: Ditto. + * gnus.el: Ditto. + +Sat Jan 25 09:49:40 1997 Lars Magne Ingebrigtsen + + * gnus-demon.el (gnus-demon): Disable demons when the minibuffer + window is active. + + * gnus-art.el (gnus-article-read-summary-keys): Disable pick mode + commands. + +Sat Jan 25 09:42:41 1997 Kurt Swanson + + * message.el (message-pipe-buffer-body): New function. + + * gnus-sum.el (gnus-summary-pipe-message): New command and + keystroke. + +Fri Jan 24 11:01:06 1997 Per Abrahamsen + + * gnus-uu.el: Cleaned up customization groups. + +Fri Jan 24 15:45:48 1997 Kurt Swanson + + * gnus-sum.el (gnus-summary-make-menu-bar): Moved cache menu. + +Fri Jan 24 10:05:49 1997 Lars Magne Ingebrigtsen + + * gnus-msg.el (gnus-summary-resend-message): Accept + process/prefix. + + * gnus-cite.el (gnus-article-fill-cited-article): Accept a width + prefix. + + * gnus-art.el (gnus-article-read-summary-keys): Disable pick mode + map. + + * gnus-sum.el (gnus-summary-make-menu-bar): Duplication removed. + +Fri Jan 24 08:33:42 1997 Lars Magne Ingebrigtsen + + * gnus.el: Red Gnus v0.83 is released. + +Fri Jan 24 05:05:38 1997 Lars Magne Ingebrigtsen + + * gnus.el (gnus-article-display-hook): Removed emphasize. + + * gnus-score.el (gnus-score-edit-current-scores): Set global + vars. + + * nnml.el (nnml-possibly-change-directory): Return nil when the + group can't be selected. + + * gnus-art.el (gnus-emphasis-alist): Don't underline + all-underscore words. + + * gnus-topic.el (gnus-topic-unindent): Give the right number of + unread articles. + (gnus-topic-indent): Ditto. + + * gnus-msg.el (gnus-summary-wide-reply-with-original): New command + and keystroke. + (gnus-summary-wide-reply): Ditto. + +Fri Jan 24 04:57:07 1997 Joe Wells + + * gnus-uu.el (gnus-quote-arg-for-sh-or-csh): New function. + (gnus-uu-command): Use it. + +Fri Jan 24 04:55:10 1997 Lars Magne Ingebrigtsen + + * gnus-topic.el (gnus-topic-mark-topic): Also bound to `#'. + +Fri Jan 24 04:44:10 1997 Greg Klanderman + + * message.el (message-do-send-housekeeping): Check for nil + message-buffer-list. + +Fri Jan 24 02:55:33 1997 Kurt Swanson + + * gnus-util.el (gnus-eval-in-buffer-window): Set buffer. + +Thu Jan 23 03:39:48 1997 Lars Magne Ingebrigtsen + + * nnsoup.el (nnsoup-file-name): New function. + (nnsoup-read-areas): Use it. + (nnsoup-dissect-buffer): New function. + (nnsoup-number-of-articles): Use it. + (nnsoup-narrow-to-article): Ditto. + (nnsoup-header): Removed. + + * gnus.el (gnus-check-backend-function): Doc fix. + + * gnus-art.el (gnus-article-goto-prev-page): Went to next article, + not prev. + + * gnus-group.el (gnus-group-insert-group-line-info): Display "*" + on unknown groups. + + * gnus-art.el (article-hide-boring-headers): Ignore errors in + `mail-extract-address-components'. + + * nnmail.el (nnmail-date-to-time): Parse zone correctly. + (nnmail-date-to-time): Seconds, dammit, seconds! + +Tue Jan 21 09:31:55 1997 Lars Magne Ingebrigtsen + + * gnus-art.el (gnus-url-mailto): Didn't accept mailto links. + + * gnus-score.el (gnus-summary-score-effect): Doc fix. + + * nnmail.el (nnmail-move-inbox): Don't prin1 password. + +Mon Jan 20 18:06:19 1997 Paul Franklin + + * gnus-sum.el (gnus-simplify-buffer-fuzzy-step): New function. + (gnus-simplify-buffer-fuzzy): Use it. + + * gnus-sum.el (gnus-simplify-buffer-fuzzy): Fix while condition. + Add self-discipline tags. + +Tue Jan 21 05:28:05 1997 Lars Magne Ingebrigtsen + + * gnus-sum.el (gnus-get-newsgroup-headers-xover): Would return + nil from NoCeM. + +Mon Jan 20 04:59:53 1997 Lars Magne Ingebrigtsen + + * gnus-art.el (gnus-button-alist): Only on word boundaries. + + * message.el (message-check-news-header-syntax): Don't prompt when + not read active file. + + * gnus-msg.el (gnus-setup-message): Always set actions. + +Sat Jan 18 07:23:41 1997 Lars Magne Ingebrigtsen + + * nntp.el (nntp-have-messaged): New variable. + (nntp-accept-process-output): Use it. + (nntp-wait-for): Ditto. + +Sat Jan 18 02:44:53 1997 Lars Magne Ingebrigtsen + + * gnus.el: Red Gnus v0.82 is released. + +Fri Jan 17 00:04:47 1997 Lars Magne Ingebrigtsen + + * nnheader.el (nnheader-find-nov-line): Do the right thing with + short buffers. + + * nnkiboze.el (nnkiboze-generate-group): Supress duplicate + suppression. + (nnkiboze-generate-group): Message better. + + * gnus-sum.el (gnus-get-newsgroup-headers-xover): Don't always + fetch more heads. + (gnus-select-newsgroup): Use it. + + * nnmail.el (nnmail-get-new-mail): Weird file-truename problem. + + * gnus-sum.el (gnus-summary-caesar-message): Dox fix. + (gnus-articles-to-read): Limit length of prompt. + + * message.el (message-followup): Fold case before comparing + "world" to Distribution. + + * gnus-sum.el (gnus-summary-save-newsrc): Save dribble buffer. + + * nnfolder.el (nnfolder-request-expire-articles): Better message. + + * gnus-nocem.el (gnus-nocem-load-cache): Interactive. + +Thu Jan 16 23:48:05 1997 Lars Magne Ingebrigtsen + + * nnmail.el (nnmail-move-inbox): Use `nnmail-pop-password'. + +Wed Jan 15 18:41:42 1997 Lars Magne Ingebrigtsen + + * nnml.el (nnml-request-expire-articles): Typo. + (nnml-request-expire-articles): Don't blank out messages so + often. + + * nnsoup.el (nnsoup-request-type): Let commands like `a' work + better. + +Wed Jan 15 05:33:23 1997 Lars Magne Ingebrigtsen + + * gnus.el: Red Gnus v0.81 is released. + +Wed Jan 15 02:57:18 1997 Lars Magne Ingebrigtsen + + * gnus-topic.el (gnus-topic-indent): Don't remove all groups from + topic. + (gnus-topic-unindent): Ditto. + + * gnus-sum.el (gnus-summary-respool-query): Don't mark anything as + read. + + * gnus-art.el (gnus-button-alist): Move news:mesg-id up. + + * gnus.el (gnus-article-display-hook): Emphasize by default. + + * gnus-topic.el (gnus-topic-rename): Mark newsrc as dirty. + + * gnus-sum.el (gnus-summary-next-page): When the article window + isn't displayed, don't scroll. + +Wed Jan 15 02:19:56 1997 Markus Linnala + + * gnus-cite.el (gnus-cite-reply-regexp, gnus-cite-always-check): + New variables. + +Wed Jan 15 02:02:03 1997 Lars Magne Ingebrigtsen + + * gnus-art.el (article-date-user): New command and keystroke. + +Wed Jan 15 02:01:15 1997 David Moore + + * gnus-art.el (gnus-article-time-format): New variable. + (article-make-date-line): Use it. + +Wed Jan 15 01:44:15 1997 Lars Magne Ingebrigtsen + + * gnus-art.el (gnus-emphasis-alist): Allow emphasis around + sentences. + (gnus-button-url-regexp): Don't allow empty URLs. + +Sun Jan 12 19:27:23 1997 Thor Kristoffersen + + * nntp.el (nntp-request-head): Work when using rlogin. + +Sun Jan 12 15:17:16 1997 Chris Bone + + * nntp.el (nntp-accept-process-output): Give numerical messages. + (nntp-wait-for): Search less. + +Fri Jan 10 17:38:38 1997 Erik Toubro Nielsen + + * gnus-art.el (gnus-Numeric-save-name): Doc fix. + +Thu Jan 9 21:51:59 1997 Dan Schmidt + + * nnmail.el (nnmail-move-inbox): Quote password. + +Thu Jan 9 18:24:32 1997 Lars Magne Ingebrigtsen + + * nnmail.el (nnmail-move-inbox): Don't nix out + nnmail-internal-password. + + * nnml.el (nnml-request-expire-articles): Also expire gzipped + articles. + + * gnus-art.el (article-emphasize): Wouldn't toggle. + +Thu Jan 9 18:18:26 1997 Lars Magne Ingebrigtsen + + * gnus.el: Red Gnus v0.80 is released. + +Thu Jan 9 12:00:21 1997 Wesley Hardaker + + * acronym.el: New package. + +Thu Jan 9 11:43:28 1997 Lars Magne Ingebrigtsen + + * gnus.el: Updated copyrights. + + * nnoo.el (nnoo-push-server): Only push the first server. + +Wed Jan 8 11:34:07 1997 David Moore + + * nnoo.el (nnoo-push-server): Revert to 0.77 behaviour. + + * nnvirtual.el (nnvirtual-info-installed): New variable. + (nnvirtual-open-server): Use it. + (nnvirtual-request-update-info): ditto. + (nnvirtual-create-mapping): ditto. + + * gnus-group.el (gnus-group-edit-group): Close the group before + editing it. + (gnus-group-add-to-virtual): ditto. + +Thu Jan 9 11:32:13 1997 Lars Magne Ingebrigtsen + + * gnus-art.el: Redefine ems. + +Wed Jan 8 20:34:09 1997 John McClary Prevost + + * message.el (message-sendmail-f-is-evil): New variable. + (message-elide-elipsis): Ditto. + +Wed Jan 8 17:19:02 1997 Paul Stodghill + + * gnus-demon.el (gnus-demon): Don't run when not idle. + +Wed Jan 8 12:58:23 1997 Lars Magne Ingebrigtsen + + * gnus-sum.el (gnus-summary-work-articles): Accept non-numerical + prefix values. + +Wed Jan 8 12:52:53 1997 Jason Rumney + + * nnmail.el (nnmail-move-inbox): Use `nnmail-internal-password'. + +Tue Jan 7 15:41:35 1997 Lars Magne Ingebrigtsen + + * gnus-art.el (gnus-article-show-hidden-text): Would bug out on + signatures. + +Mon Jan 6 23:46:53 1997 Lars Magne Ingebrigtsen + + * gnus.el: Red Gnus v0.79 is released. + +Mon Jan 6 11:23:05 1997 Lars Magne Ingebrigtsen + + * nnmail.el (nnmail-process-babyl-mail-format): Widen at the right + place. + + * nnfolder.el (nnfolder-possibly-change-group): Set current group + before reading folder. + + * message.el (message-send-mail-with-mh): Expand file name. + (message-mode-menu): Check whether mark-active exists. + + * gnus-group.el (gnus-group-get-new-news): Don't pass ARG to the + listing function. + + * gnus-xmas.el (gnus-xmas-article-show-hidden-text): Deleted. + +Sun Jan 5 21:35:37 1997 Sudish Joseph + + * gnus-xmas.el (gnus-xmas-article-show-hidden-text): Use + 'article-type as the textprop of interest. Speed fix. + + * gnus-art.el (gnus-article-show-hidden-text): Speed fix. + +Sun Jan 5 11:43:08 1997 Lars Magne Ingebrigtsen + + * nnml.el (nnml-retrieve-headers-with-nov): Use faster method for + finding the right range. + + * gnus-demon.el (gnus-demon): Would fire off even if not idle. + + * gnus-srvr.el (gnus-server-add-server): Error when defining an + existing server. + + * gnus-start.el (gnus-get-unread-articles): Update info for native + groups. + + * gnus-load.el (gnus-nocem): New file. + + * gnus-sum.el (gnus-get-newsgroup-headers-xover): Make sure the + group name isn't nil. + +Sun Jan 5 11:18:22 1997 Lars Magne Ingebrigtsen + + * gnus.el: Red Gnus v0.78 is released. + +Sun Jan 5 09:39:14 1997 Lars Magne Ingebrigtsen + + * gnus-sum.el (gnus-summary-exit-no-update): Prompt change. + (gnus-summary-limit-to-author): Ditto. + (gnus-summary-limit-to-subject): Ditto. + + * gnus-cite.el (gnus-dissect-cited-text): Recognize articles that + end with cited text. + + * gnus-topic.el (gnus-group-sort-topic): Remove nil elements. + + * nnoo.el (nnoo-push-server): When switching from the nil server, + update all the default values of the variables. + + * nnkiboze.el (nnkiboze-generate-group): Protect against nil + infos. + + * lpath.el: Included. + +Sun Jan 5 09:36:57 1997 Martin Buchholz + + * dgnushack.el (bytecomp): Required. + +Sat Jan 4 11:45:45 1997 Lars Magne Ingebrigtsen + + * gnus-art.el: Rename some functions back. + + * gnus-sum.el (gnus-summary-save-newsrc): Don't nix out scores. + + * gnus-async.el (gnus-async-prefetched-article-entry): Would + hang Emacs. + +Sat Jan 4 11:28:24 1997 Lars Magne Ingebrigtsen + + * gnus.el: Red Gnus v0.77 is released. + +Sat Jan 4 08:35:06 1997 Lars Magne Ingebrigtsen + + * gnus-cache.el (gnus-start): Don't require gnus-sum. + + * gnus-art.el: All article functions moved here. + + * article.el: Elided. + + * gnus-async.el (gnus-async-prefetched-article-entry): Check for + empty articles. + + * gnus-art.el (gnus-read-save-file-name): Expand file name in + article save dir. + +Fri Jan 3 21:22:21 1997 Paul Stodghill + + * gnus-demon.el (gnus-demon): Use `gnus-demon-idle-time'. + +Tue Dec 31 10:38:43 1996 + + * pop3.el: version 1.3 + + * pop3.el: (pop3-retr): added bill@attmail.com's big buffer sleeps + to save wear and tear on he heap. + +Thu Aug 01 11:53:48 1996 + + * pop3.el: version 1.2 + + * pop3.el: (pop3-apop): minor changes to support XEmacs built-in + md5, or William Perry's modified md5.el. + + * pop3.el: (pop3-movemail): changed to use + pop3-authentication-scheme instead of pop3-use-apop. + + * pop3.el: pop3-use-appop: transformed into + pop3-authentication-scheme. + + * pop3.el: version 1.1 + + * pop3.el: (pop3-apop): new function. Send alternate + authentication information to the server. Requires md5.el. + + * pop3.el: (pop3-open-server): set pop3-timestamp if server + returns one. + + * pop3.el: (pop3-movemail): use APOP authentication if + pop3-use-apop non-nil. + + * pop3.el: pop3-timestamp: added variable + + * pop3.el: pop3-use-apop: added variable + +Fri Jan 3 18:52:23 1997 Wesley Hardaker + + * gnus-group.el (gnus-group-get-new-news): Pass the ARG on to the + listing function. + +Fri Jan 3 18:32:24 1997 Lars Magne Ingebrigtsen + + * article.el (article-hide-boring-headers): Respect + gnus-show-all-headers. + + * gnus-sum.el (gnus-summary-save-article): Update the mode line. + +Fri Jan 3 18:30:50 1997 Erik Toubro Nielsen + + * nnmail.el (nnmail-remove-leading-whitespace): Replacing should + be non-literal. + +Fri Jan 3 18:18:30 1997 Lars Magne Ingebrigtsen + + * gnus-sum.el (gnus-summary-expire-articles-now): Use + "yes-or-no". + (gnus-summary-delete-article): Ditto. + +Fri Jan 3 18:16:27 1997 Peter Skov Knudsen + + * gnus-win.el (gnus-buffer-configuration): Don't create picons + frame unless needed. + +Fri Jan 3 17:21:30 1997 Lars Magne Ingebrigtsen + + * message.el (message-elide-region): New command and keystroke. + + * gnus-salt.el (gnus-generate-vertical-tree): Check whether we can + go backwards. + + * gnus-group.el (gnus-group-catchup-current): Prompt better. + + * gnus-undo.el (gnus-undo-make-menu-bar): Nonsense. + +Fri Jan 3 16:52:22 1997 Rajappa Iyer + + * gnus-salt.el (gnus-pick-start-reading): Possibly catch up all + unpicked articles. + +Fri Jan 3 12:12:22 1997 Lars Magne Ingebrigtsen + + * gnus-sum.el (gnus-get-newsgroup-headers-xover): Try to get the + few last headers using HEAD in any case to work around a bug in + inn. + + * gnus-xmas.el (gnus-xmas-define): Redefined. + + * gnus.el (gnus-characterp): Made into func. + +Thu Jan 2 16:21:47 1997 Sudish Joseph + + * gnus-util.el (gnus-characterp): New function. + +Wed Dec 18 18:15:39 1996 Jan Vroonhof + + * gnus-start.el (gnus-dribble-enter): Make sure we write at the + end of the dribble file + +Thu Jan 2 16:01:58 1997 Lars Magne Ingebrigtsen + + * gnus-sum.el (gnus-summary-limit-children): Make NoCeM'ed + articles read. + +Tue Dec 17 20:24:40 1996 Lars Magne Ingebrigtsen + + * gnus-sum.el (gnus-summary-save-newsrc): Respect the prefix. + +Mon Dec 16 23:47:30 1996 Lars Magne Ingebrigtsen + + * gnus.el: Red Gnus v0.76 is released. + +Mon Dec 16 14:33:58 1996 Lars Magne Ingebrigtsen + + * gnus-msg.el (gnus-bug): Insert nntp server type. + (gnus-copy-article-buffer): Remove prev/next buttons. + + * gnus-cache.el (gnus-jog-cache): Let the call func be + interactive. + + * gnus-art.el (gnus-summary-save-in-pipe): Include number of + articles. + (gnus-article-add-buttons): Don't add buttons to already + buttonized areas. + + * nntp.el (nntp-open-connection): Allow `C-g' to continue. + + * nnbabyl.el (nnbabyl-retrieve-headers): Wouldn't find all + articles sometimes. + + * gnus-sum.el (gnus-data-compute-positions): Reinstated. + (gnus-remove-thread): Do the right thing with dummy roots. + + * nndoc.el (nndoc-request-article): Only return valid articles. + + * nnfolder.el (nnfolder-delete-mail): Wouldn't delete From lines. + + * gnus-topic.el (gnus-topic-find-groups): Ignore nil groups. + + * nnfolder.el (nnfolder-save-mail): Quote all "From " lines. + +Sat Dec 14 11:49:21 1996 David Moore + + * gnus-nocem.el (gnus-nocem-groups): + news.admin.net-abuse.bulletins is to replace + news.admin.net-abuse.announce for nocemish postings. + +Mon Dec 16 13:38:38 1996 Lars Magne Ingebrigtsen + + * nnmail.el (nnmail-move-inbox): Message at end. + + * gnus-sum.el (gnus-summary-refer-parent-article): Use + "in-reply-to" header. + + * gnus-topic.el (gnus-topic-set-parameters): Enter into dribble. + + * gnus-sum.el (gnus-summary-save-newsrc): Change. + (gnus-summary-catchup): Only catch up the limited articles. + (gnus-simplify-subject-fuzzy-regexp): Changed to nil. + (gnus-simplify-buffer-fuzzy): Ignore nil + gnus-simplify-subject-fuzzy-regexp. + + * gnus-srvr.el (gnus-server-prepare): Don't insert servers twice. + +Thu Dec 12 18:18:11 1996 David Moore + + * gnus-start.el (gnus-setup-news): Use gnus-make-hashtable. + (gnus-update-active-hashtb-from-killed): ditto. + (gnus-newsrc-to-gnus-format): ditto. + + * gnus-bcklg.el (gnus-backlog-setup): ditto. + + * gnus-sum.el (gnus-create-xref-hashtb): ditto. + + * gnus-move.el (gnus-move-group-to-server): ditto. + + * gnus-util.el (gnus-create-hash-size): Power of 2 hashtables can + be _significantly_ faster than 2^x-1 tables on many risc + machines. Any gains of 2^x-1 are comparably small on other + machines. + +Fri Dec 13 05:05:03 1996 Lars Magne Ingebrigtsen + + * gnus.el: Red Gnus v0.75 is released. + +Fri Dec 13 04:49:21 1996 Andre Deparade + + * gnus-cite.el (gnus-cited-text-button-line-format-alist): Make %b + and %e usable. + +Fri Dec 13 01:06:09 1996 Lars Magne Ingebrigtsen + + * article.el (article-decode-rfc1522): Would collate subsequent + encodings. + + * gnus-start.el (gnus-check-bogus-newsgroups): Use + `map-y-or-n-p'. + + * gnus-topic.el (gnus-topic-kill-group): Save topic contents. + (gnus-topic-yank-group): Insert topic contents. + + * gnus-sum.el (gnus-simplify-subject-fuzzy-regexp): Changed + default to "". + + * gnus-score.el (gnus-score-find-favourite-words): Put point at bob. + + * gnus-sum.el (gnus-summary-limit-to-age): Dox fix & interactive + spec. + +Fri Dec 13 01:01:46 1996 David Moore + + * gnus-sum.el (gnus-summary-limit-to-age): New function and + keystroke. + +Tue Dec 10 23:42:00 1996 David Moore + + * gnus-nocem.el (gnus-nocem-groups): news.lists.filters is to + replace alt.nocem.misc + +Wed Dec 11 01:15:31 1996 Lars Magne Ingebrigtsen + + * nnfolder.el (nnfolder-request-expire-articles): Better message. + (nnfolder-delete-mail): Actually delete. + + * gnus-sum.el (gnus-summary-update-info): Don't run + `gnus-exit-group-hook'. + (gnus-summary-expire-articles): Do it. + (gnus-summary-exit): Ditto. + (gnus-summary-save-newsrc): New command and keystroke. + +Wed Dec 11 00:38:12 1996 Stainless Steel Rat + + * gnus-sum.el (gnus-simplify-buffer-fuzzy): New version. + +Mon Dec 9 21:00:09 1996 David Moore + + * gnus-sum.el (gnus-summary-catchup): Out dated catchup code + removed. + + * nnvirtual.el (nnvirtual-update-read-and-marked): Work around a + cache of active count in gnus-update-read-articles. + +Mon Dec 9 22:55:56 1996 Lars Magne Ingebrigtsen + + * article.el (article-emphasize): Use it. + + * gnus-util.el (gnus-put-text-property-excluding-newlines): New + function. + +Mon Dec 9 08:38:08 1996 Per Abrahamsen + + * gnus-sum.el: Split customize groups and added links to the manual. + +1996-12-08 Dave Love + + * gnus-vis.el (gnus-button-alist): Allow whitespace in ` match. + +Mon Dec 9 02:18:35 1996 Lars Magne Ingebrigtsen + + * gnus-art.el (gnus-button-embedded-url): New function. + (gnus-button-alist): Use it. + + * gnus-util.el (gnus-strip-whitespace): New function. + +Mon Dec 9 00:04:24 1996 Richard Stallman + + * gnus-start.el (gnus-read-init-file): Don't read init file when + started with "emacs -q". + +Sun Dec 8 18:25:34 1996 Lars Magne Ingebrigtsen + + * gnus.el: Red Gnus v0.74 is released. + +Fri Dec 6 12:47:24 1996 Wes Hardaker + + * gnus-picon.el (gnus-picons-insert-face-if-exists): Don't reverse + domains. + +Fri Dec 6 11:33:44 1996 Lars Magne Ingebrigtsen + + * nnfolder.el (nnfolder-request-article): Use it. + (nnfolder-retrieve-headers): Wouldn't find the right header. + + * nnmail.el (nnmail-search-unix-mail-delim-backward): New function. + +Thu Dec 5 21:51:03 1996 Lars Magne Ingebrigtsen + + * gnus.el (gnus-server-add-address): Don't add "*-address" to all + servers. + +Thu Dec 5 21:01:22 1996 Lars Magne Ingebrigtsen + + * gnus.el: Red Gnus v0.73 is released. + +Thu Dec 5 19:29:50 1996 Lars Magne Ingebrigtsen + + * gnus-sum.el (gnus-get-newsgroup-headers-xover): Message the line + number. + + * nnml.el (nnml-request-scan): Change server. + +Sat Nov 30 00:42:39 1996 Steven L Baur + + * earcon.el: Added Customization. + +Thu Dec 5 11:24:15 1996 Lars Magne Ingebrigtsen + + * gnus-sum.el (gnus-summary-prepare-threads): Don't output + articles outside the limit. + + * gnus-group.el (gnus-group-level): New function. + (gnus-group-list-active): Faster implementation. + (gnus-group-list-all-matching): Accept a `C-u' prefix. + + * message.el (message-news): Make sure newsey things are done. + + * gnus-kill.el (gnus-execute-1): Eval forms properly. + + * gnus-score.el (gnus-score-find-bnews): Treat "+" like ordinary + characters. + + * gnus-sum.el (gnus-summary-make-menu-bar): Update. + + * nndoc.el (nndoc-forward-type-p): Don't give false positives. + + * message.el (message-user-mail-address): Bypass mail-extr. + (message-make-forward-subject): Only fetch the first Subject. + + * gnus-art.el (gnus-button-alist): Reconize news:group urls. + + * gnus-start.el (gnus-group-change-level): Didn't quote strings + entered into dribble. + + * gnus-util.el (gnus-prin1-to-string): Use print-quoted- + + * nnbabyl.el (nnbabyl-request-article): Wouldn't find first + article properly. + (nnbabyl-delete-mail): Ditto. + +Thu Dec 5 06:16:25 1996 Per Abrahamsen + + * nnmail.el (nnmail-split-history): Use + `with-output-to-temp-buffer'. + +Thu Dec 5 08:46:26 1996 Shuhei KOBAYASHI + + * gnus-sum.el (gnus-nov-parse-line): unwind-protect the + narrowing. + +Tue Dec 3 14:06:17 1996 Lars Magne Ingebrigtsen + + * nnheader.el (nnheader-find-file-noselect): Disable local + variables. + + * gnus-group.el (gnus-group-fetch-faq): Ditto. + +Mon Dec 2 17:12:26 1996 Ralph Schleicher + + * gnus-demon.el (gnus-demon-time-to-step): Make it work. + +Sun Dec 1 07:35:32 1996 Lars Magne Ingebrigtsen + + * nntp.el (nntp-retrieve-articles): New function. + (nntp-next-result-arrived-p): New function. + +Sat Nov 30 13:50:15 1996 Lars Magne Ingebrigtsen + + * nnfolder.el (nnfolder-retrieve-headers): Parse unix mboxes better. + (nnfolder-request-article): Ditto. + + * message.el (message-rename-buffer): Make sure the renamed buffer + is valid. + +Sat Nov 30 12:06:47 1996 Lars Magne Ingebrigtsen + + * gnus-cache.el (gnus-cache-enter-article): Warn when trying to + cache negative articles. + +Sat Nov 30 08:53:48 1996 Lars Magne Ingebrigtsen + + * gnus.el: Red Gnus v0.72 is released. + +1996-11-30 Markus Linnala + + * gnus-sum.el (gnus-summary-refer-parent-article): Work when there + are no references. + +1996-11-30 Lars Magne Ingebrigtsen + + * message.el (message-fetch-field): Fetch all headers. + + * gnus-sum.el (gnus-cut-thread): Would cut off the wrong + children. + + * gnus-score.el (gnus-all-score-files): Take an optional group + param. + + * gnus-start.el (gnus-dribble-touch): New function. + (gnus-master-read-slave-newsrc): Use it. + + * gnus-salt.el (gnus-generate-vertical-tree): Would bug out on + sparse articles. + + * gnus-sum.el (gnus-summary-search-article): Would infloop. + + * gnus-nocem.el: Ignore invalid entries. + + * gnus-sum.el (gnus-data-remove): Wouldn't update properly when + treating the first article in the buffer. + (gnus-rebuild-thread): Would compute the wrong offset. + (gnus-summary-move-article): Don't mark as read. + +1996-11-28 Lars Magne Ingebrigtsen + + * gnus-sum.el (gnus-thread-loop-p): New function. + (gnus-make-threads): Avoid inflooped references. + + * gnus-start.el (gnus-gnus-to-quick-newsrc-format): Bind + print-length to nil. + +Wed Nov 27 02:41:31 1996 Lars Magne Ingebrigtsen + + * nnmail.el (nnmail-process-babyl-mail-format): Goto-char placed + wrongly. + + * gnus-group.el (gnus-group-select-group-emphemerally): New + command and keystroke. + + * gnus-sum.el (gnus-read-header): Fold continuation lines. + +Tue Nov 26 18:43:29 1996 Lars Magne Ingebrigtsen + + * gnus-sum.el (gnus-summary-update-info): Don't change buffer. + +Tue Nov 26 17:56:19 1996 Hrvoje Niksic + + * gnus-sum.el (gnus-summary-print-article): Prompt for file name. + +Tue Nov 26 17:08:07 1996 Lars Magne Ingebrigtsen + + * article.el (article-date-ut): Use original date. + +Tue Nov 26 08:36:38 1996 Wes Hardaker + + * gnus-picon.el: Customize. + + * smiley.el: Customize. Change artist's email address in comments. + +Tue Nov 26 04:37:54 1996 Lars Magne Ingebrigtsen + + * gnus.el: Red Gnus v0.71 is released. + +Tue Nov 26 00:58:25 1996 Lars Magne Ingebrigtsen + + * gnus-sum.el (gnus-get-split-value): Expand file names in save + dir. + +Mon Nov 25 22:50:19 1996 Jens Lautenbacher + + * gnus-group.el (gnus-group-make-menu-bar): Moved customize. + +Mon Nov 25 15:27:41 1996 Per Abrahamsen + + * gnus.el (custom-facep): Removed. + + * gnus-topic.el (gnus-topic-line-format): Added customize + support. + + * gnus.el (gnus-article-display-hook): Moved + `gnus-article-treat-overstrike' last. + +Mon Nov 25 11:21:15 1996 Wes Hardaker + + * gnus-picon.el: (gnus-picons-try-to-find-face): New param: rightp. + (gnus-picons-insert-face-if-exists): Use it and own new param. + More properly detect location of bar and dots. + (gnus-group-display-picons): Use above. + (gnus-article-display-picons): ditto. + +Mon Nov 25 04:17:03 1996 Lars Magne Ingebrigtsen + + * nnfolder.el (nnfolder-read-folder): Make buffer read/write. + + * gnus-sum.el (gnus-summary-print-article): Delete invisible text + first. + + * article.el (article-delete-invisible-text): New function. + + * nntp.el (nntp-possibly-change-group): Would abort async + fetches. + + * gnus-sum.el (gnus-summary-print-article): New command and + keystroke. + (gnus-summary-move-article): Select the article first. + + * message.el (message-user-agent): Define the message mail user + agent. + +Sun Nov 24 02:28:56 1996 Lars Magne Ingebrigtsen + + * nntp.el (nntp-possibly-change-group): Would get confused. + + * gnus-art.el (gnus-button-url-regexp): Allow all word-constituent + characters to be part of urls. + + * nntp.el (nntp-possibly-change-group): Wait until the status line + arrives and delete it. + +Sun Nov 24 01:36:45 1996 Lars Magne Ingebrigtsen + + * gnus.el: Red Gnus v0.70 is released. + +Sat Nov 23 23:22:27 1996 Per Abrahamsen + + * message.el (message-mode-menu): Added `message-caesar-region'. + (message-mode-field-menu): Added `message-insert-to' and + `message-insert-newsgroups'. + +Sat Nov 23 19:53:30 1996 Lars Magne Ingebrigtsen + + * nnkiboze.el: Would destroy all component group infos. + + * gnus-xmas.el (gnus-summary-mail-toolbar): Reversed cathup. + + * gnus-sum.el (gnus-summary-article-unread-p): New function. + (gnus-remove-thread-1): Avoid `text-propery-any'. + (gnus-summary-insert-subject): Ditto. + (gnus-data-compute-positions): Removed. + + * gnus-dup.el (gnus-dup-suppress-articles): Didn't do anything. + + * gnus-group.el (gnus-group-restart): Just start up Gnus + properly. + +Sat Nov 23 07:16:39 1996 Lars Magne Ingebrigtsen + + * gnus.el: Red Gnus v0.69 is released. + +Sat Nov 23 05:00:36 1996 Lars Magne Ingebrigtsen + + * gnus-cache.el (gnus-cache-update-active): Wouldn't mark the + cache active file as changed. + + * gnus-start.el (gnus-setup-news): Slaves shouldn't check for new + newsgroups. + + * gnus-sum.el (gnus-group-make-articles-read): Update group line + on undo. + + * gnus-move.el (gnus-move-group-to-server): Check whether + to-active is nil. + + * gnus-score.el (gnus-score-find-hierarchical): Do the right thing + for prefixed group names. + + * nnml.el (nnml-generate-nov-databases-1): Don't infloop. + +Sat Nov 23 04:58:49 1996 Steven L. Baur + + * gnus-score.el (gnus-score-score-files-1): Don't infloop. + +Sat Nov 23 04:40:55 1996 Lars Magne Ingebrigtsen + + * gnus-art.el (gnus-article-make-menu-bar): Protect against + undefined menu vars. + + * gnus-group.el (gnus-group-rename-group): Prompt fix. + +Fri Nov 22 12:17:14 1996 David Moore + + * nnml.el (nnml-generate-nov-databases-1): Don't infloop. + + * gnus-score.el (gnus-score-score-files-1): Don't infloop, be + slightly faster. + +Fri Nov 22 22:18:52 1996 Lars Magne Ingebrigtsen + + * gnus-move.el (gnus-move-group-to-server): Looking-at bug. + (gnus-move-group-to-server): Extend. + + * message.el (message-check-news-header-syntax): Change shoot-me + line. + +Thu Nov 21 18:31:56 1996 David Moore + + * gnus-util.el (gnus-atomic-progn, gnus-atomic-progn-assign, + gnus-atomic-setq): Routines to help protect against corruption to + internal Gnus datastructures from C-g or error signals. + + * gnus-util.el (gnus-atomic-be-safe): Variable which can set to + nil to disable the C-g atomic protection. + + * nnvirtual.el (nnvirtual-update-read-and-marked): Replaces + nnvirtual-update-reads and nnvirtual-update-marked. Does updates + to component groups atomically. + (nnvirtual-request-update-info): Update the virtual group + atomically. + +Fri Nov 22 00:19:23 1996 Lars Magne Ingebrigtsen + + * gnus.el: Create menu bar even when not using menu-bar-mode. + + * gnus-start.el (gnus-1): Don't paint picture gnu twice. + + * gnus-sum.el (gnus-group-make-articles-read): Undo in the right + buffer. + (gnus-update-read-articles): Ditto. + +Fri Nov 22 00:04:59 1996 Raja R. Harinath + + * nnheader.el (nnheader-generate-fake-message-id): Interact better + with duplicate suppression. + +Thu Nov 21 23:31:30 1996 Lars Magne Ingebrigtsen + + * gnus.el (gnus-info-set-entry): Wouldn't extend far enough. + + * gnus-salt.el (gnus-tree-minimize): Ignore errors. + + * gnus-sum.el (gnus-summary-article-sparse-p): New macro. + (gnus-summary-article-ancient-p): Ditto. + (gnus-summary-search-article): Skip sparse articles. + + * article.el (article-date-ut): Wouldn't pick out the date right. + +Thu Nov 21 23:07:34 1996 Raja R. Harinath + + * gnus-dup.el (gnus-dup-enter-articles): Ignore sparse articles. + +Thu Nov 21 21:57:52 1996 Lars Magne Ingebrigtsen + + * gnus-dup.el (gnus-dup-suppress-articles): Only suppress read + articles. + + * article.el (article-delete-text-of-type): Would bug out. + +Thu Nov 21 11:02:36 1996 David Moore + + * nnoo.el (nnoo-change-server): Only preserve un-ooed variables if + they exist globally. + +Thu Nov 21 10:52:39 1996 Steven L Baur + + * article.el (article-date-ut): Extend date header recognition to + deal with systems that put a TAB after the colon. + +Thu Nov 21 19:50:26 1996 Lars Magne Ingebrigtsen + + * gnus.el: Red Gnus v0.68 is released. + +Thu Nov 21 05:33:24 1996 Lars Magne Ingebrigtsen + + * nnoo.el (nnoo-change-server): Protect against void vars. + +Thu Nov 21 00:00:29 1996 Lars Magne Ingebrigtsen + + * gnus.el: Red Gnus v0.67 is released. + +Wed Nov 20 22:54:34 1996 Lars Magne Ingebrigtsen + + * message.el (message-mode-field-menu): Separated. + + * nnoo.el (nnoo-change-server): Preserve un-ooed variables as + well. + + * nnbabyl.el (nnbabyl-read-mbox): Understand movemailed babyl + files. + +Wed Nov 20 19:25:40 1996 Kurt Swanson + + * gnus-art.el (gnus-article-make-menu-bar): Fix menu bar. + +Wed Nov 20 05:27:45 1996 Lars Magne Ingebrigtsen + + * gnus-sum.el (gnus-article-sort-by-lines, + gnus-thread-sort-by-lines): New functions. + (gnus-summary-sort-by-lines): New command and keystroke. + + * gnus.el (gnus-other-frame): Be a bit more clever. + + * gnus-group.el (gnus-group-get-new-news): Check for new + newsgroups. + + * nnheader.el (nnheader-insert-file-contents-literally): Bind + `default-major-mode' to nil. + + * gnus-sum.el (gnus-group-make-articles-read): Yet another undo + bug. + + * nnmail.el (nnmail-article-group): Wrong `junk' check. + +Wed Nov 20 05:13:05 1996 Lars Magne Ingebrigtsen + + * gnus.el: Red Gnus v0.66 is released. + +Wed Nov 20 01:57:31 1996 Lars Magne Ingebrigtsen + + * nnmail.el (nnmail-article-group): Would lose mail when using + advanced splitting! + + * gnus-sum.el (gnus-update-read-articles): Undo fix. + +Tue Nov 19 22:56:56 1996 Lars Magne Ingebrigtsen + + * nnheader.el (nnheader-auto-mode-alist): New function. + +Tue Nov 19 21:57:29 1996 Lars Magne Ingebrigtsen + + * gnus.el: Red Gnus v0.65 is released. + +Tue Nov 19 17:41:17 1996 Lars Magne Ingebrigtsen + + * message.el (message-do-fcc): Supply FROM-GNUS param to + rmail-output. + + * gnus-msg.el (gnus-setup-message): Use the buffer name instead of + the buffer. + + * nnmail.el (nnmail-article-group): Respect `junk' advanced + splits. + + * gnus-group.el (gnus-group-restart): Clear system. + + * nnfolder.el (nnfolder-read-folder): Handle zipped files. + + * nnheader.el (nnheader-find-file-noselect): New definition. + + * gnus-art.el (gnus-article-make-menu-bar): Use the menu bar. + + * gnus-score.el (gnus-all-score-files): Would still get the score + files in wrong order. + + * gnus-start.el (gnus-find-new-newsgroups): End message on wrong + level. + + * gnus-srvr.el (gnus-server-prepare): Don't list servers twice. + + * gnus-xmas.el (gnus-xmas-read-event-char): Mystery hanging bug. + + * gnus-score.el (gnus-all-score-files): Expand all files in the + kill files directory. + + * gnus-sum.el (gnus-group-make-articles-read): Register with undo + properly. + (gnus-update-read-articles): Ditto. + + * gnus-msg.el (gnus-debug): Include gnus-async in variables. + +Tue Nov 19 00:07:14 1996 Lars Magne Ingebrigtsen + + * gnus.el: Red Gnus v0.64 is released. + +Mon Nov 18 21:42:40 1996 Loren Schall + + * gnus-sum.el (gnus-summary-insert-line): Pick apart the From + header in reversed order. + +Mon Nov 18 02:00:33 1996 Lars Magne Ingebrigtsen + + * gnus-sum.el (gnus-summary-refer-references): Protect against nil + References. + + * gnus-score.el (gnus-all-score-files): Remove duplicate score + files from the end first. + + * gnus-start.el (gnus-after-getting-new-news-hook, + gnus-get-new-news-hook): Switched defaults. + + * gnus-score.el (gnus-all-score-files): Returned score files in + reverse order. + + * gnus-util.el (gnus-make-directory): Protect against nil dirs. + + * gnus-art.el (gnus-decode-encoded-word-method): Default to + 'gnus-article-de-quoted-unreadable. + + * gnus.el (gnus-read-group): Prohibit : in group name. + (gnus-article-display-hook): Removed + `gnus-article-de-quoted-unreadable'. + + * article.el (gnus-emphasis-alist): Accept "-" as word marker. + + * messagexmas.el (message-xmas-dont-activate-region): Changed + default to t. + +Sun Nov 17 01:09:21 1996 Per Abrahamsen + + * message.el: Added customize support. + +Sun Nov 17 23:42:03 1996 Raja R. Harinath + + * gnus-gl.el (bbb-extract-token-number): Fix. + +Sun Nov 17 12:18:27 1996 Lars Magne Ingebrigtsen + + * gnus-sum.el (gnus-summary-next-article): Use it. + (gnus-group-make-articles-read): Quote undo forms. + (gnus-update-read-articles): Ditto. + + * gnus.el (gnus-key-press-event-p): New alias. + +Sat Nov 16 22:05:24 1996 Steven L Baur + + * gnus-sum.el (gnus-summary-next-article): XEmacs doesn't use + integers for keyboard events. + +Sun Nov 17 12:09:44 1996 Lars Magne Ingebrigtsen + + * gnus-group.el (gnus-group-set-timestamp): Protect against nil + gnus-newsgroup-name. + +Sun Nov 17 01:09:21 1996 Per Abrahamsen + + * nnmail.el: Added customize support. + +Sat Nov 16 22:59:47 1996 Lars Magne Ingebrigtsen + + * gnus.el (gnus-summary-line-format): Dox fix. + + * nnfolder.el (nnfolder-save-mail): Would insert extra newline at + the start. + +Sat Nov 16 19:43:22 1996 Lars Magne Ingebrigtsen + + * gnus.el: Red Gnus v0.63 is released. + +Sat Nov 16 11:32:43 1996 Lars Magne Ingebrigtsen + + * gnus-sum.el (gnus-summary-next-article): Ignore non-keyboard + events before starting to walk. + + * gnus-topic.el (gnus-topic-prepare-topic): Insert topics that + have 0 unread if there is anything under. + + * gnus-sum.el (gnus-summary-move-article): Do `B B' properly. + + * gnus-topic.el (gnus-topic-parameters): Return nil on + non-existant topics. + + * nntp.el (nntp-possibly-change-group): Would nix out async buffer + when switching groups. + + * gnus-sum.el (gnus-summary-expire-articles): Update info before + expiring. + + * article.el (article-strip-leading-blank-lines): Would strip too + much. + + * gnus-sum.el (gnus-summary-mode): Update specs after running + hook. + + * gnus-util.el (gnus-boundp): New function. + + * gnus-start.el (gnus-get-new-news-hook): Default to updating + display-time, if present. + +Fri Nov 15 13:59:16 1996 Steven L Baur + + * gnus-xmas.el (gnus-xmas-define): Better fix for dealing with + scroll-in-place, which will be preloaded in XEmacs 19.15. + + * gnus-art.el (gnus-article-prev-page): Guard scroll-(up|down) + against scroll-in-place package. + (gnus-article-next-page): Ditto. + + * gnus-salt.el (gnus-pick-next-page): Ditto. + +Fri Nov 15 21:40:12 1996 Lars Magne Ingebrigtsen + + * nnweb.el (gnus): Required. + + * gnus-group.el (gnus-group-clear-data-on-native-groups): Offer to + move cache. + + * gnus-cache.el (gnus-cache-move-cache): New command. + + * nnvirtual.el (nnvirtual-create-mapping): Handle groups with no + articles. + + * gnus-group.el (gnus-group-insert-group-line-info): Compute the + right number for dead groups. + + * nnvirtual.el: Complete-first-sentence-in-first-line-of-doc fix. + +Thu Nov 14 10:20:44 1996 Per Abrahamsen + + * gnus-win.el: Added customize support. + + * gnus-uu.el: Added customize support. + +Thu Nov 14 17:50:12 1996 Lars Magne Ingebrigtsen + + * gnus.el: Red Gnus v0.62 is released. + +Thu Nov 14 12:25:23 1996 Lars Magne Ingebrigtsen + + * gnus.el (gnus-article-display-hook): Add + `gnus-article-de-quoted-unreadable' to default value. + + * gnus-art.el (gnus-summary-article-menu): Dummy define. + + * article.el (custom): Require first. + + * dgnushack.el (require): New implementation. + + * article.el (gnus-emphasis-alist): Recognize emphasis inside + quotes. + +Thu Nov 14 10:20:44 1996 Per Abrahamsen + + * nnmail.el (nnmail-split-abbrev-alist): Added `uucp' to `mail'. + +Thu Nov 14 11:25:51 1996 Samuel Tardieu + + * nnmail.el (nnmail-search-unix-mail-delim): Skip past ">From " + after "From ". + +Thu Nov 14 10:08:27 1996 Raja R. Harinath + + * gnus-gl.el (bbb-connect-to-bbbd): Only connect if we have the + token. + +Thu Nov 14 08:46:31 1996 Lars Magne Ingebrigtsen + + * message.el (message-insert-to): Deny with "never" + courtesy-copies-to header. + + * dgnushack.el (require): Try both the uncompiled and the compiled + versions. + + * nntp.el (nntp-send-authinfo): Hide password. + +Wed Nov 13 12:00:43 1996 David Moore + + * gnus-start.el (gnus-parse-active): Correct range parsing + restored. + +Tue Nov 12 14:09:15 1996 David Moore + + * gnus-nocem.el (gnus-nocem-enter-article): Don't store the same + message id in the cache twice. + (gnus-nocem-liberal-fetch): + + * gnus-nocem.el (gnus-nocem-liberal-fetch): New Variable. + + * gnus-nocem.el (gnus-nocem-check-article, + gnus-nocem-scan-groups): Don't re-fetch a crossposted @@NCM + posting that we've alread verified and scanned. + +Wed Nov 13 23:38:00 1996 Lars Magne Ingebrigtsen + + * gnus-start.el (gnus-parse-active): Gave wrong results. + + * gnus-win.el (gnus-buffer-configuration): Doc fix. + +Wed Nov 13 13:52:20 1996 Per Abrahamsen + + * gnus-topic.el: Added customize support. + + * gnus-group.el (gnus-group-mode-hook): Added `gnus-topic-mode' + option. + + * gnus-util.el (gnus-verbose): Made customizable. + + * gnus.el (gnus-summary-line-format): Customize. + + * gnus-sum.el (gnus-summary-respool-default-method): Customize. + + * gnus.el (gnus-select-method-name): New widget. + (gnus-select-method): Use it. + +Wed Nov 13 14:19:48 1996 Lars Magne Ingebrigtsen + + * gnus-group.el (gnus-info-clear-data): Quote lists. + + * nntp.el (nntp-send-authinfo): Prompt right. + +Tue Nov 12 19:33:00 1996 Lars Magne Ingebrigtsen + + * gnus.el: Red Gnus v0.61 is released. + +Tue Nov 12 17:55:17 1996 Lars Magne Ingebrigtsen + + * nnmail.el (nnmail-move-inbox): Delete empty crash box. + + * gnus-art.el (gnus-article-make-menu-bar): Define summary article + map. + + * gnus-group.el (gnus-group-set-timestamp): Removed reference to + free variable `group'. + +Mon Nov 11 16:29:00 1996 David Moore + + * gnus-group.el (gnus-group-timestamp-delta): New function. + + * gnus-demon.el (gnus-demon-add-scan-timestamps, + gnus-demon-scan-timestamps): New functions. + +Mon Nov 11 05:27:20 1996 Lars Magne Ingebrigtsen + + * article.el (gnus-emphasis-alist): Added ":" as sentence-end. + +Mon Nov 11 05:14:02 1996 David Moore + + * nnvirtual.el: New version. + +Mon Nov 11 05:09:14 1996 Lars Magne Ingebrigtsen + + * article.el (gnus-emphasis-underline-bold): Renamed. + +Mon Nov 11 05:05:09 1996 Alexandre Oliva + + * nntp.el (nntp-possibly-change-group): Bind + `nnheader-callback-function' to nil. + +Sun Nov 10 12:13:08 1996 Lars Magne Ingebrigtsen + + * gnus-start.el (gnus-parse-active): Give correct answer. + + * nntp.el (nntp-snarf-error-message): Massage the message. + +Sun Nov 10 11:49:33 1996 Joe Wells + + * dgnushack.el (require): Load .el files only. + +Sun Nov 10 10:06:12 1996 Lars Magne Ingebrigtsen + + * gnus-move.el (gnus-move-group-to-server): Would pass wrong + params to `gnus-retrieve-headers'. + + * nntp.el (nntp-wait-for): Accept a `discard' param. + (nntp-open-connection): Would mix it up when establishing asynch + connections. + + * nnml.el (nnml-find-id): Would report false positives. + + * gnus-spec.el (gnus-update-format-specifications): Do all + computations in the right buffer. + + * nnweb.el (nnweb-type-definition): Moved search engine. + (nnweb-fetch-form): Use "POST" instead of `POST'. + + * gnus-undo.el (gnus-undo-register): Entered malformed undo + statements. + + * smiley.el (smiley-nosey-regexp-alist): Add a devilish face. + +Sun Nov 10 06:38:38 1996 Lars Magne Ingebrigtsen + + * gnus.el: Red Gnus v0.60 is released. + +Sun Nov 10 06:31:36 1996 Lars Magne Ingebrigtsen + + * gnus.el: Red Gnus v0.59 is released. + +Sun Nov 10 06:09:37 1996 Lars Magne Ingebrigtsen + + * nntp.el (nntp-decode-text): Erased everything. + + * article.el (article-remove-trailing-blank-lines): Would + infloop. + +Sun Nov 10 06:06:31 1996 Lars Magne Ingebrigtsen + + * gnus.el: Red Gnus v0.58 is released. + +Sun Nov 10 06:02:51 1996 Alexandre Oliva + + * nntp.el (nntp-possibly-change-group): Bind callback function to + nil. + +Sun Nov 10 05:35:25 1996 Lars Magne Ingebrigtsen + + * gnus-topic.el (gnus-topic-remove-topic): Remove from alist. + + * gnus-score.el (gnus-score-string): Didn't trace fuzzies and + words. + +Sat Nov 9 18:14:42 1996 Lars Magne Ingebrigtsen + + * nnweb.el (nnweb-set-hashtb): Typo. + (nnweb-read-overview): Typo. + + * nnheader.el (nnheader-skeleton-replace): New macro. + (nnheader-replace-string): Use it. + (nnheader-replace-regexp): Use it. + (nnheader-strip-cr): Use it. + + * nntp.el (nntp-retrieve-headers): Be faster. + (nntp-decode-text): Use faster algorithm. + + * nnheader.el (nnheader-replace-string): New function. + +Sat Nov 9 17:22:16 1996 Hrvoje Niksic + + * article.el (gnus-emphasis-alist): Doc fix. + +Sat Nov 9 16:27:27 1996 Per Abrahamsen + + * nnmail.el (nnmail-split-it): Fix bug in abbrev handling. + +Sat Nov 9 05:59:02 1996 Lars Magne Ingebrigtsen + + * nnweb.el (nnweb-set-hashtb): Typo. + + * article.el (gnus-emphasis-alist): One ' too many. + + * gnus-async.el (gnus-async-prefetch-article): Only message when + in the summary buffer. + + * gnus-msg.el (gnus-post-news): Handle `newsgroup' param. + (gnus-debug): Be `defcustom' aware. + +Sat Nov 9 05:41:27 1996 Lars Magne Ingebrigtsen + + * gnus.el: Red Gnus v0.57 is released. + +Fri Nov 8 22:56:59 1996 Per Abrahamsen + + * gnus.el: Added customize support. + +Sat Nov 9 05:14:58 1996 David Moore + + * nnmail.el (nnmail-expand-newtext): New version. + +Sat Nov 9 04:28:42 1996 Lars Magne Ingebrigtsen + + * gnus-xmas.el (gnus-xmas-force-redisplay): New variable. + (gnus-xmas-summary-recenter): Use it. + + * gnus-art.el (gnus-button-url): Removed seconds param since old + versions of `browse-url.el' don't support it. + (gnus-article-make-menu-bar): Add article menu to article menu. + + * article.el (gnus-emphasis-alist): Use ")" as a sentence end + marker. + +Fri Nov 8 05:33:08 1996 Lars Magne Ingebrigtsen + + * article.el (gnus-emphasis-alist): Recognize "_this_here_". + + * gnus-art.el (gnus-article-save): Save the right buffer after + stripping headers. + + * nntp.el (nntp-wait-for): Nix out "nntp reading...." message. + + * article.el (article-narrow-to-signature): Typo. + + * nntp.el (nntp-try-list-active): Would guess wrong on `some'. + + * gnus.el: condition-case -> ignore-errors. + + * nntp.el (nntp-request-close): Protect against errors. + +Fri Nov 8 03:23:02 1996 Lars Magne Ingebrigtsen + + * gnus.el: Red Gnus v0.56 is released. + +Fri Nov 8 02:45:21 1996 David S. Goldberg + + * gnus-art.el (gnus-button-url): Respect + `browse-url-new-window-p'. + +Fri Nov 8 02:34:31 1996 Lars Magne Ingebrigtsen + + * nnmail.el (nnmail-process-unix-mail-format): Fold searches. + +Thu Nov 7 09:07:32 1996 Steven L Baur + + * nnmail.el (nnmail-search-unix-mail-delim): Take better care in + ignoring bogus From_ lines. + +Fri Nov 8 02:01:06 1996 Lars Magne Ingebrigtsen + + * nnmail.el (nnmail-move-inbox): Cleaned up code. + + * gnus-int.el (gnus-request-regenerate): New function. + + * nnml.el (nnml-request-regenerate): New function. + + * gnus-srvr.el (gnus-server-regenerate-server): New command and + keystroke. + +Thu Nov 7 16:12:30 1996 Per Abrahamsen + + * gnus-start.el: Added customize support. + +Fri Nov 8 01:47:16 1996 David S. Goldberg + + * gnus-win.el (gnus-delete-windows-in-gnusey-frames): Would bug + out on nil variables. + +Fri Nov 8 01:45:06 1996 Kurt Swanson + + * gnus-sum.el (gnus-handle-ephemeral-exit): Go to the next + article. + +Thu Nov 7 16:12:30 1996 Per Abrahamsen + + * article.el (gnus-visible-headers): Convert string to list of + strings. + +Fri Nov 8 01:40:38 1996 Kurt Swanson + + * gnus-sum.el (gnus-summary-first-article): New function. + + * gnus-salt.el (gnus-pick-start-reading): Use it. + +Thu Nov 7 09:42:17 1996 Lars Magne Ingebrigtsen + + * gnus-group.el (gnus-group-catchup): Better message. + + * gnus-util.el (gnus-date-get-time): Protect against "" Dates. + + * article.el (article-strip-leading-blank-lines): Would infloop. + + * gnus-msg.el (gnus-debug): Protect against odd load-paths. + +Fri Nov 8 05:30:51 1996 Lars Magne Ingebrigtsen + + * gnus-sum.el (gnus-get-newsgroup-headers): `ref' should never be + nil. + + * gnus-msg.el (gnus-summary-followup-to-mail, + gnus-summary-followup-to-mail-with-original): New commands. + + * nnmail.el (nnmail-split-it): Use `replace-match'. + +Fri Nov 8 05:30:46 1996 David Moore + + * nnmail.el (nnmail-split-it): New version. + +Fri Nov 8 03:44:10 1996 Lars Magne Ingebrigtsen + + * gnus.el (gnus-article-display-hook): Customized. + + * article.el (gnus-emphasis-alist): Define more combinations. + (gnus-emphasis-underline-bold-italic): New face. + +Fri Nov 8 00:20:29 1996 Lars Magne Ingebrigtsen + + * gnus.el: Red Gnus v0.55 is released. + +Thu Nov 7 00:14:45 1996 Lars Magne Ingebrigtsen + + * gnus-win.el (gnus-delete-windows-in-gnusey-frames): New function. + (gnus-configure-windows): Use it. + + * nntp.el (nntp-possibly-change-group): Erased wrong buffer. + + * gnus-score.el (gnus-score-find-bnews): Anchor mathces. + + * gnus-group.el (gnus-group-insert-group-line): Would bug out on + on gnus-moderated-hashtb. + +Wed Nov 6 22:54:41 1996 Sudish Joseph + + * gnus-nocem.el (gnus-sum): Required. + +Wed Nov 6 09:13:34 1996 Lars Magne Ingebrigtsen + + * nnmail.el (nnmail-date-to-time): Trap errors. + + * nntp.el (nntp-open-connection): Erase contents of the right + buffer. + + * gnus-sum.el (gnus-summary-first-article-p): New function. + + * gnus-topic.el (gnus-topic-remove-group): Didn't use + process/prefix. + + * gnus-group.el (gnus-group-iterate): New macro. + + * gnus-sum.el (gnus-summary-prev-unread-article): Respect + `gnus-summary-goto-unread' `never'. + +Wed Nov 6 06:55:03 1996 Hrvoje Niksic + + * article.el (gnus-emphasis-alist): New version. + +Wed Nov 6 06:26:34 1996 Lars Magne Ingebrigtsen + + * gnus-art.el (gnus-article-syntax-table): New variable. + (gnus-article-mode): Use it. + + * article.el (article-strip-leading-blank-lines): Didn't do much. + +Wed Nov 6 05:51:56 1996 Kevin Buhr + + * gnus-sum.el (gnus-summary-respool-article): Get the right + servers. + +Wed Nov 6 04:00:48 1996 Lars Magne Ingebrigtsen + + * nnheader.el (nnheader-header-value): Use old definition. + + * message.el: Removed many autoloads. + +Wed Nov 6 03:44:44 1996 ISO-2022-JP + + * gnus-ems.el (gnus-ems-redefine): New Mule definition. + +Wed Nov 6 03:02:25 1996 Lars Magne Ingebrigtsen + + * gnus-xmas.el (gnus-xmas-summary-recenter): Force redisplay. + + * gnus.el (gnus-check-backend-function): Protect against errors. + + * gnus-start.el (gnus-group-change-level): Enter info into dribble + file. + +Wed Nov 6 01:58:46 1996 Hrvoje Niksic + + * article.el (gnus-emphasis-alist): New default. + +Wed Nov 6 01:47:17 1996 Joe Wells + + * gnus-uu.el (gnus-uu-reginize-string): Buggy. + (gnus-uu-uustrip-article): Temp name mixup. + +Wed Nov 6 01:27:54 1996 Lars Magne Ingebrigtsen + + * gnus-group.el (gnus-group-make-group): Use new function. + + * gnus.el (gnus-read-group): New function. + + * dgnushack.el: Less error messages under XEmacs. + +Tue Nov 5 23:59:40 1996 Lars Magne Ingebrigtsen + + * nnmail.el (nnmail-search-unix-mail-delim): New implementation. + +Tue Nov 5 23:43:34 1996 Lars Magne Ingebrigtsen + + * gnus.el: Red Gnus v0.54 is released. + +Tue Nov 5 22:34:01 1996 Lars Magne Ingebrigtsen + + * message.el (message-goto-signature): Place point better. + + * gnus-art.el (gnus-summary-save-body-in-file): Restored. + + * nntp.el (nntp-send-authinfo): Better password prompting. + + * nnmail.el (nnmail-read-passwd): Allow format strings. + +Tue Nov 5 22:10:20 1996 David Moore + + * gnus-sum.el (gnus-valid-move-group-p): New function. + (gnus-read-move-group-name): Faster implementation. + +Tue Nov 5 12:35:40 1996 Lars Magne Ingebrigtsen + + * gnus-topic.el (gnus-topic-remove-topic): Would wipe out topic + parameters. + + * gnus-sum.el (gnus-summary-stop-page-breaking): Remove all + buttons. + + * nnweb.el (nnweb-set-hashtb): Typo. + +Tue Nov 5 10:43:24 1996 Randal Schwartz + + * gnus-uu.el (gnus-uu-be-dangerous): New variable. + (gnus-uu-save-files): Use it. + +Tue Nov 5 10:19:39 1996 Lars Magne Ingebrigtsen + + * gnus-sum.el (gnus-summary-read-document): Doc fix. + (gnus-summary-catchup-and-exit): Don't exit when replying "n". + + * gnus-art.el (gnus-summary-write-to-file): Doc fix. + + * gnus-uu.el (gnus-uu-get-list-of-articles): Get numerical prefix + value. + +Tue Nov 5 10:14:02 1996 David Moore + + * gnus-start.el (gnus-groups-to-gnus-format): Simplified and made + faster. + +Tue Nov 5 04:56:33 1996 Lars Magne Ingebrigtsen + + * nnmail.el (nnmail-search-unix-mail-delim): Protect against + regexp overflows. + + * nnheader.el (nnheader-header-value): New definition. + + * nntp.el (nntp-open-connection): Erase buffer. + (nntp-possibly-change-group): Ditto. + + * nnvirtual.el (nnvirtual-create-mapping): Would ignore groups + with just one article. + +Tue Nov 5 03:41:30 1996 David Moore + + * gnus-nocem.el (gnus-nocem-enter-article): Would bug out on some + lines. + +Tue Nov 5 03:36:03 1996 Lars Magne Ingebrigtsen + + * gnus-score.el (gnus-score-find-favourite-words): Put point at + bob. + +Tue Nov 5 03:33:04 1996 jeff sparkes + + * gnus-kill.el (gnus-batch-score): Run in slave mode. + +Mon Nov 4 03:16:18 1996 Lars Magne Ingebrigtsen + + * nnheader.el (nnheader-directory-regular-files): New function. + + * nnmail.el (nnmail-get-spool-files): Allow nnmail-spool-file to + be a directory. + + * gnus-sum.el (gnus-summary-next-group): Halt prefetch. + + * gnus-async.el (gnus-async-halt-prefetch): New function. + + * message.el (message-check-news-header-syntax): Anchor + multiple-searches. + + * gnus-topic.el (gnus-topic-mode): Reset sorting function. + +Tue Oct 29 20:42:07 1996 Lars Magne Ingebrigtsen + + * gnus-topic.el (gnus-topic-remove-topic): Fold properly. + +Tue Oct 29 19:45:25 1996 Lars Magne Ingebrigtsen + + * message.el (message-generate-new-buffer-clone-locals): Bugged + out under XEmacs. + +Tue Oct 29 19:21:47 1996 David Moore + + * gnus.el: Fixed autoloads. + +Tue Oct 29 17:21:42 1996 Lars Magne Ingebrigtsen + + * gnus-art.el (gnus-url-mailto): `message-goto-subject' takes no + args. + +Mon Oct 28 15:42:21 1996 Lars Magne Ingebrigtsen + + * gnus.el: Autoload gnus-score-followup-thread. + (gnus-inhibit-startup-message): Doc fix. + +Sat Oct 26 15:48:28 1996 Lars Magne Ingebrigtsen + + * gnus-xmas.el (gnus-xmas-topic-menu-add): Add menu. + + * gnus-topic.el (gnus-topic-kill-group): Enter into dribble. + + * gnus-sum.el (gnus-summary-universal-argument): Bind + `gnus-newsgroup-process-marked' to nil before calling functions. + +Sat Oct 26 15:31:18 1996 David Moore + + * nnmail.el (nnmail-activate): Faster version. + +Fri Oct 25 09:02:08 1996 Lars Magne Ingebrigtsen + + * nnsoup.el (nnsoup-pack-replies): Error empty dirs. + + * gnus-msg.el (gnus-summary-mail-forward): Allow prefix to forward + full headers. + +Thu Oct 24 07:20:30 1996 Lars Magne Ingebrigtsen + + * gnus-nocem.el (gnus-nocem-enter-article): Would enter unbound + symbols into hashtb. + +Thu Oct 24 07:12:23 1996 Michael R. Cook + + * nnmh.el (nnmh-active-number): Misplaced paren. + +Thu Oct 24 07:02:54 1996 Lars Magne Ingebrigtsen + + * gnus-group.el (gnus-group-list-groups): Clear inboxes. + + * gnus-async.el (gnus-make-async-article-function): Use the + success param. + + * nntp.el (nntp-after-change-function-callback): Pass along the + right success param. + +Wed Oct 23 18:33:15 1996 Lars Magne Ingebrigtsen + + * gnus-score.el (gnus-summary-increase-score): Spud. + +Wed Oct 23 07:55:42 1996 William Perry + + * gnus-art.el (gnus-url-mailto): New function. + +Wed Oct 23 06:57:10 1996 Lars Magne Ingebrigtsen + + * nnbabyl.el (nnbabyl-create-mbox): New function. + (nnbabyl-open-server): Create mbox. + + * nnmbox.el (nnmbox-create-mbox): New function. + +Tue Oct 22 07:30:12 1996 Lars Magne Ingebrigtsen + + * nnml.el (nnml-request-list): Always return t. + +Tue Oct 22 03:16:27 1996 Felix Lee + + * gnus-score.el (gnus-score-adaptive): Use the right syntax + table. + +Tue Oct 22 03:08:30 1996 Lars Magne Ingebrigtsen + + * message.el (message-generate-headers): Rename Original-Sender as + well. + (message-send-news): Typo. + (message-send-news): Don't message. + +Tue Oct 22 03:06:49 1996 Felix Lee + + * gnus-score.el (gnus-score-adaptive): gnus-score-adaptive will do + line scoring or word scoring, but not both. + +Tue Oct 22 02:48:08 1996 Lars Magne Ingebrigtsen + + * message.el (message-send-news): Use it. + (message-send-mail): Ditto. + +Tue Oct 22 02:40:14 1996 Joev Dubach + + * message.el (message-generate-new-buffer-clone-locals): New + function. + +Tue Oct 22 01:19:47 1996 Lars Magne Ingebrigtsen + + * message.el: Removed `lisp-indent-hook' throughout all files. + + * gnus.el (gnus-sethash): Fix edebug form spec. + + * gnus-cache.el (gnus-cache-file-name): Translate file chars. + +Sun Oct 20 03:41:47 1996 Lars Magne Ingebrigtsen + + * nntp.el (nntp-read-server-type): Fold case. + +Sat Oct 19 08:03:17 1996 Michael Ernst + + * article.el (article-hide-headers): Do the right thing on + articles with no bodies. + (article-narrow-to-signature): Doc fix. + +Sat Oct 19 07:53:49 1996 Lars Magne Ingebrigtsen + + * nnsoup.el (nnsoup-pack-replies): Refuse to pack when there is + nothing to pack. + (nnsoup-read-areas): Don't bug out on empty packets. + + * gnus-soup.el (gnus-soup-pack-packet): Refuse to pack empty + packets. + +Sat Oct 19 07:43:33 1996 Kees de Bruin + + * gnus-sum.el (gnus-auto-center-summary): Fix. + +Sat Oct 19 07:32:27 1996 Marc Horowitz + + * gnus-topic.el (gnus-topic-remove-topic): Would clobber + duplicates. + +Sat Oct 19 07:01:14 1996 Lars Magne Ingebrigtsen + + * message.el (message-send-mail-hook): New hook. + (message-send-news-hook): Ditto. + + * gnus-art.el (gnus-summary-write-to-file): New function. + +Sat Oct 19 06:56:34 1996 Kees de Bruin + + * gnus-sum.el (gnus-summary-save-article-mail-overwrite): New + command and keystroke. + +Thu Oct 17 06:25:55 1996 Lars Magne Ingebrigtsen + + * gnus-sum.el (gnus-article-sort-by-date): Use faster + implementation. + + * gnus-util.el (gnus-string-get-time): New macro. + + * message.el (message-check-news-syntax): Check more thorougly the + From header. + (message-check): New macro. + +Thu Oct 17 06:03:56 1996 Carsten Leonhardt + + * gnus-ems.el (gnus-xemacs): Avoid clobbering functions. + +Thu Oct 17 05:34:15 1996 Lars Magne Ingebrigtsen + + * message.el (message-cite-function): Initialize from + mail-citation-hook. + +Thu Oct 17 02:45:47 1996 Lars Magne Ingebrigtsen + + * gnus.el: Red Gnus v0.52 is released. + +Wed Oct 16 21:01:41 1996 Lars Magne Ingebrigtsen + + * gnus-sum.el (gnus-summary-catchup): Return t. + +Wed Oct 16 20:32:53 1996 Kees de Bruin + + * gnus-group.el (gnus-group-mail-low-empty-face): Face fix. + +Wed Oct 16 20:00:15 1996 Lars Magne Ingebrigtsen + + * message.el (message-mode): Doc fix. + + * nnml.el (nnml-request-group): Re-read directory. + +Wed Oct 16 04:01:27 1996 Lars Magne Ingebrigtsen + + * gnus.el: Red Gnus v0.51 is released. + +Wed Oct 16 03:49:12 1996 Alexandre Oliva + + * gnus-start.el (gnus-setup-news): Make sure + `gnus-group-line-format' is bound. + +Wed Oct 16 02:57:37 1996 Lars Magne Ingebrigtsen + + * nntp.el (nntp-after-change-function-callback): Would delete the + first line of all articles. + +Mon Oct 14 21:31:42 1996 Lars Magne Ingebrigtsen + + * gnus-sum.el (gnus-summary-limit-to-marks): Accept prefix. + +Sun Oct 13 16:37:05 1996 Lars Magne Ingebrigtsen + + * gnus-srvr.el (gnus-browse-foreign-server): Message better. + +Sat Oct 12 19:33:01 1996 Lars Magne Ingebrigtsen + + * message.el (message-indent-citation): Would infloop on empty + articles. + +Sat Oct 12 19:21:05 1996 Raja R. Harinath + + * gnus.el: Autoload more functions. + +Sat Oct 12 19:09:12 1996 Lars Magne Ingebrigtsen + + * gnus-sum.el (gnus-summary-catchup): Don't move point. + (gnus-summary-limit-exclude-marks): New command. + +Fri Oct 11 15:26:02 1996 Lars Magne Ingebrigtsen + + * gnus.el: Red Gnus v0.50 is released. + +Thu Oct 10 23:36:32 1996 Jan Vroonhof + + * gnus-nocem.el (gnus-nocem): Typo. + +Thu Oct 10 23:16:57 1996 Lars Magne Ingebrigtsen + + * gnus-group.el (gnus-group-clear-data-on-native-groups): Only + clear data on native groups. + +Thu Oct 10 14:11:18 1996 Per Abrahamsen + + * gnus-cus.el (gnus-group-customize): Allow unknown entries. + (gnus-score-customize): Ditto. + (gnus-score-string-convert): Ditto. + (gnus-score-parameters): Added `touched'. + +Thu Oct 10 23:06:42 1996 Lars Magne Ingebrigtsen + + * gnus-start.el (gnus-read-active-file): Don't bug out on null + methods. + +Thu Oct 10 22:29:05 1996 Randell Jesup + + * article.el (article-hide-boring-headers): Reversed `date' + check. + +Thu Oct 10 15:24:08 1996 Lars Magne Ingebrigtsen + + * gnus-xmas.el (gnus-xmas-define): Removed gnus-display-type. + + * gnus-group.el (gnus-group-new-mail): Strip prefix. + + * nnmail.el (nnmail-new-mail-p): Didn't work. + + * gnus-score.el (gnus-score-adaptive): Use + gnus-adaptive-word-score-alist. + + * nnoo.el (nnoo-define-skeleton-1): Define + request-list-newsgroups. + + * nnweb.el (w3-forms): Removed. + + * gnus-uu.el (gnus-uu-digest-mail-forward): Use directory form. + +Tue Oct 8 14:30:53 1996 Lars Magne Ingebrigtsen + + * gnus.el: Red Gnus v0.49 is released. + +Tue Oct 8 00:15:04 1996 Per Abrahamsen + + * gnus-nocem.el: Added customize support. + +Tue Oct 8 11:48:25 1996 Lars Magne Ingebrigtsen + + * gnus-group.el (gnus-group-mail-3-empty-face): Use magenta4. + + * gnus.el (gnus-short-group-name): Would bug out on complex group + names. + (gnus-splash-face): New face. + (gnus-group-startup-message): Use it. + + * nnvirtual.el (nnvirtual-request-group): Respect + `always-rescan'. + + * gnus-load.el: Removed. + + * gnus.el (gnus-check-backend-function): Require before + checking... + + * gnus-sum.el (gnus-summary-respool-article): Use it. + + * gnus-load.el (gnus-mail-method-history): New variable. + + * gnus-sum.el (gnus-summary-normal-unread-face): Use default + face. + +Mon Oct 7 15:00:58 1996 Lars Magne Ingebrigtsen + + * gnus.el: Red Gnus v0.48 is released. + +Mon Oct 7 02:24:02 1996 Per Abrahamsen + + * gnus-sum.el: Added customize support. + +Sat Oct 5 01:29:20 1996 Per Abrahamsen + + * gnus-async.el: Added customize support. + * gnus-cache.el: Ditto. + * gnus-cite.el: Ditto. + * gnus-demon.el: Ditto. + * gnus-dup.el: Ditto. + * gnus-eform.el: Ditto. + * gnus-group.el: Ditto. + * gnus-int.el: Ditto. + * gnus-kill.el: Ditto. + * gnus-load.el (gnus-make-face, gnus-face-light-name-list, + gnus-face-dark-name-list): Removed. + +Fri Oct 4 07:17:09 1996 Lars Magne Ingebrigtsen + + * gnus-start.el (gnus-setup-news): Slaves should read the slave + files. + + * gnus-art.el (gnus-request-article-this-buffer): Removed + reference to doing-request. + +Thu Oct 3 05:06:53 1996 Lars Magne Ingebrigtsen + + * gnus.el: Red Gnus v0.47 is released. + +Thu Oct 3 02:04:37 1996 Lars Magne Ingebrigtsen + + * gnus-int.el (gnus-request-head): Use the cache. + +Wed Oct 2 00:57:22 1996 Lars Magne Ingebrigtsen + + * message.el (message-resend): Message. + + * gnus-group.el (gnus-group-timestamp-string): New function. + + * gnus-util.el (gnus-time-iso8601): New function. + + * gnus-group.el (gnus-group-set-timestamp): New function. + (gnus-group-timestamp): New subst. + + * gnus-start.el (gnus-subscribe-hierarchical-interactive): Accept + RET as default. + +Tue Oct 1 05:13:57 1996 Martin Buchholz + + * gnus-sum.el (gnus-summary-insert-pseudos): Error takes a format + string. + +Tue Oct 1 05:12:29 1996 Lars Magne Ingebrigtsen + + * gnus.el: Red Gnus v0.46 is released. + +Tue Oct 1 03:41:17 1996 Lars Magne Ingebrigtsen + + * gnus-picon.el (gnus-picons-glyph-hashtb): Made into hashtb. + +Tue Oct 1 01:50:10 1996 Lars Magne Ingebrigtsen + + * gnus-group.el (gnus-group-new-mail): New function. + (gnus-new-mail-mark): New variable. + + * nnmail.el (nnmail-new-mail-p): New function. + + * gnus-xmas.el (gnus-xmas-splash): New function. + +Tue Oct 1 01:36:17 1996 Raja R. Harinath + + * gnus-score.el (gnus-all-score-files): Didn't handle alist. + + * gnus-gl.el: Dropped `bbb-alist'. Changed cl-hashtable to obarray, + using gnus-{get,set}hash to access it. Dropped a few temp. bindings + Changed (aref (assoc "message-id" ...) ...) to (mail-header-id ...). + +Mon Sep 30 00:02:13 1996 Lars Magne Ingebrigtsen + + * gnus.el: General (and major) indentation, breaking, + if/when/unless/and/or, push revision. + + * gnus-sum.el (gnus-read-header): Set buffer before changing + vars. + +Sun Sep 29 23:20:26 1996 Lars Magne Ingebrigtsen + + * gnus-util.el (gnus-write-buffer): New function. + +Sun Sep 29 23:05:33 1996 Kurt Swanson + + * gnus-sum.el (gnus-handle-ephemeral-exit): New function. + +Sun Sep 29 22:41:01 1996 Lars Magne Ingebrigtsen + + * gnus-cache.el (gnus-cache-possibly-enter-article): Allow making + articles persistent in uncacheable groups. + +Sun Sep 29 01:23:43 1996 Lars Magne Ingebrigtsen + + * gnus.el: Red Gnus v0.45 is released. + +Sun Sep 29 00:57:13 1996 Dave Disser + + * gnus-sum.el (gnus-summary-display-article): Don't show tree + unless using threads. + +Sun Sep 29 00:19:35 1996 Lars Magne Ingebrigtsen + + * gnus-score.el (gnus-all-score-files): Remove duplicates. + +Sat Sep 28 23:47:43 1996 Lars Magne Ingebrigtsen + + * gnus-score.el (gnus-summary-increase-score): Wouldn't do regexp + bodies. + + * gnus-topic.el (gnus-topic-group-indentation): Give the right + indentation always. + +Sat Sep 28 23:23:58 1996 Lars Magne Ingebrigtsen + + * gnus-group.el (gnus-group-quick-select-group): Require + gnus-score. + + * gnus-score.el (gnus-score-thread): New function. + +Sat Sep 28 00:41:54 1996 Per Abrahamsen + + * gnus-cus.el: New file. + +Sat Sep 28 21:32:52 1996 Kevin Buhr + + * nnbabyl.el (nnbabyl-request-article): Would delete wrong + articles. + +Fri Sep 27 21:54:30 1996 Lars Magne Ingebrigtsen + + * gnus.el: Red Gnus v0.44 is released. + +Fri Sep 27 21:24:46 1996 Lars Magne Ingebrigtsen + + * gnus-sum.el (gnus-nov-parse-line): Would double articles. + +Fri Sep 27 20:52:31 1996 Shlomo Mahlab + + * gnus-cache.el (gnus-jog-cache): Call with function name. + + * gnus-group.el (gnus-group-universal-argument): Shadowed `func'. + +Fri Sep 27 19:48:52 1996 Lars Magne Ingebrigtsen + + * gnus-cite.el (gnus-article-fill-cited-article): Nix out data + after filling. + + * gnus-group.el (gnus-group-unsubscribe-current-group): Accept + second param. + (gnus-group-unsubscribe): New function. + (gnus-group-subscribe): New function. + +Fri Sep 27 17:36:31 1996 Kurt Swanson + + * gnus-sum.el (gnus-get-newsgroup-headers-xover): Never add nil + headers. + +Fri Sep 27 17:33:30 1996 Stephen Peters + + * gnus-art.el (gnus-header-face-alist): Typo. + +Fri Sep 27 04:10:21 1996 Lars Magne Ingebrigtsen + + * gnus-msg.el (gnus-summary-mail-crosspost-complaint): Add a tag + to the subject. + (gnus-mail-yank-original): Elided. + (gnus-inews-yank-articles): Would yank articles in reverse order. + +Thu Sep 26 22:39:45 1996 Lars Magne Ingebrigtsen + + * gnus.el: Red Gnus v0.43 is released. + +Thu Sep 26 22:13:00 1996 Lars Magne Ingebrigtsen + + * nnweb.el (nnweb-altavista-wash-article): Didn't remove all + markup. + + * gnus-nocem.el (gnus-nocem-check-article): Fix security hole. + +Thu Sep 26 20:23:11 1996 Lars Magne Ingebrigtsen + + * gnus-group.el (gnus-group-make-group): Accept an ARGS param. + + * nnheader.el (nnheader-concat): Accept many file names. + +Thu Sep 26 19:53:09 1996 Kurt Swanson + + * gnus-art.el (gnus-header-content-face): Buggy color names. + +Thu Sep 26 14:57:38 1996 Lars Magne Ingebrigtsen + + * nnmail.el (nnmail-save-active): Rewrite. + (nnmail-generate-active): New function. + + * gnus-util.el (gnus-delete-assq): New macro. + (gnus-delete-assoc): Ditto. + +Wed Sep 25 23:44:40 1996 Lars Magne Ingebrigtsen + + * gnus-sum.el (gnus-get-newsgroup-headers-xover): Just use one + single condition-case. + +Wed Sep 25 21:15:59 1996 Lars Magne Ingebrigtsen + + * gnus.el: Red Gnus v0.42 is released. + +Wed Sep 25 19:40:34 1996 Lars Magne Ingebrigtsen + + * gnus-art.el (gnus-header-newsgroups-face): Yucky on light + backgrounds. + +Wed Sep 25 19:25:27 1996 Michael R. Cook + + * message.el (message-ignored-news-headers): Strip Resent-Fcc. + +Wed Sep 25 19:12:59 1996 Lars Magne Ingebrigtsen + + * gnus-group.el (gnus-group-jump-to-group): Use + `gnus-group-goto-group'. + + * gnus-xmas.el (gnus-xmas-mode-line-buffer-identification): Don't + chop off half line when no colon. + +Mon Sep 23 22:12:10 1996 Lars Magne Ingebrigtsen + + * gnus-nocem.el (gnus-nocem-verifyer): Change to `mc-verify'. + +Mon Sep 23 21:43:47 1996 Lars Magne Ingebrigtsen + + * gnus.el: Red Gnus v0.41 is released. + +Mon Sep 23 21:10:37 1996 Lars Magne Ingebrigtsen + + * article.el (article-hide-headers): Don't ignore + gnus-visible-headers. + +Mon Sep 23 19:10:20 1996 Lars Magne Ingebrigtsen + + * gnus-sum.el (gnus-summary-goto-subject): Made into command. + +Mon Sep 23 18:26:47 1996 Tonny Madsen + + * nnmail.el (nnmail-default-file-modes): Use integer. + +Tue Sep 24 18:39:41 1996 Lars Magne Ingebrigtsen + + * gnus-sum.el (gnus-summary-respool-query): Better message. + +Sun Sep 22 15:12:54 1996 Per Abrahamsen + + * gnus-art.el: Customized. + + * gnus.el (gnus-inhibit-startup-message): Changed type to + boolean. + (gnus-play-startup-jingle): Ditto. + +Sun Sep 22 12:58:57 1996 Lars Magne Ingebrigtsen + + * gnus.el: Red Gnus v0.40 is released. + +Sun Sep 22 11:48:02 1996 Lars Magne Ingebrigtsen + + * custom.el (defcustom): Eval and compile. + * widget.el (define-widget-keywords): Ditto. + +Sat Sep 21 09:29:54 1996 Lars Magne Ingebrigtsen + + * article.el (article-strip-multiple-blank-lines): Would strip all + blank lines. + +Fri Sep 20 06:52:07 1996 Lars Magne Ingebrigtsen + + * gnus.el: Red Gnus v0.39 is released. + +Thu Sep 19 18:57:59 1996 Lars Magne Ingebrigtsen + + * message.el (message-ignored-cited-headers): Doc fix. + +Thu Sep 19 03:05:01 1996 Lars Magne Ingebrigtsen + + * gnus.el: Red Gnus v0.38 is released. + +Thu Sep 19 03:05:01 1996 Lars Magne Ingebrigtsen + + * gnus.el: Red Gnus v0.37 is released. + +Wed Sep 18 10:36:08 1996 Lars Magne Ingebrigtsen + + * gnus-async.el (gnus-async-prefetch-article-p): New variable. + (gnus-async-prefetch-article): Use it. + (gnus-async-unread-p): New function. + +Tue Sep 17 14:41:56 1996 Per Abrahamsen + + * gnus-cite.el (gnus-custom-import-cite-face-list): Removed. + +Wed Sep 18 04:28:16 1996 Lars Magne Ingebrigtsen + + * nnmail.el (nnmail-split-history): mapcar instead of mapconcat. + +Tue Sep 17 14:41:56 1996 Per Abrahamsen + + * gnus.el: Customized. + + * dgnushack.el (custom-file): Removed. + +Wed Sep 18 03:04:17 1996 Lars Magne Ingebrigtsen + + * nnmail.el (nnmail-check-duplication): Do splitting after + duplicate suppression. + + * gnus-salt.el (gnus-pick-mode): Don't go to unread article. + + * gnus-dup.el (gnus-dup-enter-articles): Don't enter Message-IDs + ento lists multiple times. + +Tue Sep 17 03:44:08 1996 Lars Magne Ingebrigtsen + + * gnus-uu.el (gnus-uu-grab-articles): Don't prefetch. Ask before + deleting. + + * gnus.el: Red Gnus v0.37 is released. + +Tue Sep 17 03:15:26 1996 Lars Magne Ingebrigtsen + + * custom.el: 0.9 included. + + * gnus-art.el (browse-url): Required. + + * gnus.el: Red Gnus v0.36 is released. + +Tue Sep 17 02:37:26 1996 Lars Magne Ingebrigtsen + + * gnus-edit.el: Removed. + + * custom.el: Removed. + + * gnus-cus.el: Removed. + +Mon Sep 16 05:59:45 1996 Lars Magne Ingebrigtsen + + * gnus.el: Red Gnus v0.35 is released. + +Sun Sep 15 00:47:08 1996 Lars Magne Ingebrigtsen + + * nnmail.el (nnmail-default-file-modes): New default. + +Sat Sep 14 01:48:58 1996 Lars Magne Ingebrigtsen + + * gnus-group.el (gnus-group-make-doc-group): Typo. + (gnus-useful-groups): New format. + + * gnus-cache.el (gnus-jog-cache): Doc fix. + +Fri Sep 13 02:28:47 1996 Lars Magne Ingebrigtsen + + * gnus-group.el (gnus-group-get-new-news): Read slave files here. + +Fri Sep 13 01:04:50 1996 Per Abrahamsen + + * article.el (article-decode-rfc1522): New version. + +Fri Sep 13 00:00:25 1996 Lars Magne Ingebrigtsen + + * gnus-msg.el (gnus-crosspost-complaint): Added a newline. + (gnus-summary-mail-crosspost-complaint): Insert message at the + head of the message. + +Thu Sep 12 01:56:07 1996 Lars Magne Ingebrigtsen + + * gnus.el: Red Gnus v0.34 is released. + +Thu Sep 12 01:16:38 1996 Lars Magne Ingebrigtsen + + * gnus.el: Red Gnus v0.33 is released. + +Wed Sep 11 00:22:01 1996 Lars Magne Ingebrigtsen + + * gnus-score.el (gnus-adaptive-word-syntax-table): Modified + standard syntax table. + + * nntp.el (nntp-read-server-type): Worked in the wrong buffer. + + * gnus-demon.el (gnus-demon-cancel): Put + nnheader-cancel-function-timers back in again. + + * gnus.el: Red Gnus v0.32 is released. + +Tue Sep 10 19:10:09 1996 Lars Magne Ingebrigtsen + + * gnus-kill.el (gnus-batch-score): Didn't work at all. + + * gnus-msg.el (gnus-summary-mail-nastygram): Place point at + appropriate place. + + * gnus-util.el (gnus-make-sort-function): Would nix out the + sorting list. + + * gnus-demon.el (gnus-demon-cancel): Don't run + `cancel-function-timers'. + + * message.el (message-header-format-alist): Don't fill References + headers. + +Mon Sep 9 21:51:46 1996 Lars Magne Ingebrigtsen + + * nntp.el (nntp-server-action-alist): Don't try LIST ACTIVE GROUP + on Netscape's brain-dead nntp server. + + * message.el (message-dont-send): Take proper actions. + +Mon Sep 9 21:46:44 1996 Lars Magne Ingebrigtsen + + * gnus.el: Red Gnus v0.31 is released. + +Mon Sep 9 21:16:11 1996 Lars Magne Ingebrigtsen + + * gnus-msg.el (gnus-copy-article-buffer): Decode headers after + copying. + + * gnus-picon.el (gnus-picons-refresh-before-display): New + variable. + (gnus-picons-insert-face-if-exists): Put bar back in. + +Mon Sep 9 20:31:56 1996 Lars Magne Ingebrigtsen + + * gnus-uu.el (gnus-uu-digest-mail-forward): Use the newsgroup name. + +Mon Sep 9 20:04:35 1996 Kurt Swanson + + * gnus-salt.el (gnus-pick-mouse-pick-region): New function. + +Mon Sep 9 18:37:07 1996 Lars Magne Ingebrigtsen + + * gnus-sum.el (gnus-summary-enter-digest-group): Bugged. + + * gnus-score.el (gnus-adaptive-word-syntax-table): Make ' a + word-constituant character. + +Sun Sep 8 14:46:01 1996 Lars Magne Ingebrigtsen + + * gnus-group.el (gnus-group-make-useful-group): New command and + keystroke. + (gnus-useful-groups): New variable. + +Sun Sep 8 14:46:01 1996 Lars Magne Ingebrigtsen + + * gnus.el: Red Gnus v0.30 is released. + +Sun Sep 8 13:26:36 1996 Lars Magne Ingebrigtsen + + * nndoc.el (nndoc-article-begin-function): Defvarred. + + * gnus-srvr.el (gnus-browse-unsubscribe-group): Would sometimes be + somewhat tricky. + + * gnus.el (gnus-kill-ephemeral-group): New function. + + * gnus-art.el (gnus-button-alist): Recognize group-news urls. + + * nndoc.el (nndoc-dissect-buffer): Wouldn't dissect an mbox + properly. + (nndoc-article-begin): New function. + (nndoc-mbox-body-end): Use it. + (nndoc-mbox-article-begin): Would bug out. + +Sun Sep 8 13:10:28 1996 Lars Magne Ingebrigtsen + + * gnus.el (gnus-other-frame): Always pop up a frame. + +Sun Sep 8 12:57:03 1996 Lars Magne Ingebrigtsen + + * gnus.el: Red Gnus v0.29 is released. + +Sun Sep 8 12:24:11 1996 Lars Magne Ingebrigtsen + + * nntp.el (nntp-accept-process-output): Don't message so + obsessively. + + * gnus.el: Fixed indentation and stuff. + +Sun Sep 8 12:23:56 1996 Sudish Joseph + + * nnweb.el (nnweb-fetch-form): Return t. + +Sat Sep 7 15:15:42 1996 Lars Magne Ingebrigtsen + + * gnus.el: Red Gnus v0.28 is released. + +Sat Sep 7 14:33:17 1996 Lars Magne Ingebrigtsen + + * nntp.el (nntp-after-change-function-callback): Renamed. + + * nnweb.el (nnweb-reference-search): Nix out file name. + +Sat Sep 7 14:07:13 1996 Lars Magne Ingebrigtsen + + * nnweb.el (nnweb-altavista-search): Nix out buffer file name. + + * gnus-async.el (gnus-asynch-with-semaphore): New macro. + (gnus-make-async-article-function): Nix out prefetch list when the + summary buffer dies. + + * nnweb.el (nnweb-altavista-create-mapping): Would search forever + when not getting any matches. + +Sat Sep 7 12:43:24 1996 Lars Magne Ingebrigtsen + + * gnus-msg.el (gnus-inews-yank-articles): Goto body before + yanking. + + * nnheader.el (nnheader-insert-file-contents-literally): New + definition. + (nnheader-insert-head): Use new definition. + +Sat Sep 7 12:35:37 1996 Kurt Swanson + + * gnus-salt.el (gnus-pick-elegant-flow): New variable. + +Sat Sep 7 12:03:00 1996 Lars Magne Ingebrigtsen + + * nnheader.el (nnheader-insert-head): Don't use + `insert-file-contents-literally'. + (nnheader-head-chop-length): New variable. + + * gnus-sum.el (gnus-summary-read-document): Prepend "nnvirtual:" + to group name. + +Sat Sep 7 11:12:26 1996 Lars Magne Ingebrigtsen + + * gnus-score.el (gnus-score-save): Don't check result from + gnus-make-directory. + + * gnus-util.el (gnus-make-directory): Return t. + +Fri Sep 6 17:55:48 1996 Lars Magne Ingebrigtsen + + * gnus-range.el (gnus-copy-sequence): Didn't work for all + sequences. + +Fri Sep 6 14:38:54 1996 Wes Hardaker + + * gnus-picons.el (gnus-picons-display-as-address): New variable. + (gnus-picons-map): New keymap for picons. + (gnus-picons-toggle-extent): New function. + (gnus-article-display-picons): use them. + (gnus-picons-insert-face-if-exists): ditto. + (gnus-picons-try-to-find-face): ditto. + (gnus-group-display-picons): let display catch up. + (gnus-article-display-picons): ditto. + +Fri Sep 6 08:11:02 1996 Lars Magne Ingebrigtsen + + * nnkiboze.el (nnkiboze-close-group): Rewrite. + (nnkiboze-request-list, nnkiboze-request-newgroups, + nnkiboze-request-list-newsgroups): Removed. + (nnkiboze-request-scan): New function. + (nnkiboze-directory): New default. + + * gnus-sum.el (gnus-article-read-p): New function. + + * nnkiboze.el (nnkiboze-retrieve-headers): Rewrite. + (nnkiboze-open-server): Removed. + (nnkiboze-server-opened): Ditto. + + * nnheader.el (nnheader-find-nov-line): Renamed. + (nnheader-nov-delete-outside-range): New function. + + * gnus-uu.el (gnus-uu-invert-processable): New command and + keystroke. + + * gnus-load.el (gnus-predefined-server-alist): New variable. + + * gnus.el (gnus-server-to-method): Use it. + (gnus-read-method): Ditto. + + * gnus-sum.el (t): "M V" commands weren't defined. + + * gnus-cache.el (gnus-summary-insert-cached-articles): New command + and keystroke. + + * gnus-score.el (gnus-sort-score-files): New function. + (gnus-score-file-rank): New function. + (gnus-score-find-bnews): Use it. + + * gnus-topic.el (gnus-topic-mode-map): New sort submap. + (gnus-topic-sort-groups, gnus-topic-sort-groups-by-alphabet, + gnus-topic-sort-groups-by-unread, gnus-topic-sort-groups-by-level, + gnus-topic-sort-groups-by-score, gnus-topic-sort-groups-by-rank, + gnus-topic-sort-groups-by-method): New commands and keystrokes. + + * gnus-group.el (gnus-group-sort-selected): New command. + (gnus-group-sort-selected-flat): New function. + (gnus-group-sort-selected-groups-by-alphabet, + gnus-group-sort-selected-groups-by-unread, + gnus-group-sort-selected-groups-by-level, + gnus-group-sort-selected-groups-by-score, + gnus-group-sort-selected-groups-by-rank, + gnus-group-sort-selected-groups-by-method): New commands and + keystrokes. + (gnus-group-make-menu-bar): Updated. + + * gnus-util.el (gnus-make-sort-function): Create a complete + function. + (gnus-make-sort-function-1): Renamed. + + * gnus-topic.el (gnus-group-sort-topic): New function. + + * gnus-group.el (gnus-group-sort-flat): Made into own function. + (gnus-group-sort-alist-function): New variable. + + * nnmail.el (nnmail-split-history): New variable. + (nnmail-split-history): New command. + + * gnus-score.el (gnus-score-adaptive): Don't do any work on + pseudos. + + * gnus-msg.el (gnus-post-method): Allow easier posting from mail + groups. + +Thu Sep 5 19:56:41 1996 Lars Magne Ingebrigtsen + + * gnus.el: Red Gnus v0.27 is released. + +Thu Sep 5 19:50:19 1996 Lars Magne Ingebrigtsen + + * gnus-xmas.el (gnus-xmas-modeline-glyph): Set string properly. + +Thu Sep 5 18:39:47 1996 Lars Magne Ingebrigtsen + + * gnus-sum.el (gnus-summary-edit-article-done): Make params + optional. + + * nntp.el (nntp-list-active-group): Don't change group first. + + * gnus-util.el (gnus-make-directory): New function. + + * gnus-msg.el (gnus-post-method): Do the right thing in + `to-group' groups. + +Fri Sep 6 08:05:53 1996 ISO-2022-JP + + * nnheader.el (nnheader-insert-head): Use + nnheader-insert-file-contents-literally. + +Thu Sep 5 08:29:08 1996 Lars Magne Ingebrigtsen + + * gnus-win.el (gnus-always-force-window-configuration): New + variable. + (gnus-configure-windows): Use it. + + * gnus-sum.el (gnus-summary-save-article): Give better prompts. + + * gnus-load.el (gnus-valid-select-methods): Update. + + * gnus-score.el (gnus-score-find-favourite-words): Didn't find any + words. + + * gnus-sum.el (gnus-scores-exclude-files): Defined. + + * gnus-async.el (gnus-async-prefetch-next): Don't do so much on + un-asynch groups. + +Thu Sep 5 08:26:11 1996 jeff sparkes + + * gnus-win.el (gnus-buffer-configuration): Bad cut'n'paste. + +Thu Sep 5 07:41:08 1996 Lars Magne Ingebrigtsen + + * gnus-group.el (gnus-group-list-groups): Update format specs. + +Thu Sep 5 07:11:18 1996 Jan Vroonhof + + * gnus-sum.el (gnus-summary-read-document): Generated wrong nndoc + group names. + +Thu Sep 5 06:53:07 1996 Lars Magne Ingebrigtsen + + * nnvirtual.el (nnvirtual-close-group): Don't update ephemeral + groups. + + * gnus.el (gnus-group-auto-expirable-p): Allow nil expiry params. + +Wed Sep 4 06:46:03 1996 Lars Magne Ingebrigtsen + + * gnus.el: Red Gnus v0.26 is released. + +Wed Sep 4 06:42:34 1996 Lars Magne Ingebrigtsen + + * nnmail.el (nnmail-move-inbox): Reverse logic. + +Wed Sep 4 06:35:05 1996 Lars Magne Ingebrigtsen + + * gnus.el: Red Gnus v0.25 is released. + +Wed Sep 4 05:19:58 1996 Lars Magne Ingebrigtsen + + * nnmail.el (nnmail-move-inbox): Refuse to move if + nnmail-crash-box can't be written. + + * gnus-art.el (gnus-button-url-regexp): Include : and ; in + regexp. + + * gnus-score.el (gnus-adaptive-word-score-alist): New variable. + + * nnmail.el (nnmail-move-inbox): Set file modes on wrong file. + +Tue Sep 3 06:44:36 1996 Lars Magne Ingebrigtsen + + * gnus.el: Red Gnus v0.24 is released. + +Tue Sep 3 05:30:02 1996 Lars Magne Ingebrigtsen + + * gnus-async.el (gnus-async-prefetch-article): Reset async list + when the summary buffer is killed. + + * gnus-xmas.el (gnus-xmas-modeline-glyph): Don't use glyph under + tty. + + * gnus-msg.el (gnus-copy-article-buffer): Deleted text in article + buffer. + +Tue Sep 3 05:10:19 1996 Kurt Swanson + + * gnus-sum.el (gnus-group-no-more-groups-hook): New variable. + +Tue Sep 3 04:44:31 1996 Lars Magne Ingebrigtsen + + * gnus-sum.el (gnus-summary-exit): Would bug out when using a + single article buffer. + +Mon Sep 2 05:50:07 1996 Lars Magne Ingebrigtsen + + * gnus-audio.el (gnus-audio-play): Give the sound-file argument as + ARG in addition to stdin. + +Mon Sep 2 05:28:26 1996 Lars Magne Ingebrigtsen + + * gnus.el: Red Gnus v0.23 is released. + +Mon Sep 2 05:16:46 1996 Lars Magne Ingebrigtsen + + * gnus-audio.el: Renamed from "gnus-sound". + +Mon Sep 2 05:06:17 1996 Lars Magne Ingebrigtsen + + * gnus-ems.el (gnus-xemacs): New variable. + +Mon Sep 2 03:18:18 1996 Lars Magne Ingebrigtsen + + * gnus-async.el (gnus-async-prefetch-next): Don't start fetching + the next article until we have been idle a while. + + * gnus-group.el (gnus-group-make-help-group): Use the new find-etc + function. + + * nnheader.el (nnheader-find-etc-directory): Accept a FILE + parameter. + + * gnus-msg.el (gnus-debug): Use `locate-library' instead of doing + things the hard way. + + * gnus-sum.el (gnus-set-global-variables): Copy + +Mon Sep 2 03:01:27 1996 Lars Magne Ingebrigtsen + + * gnus.el (gnus-splash): Play jingle. + + * gnus-sound.el (gnus-startup-jingle): New variable. + (gnus-play-jingle): New command. + + * gnus.el (gnus-play-startup-jingle): New variable. + +Sun Sep 1 06:38:45 1996 Lars Magne Ingebrigtsen + + * gnus.el: Red Gnus v0.22 is released. + +Sun Sep 1 05:45:59 1996 Lars Magne Ingebrigtsen + + * gnus.el: Removed unreferenced let bindings from all files. + +Sun Sep 1 02:10:28 1996 Lars Magne Ingebrigtsen + + * gnus.el ((load)): Only do the initial splash on "gnus" + commands. + + * gnus-cus.el (gnus-face-dark-name-list): Don't use "dark blue". + + * nntp.el (nntp-retrieve-headers): Would infloop sometimes. + + * gnus-group.el (gnus-group-insert-group-line-info): Indent + properly. + + * gnus-sum.el (gnus-gather-threads-by-references): Avoid + infloops. + + * gnus-salt.el (gnus-mouse-pick): Changed name. + + * nntp.el (nntp-retrieve-groups): Didn't do the right thing on + servers that don't support LIST ACTIVE. + + * gnus-win.el (gnus-current-window-configuration): New variable. + (gnus-configure-windows): Use it. + + * gnus-art.el (gnus-article-read-summary-keys): Let `C-d' work + properly. + + * gnus-sum.el (gnus-list-of-unread-articles): Active group. + +Sat Aug 31 05:05:14 1996 Lars Magne Ingebrigtsen + + * gnus.el: Red Gnus v0.21 is released. + +Sat Aug 31 02:54:39 1996 Lars Magne Ingebrigtsen + + * gnus-topic.el (gnus-topic-goto-next-group): Go to the proper + group when listing. + + * gnus-start.el (gnus-get-killed-groups): Mark .newsrc as needing + saving. + + * nnmail.el (nnmail-remove-tabs): New function. + +Fri Aug 30 06:26:37 1996 Lars Magne Ingebrigtsen + + * gnus-start.el (gnus-set-default-directory): Set to directory + file name. + + * nnmail.el (nnmail-remove-list-identifiers): New function. + (nnmail-list-identifiers): New variable. + (nnmail-prepare-incoming-message-hook): New variable. + (nnmail-move-inbox): Allow nnmail-movemail-program to be a + function. + + * article.el (article-mime-decode-quoted-printable-buffer): New + function. + + * nnmail.el (nnmail-prepare-incoming-header-hook): New variable. + (nnmail-clean-whitespace-from-headers): New function. + + * nntp.el (nntp-connection-alist): New variable. + (nntp-open-connection): Use it. + (nntp-request-close): New function. + + * gnus-demon.el (timer): Required. + + * message.el (message-reply): Bugged out on wide replies. + +Fri Aug 30 03:51:39 1996 Lars Magne Ingebrigtsen + + * gnus.el: Red Gnus v0.20 is released. + +Fri Aug 30 01:36:10 1996 Lars Magne Ingebrigtsen + + * gnus-msg.el (gnus-inews-insert-archive-gcc): Use + `gnus-group-find-parameter'. + + * nndoc.el (nndoc-mbox-article-begin): New function. + + * gnus-sum.el (gnus-summary-search-article): Would expose the + first hidden thread. + + * gnus-msg.el (gnus-copy-article-buffer): Delete annotations + before following up. + + * gnus-cite.el (gnus-article-hide-citation): Mark buttons as + annotations. + + * article.el (article-delete-text-of-type): New function. + + * nndoc.el (nndoc-type-alist): Be slightly more permissive. + + * gnus-sum.el (gnus-summary-enter-digest-group): Would nix out + quit-conf. + (gnus-summary-read-document): Ditto. + + * nndoc.el (nndoc-dissect-buffer): Escape errors in overflows. + + * message.el (message-send-news): Give a message after not + posting. + (message-reply): Remove leading spaces from Cc. + +Fri Aug 30 01:32:27 1996 Jack Vinson + + * nnmail.el (nnmail-get-split-group): New version. + +Fri Aug 30 00:47:17 1996 Jens Lautenbacher + + * gnus.texi (Group Parameters): Updated documentation + + * gnus-msg.el (gnus-inews-insert-archive-gcc): Updated to use the + topic's value of gcc-self if no group value present. + +Fri Aug 30 00:19:43 1996 Lars Magne Ingebrigtsen + + * gnus-start.el (gnus-set-default-directory): Expand default + directory. + + * gnus-group.el (gnus-group-make-web-group): Changed keystroke. + + * gnus-sum.el (gnus-summary-verbose-headers): Show article after + toggling. + +Thu Aug 29 23:50:54 1996 Lars Magne Ingebrigtsen + + * gnus-demon.el (gnus-demon-add-rescan): New function. + (gnus-demon-scan-news): New function. + +Thu Aug 29 05:34:40 1996 Lars Magne Ingebrigtsen + + * gnus.el: Red Gnus v0.19 is released. + +Thu Aug 29 02:04:35 1996 Lars Magne Ingebrigtsen + + * nndoc.el (nndoc-babyl-body-begin): Would skip empty messages. + + * nntp.el (nntp-retrieve-groups): Would infloop on some servers. + + * gnus-sum.el (gnus-nov-parse-line): Don't let messages refer back + to themselves. + + * gnus-util.el (gnus-parent-id): Don't bug out on nil references. + + * gnus-cite.el (gnus-article-hide-citation): Hide/unhide better. + + * article.el (article-hide-text-of-type): New function. + (article-hidden-text-type-p): New function. + + * gnus-cite.el (gnus-article-hide-citation): Marked the hidden + text with wrong type. + (gnus-article-hide-citation-maybe): Ditto. + (gnus-article-hide-citation): Toggle. + + * gnus-dup.el (gnus-dup-enter-articles): Would bug out on + pseudo-articles. + + * nntp.el (nntp-server-opened-hook): Send mode reader as a + default. + (nntp-retrieve-data): Format error. + +Thu Aug 29 01:52:19 1996 Lars Magne Ingebrigtsen + + * gnus-sum.el (gnus-summary-display-article): Check whether + `gnus-current-article' is nil. + +Wed Aug 28 08:44:22 1996 Lars Magne Ingebrigtsen + + * gnus-async.el (gnus-async-prefetch-article): Would clobber + fetches in progress. + + * gnus-sum.el (gnus-summary-prepare): Made into command. + + * gnus-srvr.el (gnus-server-scan-server): New command and + keystroke. + + * gnus-group.el (gnus-group-read-group): Accept a 0 prefix to not + generate buffer. + +Sun Jul 21 14:56:28 1996 Steven L Baur + + * earcon.el (earcon-regexp-alist): Plonk! + +Wed Aug 28 04:14:36 1996 Lars Magne Ingebrigtsen + + * gnus.el: Red Gnus v0.18 is released. + +Wed Aug 28 02:09:20 1996 Lars Magne Ingebrigtsen + + * nnweb.el (nnweb-dejanews-create-mapping): Would just fetch the + first 100 hits. + (nnweb-close-group): Set file name to nil before killing. + (nnweb-altavista-create-mapping): Fetch the required number of + articles. + + * gnus-group.el (gnus-group-read-ephemeral-group): Don't call the + activation several times. + + * gnus-sum.el (gnus-summary-enter-digest-group): Copy the parent's + params to the nndoc group. + (gnus-summary-read-document): Ditto. + + * message.el (message-followup): Would produce buggy messages when + replying to messages without Message-IDs. + +Sat Aug 10 23:41:07 1996 Per Abrahamsen + + * gnus.el (gnus-decode-rfc1522): Start decoding from beginning of + headers instead of end. + +Wed Aug 28 01:35:26 1996 Lars Magne Ingebrigtsen + + * gnus-demon.el (gnus-demon-cancel): Cancel function timers. + + * nnheaderxm.el (nnheader-xmas-cancel-function-timers): New + function. + + * nnheader.el (nnheader-cancel-function-timers): New alias. + + * gnus-topic.el (gnus-topic-mode): Update groups. + (gnus-topic-remove-group): Update topic. + + * gnus-group.el (gnus-group-update-group-function): New variable. + (gnus-group-update-group): Use it. + + * gnus-topic.el (gnus-topic-update-topics-containing-group): New + function. + +Tue Aug 27 14:35:01 1996 Ken Raeburn + + * nnmail.el (nnmail-move-inbox): Don't try setting modes on + "po:$USER". + +Tue Aug 27 21:45:14 1996 Lars Magne Ingebrigtsen + + * gnus-sum.el (gnus-summary-number-of-articles-in-thread): Would + bug out on unthreadeds. + +Tue Aug 27 21:38:13 1996 Kurt Swanson + + * gnus-salt.el (gnus-pick-mode-map): Typo. + +Tue Aug 27 21:35:58 1996 Lars Magne Ingebrigtsen + + * gnus-load.el: Removed gnus-vis thingies. + +Tue Aug 27 00:54:05 1996 Lars Magne Ingebrigtsen + + * gnus.el: Red Gnus v0.17 is released. + +Tue Aug 27 00:46:48 1996 Lars Magne Ingebrigtsen + + * nnweb.el (nnweb-dejanews-create-mapping): Dummy function. + +Tue Aug 27 00:43:33 1996 Lars Magne Ingebrigtsen + + * gnus.el: Red Gnus v0.16 is released. + +Tue Aug 27 00:36:58 1996 Lars Magne Ingebrigtsen + + * gnus-topic.el (gnus-topic-set-parameters): Bugout. + +Mon Aug 26 22:41:04 1996 Lars Magne Ingebrigtsen + + * nntp.el (nntp-retrieve-groups): Didn't inhibit erasing. + + * nnweb.el (nnweb-callback): Ignore if the callback buffer is + dead. + + * gnus-async.el (gnus-async-prefetch-article): Don't do anything + if Gnus is dead. + +Mon Aug 26 00:57:06 1996 Lars Magne Ingebrigtsen + + * nnweb.el (nnweb-dejanews-create-mapping): Fold search. + (nnweb-reference-create-mapping): Ditto. + (nnweb-altavista-create-mapping): Ditto. + + * gnus-async.el (gnus-asynchronous): New variable. + (gnus-async-prefetch-article): Use it. + (gnus-async-prefetch-headers): Ditto. + + * nnweb.el (nnweb-close-group): New function. + + * gnus-topic.el (gnus-topic-clean-alist): Would remove foreign + groups from topics. + +Mon Aug 26 00:10:40 1996 Lars Magne Ingebrigtsen + + * gnus.el: Red Gnus v0.15 is released. + +Sun Aug 25 23:09:18 1996 Lars Magne Ingebrigtsen + + * message.el (message-send-mail-with-qmail): Use + `message-qmail-program', which doesn't exist. + + * nndoc.el (nndoc-type-alist): Slack digests are guessable. + +Sun Aug 25 21:27:17 1996 Lars Magne Ingebrigtsen + + * gnus-salt.el (gnus-pick-mode): Nixed out the format. + (gnus-summary-pick-line-format): Buggy def. + + * gnus-sum.el (gnus-summary-read-document): Provide a quit-conf. + (gnus-summary-read-document): Do better names. + + * nnvirtual.el (nnvirtual-close-group): Don't do the unread + setting on ephemeral groups. + + * nntp.el (nntp-retrieve-groups): Would infloop. + +Sun Aug 25 02:52:11 1996 Sudish Joseph + + * message.el (message-qmail-inject-program): New variable. + (message-qmail-inject-args): New variable. + (message-send-mail-with-qmail): New function, suitable for use + as message-send-mail-function. + +Sun Aug 25 20:41:45 1996 Lars Magne Ingebrigtsen + + * nnweb.el (nnweb-fetch-form): Clear buffer file name. + + * nntp.el (nntp-request-article): Would try to copy to the same + buffer. + + * gnus-group.el (gnus-group-read-ephemeral-group): Better error + message. + + * nnweb.el (nnweb-request-group): Better error report. + + * gnus-score.el (gnus-score-load-file): Gave `nil' as a day param. + +Sun Aug 25 03:32:51 1996 Lars Magne Ingebrigtsen + + * gnus.el: Red Gnus v0.14 is released. + +Sun Aug 25 00:16:44 1996 Lars Magne Ingebrigtsen + + * gnus-util.el (gnus-prin1): New function. + (gnus-prin1-to-string): New function. + + * gnus-sum.el (gnus-summary-refer-parent-article): Bugout. + + * nndb.el (nndb-request-accept-article): Use new nntp functions. + + * pop3.el: Make MD5 defined when compiling. + + * article.el (article-strip-blank-lines): Called Gnus functions. + + * nnweb.el (nnweb-init): Create a better buffer name. + (nnweb-altavista-search): Wasn't defined. + (nnweb-reference-search): Use advanced search. + + * nnfolder.el (nnfolder-request-accept-article): Wrong params to + `save-mail'. + * nnbabyl.el (nnbabyl-request-accept-article): Ditto. + * nnmbox.el (nnmbox-request-accept-article): Ditto. + * nnmh.el (nnmh-request-accept-article): Ditto. + * nnml.el (nnml-request-accept-article): Ditto. + +Sat Aug 24 23:53:32 1996 Lars Magne Ingebrigtsen + + * nnmail.el (nnmail-get-new-mail): Tried calling nonexisting + functions. + +Sat Aug 24 23:30:07 1996 Lars Magne Ingebrigtsen + + * gnus-group.el (gnus-group-enter-directory): Temporarily bound + `nneething-read-only'. + +Fri Aug 23 23:22:16 1996 Katsumi Yamaoka + + * gnus-ems.el (gnus-ems-redefine): Set + `gnus-summary-display-table' to nil. + +Fri Aug 23 22:55:09 1996 Lars Magne Ingebrigtsen + + * gnus-art.el (gnus-summary-save-in-file): Didn't check before + creating dir. + (gnus-summary-save-in-rmail): Ditto. + (gnus-summary-save-body-in-file): Ditto. + + * message.el (message-check-news-syntax): Faulty Newsgroups + regexp. + +Thu Aug 22 20:47:48 1996 Lars Magne Ingebrigtsen + + * nnmail.el (nnmail-split-hook): New variable. + + * nnmh.el (nnmh-update-gnus-unreads): cl-nged. + (nnmh-active-number): Find the largest article number. + +Thu Aug 22 20:39:10 1996 Sam Falkner + + * nnmh.el (nnmh-update-gnus-unreads): Check all articles. + +Thu Aug 22 16:49:35 1996 Lars Magne Ingebrigtsen + + * gnus-kill.el (gnus-execute): Ignored read articles. + + * gnus-sum.el (gnus-summary-execute-command): Give a form, not a + function. + + * gnus-kill.el (gnus-execute-1): Evaled functions instead of + calling them. + + * nnmail.el (nnmail-move-inbox): Allow continuation after error. + + * gnus-score.el (gnus-adaptive-word-syntax-table): New variable. + (gnus-score-adaptive): Use it. + + * nnbabyl.el (nnbabyl-request-scan): Change group. + + * nnmbox.el (nnmbox-request-scan): Change group. + + * gnus-score.el (gnus-ignored-adaptive-words): Renamed. + (gnus-ignored-adaptive-words): New variable. + (gnus-score-adaptive): Use it. + (gnus-score-adaptive): Bugged out on undefined symbols. + (gnus-summary-score-entry): Accept numerical DATE. + (gnus-score-adaptive): Pos in wrong buf. + (gnus-score-string): Didn't accept word matches. + (gnus-enter-score-words-into-hashtb): Wrong sequence. + (gnus-score-string): Word matches inflooped. + +Wed Aug 21 15:06:47 1996 + + * smiley.el (smiley-buffer): Added some additional extent parameters. + (smiley-toggle-extent): rewrote to use above. + +Mon Aug 19 20:19:59 1996 Lars Magne Ingebrigtsen + + * gnus-spec.el (gnus-tilde-cut-form): Cut off wrong part. + +Mon Aug 19 20:09:44 1996 Samuel Tardieu + + * gnus-cache.el (gnus-cache-write-active): Would try to create + existing directory. + +Mon Aug 19 00:12:11 1996 Lars Magne Ingebrigtsen + + * article.el (article-strip-multiple-blank-lines): New command and + keystroke. + (article-strip-blank-lines): New command and keystroke. + + * nnmail.el (nnmail-move-inbox): Set file permissions on the + Incoming files. + + * gnus-group.el (gnus-group-fetch-faq): Go through the FAQ dirs + until we manage to open one. + + * nntp.el (nntp-send-authinfo-function): New variable. + (nntp-wait-for): Handle authinfo requests better. + + * gnus-sum.el (gnus-summary-article-posted-p): New command and + keystroke. + + * gnus-topic.el (gnus-topic-display-empty-topics): New variable. + + * gnus-msg.el (gnus-setup-message): Make `gnus-newsgroup-name' + local to the message buffers. + + * gnus-int.el (gnus-remove-denial): New function. + + * gnus-sum.el (gnus-summary-refer-parent-article): Allow negative + prefixes. + (gnus-summary-refer-parent-article): Allow skipping past canceled + articles. + + * gnus-util.el (gnus-parent-id): Take an optional N ancestor + param. + + * gnus-async.el (gnus-async-prefetch-article): Don't clobber async + fetches already in progress. + + * nnmail.el (nnmail-check-duplication): Allow /dev/null mail + filing. + + * gnus-sum.el (gnus-summary-catchup): Didn't do suppression. + (gnus-summary-limit-children): Never hide ticked articles. + (gnus-highlight-selected-summary): Selected face spans the entire + %(-%) area. + +Sun Aug 18 22:05:00 1996 Lars Magne Ingebrigtsen + + * gnus-group.el (gnus-group-restart): Better prompt. + + * gnus-async.el (gnus-async-prefetch-article): Don't try to fetch + old-fetched articles. + +Sun Aug 18 22:02:17 1996 Raja R. Harinath + + * gnus-gl.el (gnus-grouplens-mode): Make hooks local. + +Sun Aug 18 16:53:19 1996 Lars Magne Ingebrigtsen + + * gnus-group.el (gnus-group-get-new-news): Don't move point. + + * nnweb.el (nndejagnus): Renamed from nndejagnus. + (nnweb-remove-markup): New function. + +Sun Aug 18 14:53:55 1996 Lars Magne Ingebrigtsen + + * gnus.el: Red Gnus v0.13 is released. + +Tue Aug 20 17:30:00 1996 + + * smiley.el (smiley-map): New keymap for smileys. + (smiley-toggle-extent): New function to toggle smiley invisibility. + (smiley-buffer): Use them. + +Sun Aug 18 12:46:12 1996 Lars Magne Ingebrigtsen + + * nnoo.el (nnoo-define-skeleton-1): Defined too many functions. + +Sat Aug 17 18:43:22 1996 Lars Magne Ingebrigtsen + + * gnus-group.el (gnus-group-make-dejanews-group): New command and + keystroke. + + * gnus-start.el (gnus-site-init-file): New variable. + (gnus-read-init-file): Use it. + + * nndejanews.el: New file. + + * nnheader.el (make-full-mail-header): New function. + + * nngateway.el (nngateway-open-server): Used nntp vars. + +Sat Aug 17 15:35:28 1996 Lars Magne Ingebrigtsen + + * gnus.el: Red Gnus v0.12 is released. + +Sat Aug 17 12:58:28 1996 Lars Magne Ingebrigtsen + + * gnus-win.el (gnus-window-configuration-element): New function. + (gnus-windows-old-to-new): Use it. + (gnus-windows-old-to-new): Produced bogus results. + + * message.el (message-cancel-message): New variable. + + * gnus-srvr.el (gnus-server-mode-map): Buggy keymap. + + * gnus-group.el (gnus-group-get-new-news-this-group): Illegal + gnus-error value. + +Fri Aug 16 21:22:12 1996 Lars Magne Ingebrigtsen + + * nnmail.el (nnmail-replace-status, nnmail-decode-status, + nnmail-encode-status): New variables. + + * nnml.el (nnml-article-to-file): New function. + +Fri Aug 16 20:26:12 1996 Kurt Swanson + + * nnfolder.el (nnfolder-generate-active-file): Test the right + files. + +Fri Aug 16 19:30:57 1996 Lars Magne Ingebrigtsen + + * gnus-salt.el (gnus-possibly-generate-tree): Would bug out on + unthreaded buffers. + + * gnus-xmas.el (gnus-xmas-modeline-right-extent): Disabled. + (gnus-xmas-modeline-left-extent): Ditto. + + * gnus-group.el (gnus-group-make-menu-bar): Bugged out on + undefined variable. + + * gnus.el (gnus-read-method): Return the virtual server name if + possible. + +Thu Aug 15 18:15:58 1996 Lars Magne Ingebrigtsen + + * nngateway.el: New file. + + * nnoo.el (nnoo-define-skeleton): New macro. + (nnoo-define-skeleton-1): New function. + + * gnus-start.el (gnus-strip-killed-list): New function. + (gnus-gnus-to-quick-newsrc-format): Use it. + + * gnus-sum.el (gnus-summary-process-mark-set): New function. + (gnus-summary-yank-process-mark, gnus-summary-kill-process-mark, + gnus-summary-save-process-mark): New commands and keystrokes. + + * nnml.el (nnml-generate-nov-file): Set modes. + + * nnmail.el (nnmail-default-file-modes): New variable. + (nnmail-write-region): New function. + + * gnus-score.el (gnus-score-score-files-1): Bind case-fold-search + to nil. + +Wed Aug 14 21:20:07 1996 Lars Magne Ingebrigtsen + + * gnus-soup.el (gnus-soup-send-packet): Disable syntax checks. + +Wed Aug 14 20:28:09 1996 Fred Johansen + + * gnus-logic.el (gnus-advanced-score-rule): `and' rules were + treated improperly. + +Wed Aug 14 15:29:39 1996 Lars Magne Ingebrigtsen + + * gnus-salt.el (gnus-mouse-pick-article): New command. + + * gnus-art.el (gnus-button-url): Call with one argument. + + * gnus-start.el (gnus-set-default-directory): New function. + + * gnus-load.el (gnus-default-directory): New variable. + +Wed Aug 14 15:03:01 1996 Sudish Joseph + + * gnus-score.el (gnus-home-score-file): Changed syntax. + +Tue Aug 13 22:07:11 1996 Jan Vroonhof + + * nndoc.el (nndoc-dissect-buffer): Went into infinite loop if end + of file token wasn't properly detected. + (nndoc-type-alist): Better end-of-header regexp for + lanl.gov preprints + (nndoc-article-type): Updated doc string + +Mon Aug 12 21:01:25 1996 Sudish Joseph + + * nntp.el (nntp-request-newgroups): Switch to nntp-server-buffer + first. + +Tue Aug 13 09:44:46 1996 Lars Magne Ingebrigtsen + + * gnus-group.el (gnus-group-sort-by-real-name): New function. + + * gnus-sum.el (gnus-summary-save-article): Pass on number of + articles to be saved. + + * gnus-art.el (gnus-article-edit-article): Remove all text props. + (gnus-read-save-file-name): Take an optional defaultish parameter. + + * nntp.el (nntp-retrieve-groups): Saved. + + * message.el (message-forward): Didn't work well with multi-line + separators. + + * gnus-msg.el (gnus-summary-mail-crosspost-complaint): Check + wheteher followup-to was restricted. + + * nnsoup.el (nnsoup-store-reply): Would insert double courtesy + headers. + + * gnus-group.el (gnus-group-highlight-line): New `total' number. + +Mon Aug 12 06:25:00 1996 Lars Magne Ingebrigtsen + + * gnus.el: Red Gnus v0.11 is released. + +Mon Aug 12 03:51:57 1996 Lars Magne Ingebrigtsen + + * gnus-async.el (gnus-make-async-article-function): New function. + (gnus-async-prefetch-article): Use it. + +Sat Aug 10 07:16:29 1996 Greg Stark + + * gnus-start.el (gnus-activate-level): Doc fix. + +Sun Aug 11 03:33:02 1996 Lars Magne Ingebrigtsen + + * gnus-msg.el (gnus-summary-mail-crosspost-complaint): New command. + (gnus-crosspost-message): New variable. + + * gnus-vis.el: Removed file -- functions spread out over + gnus-group.el, gnus-sum.el and gnus-art.el. + + * gnus-util.el (gnus-turn-off-edit-menu): Renamed function. + + * gnus-salt.el (gnus-carpal-mode): Moved to this file. + + * gnus-vis.el (gnus-score-set-default): Removed. + (gnus-visual-score-map): Removed. + + * nntp.el (nntp-send-nosy-authinfo): Don't echo password. + + * gnus-srvr.el (gnus-server-open-all-servers): New command and + keystroke. + (gnus-server-close-all-servers): Ditto. + + * gnus-async.el (gnus-async-get-semaphore): New function. + (gnus-async-release-semaphore): New function. + (gnus-async-prefetch-article): Use them. + + * nntp.el (nntp-make-process-buffer): New function. + (nntp-retrieve-data): Use after-change instead of filter. + (nntp-after-change-function): New function. + + * gnus.el (gnus-read-method): Intern method. + + * gnus-cache.el (gnus-cache-save-buffers): Didn't check before + making dir. + +Sat Aug 10 14:55:33 1996 Sudish Joseph + + * gnus-win.el (gnus-buffer-configuration): Don't create picon + frame if gnus-picons-display-where is 'article. + +Sun Aug 11 02:47:30 1996 Lars Magne Ingebrigtsen + + * gnus-vis.el (gnus-highlight-selected-summary): Would bug out on + some lines. + + * gnus-spec.el (gnus-tilde-cut-form): Typo. + (gnus-parse-simple-format): Forgot to check `max-right' and + `max-left'. + (gnus-compile): Don't issue warnings. + +Fri Aug 2 14:53:02 1996 Christoph Wedler + + * smiley.el (smiley-buffer): `smiley-regexp-alist' can be a symbol + now. + +Sun Aug 11 02:37:57 1996 Greg Stark + + * gnus-msg.el (gnus-post-method): Tested the wrong variable. + +Sun Aug 11 02:28:30 1996 Lars Magne Ingebrigtsen + + * message.el (message-check-news-syntax): Messaged wrong number. + +Sat Aug 10 11:26:56 1996 Lars Magne Ingebrigtsen + + * message.el (message-y-or-n-p): Moved to before usage. + +Fri Aug 9 16:42:52 1996 Danny Siu + + * gnus-picon.el (gnus-article-display-picons): display picon even if + From line doesn't have full domain name. + +Sat Aug 10 10:11:21 1996 Lars Magne Ingebrigtsen + + * message.el (message-reply): Didn't narrow properly to the head. + (message-indent-citation): Remove all blank lines at the start. + +Sat Aug 10 07:00:34 1996 Lars Magne Ingebrigtsen + + * gnus.el: Red Gnus v0.9 is released. + +Sat Aug 10 06:03:07 1996 Lars Magne Ingebrigtsen + + * gnus-soup.el (gnus-soup-write-prefixes): Protect against + existing dirs. + + * gnus-topic.el (gnus-topic-parameters): Third parameter instead + of second. + (gnus-topic-set-parameters): Ditto. + +Sat Aug 10 05:22:43 1996 Lee Iverson + + * message.el (message-send-mail-with-mh): Didn't work. + +Sat Aug 10 03:57:42 1996 Lars Magne Ingebrigtsen + + * gnus-dup.el (gnus-dup-unsuppress-article): Data instead of + ingo. + (gnus-dup-unsuppress-article): Set the wrong variable. + +Sat Aug 10 00:52:26 1996 Jack Vinson + + * gnus.el (gnus-short-group-name): Bug in dotless names. + +Sat Aug 10 00:45:32 1996 Jens Lautenbacher + + * gnus-msg.el (gnus-inews-insert-archive-gcc): Use the `gcc-self' + parameter. + +Sat Aug 10 00:28:41 1996 François Pinard + + * gnus-load.el (gnus-info-nodes): Add info node for + `mime/viewer-mode'. + +Sat Aug 10 00:25:51 1996 Lars Magne Ingebrigtsen + + * message.el (message-reply): Don't include first empty line. + +Sat Aug 10 00:11:52 1996 François Pinard + + * gnus-sum.el (gnus-summary-prev-unread-article): Doc fix. + +Sat Aug 10 00:08:42 1996 Lars Magne Ingebrigtsen + + * gnus-util.el (gnus-date-iso8601): Protect against buggy Dates. + +Fri Aug 9 06:39:22 1996 Lars Magne Ingebrigtsen + + * gnus-topic.el (gnus-topic-mode): Hook into parameter thingies. + (gnus-topic-parameters): Buggy definition. + + * gnus-group.el (gnus-group-get-parameter-function): New + variable. + + * gnus.el (gnus-group-find-parameter): New function. + + * gnus-sum.el (gnus-summary-read-document): New command and + keystroke. + + * gnus-group.el (gnus-group-clear-data-on-native-groups): New + command. + (gnus-group-read-ephemeral-group): Accept an ACTIVATE-ONLY + parameter. + + * gnus-score.el (gnus-decay-score): New function. + (gnus-decay-scores): New function. + (gnus-decay-score-function): New variable. + (gnus-score-date): Accept a `regexp' match. + + * gnus-util.el (gnus-time-to-day): New function. + + * gnus-score.el (gnus-decay-scores): New variable. + (gnus-score-decay-constant): New variable. + (gnus-score-decay-scale): New variable. + + * gnus-sum.el (gnus-group-make-articles-read): Register undo. + + * gnus-group.el (gnus-update-read-articles): Register undo. + + * gnus-undo.el (gnus-undo-register-1): Renamed. + (gnus-undo-register): New macro. + + * gnus-group.el (gnus-group-yank-group): Be undoable. + (gnus-group-kill-group): Be undoable. + (gnus-undo): Required. + (gnus-group-clear-data): New keystroke. + + * gnus-undo.el (gnus-undo-last-command): New variable. + (gnus-undo): Didn't work. + (gnus-undo-boundary): Keep track of whether the last command did a + boundary. + (gnus-undo): Set boundary. + +Thu Aug 8 19:43:02 1996 Lars Magne Ingebrigtsen + + * gnus-spec.el (gnus-tilde-cut-form): New function. + (gnus-tilde-max-form): New definition. + (gnus-tilde-ignore-form): New function. + (gnus-parse-format): Rewrite to accept extended syntax. + + * gnus-topic.el (gnus-topic-goto-missing-group): Try to be a bit + faster. + + * gnus-group.el (gnus-group-goto-group): Accept optional FAR + parameter. + + * gnus-int.el (gnus-request-newgroups): Don't bug out on servers + that don't support this. + + * gnus.el (gnus-server-extend-method): Would bug out on non-known + methods. + + * gnus-group.el (gnus-group-get-new-news): Put point in the group + buffer. + +Wed Aug 7 15:40:44 1996 Jan Vroonhof + + * nntp.el (nntp-open-rlogin): Now can be used as + nntp-open-connection function + (nntp-open-telnet): Ditto + (nntp-open-rlogin): Needed to remove telnet junk from nntp buffer + to make new nntp-wait-for happy + all: required carriage return for end of line + +Tue Aug 6 21:58:26 1996 Jan Vroonhof + + * nndoc.el (nndoc-generate-lanl-gov-head): New function + (nndoc-transform-lanl-gov-announce): New function + (nndoc-lanl-gov-announce-type-p): New function + (nndoc-type-alist): Added support for preprint announcements + (nndoc-type-alist): Only use 'slack-digests' if forced to. + +Tue Aug 6 20:41:02 1996 Jan Vroonhof + + * nndoc.el (nndoc-type-alist): tried to call nndoc-guess-type-p + +Thu Aug 8 05:40:28 1996 Lars Magne Ingebrigtsen + + * gnus-sum.el (gnus-summary-walk-group-buffer): Put cursor in echo + area. + + * gnus-dup.el (gnus-dup-unsuppress-article): New function. + + * gnus-sum.el (gnus-mark-article-as-unread): Unsuppress + duplicates. + + * gnus-msg.el (gnus-debug): Scan gnus-load.el. + +Thu Aug 8 01:48:57 1996 Lars Magne Ingebrigtsen + + * gnus.el: Red Gnus v0.8 is released. + +Thu Aug 8 01:36:34 1996 Lars Magne Ingebrigtsen + + * gnus.el: Red Gnus v0.7 is released. + +Thu Aug 8 01:29:56 1996 Lars Magne Ingebrigtsen + + * message.el (message-deletable-headers): Have Lines be + deletable. + +Wed Aug 7 23:41:26 1996 Richard Pieri + + * gnus.el (gnus-short-group-name): New version. + +Wed Aug 7 19:55:25 1996 Lars Magne Ingebrigtsen + + * gnus-start.el (gnus-declare-backend): New function. + + * gnus-xmas.el (gnus-xmas-pointer-glyph): New variable. + (gnus-xmas-modeline-glyph): New variable. + (gnus-xmas-mode-line-buffer-identification): New definition. + + * nntp.el (nntp-request-article): Would sometimes return nil + falsely. + (nntp-find-group-and-number): Saved function. + (nntp-request-article): Use it. + (nntp-request-head): Saved. + + * gnus-dup.el (gnus-dup-suppress-articles): Message. + + * gnus-group.el (gnus-group-mark-group): Used string instead of + char. + +Wed Aug 7 02:52:55 1996 Lars Magne Ingebrigtsen + + * gnus-util.el: Use `format-time-string'. + + * gnus-sum.el (gnus-summary-edit-article-postpone): Defined + again. + + * article.el (article-make-date-line): Would say "unknown" on + "now" dates. + +Wed Aug 7 02:48:12 1996 Katsumi Yamaoka + + * message.el (message-rename-buffer): Set proper outsave name. + +Wed Aug 7 00:28:44 1996 Lars Magne Ingebrigtsen + + * nnheader.el (nnheader-temp-write): Always use + `fundamental-mode'. + + * gnus-util.el (gnus-date-iso8601): Illegal format. + + * gnus-group.el (gnus-group-make-doc-group): Full name in server + name. + + * gnus-undo.el (gnus-undo): Typo. + + * gnus-group.el (gnus-group-mark-group): Don't touch props. + + * gnus-score.el (gnus-score-headers): Don't root out 0 scores when + saving. + + * gnus-art.el (gnus-narrow-to-page): Don't do a "next-page" if + `^L' is the last char. + + * gnus.el (gnus): Autoload. + +Tue Aug 6 23:00:01 1996 Lars Magne Ingebrigtsen + + * gnus-score.el (gnus-score-string): Wouldn't do word and fuzzy + matching properly. + +Mon Aug 5 22:23:03 1996 Raja R. Harinath + + * gnus-gl.el (gnus-grouplens-mode): Clear proper variables. + +Mon Aug 5 20:27:11 1996 Lars Magne Ingebrigtsen + + * gnus-art.el (gnus-article-edit-exit): Would move point. + (gnus-article-edit): New command. + + * nnml.el (nnml-request-rename-group): Copy over .overview file. + (nnml-request-group): Better error message. + +Sat Aug 3 17:52:01 1996 Steven L Baur + + * gnus-setup.el (message): Can't require 'message until we know + where the Gnus .elcs are. + +Mon Aug 5 20:07:11 1996 François Pinard + + * gnus-util.el (gnus-date-iso8601): New function. + +Mon Aug 5 19:14:12 1996 Lars Magne Ingebrigtsen + + * gnus-sum.el (gnus-summary-search-article-forward): Show thread + when finding matches. + + * nnmail.el (nnmail-get-spool-files): Sort procmail files. + +Mon Aug 5 02:25:06 1996 Lars Magne Ingebrigtsen + + * gnus.el: Red Gnus v0.6 is released. + +Mon Aug 5 01:12:24 1996 Lars Magne Ingebrigtsen + + * nntp.el (nntp-request-type): Defined again. + +Mon Aug 5 01:01:15 1996 Ralph Schleicher + + * gnus-score.el (gnus-ignored-adaptive-words): New value. + +Mon Aug 5 00:12:54 1996 Lars Magne Ingebrigtsen + + * gnus-util.el (gnus-group-real-name): Tweaked definition. + + * gnus-eform.el (gnus-edit-form-done): Didn't call the right + function. + +Sun Aug 4 23:30:52 1996 Lars Magne Ingebrigtsen + + * gnus-score.el (gnus-score-load-files): Returned nil. + +Sun Aug 4 06:11:02 1996 Lars Magne Ingebrigtsen + + * gnus-load.el (gnus-use-undo): New variable. + + * gnus-undo.el: New file. + + * gnus-score.el (gnus-default-adaptive-word-score-alist): New + variable. + (gnus-score-adaptive): Adaptivity on words. + (gnus-ignored-adaptive-words): New variable. + (gnus-all-score-files): Made into own function. + (gnus-score-load-files): Ditto. + (gnus-score-find-favourite-words): New command and keystroke. + + * gnus-load.el (gnus-use-adaptive-scoring): Doc fix. + + * gnus-score.el (gnus-enter-score-words-into-hashtb): New + function. + (gnus-score-build-cons): Removed. + (gnus-score-string): Score words. + +Sun Aug 4 01:33:31 1996 Lars Magne Ingebrigtsen + + * gnus.el: Red Gnus v0.5 is released. + +Sun Aug 4 00:17:51 1996 Lars Magne Ingebrigtsen + + * nntp.el (nntp-wait-for): Goto point-max before inserting. + (nntp-retrieve-headers): Didn't inhibit Erasure. + + * gnus-eform.el (gnus-edit-form-mode-map): Buggy. + + * nntp.el (nntp-send-command-nodelete): New function. + +Sat Aug 3 22:21:24 1996 Lars Magne Ingebrigtsen + + * article.el (article-date-ut): Wouldn't do anything much. + + * nntp.el (nntp-wait-for): Wouldn't allow posting. + + * nnmail.el (nnmail-delete-incoming): Set to nil. + +Sat Aug 3 01:31:24 1996 Lars Magne Ingebrigtsen + + * gnus-score.el (gnus-home-score-file): New variable. + (gnus-home-score-file): New function. + (gnus-hierarchial-home-score-file): New function. + (gnus-possibly-score-headers): Use `adapt-file' param. + (gnus-home-adapt-file): New variable. + (gnus-hierarchial-home-adapt-file): New function. + + * gnus-load.el (gnus-original-article-buffer): Moved here. + + * gnus-sum.el (gnus-article-mark): New macro. + (gnus-summary-prepare-unthreaded): Use it. + (gnus-summary-prepare-threads): Ditto. + + * gnus-win.el (gnus-buffer-configuration): New `edit-article' + setting. + + * gnus-sum.el (gnus-summary-edit-article): Don't move point in the + article buffer. + (gnus-summary-edit-article-done): Don't move point after editing. + (gnus-summary-edit-article-postpone): Removed. + (gnus-summary-update-article-line): New function. + + * gnus-art.el (gnus-article-edit-mode-map): Buggy map. + +Fri Aug 2 22:36:40 1996 Lars Magne Ingebrigtsen + + * gnus.el: Red Gnus v0.4 is released. Wed Jul 31 15:23:54 1996 Ken Olstad - * gnus-xmas.el (gnus-xmas-redefine): Disbale XFace when running + * gnus-xmas.el (gnus-xmas-redefine): Disable XFace when running under tty. Wed Jul 31 14:21:38 1996 Lars Magne Ingebrigtsen @@ -21,12 +4302,238 @@ * gnus.el (gnus-group-read-group): Use `gnus-range-length' instead of `length'. -Tue Jul 30 21:42:59 1996 Lars Magne Ingebrigtsen - - * gnus.el: Gnus v5.2.38 is released. +Fri Aug 2 21:48:17 1996 Lars Magne Ingebrigtsen + + * gnus-dup.el (gnus-dup-suppress-articles): Wouldn't mark articles + properly. + +Fri Aug 2 21:40:33 1996 Glenn Coombs + + * gnus-vis.el (gnus-button-url): New definition. + +Fri Aug 2 19:08:55 1996 Lars Magne Ingebrigtsen + + * gnus-group.el (gnus-update-read-articles): Moved here. + + * gnus-sum.el (gnus-update-read-articles): Moved here. + + * gnus-async.el (gnus-async-request-fetched-article): Would bug + out on Message-IDs. + + * gnus-score.el (gnus-score-save): Would kill wrong buffer. + + * nntp.el (nntp-process-filter): Insert at point-max. + + * nnheader.el (nnheader-set-temp-buffer): Accept a noerase param. + +Fri Aug 2 00:14:16 1996 Lars Magne Ingebrigtsen + + * gnus-topic.el (gnus-topic-edit-parameters): New command. + (gnus-group-topic-parameters): New function. + (gnus-topic-set-parameters): New function. + (gnus-topic-parameters): New function. + + * gnus-group.el (gnus-group-edit-group-done): Newish definition. + + * gnus-srvr.el (gnus-server-edit-server): Use new edit function. + (gnus-server-edit-server-done): Removed. + + * gnus-group.el: Use new edit function. + + * gnus-eform.el (gnus-eform): New file. + + * gnus-group.el (gnus-group-goto-group): Tippy-toe around some + more to find the most likely instance of the group. + (gnus-edit-form): New function. + (gnus-edit-form-mode): New command. + (gnus-edit-form-make-menu-bar): New function. + (gnus-edit-form-mode-hook): New variable. + (gnus-edit-form-exit): New command and keystroke. + (gnus-edit-form-done): Ditto. + + * gnus-topic.el: Moved functions around. + (gnus-current-topic): Renamed. + (gnus-current-topics): New function. + (gnus-group-parent-topic): New function. + + * article.el (gnus-signature-separator): New default. + (gnus-signature-limit): Extended value. + (article-narrow-to-signature): Use it. + + * gnus-cite.el (gnus-cite-parse): Use new signature functions. + + * article.el (article-search-signature): New function. + (gnus-signature-separator): Allow wider syntax. + + * gnus-async.el (gnus-use-header-prefetch): New variable. + (gnus-async-set-article-buffer): Removed. + (gnus-async-prefetch-headers): New function. + (gnus-async-retrieve-fetched-headers): New function. + (gnus-async-prefetch-headers-buffer): New variable. + + * gnus-salt.el (gnus-summary-pick-line-format): New variable. + (gnus-pick-mode): Use it. + (gnus-pick-line-number): New function. + (gnus-pick-article): New command and keystroke. + (gnus-pick-mode-map): Changed " " to `gnus-pick-next-page'. + (gnus-pick-next-page): New command and keystroke. + (gnus-mark-unpicked-articles-as-read): New variable. + (gnus-pick-start-reading): Use it. + + * gnus-sum.el (gnus-summary-line-format-alist): Add pick line + number. + +Thu Aug 1 23:32:15 1996 Lars Magne Ingebrigtsen + + * nntp.el (nntp-request-list): Decode. + (nntp-request-list-newsgroups): Ditto. + + * gnus-gl.el (gnus-grouplens-mode): Update summary line specs. + + * gnus-msg.el (gnus-debug): Would bug out. + +Thu Aug 1 23:24:48 1996 Glenn Coombs + + * gnus-sum.el (gnus-summary-update-mark): Work on hidden threads. + +Thu Aug 1 00:00:16 1996 Lars Magne Ingebrigtsen + + * gnus-score.el (gnus-score-save): Wouldn't save scores. + + * gnus-load.el (gnus-summary-line-format): Moved here. + + * gnus.el (gnus-alive-p): More thorough definition. + (gnus-info-set-entry): New macro. + + * gnus-move.el: New file. + (gnus-move-group-to-server): New function. + (gnus-change-server): New command. + (gnus-group-move-group-to-server): New command. + + * gnus-start.el (gnus-parse-active): New function. + + * gnus.el (gnus-read-method): Mew function. + * gnus-group.el: Use it. + + * gnus-load.el (gnus-suppress-duplicates): New variable. + + * gnus-dup.el: New file. + + * gnus-sum.el (gnus-data-read-p): New macro. + (gnus-duplicate-mark): New variable. + +Wed Jul 31 23:09:35 1996 Lars Magne Ingebrigtsen + + * gnus.el: Red Gnus v0.3 is released. + +Wed Jul 31 21:38:08 1996 Lars Magne Ingebrigtsen + + * nntp.el (nntp-retrieve-headers-with-xover): Didn't work. + + * gnus-load.el (gnus-suppress-keymap): New function. + +Wed Jul 31 01:20:58 1996 Sudish Joseph + + * gnus-picon.el (gnus-group-display-picons): Delete just the live + extents. + +Wed Jul 31 21:15:01 1996 Lars Magne Ingebrigtsen + + * gnus.el ((load)): Only eval splash when loading. + + * gnus-group.el (gnus-group-quit): Always kill group buffer. + + * nntp.el (nntp-open-connection): Escape errors. + +Wed Jul 31 16:09:22 1996 Lars Magne Ingebrigtsen + + * nnml.el (nnml-request-rename-group): Would move subgroups as + well. + * nnmh.el: Ditto. + + * gnus-group.el (gnus-group-rename-group): Use current group name + as default. + (gnus-group-rename-group): Added doc string. + + * gnus-sum.el (gnus-general-simplify-subject): Renamed. + +Wed Jul 31 16:05:06 1996 Paul Franklin + + * gnus-sum.el (gnus-pdf-simplify-subject): New version. + +Wed Jul 31 15:59:04 1996 Raja R. Harinath + + * nntp.el (nntp-retrieve-headers-with-xover): `last' returns cdr. + +Wed Jul 31 15:18:33 1996 Lars Magne Ingebrigtsen + + * nntp.el (nntp-retrieve-headers-with-xover): Put the result in + the right buffer. + (nntp-request-body): Decode. + + * gnus.el (gnus-no-server): Would bug out when gnus-start wasn't + loaded. + + * gnus-art.el (gnus-article-edit-mode): New command. + (gnus-article-edit-mode-hook): New variable. + (gnus-article-edit-mode-map): New variable. + +Wed Jul 31 15:18:26 1996 François Pinard + + * gnus-art.el (gnus-article-edit-full-stops): New command. + +Wed Jul 31 13:03:48 1996 Lars Magne Ingebrigtsen + + * gnus-sum.el (gnus-summary-edit-wash): New command and keystroke. + + * message.el (message-sort-headers-1): Sort properly on totally + empty headers. + + * article.el (article-hide-boring-headers): Didn't hide completely + empty headers. + + * nntp.el (nntp-encode-text): Rescued. + (nntp-send-buffer): New function. + (nntp-request-post): New function. + + * gnus-util.el (gnus-define-keys-safe): New macro. + (gnus-define-keys-1): Accept `safe' param. + + * gnus-load.el (gnus-summary-mode-map): Define the main three + keymaps prematurely here. + +Wed Jul 31 12:48:23 1996 Steven L. Baur + + * gnus-load.el (gnus-default-nntp-server): Moved. + +Wed Jul 31 03:15:02 1996 Lars Magne Ingebrigtsen + + * nndoc.el (nndoc-add-type): Remove old type definition. + + * article.el: Changed variable names back to `gnus-'. + +Tue Jul 30 23:07:04 1996 Lars Magne Ingebrigtsen + + * nntp.el (nntp-connection-alist): Define as oo. + + * nndoc.el (nndoc-add-type): Wrong number of args. + (nndoc-set-delims): Free var. + +Tue Jul 30 23:02:51 1996 Lars Magne Ingebrigtsen + + * gnus.el: Red Gnus v0.1 is released. + +Tue Jul 30 22:34:11 1996 Lars Magne Ingebrigtsen + + * nntp.el (nntp-find-connection-buffer): New function. + (nntp-retrieve-headers): Use it. Tue Jul 30 00:00:28 1996 Lars Magne Ingebrigtsen + * nndoc.el (nndoc-add-type): New function. + (nndoc-guess-type): New function. + (nndoc-set-delims): New definition. + * nntp.el (nntp-open-server): Init server buffer. * gnus.el (gnus-group-prefixed-name): Do the right thing with nil @@ -34,1847 +4541,47 @@ (gnus-group-rename-group): Would act oddly when renaming native groups. -Sat Jul 27 17:46:42 1996 Lars Magne Ingebrigtsen - - * message.el (message-check-news-syntax): Use signature - separator. - - * gnus.el (gnus-group-make-group): Beep at "" methods. - (gnus-group-make-group): Don't prefix native groups. - - * nnmail.el (nnmail-move-inbox): Bug out on movemail errors. - - * gnus-cache.el (gnus-cache-file-name): Would bug out on group - names containing slashes. - - * gnus-topic.el (gnus-topic-check-topology): Make sure all groups - in topics are living. - - * nntp.el (nntp-send-strings-to-server): Give a better error - message. - -Sat Jul 27 17:33:22 1996 Teddy - - * nntp.el (nntp-open-rlogin): Change parameter order. - -Sat Jul 27 17:19:47 1996 Lars Magne Ingebrigtsen - - * gnus-topic.el (gnus-topic-check-topology): Make sure all - topologies have alists. - -Wed Jul 24 08:23:26 1996 Lars Magne Ingebrigtsen - - * gnus.el (gnus-group-jump-to-group): Don't activate group. - -Wed Jul 24 07:47:47 1996 Katsumi Yamaoka - - * message.el (message-rename-buffer): Rename autosave name. - -Wed Jul 24 06:24:07 1996 Lars Magne Ingebrigtsen - - * gnus-vis.el (gnus-group-make-menu-bar): Moved Misc menu last. - (gnus-summary-make-menu-bar): Ditto. - -Sat Jul 20 00:59:22 1996 Lars Magne Ingebrigtsen - - * smiley.el (smiley-buffer): Only do smilies under X. - - * gnus.el (gnus-make-directory): Beep on nil dirs. - (gnus-article-archive-name): Prepend the save directory. - -Fri Jul 19 23:08:52 1996 Hallvard B. Furuseth - - * message.el (message-y-or-n-p): Doc fix. - -Fri Jul 19 02:12:58 1996 Lars Magne Ingebrigtsen - - * gnus.el: Gnus v5.2.37 is released. - -Fri Jul 19 00:31:22 1996 Lars Magne Ingebrigtsen - - * gnus.el (gnus-subscribe-newsgroup): Add new groups to top-level - topic. - (gnus-group-make-archive-group): Add a to-address group param. - - * gnus-topic.el (gnus-topic-hide-topic): Doc fix. - (gnus-topic-select-group): Doc fix. - (gnus-topic-rename): Keep point nearby. - - * gnus.el (gnus-group-goto-group): More efficient (and more - correct) implementation. - (gnus-group-sort-function): Doc fix. - (gnus-group-edit-buffer): Changed to defvar. - (gnus-group-edit-group-done): Use new name. - (gnus-group-edit-group): Include name of group in grup buffer - name. - - * nnfolder.el (nnfolder-save-mail): Handle babylish ">From" - lines. - * nnmbox.el (nnmbox-request-accept-article): Ditto. - -Thu Jul 18 23:50:31 1996 Lars Magne Ingebrigtsen - - * nnmail.el (nnmail-move-inbox): Don't substitute in command - name. - - * gnus-xmas.el (gnus-xmas-modeline-glyph): New variable. - -Thu Jul 18 16:35:22 1996 Lars Magne Ingebrigtsen - - * custom.el (custom-facep): Didn't work under non-X Emacs. - -Thu Jul 18 00:02:32 1996 Lars Magne Ingebrigtsen - - * nntp.el (nntp-open-telnet): Use more permissive regexps. - - * gnus-uu.el (gnus-uu-uustrip-article): `cd' to make gnus-uu work - under NT. - -Mon Jul 15 18:11:13 1996 Jan Vroonhof - - * smiley.el (smiley-regexp-alist): Don't match important parts of URLs - (smiley-nosey-regexp-alist): New variable. - -Wed Jul 17 23:48:50 1996 Mark Borges - - * messagexmas.el (nnheader): Required. - -Wed Jul 17 02:02:25 1996 Michael Cook - - * nnmail.el (nnmail-split-abbrev-alist): New default. - -Wed Jul 17 00:27:13 1996 Lars Magne Ingebrigtsen - - * message.el (message-mode-abbrev-table): New variable. - (message-mode): New variable. - -Wed Jul 17 00:05:00 1996 Lars Magne Ingebrigtsen - - * gnus.el: Gnus v5.2.36 is released. - -Tue Jul 16 20:05:49 1996 Lars Magne Ingebrigtsen - - * message.el (message-send-mail): Bugged out under Emacs. - (message-send-news): Ditto. - - * nntp.el (nntp-retrieve-headers-with-xover): Would hang - sometimes. - -Sun Jul 14 20:01:26 1996 Lars Magne Ingebrigtsen - - * gnus.el: Gnus v5.2.35 is released. - -Sun Jul 14 18:21:14 1996 Lars Magne Ingebrigtsen - - * gnus-uu.el (gnus-uu-mark-over): Would bug out. - - * smiley.el (smiley-regexp-alist): New definition didn't work. - -Sun Jul 14 16:52:31 1996 Lars Magne Ingebrigtsen - - * gnus.el ((provide 'gnus)): Make sure `gnus-directory' is set - when compiling. - -Sun Jul 14 15:38:21 1996 Lars Magne Ingebrigtsen - - * gnus.el: autoload `gnus-copy-article-buffer'. - - * message.el (message-do-send-housekeeping): Kill a superfluous - buffers. - - * gnus-picon.el (gnus-article-display-picons): Don't bug out on - nil addresses. - - * custom.el ((fboundp 'plist-get)): Removed. - ((fboundp 'add-to-list)): Removed. - -Sun Jul 14 15:30:27 1996 Martin Buchholz - - * gnus.el: Many typo fixes. - -Thu Jul 11 18:06:24 1996 Lars Magne Ingebrigtsen - - * nntp.el (nntp-retrieve-headers-with-xover): - `accept-process-output' from `nntp-server-process'. - -Tue Jul 9 07:51:31 1996 Lars Magne Ingebrigtsen - - * gnus-vis.el (gnus-group-make-menu-bar): Un-randomize. - -Mon Jul 8 09:53:39 1996 Lars Magne Ingebrigtsen - - * gnus.el (gnus-decode-rfc1522): Goto point-min before decoding. - -Mon Jul 8 08:53:50 1996 Nat Makarevitch - - * smiley.el (smiley-regexp-alist): New definition. - -Sun Jul 7 13:33:44 1996 Sudish Joseph - - * nnmail.el (nnmail-split-fancy-syntax-table): `%' should have - punctuation syntax to support the %-hack in addresses. - -Sat Jul 6 08:11:41 1996 Lars Magne Ingebrigtsen - - * gnus.el: Gnus v5.2.34 is released. - -Sat Jul 6 05:46:12 1996 Lars Magne Ingebrigtsen - - * nnheader.el (nnheader-re-read-dir): Would sometimes bug out. - -Fri Jul 5 03:14:43 1996 Lars Magne Ingebrigtsen - - * gnus.el (gnus-summary-toggle-threads): Message the state. - -Thu Jul 4 07:52:07 1996 Lars Magne Ingebrigtsen - - * gnus.el: Gnus v5.2.33 is released. - -Thu Jul 4 06:08:11 1996 Lars Magne Ingebrigtsen - - * nntp.el (nntp-open-telnet): Working function. - (nntp-telnet-parameters, (nntp-telnet-user-name, - nntp-telnet-passwd): New variables. - - * gnus.el (gnus-summary-prepare-threads): Would infloop. - (gnus-summary-isearch-article): Don't go to the start of the - article. - -Thu Jul 4 05:44:22 1996 Steven L. Baur - - * gnus.el (gnus-article-hide-pem): New command and keystroke. - -Thu Jul 4 05:00:58 1996 Lars Magne Ingebrigtsen - - * gnus.el (gnus-summary-local-variables): Init reffed to 0. - (gnus-set-global-variables): Set reffed. - -Wed Jul 3 06:15:28 1996 Lars Magne Ingebrigtsen - - * gnus.el (gnus-reffed-article-number): Make buffer-local. - -Wed Jul 3 03:17:42 1996 Lars Magne Ingebrigtsen - - * gnus.el (gnus-article-setup-buffer): Make the original buffer go - away on exit. - - * message.el (message-reply): Insert proper number of commas. - (message-tokenize-header): Tokenize properly. - -Wed Jul 3 03:01:59 1996 Joe Wells - - * gnus.el (gnus-check-new-newsgroups): Doc fix. - -Wed Jul 3 02:58:09 1996 Lars Magne Ingebrigtsen - - * gnus.el: Gnus v5.2.33 is released. - -Wed Jul 3 00:27:35 1996 Jan Vroonhof - - * nnheader.el (nnheader-re-read-dir): Prefer efs over ange-ftp. - -Sun Jun 30 23:19:38 1996 Lars Magne Ingebrigtsen - - * gnus.el: Gnus v5.2.32 is released. - -Sun Jun 30 21:57:31 1996 Lars Magne Ingebrigtsen - - * gnus.el (gnus-check-bogus-groups-hook): New hook. - -Sun Jun 30 21:54:46 1996 Joe Wells - - * gnus-topic.el (gnus-topic-clean-alist): New function. - -Sun Jun 30 20:00:18 1996 Lars Magne Ingebrigtsen - - * gnus.el (gnus-group-next-unread-group): Allow silence. - - * gnus-cache.el (gnus-cache-possibly-alter-active): Would check - the obarray. - - * gnus.el (gnus-summary-read-group): Don't signal an error when - including expunged articles. - - * gnus-vis.el (gnus-header-button-alist): Would include ":". - - * message.el (message-reply): Inhibit point-motion hooks. - - * gnus.el (gnus-compile): Mark the .newsrc.eld file as dirty. - - * gnus-scomo.el: Renamed to "score-mode". - -Sat Jun 29 01:03:19 1996 Lars Magne Ingebrigtsen - - * gnus.el: Gnus v5.2.30 is released. - -Sat Jun 29 00:23:44 1996 Lars Magne Ingebrigtsen - - * gnus.el (gnus-article-read-summary-keys): Deal with message - composition more gracefully. - -Fri Jun 28 23:58:37 1996 Lars Magne Ingebrigtsen - - * gnus.el (gnus-group-describe-group): Re-read when given a - prefix. - -Fri Jun 28 23:34:17 1996 Lars Magne Ingebrigtsen - - * gnus.el (gnus-group-kill-level): Put groups on killed list. - - * nnfolder.el (nnfolder-read-folder): Would bug out when group not - in active file. - -Fri Jun 28 22:42:49 1996 Lars Magne Ingebrigtsen - - * gnus-score.el (gnus-summary-score-entry): Get rid of text - props. - - * gnus.el (gnus-article-read-summary-keys): Allow `A RET' to work - properly. - (gnus-summary-limit): Inhibit marking low-scored articles as - read. - - * gnus-msg.el (gnus-article-mail): Reply from the right address. - (gnus-article-mail): Yank properly. - - * gnus.el (gnus-article-mode-map): Entry for info find node. - (gnus-summary-describe-briefly): Display proper message. - - * smiley.el (smiley-circle-color): Doc fix. - - * gnus.el (gnus-summary-prepare-threads): Would display expunged - articles after a dummy line. - (gnus-group-faq-directory): Doc fix. - (gnus-summary-mode): Clear moved inboxes. - -Fri Jun 28 21:48:27 1996 Steven L. Baur - - * earcon.el: New file. - - * gnus-sound.el: New file. - -Fri Jun 28 04:02:25 1996 Lars Magne Ingebrigtsen - - * gnus.el: Gnus v5.2.29 is released. - -Thu Jun 27 23:14:54 1996 Lars Magne Ingebrigtsen - - * browse-url.el: Removed from distribution. - - * nnmh.el (nnmh-request-group): Re-read dir. - -Thu Jun 27 23:13:17 1996 Andy Norman - - * nnheader.el (nnheader-re-read-dir): New function. - -Thu Jun 27 21:50:16 1996 Lars Magne Ingebrigtsen - - * gnus.el (gnus-summary-next-article): Would stall on canceled - articles. - (gnus-dribble-enter): Would bury the wrong buffer. - - * gnus-score.el (gnus-score-followup-thread, - gnus-score-followup-article): Would switch to wrong buffer. - - * gnus.el (gnus-adjust-marked-articles): Possible fix for killed - articles. - (gnus-subscribe-hierarchically): Kill .newsrc buffer. - - * gnus-nocem.el (gnus-nocem-check-article): Would not search - properly. - -Thu Jun 27 21:50:16 1996 Lars Magne Ingebrigtsen - - * gnus.el: Gnus v5.2.28 is released. - -Thu Jun 27 23:33:18 1996 Lars Magne Ingebrigtsen - - * nnmail.el (nnmail-get-spool-files): Wouldn't get much mail. - -Thu Jun 27 19:26:42 1996 Lars Magne Ingebrigtsen - - * nnheader.el (nnheader-find-etc-directory): New function. - - * gnus.el (gnus-dribble-enter): Bury the buffer. - (gnus-buffer-configuration): Redundant entry. - (message): Don't require. - (gnus-archive-server-wanted-p): Be even more strict in when touse - the archive server. - -Thu Jun 27 19:16:56 1996 Katsumi Yamaoka - - * nnheader.el (nnheader-file-size): New function. - -Wed Jun 26 22:14:45 1996 Alastair Burt - - * gnus.el (gnus-group-kill-level): Applied `car' to an integer. - -Wed Jun 26 21:53:34 1996 Lars Magne Ingebrigtsen - - * gnus.el: Gnus v5.2.27 is released. - -Wed Jun 26 20:40:39 1996 Lars Magne Ingebrigtsen - - * gnus.el (gnus-summary-edit-article-done): Don't beep after a - `C-u e'. - - * message.el (message-autosave-directory): New default value. - - * gnus-cache.el (gnus-cache-open): Don't create cache things - unconditionally. - - * gnus.el (gnus-server-status): New function. - (gnus-group-get-new-news-this-group): Better error message. - (gnus-clear-system): Clear state alist. - (gnus-error): Doc fix. - - * nnmail.el (nnmail-get-spool-files): Use the spool file even when - using procmail. - -Wed Jun 26 20:36:40 1996 Philippe Troin - - * gnus.el (gnus-thread-total-score-1): New version. - -Wed Jun 26 20:31:25 1996 Lars Magne Ingebrigtsen - - * nnspool.el (nnspool-find-id): Quote the Message-ID. - - * message.el (message-check-news-syntax): Would respond to - i-have-a-mi-etc in References. - -Wed Jun 26 19:59:27 1996 Nat Makarevitch - - * smiley.el (smiley-regexp-alist): New definition. - -Wed Jun 26 17:45:00 1996 Lars Magne Ingebrigtsen - - * message.el (message-reply): Name the message buffer "wide - reply..." if following up on a mail group. - - * gnus.el (gnus-auto-subscribed-groups): Doc fix. - (gnus-options-subscribe): Doc fix. - - * smiley.el (smiley-buffer): Autoload. - (messagexmas): Required. - - * gnus.el (gnus-message-archive-group): Moved here. - (gnus-archive-server-wanted-p): New function used throughout. - (gnus-message-archive-group): Default to nil. - -Tue Jun 25 21:15:41 1996 Lars Magne Ingebrigtsen - - * gnus.el: Gnus v5.3 is released. - -Tue Jun 25 21:13:37 1996 Lars Magne Ingebrigtsen - - * gnus.el: Gnus v5.2.26 is released. - -Tue Jun 25 20:58:40 1996 Richard Stallman - - * gnus-ems.el: Multiply color value by .6 instead of dividing by - 3. - -Tue Jun 25 12:34:24 1996 Lars Magne Ingebrigtsen - - * message.el (message-send-news): Disable `existing-groups' check - when given a prefix. - -Mon Jun 24 16:54:26 1996 Alastair Burt - - * gnus-vis.el (gnus-summary-highlight-line): `default' mixed up - with fonts. - -Sat Jun 22 13:56:49 1996 Lars Magne Ingebrigtsen - - * gnus-cite.el (gnus-cache-close): New function. - -Sat Jun 22 11:33:42 1996 Lars Magne Ingebrigtsen - - * gnus.el: Gnus v5.2.25 is released. - -Sat Jun 22 11:16:57 1996 Lars Magne Ingebrigtsen - - * gnus.el (gnus-adjust-marked-articles): Would bug out on some - bookmarks. - -Sat Jun 22 11:13:51 1996 Raja R. Harinath - - * gnus.el (gnus-summary-save-body-in-file): Saved wrong buffer. - -Sat Jun 22 10:57:35 1996 Lars Magne Ingebrigtsen - - * gnus.el (gnus-thread-total-score-1): Replaced with old, - non-buggy version. - - * gnus-xmas.el ((find-face 'gnus-x-face)): Set proper colors. - -Fri Jun 21 18:04:03 1996 Lars Magne Ingebrigtsen - - * gnus.el: Gnus v5.2.24 is released. - -Fri Jun 21 16:36:03 1996 Christoph Wedler - - * gnus-picon.el (gnus-picons-insert-face-if-exists): Total change. - Didn't conform with the conventions for picon databases. Still a - bit (MISC must be searched for explicitly), but otherwise we would - always see the MISC/unknown face. Faster. - (gnus-article-display-picons): Use accordingly. - (gnus-group-display-picons): Use accordingly. - (gnus-picons-try-to-find-face): Optional argument for not using - `gnus-picons-glyph-alist'--otherwise we would always see the same - x-face. - (gnus-picons-display-x-face): Use it. - (gnus-picons-reverse-domain-path): Deletia. - -Fri Jun 21 15:14:33 1996 Lars Magne Ingebrigtsen - - * gnus-vis.el (gnus-group-make-menu-bar): Fix the menu bar - slightly. - - * gnus.el (gnus-thread-total-score-1): Didn't count right. - - * message.el (message-bounce): Would not skip past all blank - lines. - - * gnus.el (gnus-directory): Removed autoload. - (gnus-activate-group): Pass the `method' argument on. - -Fri Jun 21 09:41:53 1996 Hrvoje Niksic - - * gnus-vis.el (gnus-button-alist): Exclude > from mailto button. - -Fri Jun 21 09:37:39 1996 Lars Magne Ingebrigtsen - - * gnus.el (gnus-article-mode-map): `end-of-bnuffer'. :-) - -Fri Jun 21 09:34:29 1996 Philippe Troin - - * gnus.el (gnus-thread-total-score-1): Don't count non-displayed - articles. - -Fri Jun 21 09:21:11 1996 Lars Magne Ingebrigtsen - - * nnheader.el (nnheader-translate-file-chars): Would give faulty - results on NTs. - -Fri Jun 21 09:08:48 1996 Philippe Troin - - * gnus-cite.el (gnus-article-hide-citation): Would sometimes bug - out. - -Fri Jun 21 09:01:51 1996 Lars Magne Ingebrigtsen - - * gnus-msg.el (gnus-copy-article-buffer): Would include text - properties on XEmacs. - -Thu Jun 20 18:38:07 1996 Lars Magne Ingebrigtsen - - * message.el (message-mode): Took `C-n' expansion out. - -Thu Jun 20 18:35:22 1996 Lars Magne Ingebrigtsen - - * gnus.el: Gnus v5.2.23 is released. - -Thu Jun 20 15:43:50 1996 Lars Magne Ingebrigtsen - - * gnus-picon.el (gnus-article-display-picons): Use a "\n" - annotation instead of opening a line. - - * gnus.el (gnus-summary-reselect-current-group): Be silent. - - * nnml.el (nnml-request-replace-article): Update the Lines header - before writing the article to disk. - - * gnus-vis.el (gnus-button-reply): Use the address in the mailto - URL. - - * nnheader.el (nnheader-translate-file-chars): Would fail on NT. - (nnheader-directory-files-safe): New function. - (nnheader-directory-articles): Use it. - (nnheader-article-to-file-alist): Use it. - - * gnus.el (gnus-read-move-group-name): Activate group after - creating it. - - * gnus-cite.el (gnus-article-fill-cited-article): Would bug out on - empty articles. - - * message.el (message-insert-signature): Don't strip trailing - white space. - - * gnus-picon.el (gnus-picons-insert-face-if-exists): Don't insert - so many bars. - - * message.el (message-mode): Define more abbrev keys. - - * gnus-picon.el (gnus-article-display-picons): Would bug out on - some usernames. - - * gnus-xmas.el (gnus-xmas-copy-article-buffer): Removed. - -Thu Jun 20 09:38:54 1996 Lars Magne Ingebrigtsen - - * gnus.el (gnus-kill-gnus-frames): New function. - (gnus-clear-system): Use it. - (gnus-group-suspend): Ditto. - - * message.el (message-check-news-syntax): Better checksumming. - (message-checksum): Better checksum. - - * gnus-salt.el (gnus-tree-minimize): Never delete any other - windows. - -Wed Jun 19 19:44:46 1996 Christoph Wedler - - * gnus-picon.el (gnus-article-display-picons): Lowercase username. - (gnus-picons-reverse-domain-path): Lowercase domain path. - (gnus-picons-display-article-move-p): New user option. - (gnus-article-display-picons): Use it. - (gnus-group-display-picons): Use it. - -Wed Jun 19 19:31:56 1996 Lars Magne Ingebrigtsen - - * gnus.el: Gnus v5.2.22 is released. - -Wed Jun 19 18:53:46 1996 Lars Magne Ingebrigtsen - - * gnus-picon.el (gnus-group-display-picons): Insert a bar. - - * gnus-xmas.el (gnus-xmas-redefine): On XEmacs 19.13, set - `shell-command-switch'. - - * gnus.el (gnus-summary-work-articles): Use numeric value of - `C-u'. - -Wed Jun 19 18:36:23 1996 Christopher Davis - - * message.el (message-mode): Add signature separator. - (message-insert-signature): Check whether a signature is present. - -Wed Jun 19 17:29:07 1996 Lars Magne Ingebrigtsen - - * nnmh.el (nnmh-request-move-article): Make sure we change back to - the right directory. - - * gnus-picon.el (gnus-article-display-picons): Make sure the - buffer is created. - -Wed Jun 19 16:58:21 1996 Lars Magne Ingebrigtsen - - * gnus.el: Gnus v5.2.21 is released. - -Wed Jun 19 15:39:09 1996 Lars Magne Ingebrigtsen - - * gnus-picon.el (gnus-picons-glyph-alist): New variable. - (gnus-picons-try-to-find-face): Use it. - (gnus-picons-close): New function. - - * gnus.el (gnus-group-set-mode-line): After saving the .newsrc, - mark the group buffer as unmodified. - (gnus-group-name-to-method): New function. - (gnus-read-move-group-name): Use it. - (gnus-info-nodes): Add more modes. - (gnus-windows-old-to-new): Would produce invalid configurations. - -Wed Jun 19 15:36:35 1996 Philippe Troin - - * gnus-score.el (gnus-score-load-file): Would bug out on - directories not ending with a /. - -Wed Jun 19 14:46:42 1996 Lars Magne Ingebrigtsen - - * gnus.el (gnus-article-mode-map): Bind `<' and `>'. - (gnus-group-expire-articles): Close group after expiring. - - * gnus-xmas.el (gnus-xmas-redefine): Don't do the mode-line things - for XEmacs 19.13. - -Wed Jun 19 14:09:21 1996 Chuck Thompson - - * gnus-xmas.el (gnus-xmas-summary-recenter): Removed the - `sit-for'. - -Wed Jun 19 13:15:05 1996 Lars Magne Ingebrigtsen - - * gnus-picon.el (gnus-picons-get-maximum-picons): Removed. - (gnus-picons-file-suffixes): New variable. - (gnus-picons-try-suffixes): New substs. - (gnus-article-display-picons): Would sometimes insert double - picons. - (gnus-picons-try-to-find-face): Insert some air. - (gnus-picons-insert-face-if-exists): Don't stat so many files. - -Tue Jun 18 18:40:36 1996 Lars Magne Ingebrigtsen - - * gnus.el: Gnus v5.2.20 is released. - -Tue Jun 18 12:24:34 1996 Lars Magne Ingebrigtsen - - * gnus-xmas.el (gnus-xmas-group-startup-message): Fix mode line. - - * gnus-picon.el (gnus-article-display-picons): When displaying in - the article buffer, insert picon in separator line. - (gnus-article-display-picons): Get more picons. - (gnus-picons-insert-face-if-exists): New implementation. - (gnus-picons-get-maximum-picons): New variable. - - * gnus-xmas.el (gnus-xmas-summary-menu-add): Change order. - - * messagexmas.el (message-toolbar): Go to message info. - - * gnus-xmas.el (gnus-xmas-mode-line-buffer-identification): New - function. - - * gnus-ems.el (gnus-mode-line-buffer-identification): New alias. - - * gnus-xmas.el (gnus-xmas-article-show-hidden-text): New function. - - * smiley.el (smiley-regexp-alist): Require whitespace before - smiley. - - * gnus-xmas.el (gnus-xmas-article-display-xface): Use new - `gnus-x-face' face. - - * smiley.el (smiley-end-paren-p): New function. - (smiley-buffer): Use it. - - * gnus.el (gnus-group-update-group-line): Protect against nil - groups. - - * nntp.el (nntp-open-server-semi-internal): Better error message. - - * gnus.el (gnus-get-function): Accept a noerror param. - (gnus-request-head): Use it. - - * messagexmas.el (message-xmas-setup-toolbar): Would bug out on - second run. - -Tue Jun 18 09:48:12 1996 Lars Magne Ingebrigtsen - - * gnus-xmas.el (gnus-xmas-article-display-xface): Insert X-Face - after From:. - (gnus-summary-toolbar): New exit tool. - -Tue Jun 18 09:46:57 1996 Chuck Thompson - - * custom.el (custom-face-import): Check for face name. - -Tue Jun 18 06:23:45 1996 Lars Magne Ingebrigtsen - - * gnus.el (gnus-execute-command): Use `shell-command-name'. - - * gnus-uu.el (gnus-uu-treat-archive): Use `shell-command-switch'. - - * gnus.el (gnus-summary-mode-line-format-alist): Would break on - %U. - - * message.el (message-setup): Delete excess line. - - * nnmh.el (nnmh-request-list-1): Regexp-quote file name. - -Mon Jun 17 04:38:16 1996 Lars Magne Ingebrigtsen - - * gnus-score.el (gnus-summary-increase-score): Always kill the - score help buffer. - (gnus-score-insert-help): Only insert scores on relevant match - types. - - * message.el (message-send-news): Cleanup headers. - - * gnus-picon.el (gnus-group-display-picons): Make sure the buffer - is created. - - * smiley.el (annotations): Required. - - * nnmail.el (nnmail-move-inbox): Didn't push proper file onto list - of moved inboxes. - - * gnus-msg.el (gnus-copy-article-buffer): Exclude "From " lines. - -Sun Jun 16 08:18:18 1996 Barry A. Warsaw - - * gnus.el (gnus-read-save-file-name): Better prompting. - -Sun Jun 16 01:18:18 1996 Lars Magne Ingebrigtsen - - * gnus.el (gnus-request-head): Support fetching heads from all - backends. - (gnus-read-header): Use it. - (gnus-header-value): No continuation headers. - (gnus-summary-mark-article-as-unread): Beep on unmarkable - articles. - - * nnspool.el (nnspool-request-head): Fold continuation lines. - * nntp.el (nntp-request-head): Ditto. - - * gnus.el (gnus-group-delete-group): Dox fix. - (gnus-summary-prepare-threads): Output saved mark. - (gnus-summary-reselect-current-group): Ding on ephemeral groups. - - * nnmail.el (nnmail-internal-password): Cache password. - - * message.el (message-buffer-name): Better non-group news name. - (message-insert-to): Don't insert ", , ,". - (message-insert-newsgroups): Ditto. - - * gnus-srvr.el (gnus-server-set-status): New function. - (gnus-server-close-server): Use it. - (gnus-server-update-server): Update browsed servers. - -Sat Jun 15 11:32:14 1996 Lars Magne Ingebrigtsen - - * smiley.el (smiley-circle-color): New variable. - - * gnus-xmas.el (gnus-xmas-highlight-selected-summary): Only use on - XEmacs 19.13. - -Sat Jun 15 09:07:05 1996 Lars Magne Ingebrigtsen - - * gnus.el: Gnus v5.2.18-19 is released. - -Sat Jun 15 10:44:16 1996 Lars Magne Ingebrigtsen - - * smiley.el: Included in distribution. - -Sat Jun 15 06:25:19 1996 Lars Magne Ingebrigtsen - - * custom.el (custom-xmas-set-text-properties): Ignore string - props. - -Sat Jun 15 03:12:58 1996 Lars Magne Ingebrigtsen - - * nnvirtual.el (nnvirtual-request-update-mark): Would bug out on - pseudos. - - * gnus.el (gnus-read-descriptions-file): Insert prefix for foreign - groups. - (gnus-group-describe-group): Just `force' the current group. - -Sat Jun 15 02:43:29 1996 Christopher Davis - - * message.el (message-mode): Have signature separator be paragraph - separator. - -Sat Jun 15 02:26:08 1996 Lars Magne Ingebrigtsen - - * messagexmas.el (message-exchange-point-and-mark): fset to xmas. - -Sat Jun 15 01:59:08 1996 lantz moore - - * gnus-msg.el (gnus-inews-insert-archive-gcc): Don't insert spaces - at the end. - -Sat Jun 15 01:58:17 1996 Lars Magne Ingebrigtsen - - * message.el (message-tokenize-header): Would return empty - strings. - -Thu Jun 13 18:26:34 1996 Christoph Wedler - - * gnus-scomo.el (gnus-score-make-menu-bar): Correct Exit function. - - * gnus-score.el (gnus-score-edit-file): Correct message. - - * gnus-srvr.el (gnus-server-make-menu-bar): Use two symbols for - two menus. - - * gnus-xmas.el (gnus-xmas-score-menu-add): New function. - (gnus-xmas-redefine): Use it. - (gnus-xmas-server-menu-add): Add two menus. - - * nnfolder.el (nnfolder-generate-active-file): Use other function - to read file (not sure whether this is OK, but now it worked for - me, even with VM folders) - (nnfolder-read-folder): delete oldactive (never used) - -Sat Jun 15 00:45:53 1996 Lars Magne Ingebrigtsen - - * messagexmas.el (message-xmas-setup-toolbar): If one icon doesn't - exist, report a failure. - - * nnmh.el (nnmh-request-expire-articles): Message errors. - -Fri Jun 14 13:06:43 1996 Steven L Baur - - * message.el (message-yank-original): Used misnamed wrapper - function. - - * messagexmas.el (message-xmas-exchange-point-and-mark): Used - misnamed control variable. - -Fri Jun 14 06:24:02 1996 Lars Magne Ingebrigtsen - - * gnus.el: Gnus v5.2.17 is released. - -Fri Jun 14 05:16:14 1996 Lars Magne Ingebrigtsen - - * gnus-xmas.el (gnus-xmas-call-region): New function. - - * nnheaderxm.el (nnheader-xmas-find-file-noselect): Simplify. - -Fri Jun 14 04:30:30 1996 Steven L. Baur - - * messagexmas.el (message-xmas-exchange-point-and-mark): New - function. - (message-xmas-dont-activate-region): New variable. - -Fri Jun 14 02:59:30 1996 Lars Magne Ingebrigtsen - - * gnus.el (gnus-summary-next-article): Check for nil cmd. - - * gnus-xmas.el (gnus-xmas-group-startup-message): Use xbm if that - is required. - - * messagexmas.el (message-xmas-setup-toolbar): Make sure all - buttons are defined. - - * gnus-xmas.el (gnus-summary-mail-toolbar): Add other icons. - (gnus-summary-toolbar): Add next/prev/catchup icons. - - * gnus-xmas.el: Use more native functions. - -Thu Jun 13 23:40:45 1996 Steven L. Baur - - * messagexmas.el (message-use-toolbar): Check for toolbar - support. - -Thu Jun 13 22:35:43 1996 Lars Magne Ingebrigtsen - - * gnus-score.el (gnus-newsgroup-score-alist): New function. - - * gnus.el (gnus-simplify-buffer-fuzzy): Use folded search. - - * message.el (message-tokenize-header): Respect quotes. - - * gnus.el (gnus-group-kill-group): Mass killing didn't work. - - * gnus-demon.el (gnus-demon-scan-mail): Make sure the server is - openable. - -Thu Jun 13 02:41:11 1996 Lars Magne Ingebrigtsen - - * gnus.el: Gnus v5.2.16 is released. - -Thu Jun 13 02:28:26 1996 Lars Magne Ingebrigtsen - - * nnheader.el (nnheader-insert-nov): Fudge a message-id if - necessary. - - * nnml.el (nnml-request-accept-article): Use it. - - * nnmail.el (nnmail-check-syntax): New function. - - * gnus.el (gnus-group-fetch-faq): Would bug out when not called in - the group buffer. - (gnus-use-long-file-name): Doc fix. - (gnus-summary-search-article): Search backward from where we left - off. - - * gnus-xmas.el (gnus-xmas-server-menu-add): New function. - (gnus-xmas-browse-menu-add): Ditto. - -Wed Jun 12 18:32:57 1996 Christoph Wedler - - * gnus-srvr.el (gnus-server-make-menu-bar): Use - `gnus-server-deny-server' - -Wed Jun 12 23:02:19 1996 Lars Magne Ingebrigtsen - - * message.el (message-send-rename-function): New variable. - (message-do-send-housekeeping): Use it. - -Wed Jun 12 22:53:32 1996 Richard Mlynarik - - * message.el (message-make-fqdn): Make sure `user-mail-address' - and `mail-host-address' looks like a full address. - -Wed Jun 12 22:06:39 1996 Lars Magne Ingebrigtsen - - * message.el (message-generate-new-buffers): Extended syntax. - (message-buffer-name): Use it. - (message-make-fqdn): Checked `user-mail-address' directly. - (message-check-news-syntax): Check for misconfiguration. - - * nnmail.el (nnmail-move-inbox): Use it. - -Wed Jun 12 22:06:10 1996 Richard Pieri - - * nnmail.el (nnmail-read-password): New function. - -Wed Jun 12 21:59:40 1996 Lars Magne Ingebrigtsen - - * message.el (message-send): Make buffer read/write before - sending. - - * gnus-score.el (gnus-score-edit-current-scores): Correct - message. - -Wed Jun 12 19:31:50 1996 Lars Magne Ingebrigtsen - - * gnus-msg.el (gnus-inews-insert-archive-gcc): If ":" in name, - just use name. - (gnus-message-archive-group): Doc fix. - - * nnmail.el (nnmail-split-it): Regexp bogosity. - - * gnus-vis.el (gnus-button-alist): Have "news:" rule come before - URL rule. - - * message.el (message-setup): Really be read-only. - - * gnus.el (gnus-summary-import-article): Use message. - -Tue Jun 11 10:04:55 1996 Lars Magne Ingebrigtsen - - * message.el (message-make-fqdm): Use `mail-host-address' before - `user-mail-address'. - (message-make-fqdn): Typo is function name. - - * nndb.el: Make byte-compiler silent. - -Tue Jun 11 02:29:33 1996 Lars Magne Ingebrigtsen - - * gnus.el: Gnus v5.2.15 is released. - - * gnus-score.el (gnus-score-find-trace): Erase contents first. - - * nntp.el (nntp-send-region-to-server): Make sure the server is - up. - - * gnus.el (gnus-summary-edit-article-done): Reversed parameters. - - * nnheaderxm.el: Renamed. - - * nnmail.el ((eq system-type 'windows-nt)): Moved here. - -Tue Jun 11 02:11:30 1996 Lars Magne Ingebrigtsen - - * nnmail.el (nnmail-pop-password): New variable. - (nnmail-pop-password-required): New variable. - (nnmail-move-inbox): Use them. - -Mon Jun 10 21:40:13 1996 Lars Magne Ingebrigtsen - - * gnus-xmas.el (gnus-xmas-summary-recenter): Don't sit-for on - XEmacs 19.13. - - * gnus-picon.el (gnus-group-display-picons): `set-to-buffer'? - - * gnus.el (gnus-articles-to-read): Don't prompt for scored unless - there are many unscored ones. - (gnus-read-move-group-name): Prompt when group doesn't exist. - (gnus-output-to-file): New implementation. - (gnus-summary-save-article): Would duplicate while saving. - (gnus-summary-save-article): Prompts wouldn't be remembered. - (gnus-article-hide-headers): Inhibit point motion hooks. - -Mon Jun 10 05:20:24 1996 Lars Magne Ingebrigtsen - - * gnus.el: Gnus v5.2.14 is released. - - * gnus-cus.el (()): Display X face by default. - - * gnus-xmas.el (gnus-article-x-face-command): New default. - - * gnus-ems.el: Moved x-face. - - * gnus-xmas.el (gnus-xmas-article-display-xface): New function. - -Mon Jun 10 03:08:10 1996 Lars Magne Ingebrigtsen - - * gnus.el: Gnus v5.2.13 is released. - - * gnus-cus.el (()): Changed LemonChiffon to Turquoise. - - * message.el (message-signature-setup-hook): New hook. - - * gnus-xmas.el (gnus-xmas-summary-recenter): `sit-for' for right - height. - -Mon Jun 10 00:02:15 1996 Lars Magne Ingebrigtsen - - * gnus.el (gnus-article-check-hidden-text): New definition. - (gnus-hidden-arg): New function. - (gnus-article-hide-headers): Don't toggle when called - non-interactively. - - * messagexmas.el (message-xmas-setup-toolbar): Use xbms. - - * gnus-score.el (gnus-score-file-regexp): Regexp-quote suffixes. - (gnus-score-load-file): Wouldn't set `adapt-file' right. - - * gnus-xmas.el (gnus-xmas-logo-color-alist): Removed double "##". - - * gnus-score.el (gnus-score-find-bnews): Deal with "++". - -Sun Jun 9 22:18:05 1996 Lars Magne Ingebrigtsen - - * gnus-score.el (gnus-score-find-trace): Don't error, just beep. - - * gnus-cite.el (gnus-cite-minimum-match-count): Changed default to - 2. - -Sun Jun 9 05:48:18 1996 Lars Magne Ingebrigtsen - - * gnus.el (gnus-message-archive-method): Dox fix. - - * message.el (message-check-news-syntax): Allow + and _ in group - names. - - * gnus.el (gnus-group-fetch-faq): Didn't allow completion. - -Sun Jun 9 05:36:16 1996 Hrvoje Niksic - - * message.el (message-ignored-supersedes-headers): New default. - -Sun Jun 9 05:17:34 1996 Lars Magne Ingebrigtsen - - * gnus-score.el (gnus-score-score-files-1): Don't match on "/" in - file names. - * nnml.el (nnml-generate-nov-databases-1): Ditto. - * nnmh.el (nnmh-request-list-1): Ditto. - * gnus-uu.el (gnus-uu-scan-directory): Ditto. - - * nnheaderems.el: Strip CR on windows-nt. - -Sun Jun 9 05:15:13 1996 Dave Disser - - * gnus-picon.el (gnus-group-display-picons): Set instead of - switching buffer. - -Sun Jun 9 05:08:51 1996 Lars Magne Ingebrigtsen - - * gnus.el (gnus-article-read-summary-keys): Don't save winconf on - "|". - - * nnmail.el (nnmail-delete-incoming): Changed default. - - * gnus.el (gnus-eval-in-buffer-window): Indent correctly. - -Sat Jun 8 19:24:24 1996 Lars Magne Ingebrigtsen - - * gnus-cite.el (gnus-cite-minimum-match-count): Changed default. - -Fri Jun 7 22:08:53 1996 Lars Magne Ingebrigtsen - - * gnus.el: Gnus v5.2.12 is released. - - * gnus.el (gnus-summary-refer-article): Would bug out when - referring non-sparse articles. - -Fri Jun 7 19:59:45 1996 Lars Magne Ingebrigtsen - - * gnus.el: Gnus v5.2.11 is released. - - * gnus.el (gnus-summary-save-article): Would set - `gnus-original-article-buffer' to a bogus value. - (gnus-header-value): Didn't understand continuation headers! - (gnus-get-newsgroup-headers): Use new value and pick out - references when `^'. - (gnus-number-to-header): New function. - (gnus-summary-refer-article): Didn't work when sparse articles - were in action. - -Fri Jun 7 17:19:21 1996 Christoph Wedler - - * nnheader.el (nnheader-insert-head): Use - `nnheader-insert-file-contents-literally'. - (nnheader-mail-file-mbox-p): Ditto. - -Fri Jun 7 14:05:28 1996 Jens Lautenbacher - - * custom.el ((string-match "XEmacs" emacs-version)): dito - - * gnus-vis.el (gnus-group-make-menu-bar): enable customize for XEmacs - -Fri Jun 7 19:20:22 1996 Richard Pieri - - * nnheaderems.el (nnheader-ms-strip-cr): New function. - -Thu Jun 6 18:22:04 1996 Lars Magne Ingebrigtsen - - * gnus.el: Gnus v5.2.10 is released. - - * message.el (message-header-format-alist): Use - `message-fill-address' for To and Cc. - (message-fill-address): New function. - - * gnus.el (gnus-article-check-hidden-text): Respect a postive - arg. - (gnus-summary-save-article): Remove headers from the original - article buffer. - (gnus-article-hide-headers): Delete "From " if wanted. - - * nnmail.el (nnmail-load-hook): Run hooks. - -Thu Jun 6 14:41:20 1996 Lars Magne Ingebrigtsen - - * message.el (message-check-news-syntax): Don't warn on "poster". - -Wed Jun 5 20:22:48 1996 Lars Magne Ingebrigtsen - - * gnus.el: Gnus v5.2.9 is released. - - * message.el (message-setup): Add Mailcrypt magic. - -Wed Jun 5 18:01:58 1996 Lars Magne Ingebrigtsen - - * gnus-cus.el (()): New colors. - - * gnus-xmas.el (gnus-xmas-group-startup-message): Would bug out - when compiled without XPM support. - -Wed Jun 5 17:17:00 1996 Lars Magne Ingebrigtsen - - * gnus.el: Gnus v5.2.8 is released. - - * nndoc.el (nndoc-type-alist): New babyl head begin. - (nndoc-babyl-head-begin): New function. - -Wed Jun 5 16:26:55 1996 Lars Magne Ingebrigtsen - - * gnus.el (gnus-summary-save-article): Remove headers. - -Wed Jun 5 18:16:55 1996 Lars Magne Ingebrigtsen - - * gnus.el (gnus-read-old-newsrc-el-file): Would bug out. - -Wed Jun 5 12:43:22 1996 Lars Magne Ingebrigtsen - - * gnus-score.el: `V f' to flush the cache. - (gnus-score-flush-cache): Save scores before flushing. - - * gnus-cite.el (gnus-cite-prefix-regexp): Removed "-" as cite - prefix. - - * gnus.el (gnus-summary-caesar-message): Use message. - - * gnus-cite.el (gnus-cite-prefix-regexp): Allow "-" as a cite - prefix. - - * nnvirtual.el (nnvirtual-convert-headers): Wouldn't convert. - - * gnus-cus.el (()): Have `gnus-mouse-face' respect gnus-visual. - -Wed Jun 5 12:52:15 1996 Lars Magne Ingebrigtsen - - * dgnushack.el (custom-file): Changed setq. - -Tue Jun 4 13:46:45 1996 Scott Byer - - * nnfolder.el (nnfolder-read-folder) Take an additional parameter, - scanning, which is t when we are only scanning for new news. In - this case, if the modtime of the file hasn't changed since we last - scanned it, we don't bother reading the file in, and simply return - nil. When we do scan it, pay attention to the - nnfolder-distrust-mbox variable, and only scan forward from the - last marked message when nil. After scanning, remember the - modtime of the visited buffer. - - * nnfolder.el (nnfolder-save-mail) If nnfolder-current-buffer is - nil, make sure any open group is closed before changing the group - - in the case where a group was opened for scanning but not read - in because it wasn't touched, this forces the read. - - * nnfolder.el (nnfolder-possibly-change-group) Take an additional - optional variable, which indicated if we're scanning. Passes it - on to nnfolder-read-folder, and is prepared for - nnfolder-read-folder to return nil for nnfolder-current-buffer. - If we get a request to change to the currently open group, and - nnfolder-current-buffer is nil (we're on the tail end of a scan), - simply return. - - * nnfolder.el (nnfolder-request-scan) Inform - nnfolder-possibly-change-group that we're scanning. - - * nnfolder.el (nnfolder-scantime-alist) New internal variable. - Keep track of the last scantime of each mbox. - - * nnfolder.el (nnfolder-distrust-mbox) New variable. When t, - nnfolder-read-folder reverts to it's old behavior of scanning an - entire file looking for unmarked messages. When nil (the - default), scans forward from the last marked message. Unless you - have an external mailer which inserts new messages in the middle - of your mailboxes, leave nil. - -Wed Jun 5 09:20:38 1996 Lars Magne Ingebrigtsen - - * message.el (message-goto-body): Expand abbrev. - -Tue Jun 4 17:12:06 1996 Lars Magne Ingebrigtsen - - * gnus.el: Gnus v5.2.7 is released. - -Tue Jun 4 18:26:24 1996 Christoph Wedler - - * message-xms.el (message-xmas-find-glyph-directory): Wouldn't use - PACKAGE-xmas-glyph-directory even if it is non-nil and a - directory. - (message-toolbar): Use special ispell function for messages. Jump - to info pages for message composition. - -Tue Jun 4 17:12:06 1996 Lars Magne Ingebrigtsen - - * message.el (rmail): Require. - -Tue Jun 4 18:11:46 1996 Lars Magne Ingebrigtsen - - * gnus-cus.el (()): Bold group faces. - -Tue Jun 4 15:10:20 1996 Lars Magne Ingebrigtsen - - * gnus-cus.el (()): Unbold group faces. - - * custom.el (custom-face-lookup): Make all parameters optional. - - * gnus.el (gnus-thread-total-score): Protect against nil input. - -Tue Jun 4 11:11:13 1996 Lars Magne Ingebrigtsen - - * gnus.el: Gnus v5.2.6 is released. - - * gnus.el (gnus-summary-make-local-variables): Set local variables - correctly. - -Tue Jun 4 07:51:02 1996 Steven L. Baur - - * gnus-cus.el (()): New "light' group highlighting. - -Tue Jun 4 07:26:10 1996 Lars Magne Ingebrigtsen - - * gnus.el (gnus-subscribe-hierarchical-interactive): Don't accept - wrong characters. - - * message.el (message-directory): Autoload. - -Mon Jun 3 07:30:18 1996 Lars Magne Ingebrigtsen - - * gnus.el (gnus-summary-make-local-variables): Separated into own - function. - (gnus-summary-make-local-variables): Respect global values. - - * nnheader.el (sendmail): Unrequired. - (backquote): Ditto. - - * nntp.el (rnews): Unrequired. - - * gnus-msg.el (gnus-group-post-news): `C-u a' posts to the group - under point, `C-u 1 a' prompts, `a' uses an empty group name. - - * message.el (message-setup): Make separator read-only. - - * gnus-cus.el (()): Define `gnus-group-highlight'. - - * gnus-vis.el (gnus-group-highlight): Commented out. - - * gnus-topic.el (gnus-topic-yank-group): Yank topics at the end of - the buffer correctly. - - * gnus-score.el (gnus-score-adaptive): Make sure we use the - buffer-local adaptive score variable. - - * gnus-msg.el (gnus-group-post-news): Prompt when given a prefix. - - * nnvirtual.el (nnvirtual-catchup-group): Might have corrupted the - list of component groups. - - * gnus-ems.el: Work under OS/2 again. - - * gnus.el (gnus-remove-header): New function. - (gnus-read-header): Use it. - (gnus-summary-insert-subject): Didn't work when editing articles - in a non-threaded display. - (gnus-summary-update-article): Would create multiple root - threads when editing. - - * message.el (message-do-send-housekeeping): Reverse check. - - * nnheader.el (backquote): Required. - - * gnus.el (backquote): Required. - - * message.el (message-make-from): Use the `user-full-name' - variable. - -Sun Jun 2 16:50:49 1996 Lars Magne Ingebrigtsen - - * message.el (message-number-of-buffers): New variable. - (message-generate-new-buffers): Changed default. - (message-do-send-housekeeping): New function. - (message-buffer-name): New function. - -Sun Jun 2 07:41:20 1996 Lars Magne Ingebrigtsen - - * gnus.el: Gnus v5.2.5 is released. - - * gnus-topic.el (gnus-topic-remove-group): Only delete first - instance. - (gnus-topic-move-group): Ditto. - (gnus-topic-change-level): Ditto. - - * gnus.el (gnus-summary-insert-subject): Do rebuilding of sparse - articles right. - (gnus-summary-update-article): Do updating of referred articles - right. - (gnus-delete-first): New function. - - * gnus-cus.el (()): Color change. - - * gnus.el (gnus-version): Accept a prefix to insert. - -Sat Jun 1 02:03:42 1996 Lars Magne Ingebrigtsen - - * custom.el: Require cl. - - * gnus.el (gnus-group-list-matching): `10 A m' to read the active - file. - - * message.el (message-supersede): Don't use - `mail-strip-quoted-names'. - (message-cancel-news): Ditto. - - * nnfolder.el (nnfolder-retrieve-headers): Don't allow selecting - empty groups. - (nnfolder-request-group): Ditto. - -Sat Jun 1 01:26:45 1996 Per Abrahamsen - - * dgnushack.el (custom-file): Nix out. - -Sat Jun 1 01:24:28 1996 Massimo Campostrini - - * gnus-cus.el (()): Wrong number of arguments. - -Fri May 31 08:32:38 1996 Lars Magne Ingebrigtsen - - * gnus.el: Removed obsolete autoloads. - - * gnus-demon.el (gnus-demon-init): Use `nnheader-run-at-time'. - - * gnus.el (gnus-group-catchup-current): Warn. - - * gnus-srvr.el (gnus-browse-foreign-server): Message better. - - * gnus-topic.el (gnus-topic-change-level): Make sure we're in the - group buffer. - - * gnus-srvr.el (gnus-server-exit-hook): New hook. - (gnus-server-exit): Use it. - - * gnus-topic.el (gnus-topic-mode): Update more. - - * gnus.el (gnus-group-update-group-hook): New hook. - (gnus-group-update-group): Use it. - -Fri May 31 04:33:16 1996 Lars Magne Ingebrigtsen - - * gnus.el: Gnus v5.2.4 is released. - - * custom.el (custom-face-lookup): Escape errors. - - * gnus-msg.el (gnus-inews-do-gcc): Don't do anything unless Gnus - is alive. - - * custom.el (custom-face-lookup): Wrong number of params. - -Fri May 31 00:14:17 1996 Lars Magne Ingebrigtsen - - * gnus.el (gnus-continuum-version): Also give responses to - directory names. - (gnus-summary-update-article): Would bug out on editing articles. - -Thu May 30 05:04:07 1996 Lars Magne Ingebrigtsen - - * gnus.el: Gnus v5.2.2 is released. - - * gnus.el (gnus-article-hide-headers): Show boring headers as - well. - -Tue May 28 15:47:15 1996 Per Abrahamsen - - * custom.el ((fboundp 'event-point)): Wrong test. - -Thu May 30 03:19:21 1996 Lars Magne Ingebrigtsen - - * gnus.el (gnus-headers-decode-quoted-printable): Wrong name. - - * message.el (message-header-hook): Defvarred. - - * gnus-nocem.el (gnus-nocem-verifyer): Couldn't verify that it - works. - -Thu May 30 00:25:46 1996 Lars Magne Ingebrigtsen - - * gnus-nocem.el (gnus-nocem-verify-issuer): Widen before - verifying. - -Wed May 29 23:19:46 1996 Lars Magne Ingebrigtsen - - * custom.el (custom-xmas-set-text-properties): Changed name. - -Wed May 29 23:01:52 1996 Paul D. Smith - - * gnus-cus.el: toggle -> sexp. - -Wed May 29 23:00:48 1996 Lars Magne Ingebrigtsen - - * gnus-msg.el (gnus-inews-add-send-actions): Use `gnus-add-hook'. - -Wed May 29 22:52:47 1996 Francois Felix Ingrand - - * gnus-topic.el (gnus-topic-remove-group): Would not delete groups - from topics. - -Wed May 29 08:57:20 1996 Lars Magne Ingebrigtsen - - * custom.el (custom-face-lookup): Avoid `modify-face' to speed up - face retrieval on Indys & over slow modem lines. - -Wed May 29 05:08:04 1996 Lars Magne Ingebrigtsen - - * gnus.el: Gnus v5.2.2 is released. - - * custom.el (custom-xmas-add-text-properties, - custom-xmas-put-text-property): New functions used throughout. - May now work under XEmacs. - -Wed May 29 00:07:13 1996 Lars Magne Ingebrigtsen - - * gnus-cite.el (gnus-cite-article): New variable. - (gnus-cite-parse-maybe): Use it. - - * nnspool.el (nnspool-open-server): Refuse opening if the active - file doesn't exist. - - * gnus.el (gnus-read-active-file): Message more. - - * nntp.el (nntp-request-article): Wouldn't wait until the entire - article had arrived. - - * nnvirtual.el (nnvirtual-request-group): Make sure that things - don't recurse endlessly. - - * message.el (message-expand-group): Make buffer not read-only. - - * gnus-nocem.el (gnus-nocem-verifyer): New variable. - (gnus-nocem-verify-issuer): Use it. - - * gnus-xmas.el (gnus-xmas-logo-color-alist): New variable. - (gnus-xmas-logo-color-style): New variable. - (gnus-xmas-logo-colors): Use them. - -Tue May 28 00:28:38 1996 Lars Magne Ingebrigtsen - - * gnus-score.el (gnus-score-followup): Would infloop on exact - matches. - - * message.el (message-forward): Insert separator at the start of - the line. - - * nnfolder.el (nnfolder-save-buffer): New function. - (nnfolder-save-buffer-hook): New variable. - - * message.el (message-mode-hook): Defined variable. - - * nntp.el (nntp-request-close): Remove the sentinel before closing - connection. - - * gnus.el (gnus-group-mode): Add to local hook. - (gnus-continuum-version): Would return wrong answer for non-alpha - releases. - (gnus-version-number): New variable. - (gnus-version): Use it. - - * gnus-msg.el (gnus-inews-add-send-actions): Add to local hook. - - * gnus-xmas.el (gnus-xmas-add-hook): New function. - - * gnus-ems.el (gnus-add-hook): New alias. - -Tue May 28 00:23:17 1996 Joao Cachopo - - * gnus-salt.el (gnus-binary-mode): Would put wrong minor mode - keymap into alist. - -Tue May 28 00:18:19 1996 Thor Kristoffersen - - * nntp.el (nntp-close-server): Supply parameter to - `nntp-server-opened'. - -Sun May 26 20:29:02 1996 Lars Magne Ingebrigtsen - - * gnus.el (gnus-article-sort-by-date): Inline. - - * nnmail.el (nnmail-find-file): Don't insert literally. - - * message.el (message-send-mail-with-mh): Save before sending. - - * gnus-cite.el (gnus-article-hide-citation): Would bug out. - - * gnus-topic.el (gnus-topic-grok-active): Could only be run once. - - * message.el (message-check-news-syntax): Don't warn on long - signatures on forwarded articles. - - * gnus.el (gnus-request-article-this-buffer): Put un-numbered - articles into the original buffer as well. - -Sun May 26 03:51:38 1996 Lars Magne Ingebrigtsen - - * gnus.el: Gnus v5.2.1 is released. - - * gnus.el: Gnus v5.2.0 is released. - - * gnus.el: September Gnus v0.96 is released. - - * nnheader-ems.el: Raw-file confusion. - - * gnus-xmas.el (gnus-xmas-logo-colors): New variable. - (gnus-xmas-group-startup-message): Use it. - -Sun May 26 02:35:48 1996 Lars Magne Ingebrigtsen - - * nnheader-ems.el: Bind nnheader-insert-raw-file-contents. - - * gnus.el: 0.95 is released. - -Sun May 26 02:34:01 1996 Bart Robinson - - * gnus.el (gnus-save-newsrc-file): Make the backups go to the - right directory. - -Sun May 26 00:04:38 1996 Lars Magne Ingebrigtsen - - * gnus.el (gnus-cut-thread): Wouldn't cut properly with - old-fetched and dormant articles. - -Sat May 25 22:49:51 1996 Lars Magne Ingebrigtsen - - * gnus.el (gnus-summary-search-article): Continue from where we - were. - (gnus-summary-insert-subject): Wouldn't insert when old-fetched - articles. - (gnus-cut-threads): Would display too many threads when both - sparse & ancient articles were present. - (gnus-invisible-cut-children): New function. - -Fri May 24 17:56:19 1996 Andy Norman - - * nnheader-ems.el (nnheader-xmas-find-file-noselect): Use - `nnheader-insert-file-contents-literally'. - -Fri May 24 17:51:46 1996 Lars Magne Ingebrigtsen - - * gnus.el (gnus-summary-find-prev): With point at eob, would - select the next-to-last article. - -Fri May 24 17:25:48 1996 Magnus Hammerin - - * gnus.el (gnus-group-mode): Use `gnus-make-local-hook'. - (gnus-sortable-date): Typo. - -Fri May 24 17:24:15 1996 ISO-2022-JP - - * gnus.el (gnus-narrow-to-signature): Didn't work. - -Fri May 24 21:27:49 1996 Lars Magne Ingebrigtsen - - * gnus.el: 0.94 is released. - - * nnvirtual.el (nnvirtual-request-group): Don't include itself in - its component groups. - - * gnus.el (gnus-summary-mark-below): Changed default. - -Fri May 24 19:29:17 1996 Lars Magne Ingebrigtsen - - * message.el (message-check-news-syntax): Check invalid Newsgroups - syntax. - (message-mode-menu): Added spellcheck. - - * nntp.el (nntp-wait-for-response): Peel off ^Ms. - - * message.el (message-fix-before-sending): New function. - (message-send): Use it. - (message-check-news-syntax): Check for invalid group names. - - * gnus.el (gnus-summary-number-of-articles-in-thread): Return 0 if - not included. - -Thu May 23 23:32:43 1996 Lars Magne Ingebrigtsen - - * gnus.el: September Gnus v0.93 is released. - - * nnbabyl.el (nnbabyl-read-mbox): Would bogously increase the - number in groups. - -Thu May 23 21:06:47 1996 Lars Magne Ingebrigtsen - - * gnus.el: September Gnus v0.92 is released. - - * gnus-soup.el (gnus-soup-add-article): Would remove Xrefs from - packet. - - * gnus.el (gnus-summary-catchup-to-here): Don't show hidden - threads. - - * nnmail.el (nnmail-moved-inboxes): New variable. - (nnmail-move-inbox): Use it. - - * gnus-uu.el (gnus-uu-decode-uu): Optional argument. - - * nnbabyl.el (nnbabyl-insert-lines): Don't insert negative Lines - headers. - -Thu May 23 19:28:15 1996 Lars Magne Ingebrigtsen - - * gnus.el (gnus-summary-insert-pseudos): Would create contiguous - mouse-face areas. - - * nnheader-ems.el: New file. - (nnheader-xmas-run-at-time): New function. - (nnheader-xmas-cancel-timer): Ditto. - (nnheader-xmas-insert-file-contents-literally): Moved here. - - * gnus.el (gnus-read-move-group-name): Bind - minibuffer-confirm-incomplete. - -Thu May 23 15:20:47 1996 Lars Magne Ingebrigtsen - - * nntp.el (nntp-request-close): Give the QUIT time to reach the - server before closing the connection. - (nntp-close-server): Ditto. - - * gnus.el (gnus-summary-exit): Run the exit hook with point on the - group being exited. - -Thu May 23 15:03:16 1996 - - * gnus.el (gnus-narrow-to-signature): Mimeish new definition. - -Thu May 23 15:03:16 1996 Lars Magne Ingebrigtsen - - * nnfolder.el (nnfolder-close-group): Don't read the buffer when - closing down. - - * gnus.el (gnus-group-exit): Prompt even when the server is down. - -Wed May 22 21:56:56 1996 Lars Magne Ingebrigtsen - - * gnus.el: September Gnus v0.91 is released. - - * gnus.el (gnus-setup-news): Slave Gnusii should clear the dribble - buffer. - -Wed May 22 22:32:21 1996 Lars Magne Ingebrigtsen - - * gnus-score.el (gnus-summary-set-score): Moved here. - (gnus-summary-raise-score): Would bug out on nil arguments. - - * message-xmas.el (message-toolbar): Changed. - - * gnus-xmas.el (gnus-summary-mail-toolbar): New toolbar. - (gnus-xmas-setup-summary-toolbar): Use it. - -Wed May 22 19:24:04 1996 Lars Magne Ingebrigtsen - - * gnus.el (gnus-message-archive-method): Buggy definition. - (gnus-summary-prepare-threads): Don't mark ancient as low-scored. - (gnus-summary-prepare-unthreaded): Ditto. - -Wed May 22 02:14:42 1996 Lars Magne Ingebrigtsen - - * gnus.el (gnus-save-hidden-threads): New macro. - (gnus-hidden-threads-configuration): New function. - (gnus-restore-hidden-threads-configuration): New function. - (gnus-summary-search-article): Use it. - - * gnus-picon.el (gnus-picons-reverse-domain-path): New definition. - - * message.el: Required wrong file under XEmacs. - - * gnus-gl.el (bbb-get-predictions): Return nil on errors. - - * nnfolder.el (nnfolder-close-group): Make sure the buffer is - alive before killing it. - -Tue May 21 20:08:33 1996 Lars Magne Ingebrigtsen - - * gnus.el: September Gnus v0.90 is released. - - * gnus.el (gnus-dribble-read-file): Don't do modes unless they are - available. - - * gnus-score.el (gnus-summary-score-entry): Wouldn't show - immediate scorign of followups. - (gnus-score-save): Use prin1 instead of format. - - * gnus-msg.el (gnus-bug-kill-buffer): Bogus. - -Tue May 21 18:32:29 1996 Lars Magne Ingebrigtsen - - * gnus-vis.el (gnus-button-next-page): New command. - (gnus-button-prev-page): Ditto. - - * gnus-topic.el (gnus-topic-unique): Removed variable. - (gnus-current-topic): New function. - (gnus-topic-move-group): Use it. - (gnus-topic-goto-next-group): Use it. - -Tue May 21 11:08:42 1996 Steven L Baur - - * gnus-setup.el: Copyright assigned to FSF. - -Tue May 21 17:09:27 1996 Lars Magne Ingebrigtsen - - * message.el (message-fetch-field): New function. - - * gnus.el (gnus-directory): New variable. - - * message.el (message-directory): New variable. - - * nnmail.el (nnmail-insert-lines): Make sure point is at the - beginning of the line. - (nnmail-directory): New variable. - - * gnus.el (gnus-mode-string-quote): New function. - (gnus-set-mode-line): Use it. - -Tue May 21 10:34:26 1996 Lars Magne Ingebrigtsen - - * gnus-msg.el (gnus-inews-do-gcc): Use message narrow to headers. - (gnus-inews-do-gcc): Find the right archive method. - - * gnus.el (gnus-select-newsgroup): Check whether the group can be - requested first. - (gnus-no-server): Nonsensical. - (gnus-group-mark-group): Go past topic lines. - (gnus-server-to-method): Would return nil on select methods. - - * gnus-topic.el (gnus-topic-mode): Don't check topology unless we - have the newsrc alist. - (gnus-topic-check-topology): Wouldn't check topology properly. - - * nnsoup.el (nnsoup-request-list): Make sure the active file is - read first. - - * gnus.el (gnus-sortable-date): Simplified. - (gnus-group-set-mode-line): Remove the ":" if the server is "". - -Tue May 21 10:13:28 1996 Jack Vinson - - * message.el (message-rename-buffer): New command and keystroke. - -Mon May 20 10:15:12 1996 Lars Magne Ingebrigtsen - - * gnus.el (gnus-summary-search-article): New implementation; set - point in the article buffer to the match. - (gnus-parent-headers): New function. - (gnus-dd-mmm): Protect against broken dates. - - * gnus-topic.el (gnus-topic-unread): New function. - (gnus-topic-update-topic-line): Use it. - - * gnus.el (gnus-group-list-active): Protect against unbound - symbols. - +Mon Jul 29 14:17:30 1996 Lars Magne Ingebrigtsen + + * gnus-load.el (gnus-startup-hook): Removed hilit removal. + + * gnus-async.el: New file. + + * gnus-int.el (gnus-asynchronous-p): New function. + + * nntp.el: Replaced with new, asynchronous version. + +Mon Jul 29 11:48:07 1996 Paul Franklin + + * gnus-sum.el (gnus-pdf-simplify-subject): New function. + (gnus-summary-simplify-subject-query): New command. + +Mon Jul 29 10:05:30 1996 Lars Magne Ingebrigtsen + + * gnus-sum.el (gnus-summary-mode-map): Command for emphasis. + + * gnus-art.el (gnus-article-wash-status): Report emphasis. + + * article.el (article-unhide-text-type): New function. + (article-emphasize): New function. + (article-emphasis-alist): New variable. + + * gnus-score.el (gnus-score-headers): Hook into advanced scoring. + + * gnus-logic.el: New file. + + * article.el (article-treat-overstrike): Mark hiding type. + +Mon Jul 29 10:00:52 1996 d. hall + + * gnus-art.el (gnus-article-wash-status): New function. + +Sun Jul 28 15:20:19 1996 Lars Magne Ingebrigtsen + + * article.el (article-hidden-arg): Renamed all variables and + functions to `article-'. + + * gnus.el: Split file into gnus-start.el, gnus-group.el, + gnus-sum.el, gnus-art.el, gnus-win.el, gnus-load.el, gnus-util.el, + gnus-bcklg.el, gnus-spec.el, article.el, and gnus-int.el. + diff -r ad457d5f7d04 -r 0293115a14e9 lisp/gnus/ChangeLog.1 --- a/lisp/gnus/ChangeLog.1 Mon Aug 13 08:48:43 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,3051 +0,0 @@ -Sun Jan 21 08:21:03 1996 Lars Ingebrigtsen - - * ChangeLog continues in a different file. - -Sun Jan 21 01:59:13 1996 Lars Magne Ingebrigtsen - - * gnus.el (gnus-summary-recenter): Recenter horizontally. - - * gnus.el: 0.30 is released. - -Sun Jan 21 01:08:58 1996 Lars Magne Ingebrigtsen - - * gnus.el (gnus-horizontal-recenter): Would infloop. - (gnus-cut-threads): Cut off `more' threads. - - * gnus-xmas.el (gnus-xmas-move-overlay): Handle detached extents. - (gnus-xmas-make-overlay): New function. - - * gnus-salt.el (gnus-tree-recenter): Search all frames. - - * gnus.el (gnus-all-windows-visible-p): Be `frame' aware. - - * gnus-salt.el (gnus-salt): Provide. - - * gnus-xmas.el (gnus-xmas-tree-minimize): New function. - - * gnus-salt.el (gnus-tree-read-summary-keys): Don't use - `overlay-end'. - - * gnus-xmas.el (gnus-xmas-define): Redefine overlay-end. - - * gnus-ems.el (gnus-overlay-end): New alias. - - * gnus-salt.el (gnus-tree-minimize): Don't use - `save-selected-window'. - -Sat Jan 20 08:40:46 1996 Lars Ingebrigtsen - - * gnus-uu.el (gnus-uu-grab-articles): Give a better message. - -Sat Jan 20 08:19:29 1996 Colin Rafferty - - * gnus.el (gnus-summary-reparent-thread): New command and - keystroke. - -Sat Jan 20 04:12:17 1996 Lars Ingebrigtsen - - * gnus-score.el (gnus-score-kill-help-buffer): New function. - (gnus-summary-increase-score): Use the default values. - - * gnus-cache.el (gnus-jog-cache): Make sure Gnus is started. - (gnus-jog-cache): New implementation. - - * gnus.el (gnus-unload): Also unload nn*. - (gnus-group-mark-region): New command and keystroke. - - * nnmail.el (nnmail-process-babyl-mail-format): Fold case. - (nnmail-process-unix-mail-format): Ditto. - (nnmail-process-mmdf-mail-format): Ditto. - - * gnus.el (gnus-group-faq-directory): New default. - - * gnus-mh.el (gnus-mh-mail-setup): Use original article buffer. - - * gnus-salt.el (gnus-tree-highlight-article): Move point. - -Sat Jan 20 03:32:17 1996 Kai Grossjohann - - * gnus.el (gnus-summary-find-matching): Typo. - -Sat Jan 20 00:54:13 1996 Lars Ingebrigtsen - - * gnus.el (gnus-build-sparse-threads): Allow `more' as a value. - (gnus-request-update-mark): Wrong number of parameters. - - * gnus-vis.el (gnus-article-highlight-signature): Use new function. - - * gnus.el (gnus-group-uncollapsed-levels): New variable. - (gnus-short-group-name): Use it. - (gnus-narrow-to-signature): New function. - (gnus-article-hide-signature): Use it. - - * gnus-msg.el (gnus-inews-insert-archive-gcc): Allow disabling - archiving. - (gnus-inews-insert-archive-gcc): Allow var to be a function. - (gnus-inews-real-user-address): Always use `system-name'. - - * gnus.el (gnus-sort-threads): Would choke when no sorting - functions were specified. - (gnus-group-sort-groups): Ditto. - - * gnus-cite.el (gnus-dissect-cited-text): New function. - (gnus-article-toggle-cited-text): New function. - (gnus-cited-text-button-line-format): New variable. - (gnus-article-hide-citation): Add buttons. - (gnus-cited-lines-visible): New variable. - - * gnus.el (gnus-summary-move-article): Don't allow moving to the - current group. - -Sat Jan 20 00:50:36 1996 Kai Grossjohann - - * gnus.el (gnus-summary-move-article): Didn't update marks. - -Sat Jan 20 00:16:44 1996 Lars Ingebrigtsen - - * gnus.el (gnus-request-accept-article): Make sure there's a - newline at the end of the article. - - * gnus-soup.el (gnus-soup-parse-areas): Kill buffer after - parsing. - -Thu Jan 18 11:50:06 1996 Wes Hardaker - - * gnus.el (auto-load): Added gnus-group-display-picons to the - gnus-picon auto-load list. Also made the refernce(s) interactive. - -Fri Jan 19 04:20:16 1996 Lars Magne Ingebrigtsen - - * gnus-xmas.el (gnus-xmas-read-event-char): Don't force event keys - to be numbers. - -Fri Jan 19 04:11:39 1996 Lars Magne Ingebrigtsen - - * gnus-srvr.el (gnus-server-position-point): Define. - - * gnus-salt.el (gnus-tree-recenter): Don't use - `save-selected-window'. - -Thu Jan 18 03:08:40 1996 Lars Magne Ingebrigtsen - - * gnus.el: 0.29 is released. - -Wed Jan 17 17:00:55 1996 Steven L. Baur - - * gnus-msg.el (gnus-inews-domain-name): mail-host-address may not - be predefined. - -Wed Jan 17 17:00:55 1996 Steven L. Baur - - * gnus-xmas.el (gnus-xmas-find-file-noselect): - nnheader-insert-file-contents-literally lost the prefix - -Thu Jan 18 00:03:30 1996 Lars Magne Ingebrigtsen - - * gnus.el (gnus-horizontal-recenter): Didn't work very well. - (gnus-dribble-enter): Don't enter anything if the buffer doesn't - exist. - (gnus-recenter): New command. - (gnus-summary-refer-article): Give an error message. - (gnus-article-refer-article): Don't move point. - -Wed Jan 17 23:32:43 1996 Lars Magne Ingebrigtsen - - * gnus.el (gnus-article-hide-boring-headers): Hide empty headers. - (gnus-summary-recenter): Place point before recentering. - -Wed Jan 17 22:58:05 1996 Lars Magne Ingebrigtsen - - * gnus.el (gnus-article-hide-header): Hide boring headers - selectively. - (gnus-article-hide-header): Didn't hide anything. - - * nntp.el: Make sure `open-network-stream' has the right - definition. - - * gnus.el: 0.28 is released. - -Wed Jan 17 19:34:31 1996 Lars Ingebrigtsen - - * nntp.el (tcp): Require tcp. - - * gnus.el (gnus-update-marks): Ignore dead groups. - - * gnus-cus.el: Changed `gnus-button-url' variable. - -Wed Jan 17 19:27:36 1996 Marc Auslander - - * gnus.el (gnus-summary-mark-below): Would infloop. - -Wed Jan 17 19:00:02 1996 Lars Ingebrigtsen - - * gnus-srvr.el (gnus-server-mode-map): Keymap was buggy. - - * gnus-score.el (gnus-score-check-syntax): Would bug out on Lines - headers. - - * gnus.el (gnus-info-find-node): Configure to the info buffer. - - * nnvirtual.el (nnvirtual-create-mapping): Division by zero. - -Wed Jan 17 18:53:50 1996 Ulrich Pfeifer - - * gnus.el (gnus-summary-move-article): Reversed checks. - (gnus-summary-move-article): Would try to remove mark from nil. - -Wed Jan 17 18:37:45 1996 Lars Ingebrigtsen - - * gnus.el (gnus-summary-update-article): Totally bugged out. - - * nnml.el (nnml-request-article): Didn't fetch by Message-ID. - -Tue Jan 16 17:25:28 1996 Steven L. Baur - - * nnfolder.el (nnfolder-read-folder): Too many parameters for - find-file-noselect for XEmacs. - - * nnbabyl.el (nnbabyl-read-mbox): Too many parameters for - find-file-noselect for XEmacs. - - * nnmbox.el (nnmbox-possibly-change-newsgroup): Too many parameters - for find-file-noselect for XEmacs. - - * gnus-xmas.el (insert-file-contents-literally): Restored from - v0.26 nnheader.el since XEmacs 19.13 doesn't have this function. - - * gnus-msg.el (gnus-bug): (emacs-version) does not take a parameter - in XEmacs. - - * gnus-nocem.el (gnus-nocem-scan-groups): make-vector takes two - parameters. - -Wed Jan 17 05:46:51 1996 Lars Ingebrigtsen - - * gnus-xmas.el (gnus-xmas-find-file-noselect): Moved to this - file. - - * gnus-msg.el (gnus-forward-included-headers): New variable. - (gnus-forward-insert-buffer): Use it. - - * gnus-score.el (gnus-score-adaptive): Use `mail-header-*' instead - of `gnus-header-*'. - - * gnus.el (gnus-list-groups-with-ticked-articles): New variable. - (gnus-group-prepare-flat): Use it. - (gnus-header-from): Put back in again. - (gnus-article-hide-boring-headers): Don't bug out on articles with - no From header. - - * gnus-topic.el (gnus-topic-find-groups): Ditto. - - * gnus-msg.el (gnus-debug): Be more lenient with malformed files. - -Wed Jan 17 05:29:17 1996 Kai Grossjohann - - * gnus-msg.el (gnus-inews-insert-gcc): Go through all Gcc'd - groups. - -Wed Jan 17 02:26:21 1996 Lars Ingebrigtsen - - * gnus-msg.el (gnus-inews-domain-name): Also use - mail-host-address. - - * nndoc.el (nndoc-guess-type): Guess `news' when it's news. - - * gnus-msg.el (gnus-debug): Only insert "environment" line if the - environment follows. - (gnus-inews-check-post): Check empty articles. - - * gnus.el (gnus-summary-edit-article-done): Run display hook. - (gnus-newsrc-to-gnus-format): Group names can be just numbers. - - * nnmail.el (nnmail-check-duplication): Allow - `nnmail-treat-duplicates' to be a function. - - * nnheader.el (nnheader-functionp): New function. - - * gnus-salt.el (gnus-pick-mode-map): Added `gnus-uu-mark-over'. - - * gnus-uu.el (gnus-uu-mark-over): New command and keystroke. - - * gnus.el (gnus-find-new-newsgroups): Allow a prefix to force - `ask-server'. - -Wed Jan 17 02:14:22 1996 Jason L. Tibbitts, III - - * gnus.el (gnus-simplify-buffer-fuzzy): Didn't work for adaptive - scoring. - (gnus-summary-select-article): Allow scrolling up. - -Tue Jan 16 22:28:41 1996 Lars Magne Ingebrigtsen - - * gnus.el: Applied typo fix patches from eggert@twinsun.COM (Paul - Eggert). - -Tue Jan 16 21:14:44 1996 Lars Magne Ingebrigtsen - - * gnus.el: 0.27 is released. - - * nnvirtual.el (nnvirtual-retrieve-headers): Would bug out on - canceled articles. - - * gnus.el (gnus-message-archive-method): Never get new mail. - -Tue Jan 16 19:42:21 1996 Ken Raeburn - - * nnmail.el (nnmail-process-babyl-mail-format): Some movemails do - not add an EOOH line. - -Tue Jan 16 19:26:31 1996 Lars Magne Ingebrigtsen - - * nnml.el (nnml-request-article): Would try to retrieve - non-qualified path. - (nnml-possibly-change-directory): Nix out the file alist. - - * nnheader.el (nnheader-article-to-file-alist): Translated twice. - - * gnus.el (gnus-article-hidden-text-p): New function. - -Tue Jan 16 15:20:08 1996 Lars Ingebrigtsen - - * nnspool.el (nnspool-retrieve-headers-with-nov): Extra slash in - path. - - * gnus-topic.el (gnus-topic-check-topology): Hardcoded "Gnus" - topic name. - - * gnus-soup.el (gnus-soup-unique-prefix): Be silent. - - * gnus.el (gnus-summary-insert-pseudos): Put text props instead of - adding. - - * gnus-cite.el (gnus-article-hide-citation, - gnus-article-hide-citation-maybe): Toggle. - - * gnus.el (gnus-article-show-hidden-text): Also hide. - (gnus-article-check-hidden-text): New function. - (gnus-article-hide-headers, gnus-article-hide-boring-headers, - gnus-article-hide-pgp, gnus-article-hide-signature): Toggle. - -Mon Jan 15 14:00:32 1996 Lars Ingebrigtsen - - * gnus.el (gnus-group-sort-groups): Make composite sort function. - - * gnus-msg.el (gnus-inews-do-gcc): Put the message in its own - buffer before archiving. - - * gnus-topic.el (gnus-topic-mode-map): Bugged totally out. - (gnus-topic-mode): change-level-function is a function, not a - hook. - (gnus-topic-yank-group): Yank into the line under point. - - * gnus-score.el (gnus-score-check-syntax): Would always report - errors. - -Sat Jan 13 00:31:02 1996 Lars Magne Ingebrigtsen - - * gnus-salt.el (gnus-possibly-generate-tree): Cut thread before - generating. - - * gnus.el (gnus-cut-threads): New function. - (gnus-summary-prepare): Use it. - (gnus-id-to-header): New function. - (gnus-read-header): Use it. - (gnus-get-newsgroup-headers): Allow reading new versions of - headers. - (gnus-get-newsgroup-headers-xover): Ditto. - - * nntp.el (nntp-accept-response): Never hang waiting for process - output. - - * gnus.el (gnus-ask-server-for-new-groups): Wouldn't subscribe - groups from odd servers. - -Fri Jan 12 11:36:07 1996 Lars Magne Ingebrigtsen - - * nnfolder.el (nnfolder-possibly-change-group): Create parent - dirs. - - * gnus-ems.el: Would remove intangible props under 19.30. - - * nnmail.el (nnmail-expired-article-p): Accept inhibition. - (nnmail-save-active): Create the directory if it doesn't exist. - (nnmail-procmail-suffix): Changed default. - - * gnus-msg.el (gnus-inews-do-gcc): Report failures. - - * gnus.el (gnus-request-create-group): Accept a method parameter. - - * gnus-msg.el (gnus-tokenize-header): Accept a separator. - - * nnfolder.el (nnfolder-inhibit-expiry): New variable. - - * gnus-msg.el (gnus-message-archive-group): New variable. - (gnus-inews-insert-archive-gcc): New function. - - * gnus.el (gnus-message-archive-method): New variable. - (gnus-ask-server-for-new-groups): Use it. - (gnus-read-active-file): Ditto. - (gnus-read-all-descriptions-files): Ditto. - - * nndraft.el (nndraft-request-accept-article): Don't be so - chatty. - - * gnus-score.el (gnus-score-default-header): New variable. - (gnus-score-default-type): Ditto. - (gnus-score-default-duration): Ditto. - - * nnheader.el (nntp-header-number): Removed all `nntp-header-' - aliases. - (mail-header-number): Rewrote all macros. - (nnheader-insert-file-contents-literally): Removed. - - * gnus-score.el (gnus-score-adaptive): Wrap macros. - - * nnheader.el (mail-header-message-id): New alias for - `mail-header-id'. - - * gnus.el (gnus-replace-chars-in-string): Removed. - (gnus-summary-find-matching): Wrap `mail-header-' macros in - lambdas instead of using the Gnus functions. - (gnus-header-number): Removed all functional equivalents. - - * nnmail.el: Changed gnus-verbose-backends in all backends. - - * nnspool.el (nnspool-replace-chars-in-string): Removed. - (nnspool-number-base-10): Removed. - - * nnheader.el (nnheader-message): New function. - (gnus-verbose-backends): Changed default. - (nnheader-be-verbose): New function. - (nnheader-group-pathname): New function. - - * nnfolder.el (nnfolder-generate-active-file): New command. - - * nnheader.el (nnheader-mail-file-mbox-p): New function. - (nnheader-file-to-group): New function. - - * gnus-cache.el (gnus-uncacheable-groups): New default. - -Thu Jan 11 22:26:42 1996 Lars Magne Ingebrigtsen - - * gnus-salt.el (gnus-pick-display-summary): New variable. - (gnus-pick-start-reading): Use it. - -Wed Jan 10 19:45:33 1996 Paul Eggert - - * gnus.el (gnus-article-date-ut): Avoid race condition when - computing current time and zone. - * gnus-msg.el (gnus-inews-date): Likewise. - -Thu Jan 11 10:55:34 1996 Lars Magne Ingebrigtsen - - * gnus.el (gnus-summary-goto-colon): New function; use horizontal - recentering. - - * gnus-salt.el (gnus-generate-tree): Use new recenter function. - (gnus-highlight-selected-tree): Ditto. - - * gnus.el (gnus-set-mode-line): Make tree buffer mode line. - (gnus-article-goto-next-page): Didn't work all the time. - (gnus-article-read-summary-keys): Allow proper paging from the - tree buffer. - (gnus-horizontal-recenter): New function. - - * gnus-vis.el (gnus-article-add-buttons): New implementation. - (gnus-button-alist): New default. - - * gnus.el (gnus-select-article-hook): Changed default. - (gnus-summary-display-article): Removed call to - `gnus-summary-show-thread'. - - * gnus-vis.el (gnus-article-highlight-headers): New implementation. - - * gnus-soup.el (gnus-soup-write-areas): Be silent. - (gnus-soup-write-replies): Ditto. - -Wed Jan 10 09:50:39 1996 Lars Magne Ingebrigtsen - - * gnus.el (gnus-sort-articles): New function. - (gnus-summary-prepare): Use it. - (gnus-sort-threads): New implementation. - (gnus-sort-articles): Ditto. - (gnus-make-sort-function): New function. - - * nnmail.el (nnmail-pre-get-new-mail-hook): New variable. - (nnmail-post-get-new-mail-hook): New variable. - (nnmail-split-incoming): Do more checking for babyl file format. - (nnmail-process-babyl-mail-format): Really remove bogus Message-IDs. - (nnmail-process-unix-mail-format): Ditto. - (nnmail-process-mmdf-mail-format): Ditto. - - * nndraft.el (nndraft-request-associate-buffer): Clear modtime. - - * gnus-vis.el (gnus-button-marker-list): New variable. - (gnus-article-add-buttons): Use it to delete all old markers. - - * nnkiboze.el (nnkiboze-close-group): Don't delete all NOV lines - on Gnus startup. - - * gnus.el (gnus-sort-threads): Use `gnus-article-sort-functions'. - - * gnus-score.el (gnus-summary-increase-score): Prompt when - matching on References. - - * nnsoup.el (nnsoup-make-active): Clear message. - - * gnus.el (gnus-window-min-width): New variable. - (gnus-window-min-height): New variable. - (gnus-configure-frame): Use them. - (gnus-summary-prepare-exit-hook): Defun instead of defvar. - (gnus-summary-exit-hook): Ditto. - (gnus-parse-headers-hook): Ditto. - - * gnus-salt.el (gnus-generate-tree-function): New variable. - (gnus-tree-edge): New macro. - - * gnus-ems.el: Set a default - `nnheader-file-name-translation-alist' based on system-type. - - * gnus-msg.el (gnus-bug): Don't `message' emacs-version. - -Tue Jan 09 10:51:22 1996 Lars Magne Ingebrigtsen - - * nnvirtual.el (nnvirtual-possibly-change-group): Would choke on - exit when using cache. - - * gnus.el (gnus-request-article-this-buffer): Didn't allow reading - from virtual groups. - - * gnus-salt.el (gnus-tree-mode): New major mode. - - * gnus.el (gnus-read-init-file): Give better error messages when - reading the init file. - - * gnus-srvr.el (gnus-browse-mode): Moved to this file. - - * gnus.el (gnus-summary-display-article): Don't call the visual - updating functions twice. - (gnus-id-to-article): New function. - (gnus-article-displayed-root-p): New function. - (gnus-summary-top-thread): New command and keystroke. - (gnus-parent-id): Would bug out on empty References. - (gnus-add-configuration): Doc fix. - - * gnus-vis.el (gnus-summary-highlight-line-function): New - variable. - (gnus-summary-highlight-line): Use it. - - * gnus.el (gnus-article-read-summary-keys): Accept parameter to - not restore window config. - - * nnspool.el (nnspool-find-id): Condition-case the grep call. - - * gnus.el (gnus-updated-mode-lines): New default. - -Mon Jan 08 00:00:32 1996 Lars Magne Ingebrigtsen - - * gnus.el (gnus-use-trees): New variable. - - * gnus-salt.el (gnus-binary-mode): New minor mode. - (gnus-tree-mode): New major mode. - - * gnus-msg.el (gnus-mail-method): New variable. - (gnus-mail-setup): Use it. - - * gnus.el (gnus-build-sparse-threads): New function. - (gnus-sparse-mark): New variable. - (gnus-build-sparse-threads): New variable. - (gnus-summary-read-group): Use the new function. - (gnus-cut-thread): New subst. - (gnus-cut-thread): Limit fetch-old-headers 'some properly. - - * nnheader.el (make-mail-header): New function. - - * nnml.el (nnml-make-nov-line): Fudge better Message-IDs. - - * nnheader.el (nnheader-narrow-to-headers): Moved the function here. - - * gnus.el (gnus-summary-import-article): Make arpa date. - - * nnheader.el (nnheader-replace-header): New function. - - * gnus.el (gnus-summary-move-article): Move, copy and crosspost in - one function. - (gnus-summary-copy-article): Just use the move function. - (gnus-summary-crosspost-article): New command and keystroke. - -Sun Jan 07 06:25:00 1996 Lars Magne Ingebrigtsen - - * gnus-score.el (gnus-score-followup): Allow "thread" scoring. - - * nnml.el (nnml-request-article): Allow fetching gzipped articles. - (nnml-retrieve-headers): Ditto. - (nnmail-article-file-alist): New variable. - - * nnheader.el (nnheader-article-to-file-alist): New function. - - * gnus-demon.el (gnus-demon-time-to-step): Use gnus-encode-date. - - * gnus.el (gnus-encode-date): New function. - (gnus-time-minus): New function. - (gnus-article-date-ut): Use them. - (gnus-seconds-since-epoch): Removed. - (gnus-define-keys): New macro. - (gnus-define-keys-1): New function. - - * gnus.el: Rewrote all keymaps. - - * gnus-msg.el (gnus-tokenize-header): New function. - - * gnus-cus.el: Hide boring headers by default. - - * gnus-msg.el (gnus-use-followup-to): Changed default. - (gnus-check-before-posting): Ditto. - (gnus-inews-check-post): Check for totally redirected followups. - - * nnmh.el (nnmh-request-group): Would insert into group buffer. - - * gnus-uu.el (gnus-uu-unmark-by-regexp): New command. - (gnus-uu-unmark-region): New command. - (gnus-uu-unmark-buffer): New command. - - * gnus-salt.el (gnus-pick-mode): New function. - (gnus-pick-start-reading): New command. - - * gnus.el (gnus-summary-mark-excluded-as-read): New command and - keystroke. - - * gnus-salt.el: New file. - - * gnus-uu.el (gnus-uu-mark-all): Rewrite. - - * gnus-msg.el (gnus-inews-news): Use new method. - - * nnsoup.el (nnsoup-store-reply): Accept already prepared news. - - * gnus-msg.el (gnus-post-method): Allow a 0 prefix to prompt the - user for a post method. - (gnus-inews-news): Doc fix. - - * gnus.el (gnus-summary-prepare): Don't try to generate the - summary buffer when there are no headers. - -Sat Jan 06 15:04:34 1996 Lars Magne Ingebrigtsen - - * gnus-vis.el: Inserted all new commands in all menus. - - * gnus-topic.el (gnus-topic-make-menu-bar): New function. - - * gnus-score.el (gnus-score-check-syntax): Do further syntax - checking. - - * gnus.el (gnus-configure-frame): Don't bug out on the `nil' - buffer. - - * gnus-score.el (gnus-score-update-all-lines): New function. - (gnus-summary-rescore): Use it. - - * gnus.el (gnus-simplify-subject-fully): Didn't strip leading Re: - if `gnus-summary-gather-subject-limit' was a number. - (gnus-short-group-name): Collapse more. - -Tue Jan 2 19:22:12 1996 Michael Ernst - - * gnus.el (gnus-simplify-subject-ignored-prefixes): new variable. - (gnus-simplify-subject): use above to simplify subjects. - -Sat Jan 06 14:14:24 1996 Lars Magne Ingebrigtsen - - * gnus.el (gnus-strict-mime): Doc fix. - -Tue Jan 2 17:27:34 1996 Michael Ernst - - * gnus.el (gnus-simplify-subject): Remove more kinds of "Re:" - prefixes, and remove multiple prefixes when they exist. - -Sat Jan 06 12:55:37 1996 Lars Magne Ingebrigtsen - - * gnus.el (gnus-summary-initial-limit): Don't always show groups - that have had all articles expunged. - (gnus-summary-read-group): Would bug out when deadening buffers. - (gnus-summary-exit): Wouldn't update windows when deadening. - (gnus-summary-isearch-article): Use proper window config. - (gnus-article-remove-trailing-blank-lines): New command and - keystroke. Suggested by Michael Ernst . - - * gnus-score.el (gnus-score-edit-alist): Make sure the score dir - exists. - (gnus-score-edit-file): Ditto. - - * nnml.el (nnml-generate-active-info): Could {pre,ap}pend all - lines with ".". - -Fri Jan 05 02:14:34 1996 Lars Magne Ingebrigtsen - - * gnus.el (gnus-summary-insert-pseudos): Add mouse face to - pseudos. - - * nnmail.el (nnmail-check-duplication): New function. - (nnmail-treat-duplicates): Renamed variable; new values. - (nnmail-process-babyl-mail-format): Use it. - (nnmail-process-unix-mail-format): Ditto. - (nnmail-process-mmdf-mail-format): Ditto. - - * gnus.el (gnus-visible-headers): Changed default. - - * gnus-xmas.el (gnus-xmas-define): Provide a sloppy - `encode-time'. - - * nnvirtual.el (nnvirtual-always-rescan): New variable. - (nnvirtual-request-group): Use it. - - * nntp.el (nntp-read-server-type): New function. - (nntp-server-action-alist): New variable. - - * gnus-cache.el (gnus-cache-possibly-remove-articles): Allow - caching in virtual groups. - - * nnvirtual.el (nnvirtual-find-group-art): New function - * gnus-cache.el (gnus-cache-possibly-enter-article): Use it. - - * gnus.el (gnus-group-exit): Close the cache instead of open it. - (gnus-group-quit): Ditto. - (gnus-virtual-group-p): New function. - (gnus-mark-xrefs-as-read): Use it. - (gnus-select-newsgroup): Allow cache lists to be displayed in - virtual groups. - - * gnus-cache.el (gnus-cache-possibly-enter-article): Check for - pseudos. - - * nnvirtual.el (nnvirtual-request-update-mark): New function. - * gnus.el (gnus-summary-mark-article-as-read): Use it. - - * nntp.el (nntp-request-type): New function. - - * nnspool.el (nnspool-request-type): New function. - - * nnvirtual.el: Complete rewrite. Now much slower. - - * gnus.el (gnus-request-update-info): Changed into a subst. - (gnus-get-unread-articles-in-group): Allow updating from the - backends here. - (gnus-check-group): New function. - - * nnheader.el (nnheader-get-report): New function. - - * gnus.el (gnus-adjust-marked-articles): Would uncompess killed - lists. - - * gnus-topic.el (gnus-topic-grok-active-1): New function. - (gnus-topic-grok-active): New function. - (gnus-group-active-topic-p): New function. - (gnus-topic-fold): Use it. - (gnus-topic-list-active): New command and keystroke. - - * nneething.el (nneething-exclude-files): Changed default. - - * nnheader.el (nnheader-insert): New function. - -Thu Jan 04 01:45:08 1996 Lars Magne Ingebrigtsen - - * nndoc.el (nndoc-request-group): Report. - - * nnmbox.el (nnmbox-request-group): Report. - - * nnml.el (nnml-request-group): Report. - (nnml-request-article): Report. - - * nnmh.el: Report. - - * nnfolder.el (nnfolder-request-group): Report. - - * nnheader.el (nnheader-report): New function. - - * gnus.el (gnus-sort-gathered-threads): New function. - (gnus-summary-prepare): Use it. - (gnus-gather-threads-by-subject): Renamed function. - (gnus-ids-in-references): New function. - (gnus-summary-thread-gathering-function): New variable. - (gnus-summary-prepare): Use it. - (gnus-summary-gather-threads-by-references): New function. - - * nneething.el (nneething-create-mapping): Add timestamps to - mappings. - - * gnus.el (gnus-article-setup-buffer): Also allow several - `gnus-original-article-buffer's. - (gnus-configure-frame): Allow `frame' in buffer confuguration. - (gnus-other-frame): New command. - (gnus-build-get-header): Don't mark unread old-fetched headers as - read if they are unread. - (gnus-article-read-summary-keys): New command. - (gnus-article-mode-map): New implementation -- actually works. - (gnus-article-goto-next-page): New command. - (gnus-article-goto-prev-page): New command. - (gnus-summary-rescan-group): New implementation. - - * gnus-msg.el (gnus-mail-send-and-exit): Add `to-list' instead of - `to-address'. - (gnus-mail-reply): Use `broken-reply-to' group parameter. - (gnus-news-followup): Ditto. - - * nnheader.el (nnheader-file-name-translation-alist): New variable. - (nnheader-translate-file-chars): New function. - * nnkiboze.el (nnkiboze-score-file): Use it. - (nnkiboze-nov-file-name): Ditto. - * gnus-score.el (gnus-score-file-name): Use it. - * gnus.el (gnus-read-save-file-name): Use it. - - * gnus.el (gnus-group-universal-argument): New command and - keystroke. - (gnus-summary-universal-argument): Rewrite. - (gnus-group-unmark-all-groups): New command and keystroke. - (gnus-read-save-file-name): If the user types a directory name, - append the default file name to the directory. - (gnus-summary-insert-subject): Wouldn't allow `P'-ing past an - undisplayed canceled article. - (gnus-summary-update-article): New function. - (gnus-summary-edit-article-done): Use it. - -Wed Jan 03 10:42:48 1996 Lars Magne Ingebrigtsen - - * gnus.el (gnus-article-hide-header): New function. - (gnus-article-hide-boring-headers): New command and keystroke. - (gnus-boring-article-headers): New variable. - - * gnus-score.el (gnus-score-expiry-days): Allow nil as a value. - (gnus-update-score-entry-dates): New variable. - (gnus-score-string): Use it. - - * gnus.el (gnus-summary-limit-to-author): New command and - keystroke. - (gnus-summary-goto-unread): Allow `never' value. - (gnus-summary-next-page): Use it. - (gnus-summary-mark-forward): Ditto. - -Wed Jan 03 09:58:14 1996 Masaharu Onishi - - * gnus.el (gnus-parent-id): Didn't return the last Message-ID if - the References contained newlines. - -Wed Jan 03 03:51:05 1996 Lars Magne Ingebrigtsen - - * gnus-msg.el (gnus-inews-modify-mail-mode-map): Typo. - - * nndoc.el (nndoc-guess-type): Look for babyl before forward. - - * nnmail.el (nnmail-crosspost-link-function): New variable. - * nnml.el (nnml-save-mail): Use it. - * nnmh.el (nnmh-save-mail): Ditto. - - * gnus.el (gnus-group-set-current-level): Would bug out on killed - groups. - - * gnus-topic.el (gnus-topic-yank-group): Would yank articles into - wrong topics. - - * gnus.el (gnus-summary-exit): Run the exit hook at an earlier - point. - (gnus-summary-mode-map): "T T" clobbering. - (gnus-summary-number-of-articles-in-thread): Wouldn't count - adopted threads. - (gnus-summary-walk-group-buffer): Respect the gnus-keep-same-level - variable. - - * gnus-topic.el (gnus-topic-change-level): New function. - - * gnus.el (gnus-group-change-level-function): New variable. - - * gnus-topic.el (gnus-topic-mode): Toggling the mode off would bug - out. - (gnus-topic-check-topology): Make sure that the topic-alist does - exist. - - * gnus-xmas.el (gnus-xmas-read-event-char): Typo. - - * gnus.el (gnus-summary-mark-article-as-read): Auto-expire ancient - articles. - (gnus-goto-next-group-when-activating): New variable. - (gnus-group-get-new-news-this-group): Use it. - - * nndoc.el (nndoc-transform-clari-briefs): New function. - (nndoc-type-alist): Understand ClariNet briefs. - - * gnus.el (gnus-group-read-ephemeral-group): Return whether the - group could be entered. - - * gnus-cache.el (gnus-cache-write-active): Would bug out when the - cache dir didn't exist. - -Tue Jan 02 08:31:45 1996 Lars Magne Ingebrigtsen - - * gnus-msg.el (gnus-inews-set-point): New function. - (gnus-sendmail-mail-setup): Use it. - (gnus-new-news): Ditto. - - * gnus.el (gnus-group-browse-foreign-server): Place point before - prompt. - -Thu Dec 21 02:57:06 1995 Lars Magne Ingebrigtsen - - * gnus.el (gnus-summary-walk-group-buffer): Would skip every other - group. - - * gnus.el: 0.26 is released. - -Wed Dec 20 10:18:18 1995 Hideki Ono - - * gnus.el (gnus-update-marks): Compressed list shouldn't be sort. - -Wed Dec 20 00:02:44 1995 Lars Ingebrigtsen - - * gnus.el (gnus-summary-number-of-articles-in-thread): Would - return 0. - (gnus-parse-simple-format): Would mangle some simple mode lines. - (gnus-group-line-format-alist): Wrong spec. - - * gnus-score.el (gnus-file-name-translation-table): New variable. - (gnus-score-find-bnews): Use it. - (gnus-score-file-name): Ditto. - - * gnus-xmas.el (gnus-xmas-group-startup-message): Show the TTY - startup screen on a TTY. - - * gnus.el (gnus-save-killed-list): Doc fix. - (gnus-simplify-mode-line): Leave a bit of space after the id. - (gnus-max-width-function): Would never chop off anything. - (gnus-update-format): Didn't update spec list. - - * nnmail.el (nnmail-insert-lines): Never insert negative Lineses - headers. - - * gnus-cache.el (gnus-cache-possibly-enter-article): Didn't enter - articles into the `gnus-newsgroup-cached' list. - - * gnus-topic.el (gnus-group-prepare-topics): Don't check the - topology quite so often. - - * gnus.el (gnus-group-remove-mark): Didn't remove mark from - undisplayed groups. - - * nnspool.el (nnspool-request-head): Didn't return the artgroup. - - * gnus.el (gnus-summary-update-line): Update tertiary mark as - well. - -Tue Dec 19 22:47:29 1995 Lars Ingebrigtsen - - * gnus-xmas.el (gnus-xmas-read-event-char): Junk all non-key - events. - - * gnus.el (gnus-group-line-format-alist): %t should be a string. - - * gnus-cache.el (gnus-cache-generate-active): Would create bogus - active files. - -Tue Dec 19 18:13:49 1995 Lars Magne Ingebrigtsen - - * gnus.el: 0.25 is released. - - * gnus-msg.el (gnus-cancel-news): Insert the usual user name, not - the "real" one. - - * gnus.el (gnus-group-list-inactive-groups): New variable. - (gnus-group-prepare-flat): Use it. - (gnus-summary-select-article): Returned wrong value. - - * gnus-topic.el (gnus-topic-find-groups): Ditto. - -Tue Dec 19 00:26:26 1995 Lars Ingebrigtsen - - * gnus.el (gnus-summary-limit-to-articles): Reset the processed - articles. - (gnus-summary-goto-subject): Would bug out when used silently. - - * nnsoup.el (nnsoup-request-expire-articles): Didn't really work. - - * gnus-cite.el (gnus-article-hide-citation): Take a prefix to - "show". - - * gnus.el (gnus-article-hide-headers): Take a prefix to "show". - (gnus-article-hide-pgp): Ditto. - (gnus-article-hide-signature): Ditto. - (gnus-article-hide): Ditto. - (gnus-article-show-hidden-text): New function. - -Mon Dec 18 15:13:21 1995 Lars Ingebrigtsen - - * gnus.el (gnus-request-restore-buffer): New function. - - * gnus-msg.el (gnus-associate-buffer-with-draft): New function. - (gnus-enter-into-draft-group): Removed functio. - - * gnus.el (gnus-request-associate-buffer): New function. - - * nndraft.el: New file. - -Sun Dec 17 20:16:45 1995 Lars Ingebrigtsen - - * gnus-score.el (gnus-score-score-files-1): New function. - (gnus-score-score-files): Use it to be able to provide full bnews - file syntax matching when using short file names. - - * gnus-cite.el (gnus-article-hide-citation-in-followups): New - command and keystroke. - - * gnus-score.el (gnus-summary-rescore): New command and keystroke. - - * gnus.el (gnus-summary-catchup-and-goto-next-group): Didn't save - point. - (gnus-single-article-buffer): New variable. - (gnus-article-setup-buffer): Use it. - (gnus-summary-setup-buffer): Ditto. - (gnus-move-split-methods): New variable. - (gnus-get-split-value): New function. - (gnus-read-save-file-name): Use it. - (gnus-read-move-group-name): New function. - (gnus-summary-copy-article): Use them. - (gnus-summary-move-article): Ditto. - -Sun Dec 17 16:06:11 1995 Lars Magne Ingebrigtsen - - * gnus.el: 0.24 is released. - - * nndoc.el (nndoc-guess-digest-type): Didn't grok MIME digests. - - * gnus.el (gnus-all-windows-visible-p): Would bug out on buffers - that didn't exist. - (gnus-all-windows-visible-p): Allow strings in buffer-config. - (gnus-configure-frame): Ditto. - (gnus-remove-text-with-property): Didn't remove all text. - - * gnus-uu.el (gnus-uu-grab-articles): Would delete files after - decoding them. - -Sun Dec 17 00:12:34 1995 Lars Ingebrigtsen - - * gnus-score.el (gnus-score-followup-article): New command. - (gnus-score-followup-thread): New command. - - * gnus.el (gnus-compile): New implementation; save in - .newsrc.eld. - (gnus-summary-rethread-thread): New command and keystroke. - -Sat Dec 16 22:22:58 1995 Lars Ingebrigtsen - - * nnspool.el (nnspool-find-article-by-message-id): Decompose the - output; renamed. - (nnspool-request-article): Use the function. - (nnspool-retrieve-headers): Ditto. - - * gnus.el (gnus-group-catchup): Do the auto-expirable thaang. - - * gnus-cache.el (gnus-cache-possibly-enter-article): Don't enter - empty articles into the cache. - - * nnspool.el (nnspool-find-nov-line): Would often not find the - right line. - -Sat Dec 16 14:26:27 1995 Lars Magne Ingebrigtsen - - * gnus.el (gnus-summary-exit): Would nix out the group name of - parents to nndoc groups. - - * gnus.el: 0.23 is released. - -Fri Dec 15 20:55:26 1995 Lars Ingebrigtsen - - * gnus.el (gnus-buffer-configuration): New default value. - (gnus-configure-windows): Use it. - (gnus-all-windows-visible-p): New implementation. - -Fri Dec 15 19:28:07 1995 Jason L. Tibbitts, III - - * nnml.el (nnml-generate-nov-file): Directory names with/without - slashes. - -Fri Dec 15 18:55:28 1995 Lars Ingebrigtsen - - * gnus-cache.el (gnus-cache-generate-nov-databases): Called wrong - nnml function. - - * gnus.el (gnus-summary-exit): Don't clear the group name until - the last hook has been run. - -Fri Dec 15 18:53:29 1995 Lance A. Brown - - * gnus.el (gnus-parse-simple-format): %4,4i would break function. - -Fri Dec 15 18:48:07 1995 Michael Sperber - - * nnheader.el (nnheader-file-to-number): Would return a list of - strings. - -Fri Dec 15 12:14:08 1995 Lars Ingebrigtsen - - * gnus.el (gnus-configure-frame): New function. - -Thu Dec 14 20:16:30 1995 Jason L. Tibbitts, III - - * gnus.el (gnus-simplify-subject-fully): New function. - -Thu Dec 14 17:55:03 1995 Lars Ingebrigtsen - - * gnus.el (gnus-update-missing-marks): New function. - (gnus-select-newsgroup): Use it. - - * gnus-uu.el (gnus-uu-grabbed-file-functions): New variable. - (gnus-uu-grab-articles): Use it. - (gnus-uu-grab-view, gnus-uu-grab-move): New functions. - - * gnus-score.el (gnus-possibly-score-headers): Allow a - `score-file' group parameter. - -Thu Dec 14 12:42:20 1995 Lars Magne Ingebrigtsen - - * nnheader.el (nnheader-file-to-number): Returned strings instead - of numbers. - -Thu Dec 14 10:48:51 1995 Lars Magne Ingebrigtsen - - * gnus.el (gnus-summary-toggle-header): Don't do that hook dance. - - * gnus.el: 0.22 is released. - -Thu Dec 14 10:02:08 1995 Lars Magne Ingebrigtsen - - * gnus-xmas.el (gnus-xmas-read-event-char): New function. - - * gnus.el (gnus-summary-last-subject): New function. - (gnus-summary-next-article): Understand all key events. - (gnus-summary-walk-group-buffer): New function. - (gnus-read-event-char): New function. - -Wed Dec 13 16:06:29 1995 Lars Ingebrigtsen - - * gnus-msg.el (gnus-new-mail, gnus-mail-reply): Didn't insert - Gcc. - - * gnus-score.el (gnus-score-load-file): Allow `adapt-file' atom. - (gnus-score-adaptive): Use it. - - * gnus.el (gnus-group-visible-select-group): New command and - keystroke. - (gnus-read-save-file-name): Extend the syntax of - `gnus-split-methods'. - (gnus-article-archive-name): New function. - (gnus-split-methods): New default; use function above. - (gnus-summary-update-secondary-mark): Update highlighting after - setting secondary marks. - - * nnfolder.el (nnfolder-request-group): Don't load all nnfolder - groups on startup. - -Tue Dec 12 19:48:55 1995 Lars Ingebrigtsen - - * gnus.el (gnus-group-insert-group-line): Number of marked (etc) - didn't work. - -Tue Dec 12 19:37:05 1995 Timo Metzemakers - - * gnus.el (gnus-summary-reselect-current-group): Really reselect - the group. - -Tue Dec 12 10:38:05 1995 Lars Ingebrigtsen - - * nnmail.el (nnmail-days-to-time): Would result in short expiry - times in groups with veeery long expiry times. - - * gnus-vis.el (gnus-summary-highlight-line): Bind `number'. - - * gnus-score.el (gnus-score-find-bnews): Protect agains bogus - score file names. - - * gnus.el (gnus-activate-all-groups): New command and keystroke. - - * gnus-vis.el (gnus-article-prev-button): New command and keystroke. - - * gnus-cache.el (gnus-cache-generate-nov-databases): New command. - - * gnus-score.el (gnus-score-load-file): Accept - `thread-mark-and-expunge' atom. - - * gnus.el (gnus-newsgroup-saved): New variable. - (gnus-summary-set-saved-mark): New function. - (gnus-kill-summary-on-exit): New variable. - (gnus-dead-summary-mode): New minor mode. - (gnus-deaden-summary, gnus-summary-wake-up-the-dead): New - functions. - (gnus-summary-catchup-and-goto-next-group): Respect - `gnus-auto-select-next', etc. - (gnus-article-hide-headers): New implementation. - (gnus-article-header-rank): New function. - (gnus-article-header-less): Ditto. - (gnus-visible-headers, gnus-ignored-headers): Can now be lists of - regexps. - (gnus-thread-expunge-below): New variable. - (gnus-expunge-thread): New variable. - - * gnus-mh.el (gnus-summary-save-in-folder): There is no - `mh-search-path'. - -Mon Dec 11 07:21:25 1995 Lars Ingebrigtsen - - * gnus.el (gnus-article-sort-functions): New variable. - (gnus-article-sort-by-number, gnus-article-sort-by-author, - gnus-article-sort-by-subject, gnus-article-sort-by-date, - (gnus-article-sort-by-score): New functions. - (gnus-thread-sort-by-number, gnus-thread-sort-by-author, - gnus-thread-sort-by-subject, gnus-thread-sort-by-date, - gnus-thread-sort-by-score, gnus-summary-sort-by-number, - gnus-summary-sort-by-author, gnus-summary-sort-by-subject, - gnus-summary-sort-by-date, gnus-summary-sort-by-score, - gnus-summary-sort): New implementations. - (gnus-summary-mode-line-format): Doc fix. - (gnus-insert-pseudo-articles): New variable. - (gnus-activate-level): New variable. - (gnus-get-unread-articles): Use it. - - * nnkiboze.el (nnkiboze-request-delete-group): New function. - - * gnus.el (gnus-subscribe-killed): New function. - (gnus-group-kill-group): Make mass group slaughter faster. - (gnus-group-kill-level): New command and keystroke. - - * gnus-cache.el (gnus-cache-generate-active): Messed up the active - file. - - * gnus.el (gnus-summary-update-secondary-mark): New function. - (gnus-cached-mark): New variable. - (gnus-gmt-to-local): Removed function. - (gnus-narrow-to-page): New implementation. - - * gnus-cache.el (gnus-cache-enter-article): New command and - keystroke. - (gnus-cache-remove-article): Ditto. - (gnus-passive-cache): New variable. - (gnus-cached-article-p): New function. - - * gnus.el (gnus-summary-mode-line-format, - gnus-article-mode-line-format, gnus-group-mode-line-format): - Include the buffer name in all mode lines. - - * gnus-topic.el (gnus-topic-yank-group, gnus-topic-kill-group): - Allow kill/yank inside and in between topics. - - * gnus.el (gnus-request-type): Wouldn't work. - -Sun Dec 10 13:16:49 1995 Lars Ingebrigtsen - - * gnus-topic.el (gnus-topic-insert-topic-line): Remove old text - properties before setting new. - - * nnml.el: Understand jka-compr. - (nnml-generate-nov-databases): Would make empty group disappear. - - * nnheader.el (nnheader-numerical-short-files): New variable. - (nnheader-numerical-full-files): Ditto. - - * gnus-msg.el (gnus-summary-resend-message): Rename old Resent-* - headers. - - * gnus-cache.el (gnus-cache-retrieve-headers): Allow fetching of - old headers. - - * nnmail.el (nnmail-get-spool-files): Don't ditch procmail - symlinks. - - * gnus-msg.el (gnus-inews-insert-signature): Don't insert - signature if mail-signature. - - * gnus.el (gnus-group-make-help-group): Find gnus-tut in the etc - directory. - -Sun Dec 10 12:29:54 1995 Lars Magne Ingebrigtsen - - * gnus.el (gnus-article-date-ut): Bugged out on pseudos. - -Sun Dec 10 10:38:47 1995 Lars Magne Ingebrigtsen - - * gnus.el: 0.21 is released. - - * gnus.el (gnus-backlog-shutdown): New function. - (gnus-backlog-buffer): Would return a list the first time called. - - * gnus-msg.el (gnus-summary-send-draft): Didn't manage to actually - post anything. - (gnus-summary-cancel-article): Would bug out when canceling - canceled articles. - - * gnus.el (gnus-create-xref-hashtb): Wouldn't mark component - groups as read. - (gnus-method-option-p): Only checked 'post. - -Sun Dec 10 07:18:56 1995 David K}gedal - - * gnus-cache.el (gnus-cache-generate-active): Didn't work. - -Sun Dec 10 10:01:06 1995 Lars Magne Ingebrigtsen - - * gnus-setup.el (gnus-use-bbdb): `gnus-startup-hook' wasn't - quoted. - -Sun Dec 10 06:37:45 1995 Lars Ingebrigtsen - - * nndoc.el: Reimplemented most of this file. - -Sat Dec 9 16:35:54 1995 Lars Ingebrigtsen - - * gnus.el (gnus-summary-setup-buffer): Didn't set - `gnus-summary-buffer' reliably. - (gnus-summary-enter-digest-group): Use the original article - buffer. - -Sat Dec 9 10:59:52 1995 Lars Magne Ingebrigtsen - - * gnus.el (gnus-group-expire-articles): Wrong arguments. - - * nnmail.el (nnmail-time-less): Didn't return proper times. - - * gnus.el: 0.20 is released. - -Sat Dec 9 08:50:34 1995 Lars Magne Ingebrigtsen - - * gnus.el (gnus-update-marks): Chop off nils at the end of group - infos. - - * gnus.el: 0.19 is released. - -Sat Dec 9 03:21:40 1995 Lars Ingebrigtsen - - * gnus-setup.el (gnus-use-bbdb): Said `gnus-use-mh' instead of - `gnus-use-mhe'. - -Fri Dec 8 07:44:35 1995 Lars Ingebrigtsen - - * nnmail.el (nnmail-expiry-wait): Can now be a floating point - number. - - * gnus.el (gnus-group-list-level): New command and keystroke. - (gnus-group-expire-articles): Use `expiry-wait' group parameter. - - * nnmail.el (gnus-expired-article-p): New function. - (nnmail-expired-article-p): New function. - (nnmail-expiry-wait): Allow `never' and `immediate' values. - - * nnbabyl.el (nnbabyl-request-expire-articles): Use it. - * nnml.el (nnml-request-expire-articles): Ditto. - * nnmh.el (nnmh-request-expire-articles): Ditto. - * nnfolder.el (nnfolder-request-expire-articles): Ditto. - * nnmbox.el (nnmbox-request-expire-articles): Ditto. - * nnsoup.el (nnsoup-request-expire-articles): Ditto. - - * gnus-msg.el (gnus-required-mail-headers): Allow Expires as a - value. - (gnus-inews-insert-headers): Use it. - (gnus-inews-expires): New function. - (gnus-article-expires): New variable. - (gnus-distribution-function): New variable. - (gnus-inews-distribution): New function. - - * gnus.el (gnus-group-edit-group-done): Allow creation of new - groups. - - * gnus-topic.el (gnus-topic-insert-topic-line): Remove excess - properties. - - * gnus-mh.el (gnus-mh-mail-setup): Let mh decide where to put - point. - - * gnus.el (gnus-summary-exit): Clear group name. - (gnus-summary-exit-no-update): Ditto. - -Tue Dec 5 21:54:39 1995 Steven L. Baur - - * gnus-setup.el: Use default installation paths, misc. cleanup - -Fri Dec 8 06:33:48 1995 Lars Ingebrigtsen - - * nnmail.el (nnmail-save-active): Don't bug out on backends that - don't have an active file. - -Wed Dec 6 08:29:04 1995 Steven L. Baur - - * gnus-msg.el (gnus-mail-reply): Defend against zmacs regions being - enabled. - -Fri Dec 8 05:20:06 1995 Jens Lautenbacher - - * gnus.el (gnus-group-unsubscribe-group): Don't update groups twice. - -Thu Dec 7 10:31:04 1995 Lars Ingebrigtsen - - * gnus-cache.el (gnus-cache-open): New function. - (gnus-cache-close): Ditto. - (gnus-cache-generate-active): New command. - (gnus-cache-update-active): New function. - (gnus-cache-write-active): Ditto. - (gnus-cache-read-active): Ditto. - - * gnus.el (gnus-kill-all-overlays): New function. - - * gnus-cache.el (gnus-cache-active-file): New variable. - -Wed Dec 6 23:08:28 1995 Lars Magne Ingebrigtsen - - * nnspool.el (nnspool-find-nov-line): Wouldn't do anything right. - -Wed Dec 6 04:25:38 1995 Lars Ingebrigtsen - - * gnus.el (gnus-update-marks): Killed articles shouldn't be - uncompressed. - (gnus-article-hide-pgp): Don't delete "- " quotes. - - * gnus-topic.el (gnus-topic-create-topic): Default to the root - topic as the parent. - - * gnus-msg.el (gnus-debug): Reverse order. - - * nnsoup.el (nnsoup-store-reply): Do more messaging. - - * gnus-soup.el (gnus-soup-store): Enter each buffer just once. - - * gnus-topic.el (gnus-topic-move-matching): Swapped interactive - args. - (gnus-topic-copy-matching): Ditto. - - * gnus.el (gnus-summary-prepare-threads): Mark low-scored as - expirable, if desired. - (gnus-summary-prepare-unthreaded): Ditto. - (gnus-summary-limit-children): Ditto. - -Wed Dec 6 04:14:28 1995 Wes Hardaker - - * gnus.el (gnus-gnus-to-newsrc-format): Would bug on on ranks. - -Tue Dec 5 15:58:01 1995 Jens Lautenbacher - - * gnus.el (gnus-build-old-threads): Will work again. - -Tue Dec 5 10:35:51 1995 David K}gedal - - * gnus-msg.el (gnus-inews-insert-headers): Use cadr of the result - from gnus-extract-address-components instead of the car. - (gnus-summary-resend-message): Do not call mail-setup, and use - fewer headers. - -Wed Dec 6 03:01:04 1995 Lars Ingebrigtsen - - * nnmail.el (nnmail-process-mmdf-mail-format): Renamed. - (nnmail-process-mmdf-mail-format): Wouldn't skip delims. - - * gnus-mh.el (gnus-summary-save-in-folder): Search `exec-path' for - "rcvstore". - - * nnvirtual.el (nnvirtual-request-type): New function. - - * gnus-msg.el (gnus-post-news): Allow correct followup and posting - in nnsoup and nnvirtual groups. - - * nnsoup.el (nnsoup-request-type): New function. - - * gnus.el (gnus-request-type): New function. - - * gnus-msg.el (gnus-news-group-p): New function. - -Wed Dec 6 02:20:13 1995 Steven L. Baur - - * gnus-setup.el: New version. - -Tue Dec 5 10:07:09 1995 Lars Ingebrigtsen - - * gnus-msg.el (gnus-mail-reply): Would sometimes try to go to - nil. - - * gnus.el (gnus-article-prepare): Nix out non-header headers. - (gnus-set-mode-line): Protect agains pseudos. - (gnus-update-marks): Always sort before compressing. - -Tue Dec 5 09:57:20 1995 Ishikawa Ichiro - - * gnus-msg.el (gnus-group-post-news): Don't bug out on empty group - buffers. - -Tue Dec 5 09:32:57 1995 Lars Ingebrigtsen - - * nnmail.el (nnmail-process-unix-mail-format): Better error - message. - - * gnus-topic.el (gnus-topic-rename): Bugged out and didn't - redisplay. - -Sun Dec 3 11:44:08 1995 Steven L. Baur - - * gnus-msg.el (gnus-inews-do-fcc): Protect call to rmail-output by - temporarily setting mail-use-rfc822 to t. - - * gnus.el (gnus-summary-save-in-mail): Ditto. - -Tue Dec 5 09:28:00 1995 Lars Ingebrigtsen - - * nnmail.el (nnmail-get-new-mail): Dereference symlinks. - -Tue Dec 5 03:22:37 1995 Lars Magne Ingebrigtsen - - * nnbabyl.el (nnbabyl-close-server): Restore buffer mode on exit. - - * gnus-score.el (gnus-summary-increase-score): Simplify Xref - matches. - - * gnus.el: 0.18 is released. - -Mon Dec 4 02:06:19 1995 Lars Ingebrigtsen - - * gnus-msg.el (gnus-summary-resend-message): New command and - keystroke. - (gnus-inews-insert-headers): Deleted wrong part of line. - - * nnmail.el (nnmail-process-unix-mail-format): Don't bug out on - (nearly) empty files. - - * gnus-msg.el (gnus-summary-mail-other-window): Force window config. - - * gnus-cache.el (gnus-cache-file-name): Make sure there are no - double slashes in the name. - -Mon Dec 4 02:00:01 1995 Jason L. Tibbitts, III - - * gnus-uu.el (gnus-uu-decode-with-method): Didn't respect - `gnus-uu-do-not-unpack-archives'. - -Mon Dec 4 01:52:10 1995 Lars Ingebrigtsen - - * gnus.el (gnus-summary-move-article): Marked all moved articles - as read. - -Sun Dec 3 16:49:58 1995 Jens Lautenbacher - - * gnus-topic.el (gnus-topic-update-topic-line): bombed out on exit - from a group that was selected from the list of killed groups - -Sun Dec 3 15:03:02 1995 Jens Lautenbacher - - * gnus-topic.el (gnus-topic-update-topic): parameter `group' in - call to gnus-group-goto-group may be NIL in topic-mode - -Sun Dec 3 11:44:08 1995 Steven L. Baur - - * gnus.el (gnus-slave-no-server): New Function. - (gnus-no-server): Add optional slave parameter. - -Mon Dec 4 01:05:47 1995 Lars Ingebrigtsen - - * gnus.el (gnus-group-goto-group): Ignore nil groups. - -Sun Dec 3 04:19:33 1995 Jens Lautenbacher - - * gnus-topic.el (gnus-topic-mode-map): Using mouse-2 to hide/show - topics works. - -Fri Dec 1 21:21:18 1995 Steven L. Baur - - * gnus-msg.el (gnus-inews-insert-headers): Call new function for - value of X-Newsreader:, and X-Mailer: headers - (gnus-extended-version): New function returning a string with Gnus - version + Emacs version - -Mon Dec 4 00:18:44 1995 Lars Ingebrigtsen - - * gnus.el: Show Apparently-To and Resent-*. - (gnus-build-get-header): Include old-fetched articles in the limit. - -Sun Dec 3 22:45:15 1995 Lars Ingebrigtsen - - * gnus-topic.el (gnus-topic): Provide. - -Sun Dec 3 03:09:29 1995 Lars Magne Ingebrigtsen - - * gnus.el (gnus-group-insert-group-line): Didn't set proper - numbers of unread articles. - - * gnus-setup.el: New file. - -Sun Dec 3 00:34:01 1995 Lars Magne Ingebrigtsen - - * gnus-topic.el (gnus-topic-delete): New command and keystroke. - - * gnus.el: 0.17 is released. - -Sat Dec 2 00:10:23 1995 Lars Ingebrigtsen - - * gnus.el (gnus-intern-safe): Didn't return the proper symbol. - - * gnus-topic.el (gnus-topic-move-matching): New command and - keystroke. - (gnus-topic-copy-matching): New command and keystroke. - (gnus-topic-change-name): New command and keystroke. - - * gnus.el (gnus-group-mark-regexp): New command and keystroke. - - * gnus-topic.el (gnus-topic-mark-topic): New command and - keystroke. - (gnus-topic-get-new-news-this-topic): New command and keystroke. - - * gnus.el (gnus-group-set-mark): New function. - -Fri Dec 1 01:58:48 1995 Lars Ingebrigtsen - - * gnus-topic.el (gnus-topic-copy-to-topic): New function. - - * gnus-topic.el: Changes throughout. - - * gnus.el (gnus-summary-prepare-threads): Have "name" default more - often to From. - (gnus-summary-insert-line): Ditto. - (gnus-get-unread-articles): Close the group. - (gnus-update-format-specifications): Really read the descriptions - files. - (gnus-post-method): Would return the wrong posting method. - (gnus-summary-dummy-line-format): Set mouse-face. - (gnus-update-summary-mark-positions): Bind `gnus-visual' to nil. - (gnus-get-newsgroup-headers): Don't reset - `gnus-article-internal-prepare-hook'. - (gnus-group-edit-global-kill): Better message. - (gnus-topic-alist): New variable. - - * gnus-msg.el (gnus-signature-before-forwarded-message): New - variable. - (gnus-forward-start-separator): Changed name. - (gnus-forward-end-separator): Ditto. - (gnus-forward-insert-buffer): Use them. - - * gnus.el (gnus-check-bogus-newsgroups): Be a bit more - conservative in removing bogus groups. - -Wed Nov 29 22:02:36 1995 Lars Ingebrigtsen - - * gnus.el (gnus-mouse-pick-group): Doc fix. - (gnus-group-expire-articles): Bugged out on compress sequences. - (gnus-parse-complex-format): Changed %[ specs into %{ specs. - (gnus-group-set-mode-line): Bind `header'. - (gnus-summary-prepare-threads): Don't output lots and lots of - dummy lines. - - * gnus-topic.el (gnus-mouse-pick-topic): New command. - - * gnus.el (gnus-group-insert-group-line): Make sure - `gnus-tmp-number' is a string. - (gnus-summary-find-next): Wouldn't handle - `gnus-summary-check-current'. - -Wed Nov 29 21:56:33 1995 Luc Van Eycken - - * gnus.el (gnus-summary-hide-thread): Didn't hide the last thread. - -Wed Nov 29 16:49:25 1995 Lars Ingebrigtsen - - * gnus.el (gnus-summary-prepare-threads): WOuld possibly print - empty lines when that wasn't required. - - * gnus-topic.el (gnus-group-prepare-topics): Created buggy - topologies. - - * gnus.el (gnus-group-sort-by-method): Didn't sort. - (gnus-article-prepare): Deactivate active regions. - (gnus-add-marked-articles): Bugged out when forcing marks. - (gnus-get-newsgroup-headers): Allow dependencies hashtb as a - parameter. - * nnvirtual.el (nnvirtual-convert-headers): Use it. - - * gnus-vis.el (gnus-button-url): New function. - (gnus-button-alist): Use it. - - * gnus.el (gnus-dribble-read-file): Turn on auto save mode - unconditionally. - - * gnus-msg.el (gnus-forward-start-delimiter): New variable. - (gnus-forward-end-delimiter): Ditto. - (gnus-forward-insert-buffer): Use them. - - * gnus-vis.el (gnus-button-alist): Handle mailto: URLs - internally. - -Sun Nov 26 14:46:55 1995 Steven L. Baur - - * gnus.el (gnus-summary-edit-article): force read of articles - that Gnus thinks are pseudos. - -Sun Nov 26 14:46:55 1995 Steven L. Baur - - * gnus.el (gnus-no-server): typo prevented entry to gnus - -Wed Nov 29 15:03:18 1995 Lars Ingebrigtsen - - * gnus.el (gnus-functionp): New function. - (gnus-group-list-active): Really read the active file first. - (gnus-group-list-killed): Ditto. - - * gnus-msg.el: Used throughout. - (gnus-mail-reply): When yanking multiple articles, didn't cite - right. - -Mon Nov 27 17:39:04 1995 Lars Ingebrigtsen - - * nnmail.el (nnmail-process-unix-mail-format): Might possibly - collate two mails. - (nnmail-process-unix-mail-format): Would become confused when - articles contained Content-Length headers. - -Sun Nov 26 15:15:29 1995 Lars Magne Ingebrigtsen - - * gnus.el: 0.16 is released. - - * gnus.el (gnus-select-newsgroup): Would bug out on dead groups. - (gnus-summary-hide-thread): Didn't work at all. - - * gnus-xmas.el (gnus-xmas-group-remove-excess-properties): - Redefinition of the function. - (gnus-xmas-group-insert-group-line-info): Removed function. - - * gnus.el (gnus-group-remove-excess-properties): New dummy - function. - -Sat Nov 25 13:41:08 1995 Steven L. Baur - - * gnus.el (gnus-mouse-face-function): One comma too many on - gnus-mouse-face-prop - - * gnus-xmas.el (gnus-xmas-redefine): Don't undefine - gnus-mouse-face-function. - (gnus-xmas-group-insert-group-line-info): Remove now bogus first - parameter. - -Sun Nov 26 14:33:52 1995 Lars Magne Ingebrigtsen - - * gnus-score.el (gnus-score-set-mark-below): Use new update - function. - -Sat Nov 25 18:31:11 1995 Lars Ingebrigtsen - - * gnus.el (gnus-byte-code): Didn't work for uncompiled functions. - (gnus-summary-prepare-unthreaded): Mark articles as read. - (gnus-summary-update-lines): Just do visual highlighting. - (gnus-summary-insert-line): Allow visual highlights here. - (gnus-summary-update-lines): Removed function. - (gnus-summary-prepare-threads): More efficient implementation. - - * gnus-score.el (gnus-score-update-lines): New implementation. - -Sat Nov 25 12:38:20 1995 Lars Magne Ingebrigtsen - - * gnus.el (gnus-group-first-unread-group): Bugged out on topics. - -Sat Nov 25 10:55:49 1995 Lars Magne Ingebrigtsen - - * gnus.el: 0.15 is released. - - * gnus-topic.el (gnus-topic-mode): Allow not redisplaying. - - * gnus.el (gnus-summary-update-info): Kill score list. - - * gnus-vis.el (gnus-button-alist): Didn't allow clicking on URLs. - - * gnus.el (gnus-summary-read-group): Wouldn't allow selecting - groups with just ticked articles. - -Fri Nov 24 13:35:45 1995 Lars Ingebrigtsen - - * gnus.el (gnus-update-format): Command to update and show format - specs. - -Thu Nov 23 12:58:33 1995 Lars Ingebrigtsen - - * gnus.el (gnus-guess-doc-type): New function. - (gnus-group-make-doc-group): Accept forward and MMFD. - (gnus-summary-enter-digest-group): Guess at a type. Prefix forces - old interpretation. - (gnus-find-new-newsgroups): Would choke on unbound group syms. - (gnus-group-insert-group-line-info): Might bug out when listing - bogus things. - - * nndoc.el (nndoc-type-to-regexp): Now understands MMFD files. - - * gnus.el (gnus-summary-work-articles): Include the active region - in the process/prefix convention. - (gnus-group-process-prefix): Ditto. - - * nnmail.el (nnmail-article-group): Be a bit more efficient. - - * nnmbox.el (nnmbox-save-mail): Accept stuff from MMFD and babyl - inboxes. - * nnfolder.el (nnfolder-save-mail): Ditto. - - * nnmail.el (nnmail-crash-box): New variable. - (nnmail-get-new-mail): First move over to .gnus-crash-box before - moving to Incoming*. - (nnmail-process-mmfd-mail-format): New function. - - * gnus-mh.el (gnus-mh-mail-setup): Copy the keymap before altering - it. - - * gnus.el (gnus-tmp-prev-perm): Removed variable and use thereof. - (gnus-no-server): Make `gnus-group-use-permanent-levels' into a - buffer-local variable. - -Thu Nov 23 12:54:41 1995 Luc Van Eycken - - * gnus.el (gnus-summary-prepare-threads): Put data-pos at the - beginning of the line. - -Thu Nov 23 12:18:38 1995 Lars Ingebrigtsen - - * gnus.el (gnus-summary-limit-children): Would sometimes bug out. - (gnus-article-date-ut): Would narrow to headers. - (gnus-article-date-ut): Do highlighting when called - interactively. - - * gnus-cache.el (gnus-cache-request-article): Made buffer not - read-only. - -Thu Nov 23 12:04:16 1995 - - * gnus.el (gnus-decode-encoded-word-method): New variable. - (gnus-article-prepare): Use it. - -Thu Nov 23 10:32:23 1995 Lars Ingebrigtsen - - * gnus-ems.el (gnus-ems-redefine): New Mule definition. - - * gnus.el (gnus-permanently-visible-groups): New variable. - (gnus-group-prepare-flat): Use it. - - * gnus-topic.el (gnus-topic-find-groups): Ditto. - -Thu Nov 23 10:03:12 1995 Marc Horowitz - - * gnus-uu.el (gnus-uu-grab-articles): Use the normal Gnus article - fetching functions. - -Thu Nov 23 08:53:28 1995 Lars Ingebrigtsen - - * gnus-vis.el (gnus-button-alist): Recognize - URLs and treat them internally. - - * nnmail.el (nnmail-get-spool-files): Allow `pop' as a value to - `nnmail-spool-file'. - -Thu Nov 23 08:40:12 1995 Ken Raeburn - - * nnmail.el (nnmail-process-babyl-mail-format): New function. - (nnmail-get-new-mail): Now really handles POP mail. - -Wed Nov 22 13:26:45 1995 Lars Ingebrigtsen - - * gnus.el (gnus-summary-next-article): Use - `gnus-group-next-unread-group', etc. - (gnus-group-save-newsrc): Allow a prefix to force. - (gnus-group-sort-groups): Accept a prefix to reverse the sort. - (gnus-parse-simple-format): Optimize the output. - -Tue Nov 21 11:28:59 1995 Lars Ingebrigtsen - - * gnus.el (gnus-parse-complex-format): Now allows multiple - mouse-face regions and multiple face regions. - (gnus-update-format-specifications): Allow forcing. - - * gnus-topic.el: Turned into a minor mode. Now supports - hierarchal topics. - - * gnus.el (gnus-nntp-message): Removed function. - (gnus-request-post): Now only accepts one parameter. - -Mon Nov 20 08:51:45 1995 Lars Ingebrigtsen - - * gnus.el (gnus-open-server): Didn't deny properly. - (gnus-offer-save-summaries): Ignore unprepared summaries. - - * gnus-srvr.el (gnus-server-insert-server-line): Would list - incorrectly. - - * nnspool.el (nnspool-close-server): Really close. - * nnmh.el (nnmh-close-server): Ditto. - * nnml.el (nnml-close-server): Ditto. - - * gnus-srvr.el (gnus-server-read-server): Do updates when failing - to connect. - (gnus-enter-server-buffer): Changed name. - - * gnus.el: Changes thourout to avoid uncompressing/compressing - marks lists when starting up and shutting down. - (gnus-create-xref-hashtb): Mark ticks and dormants as read. - (gnus-backlog-request-article): Bind `buffer-read-only' to nil. - -Sun Nov 19 07:46:43 1995 Lars Ingebrigtsen - - * gnus.el (gnus-summary-toggle-header): Inhibit hiding. - (gnus-mode-non-string-length): Increased due to the new line - number element. - (gnus-group-quit-config): Returned a list instead of a buffer. - -Sun Nov 19 07:28:29 1995 Steven L. Baur - - * gnus.el (gnus-mouse-face-function): One "," too many. - - * gnus-xmas.el (gnus-xmas-redefine): Don't redefine - `gnus-mouse-face-function'. - - * gnus-msg.el (gnus-inews-article): Removed X- prefixes too late. - -Sun Nov 19 06:20:14 1995 Lars Ingebrigtsen - - * gnus-msg.el (gnus-mail-reply): Repsect Mail-Copies-To. - - * gnus.el: Autoload `gnus-summary-save-in-folder'. - -Mon Nov 13 00:35:47 1995 MORIOKA Tomohiko - - * gnus-mh.el (gnus-summary-save-in-folder): Save - `gnus-original-article-buffer' instead of `gnus-article-buffer'. - - * gnus-vm.el (gnus-summary-save-in-vm): Save - `gnus-original-article-buffer' instead of `gnus-article-buffer'. - - * gnus.el (gnus-summary-save-in-rmail): Save - `gnus-original-article-buffer' instead of `gnus-article-buffer'. - (gnus-summary-save-in-mail): Save `gnus-original-article-buffer' - instead of `gnus-article-buffer'. - -Sun Nov 19 01:17:56 1995 Lars Ingebrigtsen - - * gnus.el (gnus-article-prepare): Changed canceled-message. - (gnus-summary-hide-thread): Hide even the last thread. - - * nnsoup.el (nnsoup-close-group): Kill all buffers related to the - group. - -Sat Nov 18 07:14:59 1995 Lars Ingebrigtsen - - * gnus.el (gnus-group-mode): Don't create menus unless the menu - bar is being used. - - * gnus-msg.el (gnus-post-news): Use `to-list' parameter. - -Fri Nov 17 03:35:58 1995 Lars Magne Ingebrigtsen - - * gnus-el: 0.14 is released. - - * gnus-vis.el ((require 'cl)): Require cl. - - * gnus.el (gnus-active): New macro. - (gnus-intern-safe): Ditto. - (gnus-set-active): Ditto. - -Fri Nov 17 01:33:26 1995 Lars Magne Ingebrigtsen - - * gnus.el (gnus-max-width-function): Totally bugged out. - - * gnus-msg.el (gnus-new-news): Set point on Subject. - (gnus-inews-insert-bfcc): Don't narrow to headers. - - * gnus.el (gnus-articles-to-read): `C-u SPC' would have no real - effect. - (gnus-article-date-ut): Would chop up lines. - - * nnheader.el: Require cl. - -Fri Nov 17 00:11:10 1995 Lars Magne Ingebrigtsen - - * gnus.el (gnus-select-newsgroup): Expiry marks would disappear. - (gnus-headers-decode-quoted-printable): Use subst-char instead of - search/replace. - (gnus-remove-thread): Didn't remove properly. - -Thu Nov 16 06:28:17 1995 Lars Ingebrigtsen - - * gnus.el: Intern group in active hashtb throughout. - -Wed Nov 15 06:13:48 1995 Lars Ingebrigtsen - - * gnus.el: 0.13 is released. - - * gnus-score.el (gnus-score-get): Turned into a defsubst. - (gnus-score-find-bnews): Slightly less funcalling. - - * gnus.el (gnus-group-real-name): Turned into a macro. - (gnus-server-equal): Ditto. - (gnus-server-add-address): Turned into defsubst. - (gnus-server-get-method): Ditto. - (gnus-secondary-method-p): Ditto. - -Mon Nov 13 22:13:10 1995 Lars Ingebrigtsen - - * gnus.el (gnus-group-mode-map): Moved fetch-faq. - - * gnus-vis.el (gnus-button-alist): Be a bit more restrictive. - - * gnus-msg.el (gnus-inews-insert-headers): Would choke on empty - headers. - - * nnml.el (nnml-make-nov-line): Include the Xref: in the nov line. - -Mon Nov 13 21:54:36 1995 - - * gnus.el (gnus-summary-save-in-rmail): Save original article - buffer. - -Mon Nov 13 15:10:28 1995 Lars Ingebrigtsen - - * nnsoup.el (nnsoup-open-server): Don't force using nnsoup as a - posting agent. - - * gnus.el (gnus-info-group, gnus-info-level, gnus-info-read, - gnus-info-method, gnus-info-options): New macros. Massive changes - throughout the file. - (gnus-get-info): New macro. - (gnus-group-add-score): New function. - (gnus-summary-bubble-group): New function. - (gnus-group-mode-map): New group sort submap. - (gnus-group-sort-groups-by-alphabet, - gnus-group-sort-groups-by-unread, gnus-group-sort-groups-by-level, - gnus-group-sort-groups-by-score, gnus-group-sort-groups-by-rank, - gnus-group-sort-groups-by-method): New commands and keystrokes. - - * nnsoup.el (nnsoup-set-variables): Autoload; doc fix. - - * gnus-score.el (gnus-score-headers): Score "header" names are now - case-insensitive. - - * gnus.el (gnus-rebuild-thread): Didn't work when using a - non-threaded display. - -Sun Nov 12 00:11:34 1995 Lars Ingebrigtsen - - * nnmail.el (nnmail-use-long-file-names): New variable. - (nnmail-group-pathname): Use it. - - * gnus.el (gnus-auto-select-first): Allow `best' as a value. - - * gnus-uu.el (gnus-uu-save-article): Quote lines that start with - dashes. - - * gnus-mh.el (gnus-mh-mail-setup): Don't use a (None) subject. - - * gnus-msg.el (gnus-inews-insert-bfcc): New function. - (gnus-new-news): Use it. - - * gnus.el (gnus-summary-generate-hook): New variable. - (gnus-summary-prepare): Use it. - - * nnsoup.el (nnsoup-index-buffer): Disable undo. - - * gnus.el (gnus-select-newsgroup): Fetch old headers before - scoring. - (gnus-dribble-read-file): Force setting the dribble buffer file - name. - (gnus-summary-catchup-to-here): Treat `all' right, and catchup to - the right article. - (gnus-summary-catchup): Update mode line. - (gnus-summary-refer-references): Didn't really work. - (gnus-summary-toggle-header): Would barf if point weren't at - point-min. - -Sat Nov 11 11:21:58 1995 Lars Ingebrigtsen - - * nnmail.el (nnmail-move-inbox): Bind default directory before - calling movemail. - - * nndoc.el (nndoc-type-to-regexp): Changed babyl body-begin regexp. - - * nnml.el (nnml-generate-nov-databases): Don't choke on files that - start with empty lines. - - * gnus.el (gnus-souped-mark): New variable. - (gnus-summary-mark-article-as-read): Use it. - (gnus-set-mode-line): Would compute incorrect mode lines. - - * gnus.el: Changes throughout making ticked and dormant articles - subsets of the read articles instead of the unread articles. - - * gnus-soup.el (gnus-soup-add-article): Use it. - - * gnus-msg.el (gnus-post-news): Respect to `to-group' group - parameter. - - * gnus.el (gnus-sublist-p): New function. - (gnus-group-prepare-flat-list-dead): Faster implementation. - -Fri Nov 10 03:17:03 1995 Lars Ingebrigtsen - - * gnus.el (gnus-newsgroup-threads): Double defvar. - (gnus-newsgroup-prepared): New variable. - (gnus-summary-setup-buffer): Use it. - (gnus-summary-prepare-threads): Don't destroy threads while - generating. - (gnus-remove-thread): Didn't remove gathered threads. - (gnus-rebuild-thread): Didn't generate anything properly. - (gnus-summary-refer-parent-article): Didn't find parent. - - * gnus-msg.el (gnus-mail-send-method): Removed variable. - (gnus-auto-mail-to-author): Doc fix. - - * nnheader.el (nnheader-remove-header): Return the number of - headers removed. - - * gnus.el (gnus-headers-de-quoted-unreadable): New function. - (gnus-headers-decode-quoted-readable): New function. - (gnus-article-de-quoted-unreadable): Use it. - -Fri Nov 10 00:00:47 1995 Steven L. Baur - - * gnus-vis.el (gnus-header-button-alist): Recognize X-Url - headers. - -Fri Nov 10 00:00:47 1995 Lars Ingebrigtsen - - * gnus-msg.el (gnus-delete-supersedes-headers): Also remove Xref - and Lines. - (gnus-summary-supersede-article): Delete multi-line headers. - (gnus-news-followup): Insert a few empty lines in new articles. - (gnus-mail-reply): Put point the right place when replying. - (gnus-inews-organization): Don't interpret signatures that begin - with ~ as strings. - (gnus-news-followup): Respect the Newsgroup header. - - * nnsoup.el (nnsoup-write-buffers): New function. - (nnsoup-request-close): Use it. - (nnsoup-pack-replies): Ditto. - - * gnus-soup.el (gnus-soup-parse-replies): Didn't kill buffer. - (gnus-soup-write-prefixes): Would change current buffer. - -Thu Nov 9 20:54:35 1995 Lars Ingebrigtsen - - * gnus.el (gnus-mouse-face-function): More efficient implementation. - (gnus-max-width-function): Ditto. - - * gnus-msg.el (gnus-inews-news): Get the error message from the - right backend. - - * gnus.el (gnus-summary-limit-to-score): Don't infloop. - (gnus-request-post-buffer): Removed function. - (gnus-method-option-p): New function. - (gnus-post-method): New function. - (gnus-request-post): Use it. - - * nnsoup.el (nnsoup-write-active-file): Would possibly kill the - active file. - -Mon Nov 6 13:16:33 1995 Lars Ingebrigtsen - - * gnus-msg.el (gnus-new-news): Removed prompting for group name. - (gnus-group-post-news): Prompt for group name. - (gnus-inews-do-fcc): Rewrite. - - * gnus.el (gnus-group-get-parameter): New function. - -Sat Nov 4 19:24:57 1995 sudish joseph - - * gnus-msg.el (gnus-group-post-news): Use the group under point as - the default when composing the post buffer. (This means that - `a' over a mail group will get you a *mail* buffer.) Using a - prefix ARG will force a fresh post buffer (i.e., no default - group is used). - -Mon Nov 6 12:54:40 1995 steve@miranova.com (Steven L. Baur) - - * gnus-topic.el (gnus-topic-toggle-topic): New command and - keystroke. - -Sat Nov 4 19:07:31 1995 Per Abrahamsen - - * gnus-vis.el (gnus-group-make-menu-bar): Add key description for - the "See old articles" entry and made it run - gnus-group-select-group with an argument. - * gnus.el (gnus-group-select-group-all): Deleted. - -Mon Nov 6 12:22:20 1995 Lars Ingebrigtsen - - * gnus.el (gnus-save-newsrc-file): Set local `version-control' to - `never'. - (gnus-gnus-to-newsrc-format): Ditto. - - * gnus-msg.el (gnus-new-news): Move point to the right place. - (gnus-sendmail-mail-setup): Ditto. - -Sun Nov 5 10:05:47 1995 Lars Ingebrigtsen - - * gnus-msg.el (gnus-configure-posting-styles): Make sure that - `gnus-newsgroup-name' is set. - - * gnus-topic.el (gnus-group-add-to-topic): Remove process marks. - - * nnml.el (nnml-request-move-article): The article has to be - deletable to be moved. - * nnmh.el (nnmh-request-move-article): Ditto. - - * nnmh.el (nnmh-deletable-article-p): New function. - - * nnml.el (nnml-deletable-article-p): New function. - - * gnus.el (gnus-data-compute-positions): Doc fix. - (gnus-summary-sort): Make sure positions were updated. - (gnus-request-article-this-buffer): Set original article buffer to - be read-only. - -Fri Nov 3 03:01:09 1995 Lars Magne Ingebrigtsen - - * gnus.el (gnus-request-article-this-buffer): Make sure all - overlays are dead. - -Fri Nov 3 00:41:22 1995 Lars Ingebrigtsen - - * gnus-xmas.el: Removed mouse tracker. - - * gnus.el (gnus-mouse-face-function): Redefined so that it also - works under XEmacs. - -Thu Nov 2 03:40:22 1995 Lars Ingebrigtsen - - * gnus.el (gnus-batch-score): Don't generate threads and stuff. - (gnus-sort-threads): Better message. - -Tue Oct 31 21:26:35 1995 Lars Ingebrigtsen - - * gnus-topic.el (gnus-topic-remove-topic): Would eat groups under - emtpy topics. - - * gnus.el (gnus-simplify-buffer-fuzzy): Would strip trailing - newlines. - (gnus-group-list-groups): Update format specs. - (gnus-summary-limit-children): Didn't mark as read. - -Mon Oct 30 00:09:42 1995 Lars Ingebrigtsen - - * gnus.el (gnus-summary-find-matching): Wouldn't do `backward' ok. - (gnus-summary-limit-to-subject): Don't just limit to articles - after point. - (gnus-articles-to-read): Respond properly to numerical prefixes. - - * gnus-msg.el (gnus-inews-article): Do the To/X-To shuffle dance. - - * gnus.el (gnus-summary-expire-articles): Be less complaining when - doing total-expiry. - - * gnus-msg.el (gnus-mail-send): Remove empty headers before - sending. - (gnus-inews-remove-empty-headers): New function. - - * gnus.el (gnus-summary-find-next): Respect - `gnus-summary-check-current'. - (gnus-summary-find-prev): Ditto. - (gnus-summary-mode-map): Limit map had disappeared. - (gnus-summary-limit-children): Wouldn't limit properly with - gnus-fetch-old-headers 'some. - -Sun Oct 29 23:37:17 1995 Lars Ingebrigtsen - - * nnmh.el: Use nnmail's new definition. - * nnml.el: Ditto. - - * nnmail.el (nnmail-group-pathname): Use nnmh's definition. - - * gnus.el (gnus-group-startup-message): Change. - -Sun Oct 29 19:57:57 1995 Lars Magne Ingebrigtsen - - * gnus.el: 0.12 is released. - -Tue Oct 24 22:11:44 1995 Peter Arius - - * gnus.el (gnus-summary-skip-intangible): Quotes missing in macro - body; turned into an inline function. - (gnus-summary-article-intangible-p): dito. - (gnus-summary-article-number): Didn't skip intangible articles - when compiled. Turned from macro into an inline function. - -Thu Oct 26 00:04:57 1995 Lars Ingebrigtsen - - * gnus-msg.el (gnus-new-news): Would bug out on nil group names. - - * gnus-mh.el (gnus-mh-mail-send-and-exit): Use mh's send-letter - function. - - * gnus.el (gnus-summary-number-of-articles-in-thread): Don't count - limited articles. - (gnus-summary-number-of-articles-in-thread): Count false roots - correctly. - - * gnus-msg.el (gnus-inews-do-fcc): Expand the FCC file name. - - * gnus.el (gnus-summary-read-group): Update summary line after - setting the initial limit. - (gnus-summary-mode-map): Moved all limit commands to the `/' - submap. - - * gnus-msg.el (gnus-new-mail): Didn't run `gnus-mail-hook'. - -Wed Oct 25 22:45:44 1995 Lars Ingebrigtsen - - * gnus-mh.el (gnus-mh-mail-setup): Didn't set `gnus-mail-buffer'. - - * gnus.el (gnus-compile): Didn't really work. - - * nnbabyl.el (nnbabyl-request-article): Handle Summary-Line. - - * gnus-topic.el: Didn't really work. - - * gnus.el (gnus-parse-simple-format): Bugged out on user format - functions. - (gnus-group-make-help-group): Don't signal errors on non-retrieval - of the doc group. - (gnus-summary-toggle-header): Would delete functions from hook - forever. - -Thu Oct 19 10:08:24 1995 Lars Magne Ingebrigtsen - - * gnus-msg.el (gnus-inews-send-mail-copy): Changed X-Courtesy-Copy - to Posted-To. - -Mon Oct 16 11:57:14 1995 Lars Ingebrigtsen - - * gnus.el (gnus-group-foreign-p): New definition. Secondary - groups aren't foreign. - (gnus-group-native-p): New function. - (gnus-group-secondary-p): New function. - - * gnus-msg.el (gnus-inews-news): Would bug out when called from a - "non-running" Gnus. - - * gnus-mh.el (gnus-mh-mail-setup): Bugged out. - - * gnus.el: 0.11 is released. - -Wed Oct 4 23:08:30 1995 Sudish Joseph - - * gnus.el (gnus-server-yank-server): Couldn't add new servers coz - this bugged out when gnus-server-alist was empty. - (gnus-server-prepare): Bugged out. - -Mon Oct 16 10:59:47 1995 Lars Ingebrigtsen - - * gnus.el (gnus-rebuild-thread): Rebuild complete gathered - threads. - -Sun Oct 15 07:57:26 1995 Lars Ingebrigtsen - - * gnus-msg.el (gnus-new-news): Would insert prefixed group name. - - * gnus.el (gnus-update-format-specifications): Allow the format - strings to be forms. - - * gnus-topic.el (gnus-group-add-to-topic): New command and - keystroke. - - * gnus.el (gnus-article-hide-pgp): Decode the "^- " stuff. - - * gnus-msg.el (gnus-inews-send-mail-copy): WOuld screw things up - when inserting courtesy message. - - * gnus.el (gnus-group-set-current-level): Do better prompting. - (gnus-group-set-current-level): Didn't heed the process mark. - (gnus-select-newsgroup): Would do odd things when selecting a - group with a numerical prefix with some ticked articles. - -Sun Oct 15 03:16:03 1995 Lars Magne Ingebrigtsen - - * gnus.el: 0.10 is released. - - * gnus.el (gnus-summary-limit-to-marks): Don't do any adaptive - thingies. - -Sun Oct 15 01:27:57 1995 Lars Magne Ingebrigtsen - - * gnus.el (gnus-summary-limit-to-marks): Doc fix. - (gnus-remove-articles-1): Updated positions incorrectly. - (gnus-parse-simple-format): User-defined specs bugged out. - -Sat Oct 14 10:04:27 1995 Lars Ingebrigtsen - - * gnus-msg.el (gnus-posting-styles): New variable. - (gnus-posting-style-alist): New variable. - (gnus-configure-posting-styles): New function. - (gnus-new-news): Use it. - (gnus-news-followup): Use it. - (gnus-mail-setup): Use it. - - * gnus-score.el (gnus-score-adaptive): Iterate over data, not the - buffer. - - * gnus.el (gnus-data-pseudo-p): New function. - - * gnus-score.el: Removed `gnus-score-remove-lines-adaptive'. - - * nnfolder.el (nnfolder-request-delete-group): Didn't totally - remove the group from all structures. - - * gnus.el (gnus-summary-move-article): Don't remove lines that - correspond to moved articles. - (gnus-summary-copy-article): Copy into the cache, possibly. - (gnus-summary-move-article): Ditto. - - * gnus-uu.el (gnus-uu-find-articles-matching): Iterate over the - data instead of the buffer. - - * gnus.el (gnus-rebuild-thread): Didn't work on untreaded displays - (or anywhere else). - (gnus-summary-insert-dummy-line): New implementation. - (gnus-summary-prepare-threads): Don't output dummy lines that - don't have children. - (gnus-summary-skip-intangible): New function. - (gnus-summary-article-intangible-p): New function. - -Sat Oct 14 02:07:39 1995 Lars Magne Ingebrigtsen - - * gnus.el: 0.9 is released. - - * gnus.el (gnus-summary-refer-parent-article): Take a look at the - actual References header. - - * gnus-msg.el (gnus-bug): Wrong number of arguments for - `mail-setup'. - -Fri Oct 13 10:25:49 1995 Lars Ingebrigtsen - - * gnus-msg.el (gnus-mail-reply): Would ignore To headers. - -Fri Oct 13 05:58:15 1995 Lars Magne Ingebrigtsen - - * gnus.el: 0.8 is released. - - * gnus.el (gnus-parse-format): Would totally bug out. - -Fri Oct 13 01:38:43 1995 Lars Ingebrigtsen - - * gnus.el (gnus-summary-toggle-header): Run - `gnus-article-display-hook' after unhiding headers. - - * gnus-vis.el (gnus-summary-highlight-line): Would sometimes boug - out on nil marks. - - * gnus-msg.el (gnus-new-news): Have `C-c C-d' work in new - *post-news* buffers. - (gnus-post-prepare-function): Not used. - (gnus-post-prepare-hook): Ditto. - - * gnus-soup.el (gnus-soup-write-replies): Create dir if it doesn't - exist. - - * gnus-msg.el (gnus-prepare-article-hook): Don't insert - signature. - - * gnus-score.el (gnus-score-adaptive): Would bug out an pseudos. - - * nnfolder.el (nnfolder-request-create-group): Would create bogus - active entries. - -Thu Oct 12 09:47:37 1995 Lars Ingebrigtsen - - * gnus.el (gnus-summary-pipe-output): Raise the *Shell* window. - (gnus-group-sort-groups): Would peel off the first group. - - * gnus-msg.el (gnus-mail-forward): Would create two headers. - - * nndoc.el (nndoc-type-to-regexp): Allow reading of forwarded - article. - - * gnus-msg.el (gnus-mail-setup): Changed params. - -Thu Oct 12 03:20:42 1995 Lars Magne Ingebrigtsen - - * gnus.el: 0.7 is released. - - * gnus-xmas.el (gnus-xmas-setup-group-toolbar): Would bug out when - there was no etc dir. - -Thu Oct 12 02:42:50 1995 Lars Magne Ingebrigtsen - - * gnus-msg.el (gnus-inews-check-post): Check for bogus From lines. - -Wed Oct 11 03:29:56 1995 Lars Ingebrigtsen - - * gnus.el (gnus-data-update-list): New function. - (gnus-rebuild-thread): Didn't really work. - (gnus-summary-isearch-article): Allow regexp isearch. - (gnus-buffer-substring): Made into a macro. - -Thu Oct 5 13:09:27 1995 Lars Ingebrigtsen - - * gnus.el (gnus-nov-parse-line): Use NoCeM. - - * gnus-score.el (gnus-score-close): New function. - - * gnus-nocem.el: New file. - - * gnus-demon.el: New file. - -Wed Oct 4 20:03:44 1995 Lars Ingebrigtsen - - * gnus.el (gnus-summary-limit-to-unread): Did the opposite of what - it was supposed to do. - (gnus-summary-initial-limit): New function. - (gnus-summary-limit-children): New function. fetch-old 'some, - dormant and expunge now works again. - (gnus-compile): New command. - - * gnus.el: Byte-compile all default format specs. - -Wed Oct 4 12:28:04 1995 Lars Magne Ingebrigtsen - - * gnus.el: 0.6 is released. - - * x-easymenu.el: Included twice. - -Mon Oct 2 08:23:30 1995 Lars Ingebrigtsen - - * gnus-soup.el (gnus-soup-write-prefixes): New function. - - * gnus.el (gnus-group-make-directory-group): Create better group - names. - (gnus-summary-toggle-header): More correct implementation. - - * nneething.el (nneething-map-file): Would bug out if the map dir - exists. - - * gnus.el (gnus-saved-headers): New variable. - - * gnus-msg.el (gnus-news-followup): Do X-Mail-Copy handling. - - * gnus-topic.el (gnus-topic-insert-topic): Use `topic' local - params. - - * gnus.el (gnus-group-update-group): New implementation. - - * gnus-msg.el (gnus-mailing-list-groups): New variable. - - * gnus.el (gnus-open-server): Deny or allow opening based on - previous successes. - (gnus-server-open-server): New command and keystroke. - (gnus-server-close-server): Ditto. - (gnus-server-deny-server): Ditto. - (gnus-backlog-enter-article): New function. - (gnus-backlog-remove-oldest-article): New function. - (gnus-backlog-request-article): New function. - (gnus-request-article-this-buffer): Use the backlog. - (gnus-keep-backlog): New variable. - - * nntp.el: Removed all `nntp-timeout-servers' code. - -Sun Oct 1 11:40:58 1995 Lars Ingebrigtsen - - * gnus.el (gnus-score-find-bnews): Would sometimes add the local - score file twice. - -Thu Sep 28 21:10:44 1995 Per Abrahamsen - - * gnus.el (gnus-article-treat-overstrike): Fixed range error for - the letter backspace underscore case. - -Wed Sep 27 17:28:31 1995 Per Abrahamsen - - * gnus-msg.el (gnus-inews-insert-mime-headers): Allow it to be - called in the compose buffer. - -Sun Oct 1 10:26:26 1995 Lars Ingebrigtsen - - * gnus.el (gnus-summary-copy-article): Would bug out on - respooling. - - * nndir.el (nndir-request-expire-articles): Couldn't expire - articles. - - * gnus.el (gnus-group-make-group): Returned nil. - - * gnus-msg.el (gnus-post-news): Couldn't post from the group - buffer. - -Wed Sep 27 14:53:36 1995 Per Abrahamsen - - * gnus-edit.el (gnus-score-custom-get): Setting adapt to an atom - didn't work. Reported by kchrist@lochness.ncrmicro.ncr.com (Kevin - Christian). - -Sun Oct 1 09:34:18 1995 Lars Ingebrigtsen - - * gnus-msg.el (gnus-message-of): New function. - - * gnus.el (gnus-get-newsgroup-headers): Don't set references to - "none". - (gnus-summary-prepare-threads): Would output the subject several - times when dummying. - (gnus-get-newsgroup-headers): Would never find the first header in - each head. - -Sat Sep 30 05:05:57 1995 Lars Magne Ingebrigtsen - - * gnus-msg.el (gnus-news-followup): Insert signature before - composing. - -Fri Sep 29 05:33:01 1995 Lars Magne Ingebrigtsen - - * gnus.el: 0.5 is released. - - * gnus.el (gnus-article-mode-map): Took out boogaboo. - -Thu Sep 28 05:12:00 1995 Lars Ingebrigtsen - - * gnus-xmas.el: New file for XEmacs functions. - (gnus-xmas-find-glyph-directory): New function. - (gnus-xmas-glyph-directory): New variable. - - * nnkiboze.el (nnkiboze-generate-group): Also search read - articles. Would destroy mark lists. - (nnkiboze-level): New variable. - (nnkiboze-generate-group): Use it. - (nnkiboze-remove-read-articles): New variable. - (nnkiboze-close-group): Use it. - - * gnus.el (gnus-article-hide-pgp): New command and keystroke. - (gnus-group-make-kiboze-group): Didn't allow scoring on "all", - etc. - (gnus-group-make-kiboze-group): Ignored - `gnus-use-long-file-name'. - -Wed Sep 27 06:44:57 1995 Lars Magne Ingebrigtsen - - * gnus.el (gnus-summary-hide-thread): Didn't work. - (gnus-summary-go-to-next-thread): New implementation. - - * gnus-topic.el (gnus-group-topic-face): Changed to bold. - -Tue Sep 26 20:06:13 1995 Per Abrahamsen - - * gnus-vis.el (gnus-header-button-alist): Fixed regexps. Doc - cleanup. - (gnus-article-add-buttons-to-head): Allow multiple headers to be - match by the same `gnus-header-button-alist' entry. - -Wed Sep 27 04:19:55 1995 Lars Magne Ingebrigtsen - - * gnus.el (gnus-group-make-doc-group): Move point to the group - that was created. - - * gnus-msg.el (gnus-news-followup): Would configure to `reply' - config. - - * gnus.el (gnus-summary-limit-to-marks): Did the opposite of what - it was supposed to do. - (gnus-summary-prepare-unthreaded): Would never allow - seeing dormant articles - - * nnml.el (nnml-find-id): Inserted dir instead of nov file. - - * gnus-msg.el (gnus-required-mail-headers): Make In-Reply-To a - required header, when it is optional. - - * nndir.el: Didn't work for the archive groups. - - * gnus.el (gnus-group-make-archive-group): Create a more sensible - server name. - (gnus-request-article-this-buffer): Used `insert-buffer'. - -Tue Sep 26 02:54:56 1995 Lars Magne Ingebrigtsen - - * gnus.el (gnus-summary-prepare-threads): Would thread incorrectly - when using 'adopt, sometimes. - (gnus-read-newsrc-el-file): Give an error message when the .eld - file bugs out. - -Tue Sep 26 01:36:17 1995 Lars Magne Ingebrigtsen - - * gnus.el: 0.4 is released. - - * gnus.el (gnus-summary-prepare-threads): New roots would be - ignored. - - * gnus-msg.el (gnus-new-news): Didn't save winconf. - - * gnus.el (gnus-group-fetch-faq): Didn't really work. - -Mon Sep 25 22:43:22 1995 Lars Magne Ingebrigtsen - - * gnus.el: 0.3 is released. - - * gnus-msg.el (gnus-inews-insert-headers): Heed - check-before-posting. - (gnus-mail-reply): Allow specification of In-Reply-To. - (gnus-inews-in-reply-to): New function. - -Mon Sep 25 00:03:03 1995 Lars Ingebrigtsen - - * gnus.el (gnus-get-unread-articles): Don't treat nnvirtual groups - specially. - (gnus-get-unread-articles): Allow updating of info. - (gnus-request-update-info): New function. - (gnus-group-sort-function): Can now be a list. - (gnus-group-sort-groups): Use it. - (gnus-group-sort-by-method): New function. - (gnus-group-topic-p): New function. - - * gnus-topic.el: Finally included Ilja Weis' gnus-topic. - -Sun Sep 24 02:18:12 1995 Lars Ingebrigtsen - - * gnus-vis.el (gnus-header-button-alist): New variable. - (gnus-button-mailto): New function. - (gnus-button-reply): New function. - (gnus-article-add-buttons-to-head): New command and keystroke. - - * gnus.el (gnus-group-add-parameter): New function. - (gnus-fetch-group): New autoloaded command. - (gnus-summary-articles-in-thread): New function. - (gnus-summary-kill-thread): Use it. - (gnus-summary-raise-thread): Ditto. - (gnus-thread-operation-ignore-subject): New variable. - - * gnus-msg.el (gnus-post-news): When posting to a mail group that - has no to-address, add the To in the mail to the group - parameters. - - * gnus.el (gnus-create-xref-hashtb): Mark ticked and dormant - articles as read when Xreffing. - (gnus-dribble-directory): New variable. - (gnus-dribble-file-name): Use it. - (gnus-auto-select-next): Additional value: `almost-quietly'. - (gnus-summary-next-article): Use it. - (gnus-summary-last-article-p): New function. - (gnus-summary-save-article-body-file): New command and keystroke. - (gnus-summary-save-body-in-file): New function. - (gnus-prompt-before-saving): New variable. - (gnus-summary-save-article): Use it. - (gnus-request-article-this-buffer): Fetch the article from - `gnus-article-original-buffer' if it is there. - (gnus-summary-mode-line-format-alist): New specs for ticked, - dormant, read and expunged articles. - - * gnus-cache.el (gnus-uncacheable-groups): New variable. - (gnus-cache-possibly-enter-article): Use it. - - * gnus-score.el (gnus-score-uncacheable-files): New variable. - (gnus-score-save): Use it. - - * gnus.el (gnus-auto-subscribed-groups): New variable. - - * nnfolder.el (nnfolder-request-delete-group): New function. - (nnfolder-request-rename-group): New function. - - * nnbabyl.el (nnbabyl-request-delete-group): New function. - (nnbabyl-request-rename-group): New function. - - * nnmbox.el (nnmbox-save-mail): Ran wrong hook. - (nnmbox-request-delete-group): New function. - (nnmbox-request-rename-group): New function. - - * nnmh.el (nnmh-request-delete-group): New function. - (nnmh-request-rename-group): New function. - -Sat Sep 23 02:33:29 1995 Lars Ingebrigtsen - - * gnus.el (gnus-summary-next-article): Use `read-char-exclusive' - instead of read-char. - - * nnbabyl.el (nnbabyl-retrieve-headers): Wrong number of arguments. - - * gnus.el (gnus-save-quick-newsrc-hook): New hook. - (gnus-save-quick-newsrc-hook): New hook. - - * gnus-msg.el (gnus-news-followup): Used news-mode instead of - news-reply-mode. - - * gnus-uu.el (gnus-uu-digest-mail-forward): Would call wrong - forward function. - - * gnus-msg.el (gnus-mail-reply): Would add _-_ to all - message-ids. - - * gnus.el (gnus-request-delete-group): New function. - (gnus-request-rename-group): New function. - (gnus-group-delete-group): New command and keystroke. - (gnus-group-rename-group): New command and keystroke. - - * nnml.el (nnml-request-delete-group): New function. - (nnml-request-rename-group): New function. - - * nnsoup.el (nnsoup-request-scan): New function. - -Fri Sep 22 22:35:37 1995 Lars Magne Ingebrigtsen - - * gnus.el: 0.2 is released. - -Thu Sep 21 14:19:41 1995 Sudish Joseph - - * gnus.el (gnus-article-display-x-face): Use start-process instead - of call-process-region so that we may delete the old x-face - process when visiting a new article. - -Fri Sep 22 22:35:37 1995 Lars Magne Ingebrigtsen - - * gnus.el (gnus-read-header): Didn't work when reffing. - -Fri Sep 22 21:28:32 1995 Lars Magne Ingebrigtsen - - * nntp.el (nntp-find-group-and-number): int-to-string instead of - string-to-int. - - * gnus.el (gnus-set-global-variables): Didn't set - gnus-newsgroup-data. - - * gnus-msg.el (gnus-mail-send): Didn't remove - mail-header-separator. - - * gnus.el (gnus-activate-group): Scanned groups too late. - -Fri Sep 22 01:05:59 1995 Lars Ingebrigtsen - - * gnus.el (gnus-summary-prepare-threads): Use `gnus-subject-equal' - to compare the not-thread-ignore-subject thing. - (gnus-visual-p): New function. - (gnus-visual): Can now be a list of visual elements. - (gnus-request-article-this-buffer): Request all article to - `gnus-original-article-buffer', and then copy it to wherever it's - supposed to go. - (gnus-original-article-buffer): New variable. - (gnus-summary-insert-article): New function. - (gnus-summary-goto-subject): Allow jumping to articles not - currently in the buffer. - - * gnus-msg.el: Reworked all the sendmail/mh-e/vm/rnewspost buffer - entry points. - -Thu Sep 21 13:47:01 1995 Lars Ingebrigtsen - - * gnus.el (gnus-group-mode-map): New score submap. - (gnus-group-list-active): New command and keystroke. - (gnus-group-get-new-news): Allow a forced re-read of the active - file(s). - - * gnus-score.el (gnus-score-flush-cache): New command and - keystroke. - - * gnus.el (gnus-group-set-current-level): Display current level. - (gnus-group-quick-select-group): New command and keystroke. - - * gnus-uu.el (gnus-uu-digest-mail-forward): If the subject or from - are the same in a series, use that from or subject in the - headers. - - * nnmail.el (nnmail-delete-file-function): New variable. - * nnml.el (nnml-request-expire-articles): Use it. - - * gnus.el (gnus-summary-read-group): Allow entering a group for - side-effects; without generating the summary buffer lines. - (gnus-summary-show-article): Allow the prefix to fetch the "raw" - article. - (gnus-group-faq-directory): Allow lists as values. - (gnus-group-fetch-faq): If given a prefix arg, prompt for faq dir - from list above. - - * nntp.el (nntp-request-close): Send QUIT to the server before - hanging up. - -Thu Sep 21 02:10:14 1995 Lars Magne Ingebrigtsen - - * nnml.el (nnml-request-expire-articles): Bugged out. - (nnmh-request-expire-articles): Ditto. - -Wed Sep 20 22:20:09 1995 Lars Magne Ingebrigtsen - - * gnus.el: v0.01 is released. - - * gnus.el (gnus-create-xref-hashtb): Our newsreader has Xrefs with - "group/number" instead of "group:number". - - * gnus-msg.el (gnus-cancel-news): Make sure the From line is the - read address. - -Wed Sep 20 01:42:46 1995 Lars Ingebrigtsen - - * gnus-uu.el (gnus-uu-unmark-thread): New command and keystroke. - - * gnus-msg.el (gnus-inews-check-post): Check for Approved. - - * nnspool.el (nnspool-rejected-article-hook): New hook. - - * gnus-msg.el (gnus-make-draft-group): New function. - (gnus-summary-send-draft): New command. - (gnus-draft-group-directory): New variable. - (gnus-message-sent-hook): New hook. - - * nnmh.el (nnmh-request-create-group): New function. - - * nndir.el (nndir-request-accept-article): New function. - (nndir-request-expire-articles): New function. - (nndir-request-create-group): New function. - - * gnus-msg.el (gnus-required-mail-headers): New variable. - (gnus-inews-do-gcc): New function. - (gnus-outgoing-message-group): New variable. - - * gnus.el (gnus-select-newsgroup): Don't use magic to fetch old - headers. - (gnus-select-newsgroup): Don't fetch old headers if there is only - 1 article in the group. - -Tue Sep 19 20:16:24 1995 Lars Ingebrigtsen - - * gnus-msg.el (gnus-inews-article): Remove To and Cc headers after - posting. - - * gnus.el (gnus-writable-groups): New function. - - * gnus-msg.el (gnus-bounced-headers-junk): New variable. - (gnus-resend-bounced-mail): New command and keystroke. - - * gnus.el (gnus-newsgroup-threads): Removed variable all over. - (gnus-asynchronous-article-function): Removed variable. - - * gnus-msg.el (gnus-inews-article): Do mail sending after all the - headers have been generated. - - * nnheader.el (nnheader-set-temp-buffer): New function. - - * gnus-msg.el (gnus-inews-remove-headers-after-mail): New - function. - - * nnheader.el (nnheader-remove-header): New function. - - * gnus-msg.el (gnus-inews-cleanup-headers): Forked out into a - separate function. - -Sun Sep 17 01:11:10 1995 Sudish Joseph - - * gnus-score.el (gnus-score-trace): (car gnus-score-trace) now - contains the score file from which the 'cdr was loaded, instead - of the (unused) article number. - Modified each of the gnus-score-{type} functions to use the - above format for gnus-score-trace. - (gnus-score-find-trace): Show score file from which each entry - was loaded. - -Tue Sep 19 17:03:17 1995 Lars Magne Ingebrigtsen - - * nntp.el (nntp-warn-about-losing-connection): New variable. - -Mon Sep 18 14:54:30 1995 Per Abrahamsen - - * gnus.el (gnus-summary-respool-query): Rename from - `gnus-summary-fancy-query' and made it work with all values for - `nnmail-split-methods'. - (gnus-summary-mode-map): Updated for above change. - -Tue Sep 19 00:03:57 1995 Lars Ingebrigtsen - - * gnus.el (gnus-read-header): All the backends now deliver group - name and number when fetching by Message-ID, so article numbers - should be better. - - * nntp.el (nntp-find-group-and-number): New function. - - * nnspool.el (nnspool-find-article-by-message-id): Didn't kill the - work buffer. - (nnspool-article-pathname): Changed logic. - - * gnus.el (gnus-read-header): Don't use nn*-retrieve-headers. - - * nnmbox.el (nnmbox-request-article): Allow fetches by - Message-ID. - * nnbabyl.el (nnbabyl-request-article): Ditto. - * nnfolder.el (nnfolder-request-article): Ditto. - - * nnml.el (nnml-id-to-number): New function. - (nnml-request-article): Allow fetches by Message-ID. - - * gnus.el (gnus-summary-import-article): Insert Message-ID and - Lines. - (gnus-summary-set-local-parameters): New function to allow local - variables in group parameters. - (gnus-summary-mode-line-format-alist): Allow unprefixed group name - in the mode lines. - - * gnus-msg.el (gnus-mail-reply-using-mail): New key in mail - buffers. - (gnus-put-message): New function. - -Mon Sep 18 11:42:37 1995 Lars Ingebrigtsen - - * gnus.el (gnus-article-date-original): New command and keystroke. - (gnus-article-parent-p): New function. - (gnus-summary-article-parent): New function. - (gnus-summary-article-children): New function. - (gnus-summary-go-down-thread): New implementation. - (gnus-summary-go-up-thread): Ditto. - (gnus-getenv-nntpserver): New function to use /etc/nntpserver. - (gnus-select-method): Use it. - (gnus-nntp-server-file): New variable. - (gnus-summary-gather-exclude-subject): New variable. - (gnus-gather-threads): Use it. - (gnus-summary-refer-references): New command and keystroke. - - * gnus-cite.el (gnus-cite-attribution-suffix): Changed name from - `gnus-cite-attribution-postfix'. - - * nnml.el (nnml-request-expire-articles): Feature group name in - message. - * nnmbox.el (nnmbox-request-expire-articles): Ditto. - * nnbabyl.el (nnbabyl-request-expire-articles): Ditoo. - * nnmh.el (nnmh-request-expire-articles): Ditto. - * nnfolder.el (nnfolder-request-expire-articles): Ditto. - - * gnus-uu.el (gnus-uu-mark-buffer): New command and keystroke. - - * gnus.el (gnus-make-threads): Minimized implementation. - (gnus-make-threads-and-expunge): Removed. - (gnus-get-newsgroup-headers): Do full threading here. - (gnus-summary-prepare-threads): Do weeding here. - (gnus-summary-prepare-unthreaded): And here. - (gnus-nov-parse-line): Do full threading here as well. - (gnus-request-scan): New function, and new functions in all the - mail backends. - (gnus-activate-group): Possibly scan. - (gnus-master-read-slave-newsrc): New function. - (gnus-slave-save-newsrc): New function. - (gnus-read-newsrc-file): Use them. - (gnus-slave): New command. - -Sun Sep 17 16:04:38 1995 Lars Ingebrigtsen - - * gnus.el (gnus-total-expirable-newsgroups): New variable. - (gnus-group-total-expirable-p): New function; use it. - (gnus-group-auto-expirable-p): New function. Allow - `(auto-expire . t)'. - (gnus-get-newsgroup-headers): Faster implementation. - - * nnheader.el (nnheader-insert-references): Used a Gnus function. - - * nnmail.el (nnmail-delete-incoming): Changed default to nil. - (nnmail-get-new-mail): New function. - * nnfolder.el (nnfolder-get-new-mail): Use it. - * nnmh.el (nnmh-get-new-mail): Ditto. - * nnml.el (nnml-get-new-mail): Ditto. - * nnmbox.el (nnmbox-get-new-mail): Ditto. - * nnbabyl.el (nnbabyl-get-new-mail): Ditto. - - * nnheader.el (nnheader-max-head-length): New variable. - (nnheader-insert-head): Use it. - - * gnus.el (gnus-summary-find-matching): New function. - (gnus-newsgroup-data-reverse, gnus-newsgroup-limit, - gnus-newsgroup-limits, gnus-newsgroup-data): New variables. - (gnus-summary-mode-map): New limit map. - (gnus-summary-limit-to-subject): New command and keystroke. - (gnus-summary-limit-to-articles): New command and keystroke. - (gnus-summary-limit-to-unread): Changed name. - (gnus-summary-limit-to-score): Changed name. - (gnus-summary-unlimit-dormant): Changed name. - (gnus-summary-limit-to-nondormant): Changed name. - (gnus-summary-limit): New function. - (gnus-data-*): New macros and functions. - (gnus-summary-limit-to-marks): Changed name. - diff -r ad457d5f7d04 -r 0293115a14e9 lisp/gnus/ChangeLog.2 --- a/lisp/gnus/ChangeLog.2 Mon Aug 13 08:48:43 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,3161 +0,0 @@ -Mon May 20 00:31:36 1996 Per Abrahamsen - - * ChangeLog continues in a different file. - -Mon May 20 00:31:36 1996 Per Abrahamsen - - * nnmail.el (nnmail-article-group): Do not split into empty list - of groups. - -Mon May 20 09:42:15 1996 Lars Magne Ingebrigtsen - - * gnus-picon.el: Ran `indent-sexp' over file. - (gnus-article-display-picons): Make sure there is a From before - doing anything. - - * nnfolder.el (nnfolder-save-mail): Insert a blank line before the - From line. - - * message.el (message-mode-map): Changed key. - (message-sort-headers): `start-open' text props. - (message-sort-headers): Would sort oddly on continuation lines. - -Sun May 19 20:26:50 1996 Lars Magne Ingebrigtsen - - * gnus.el (gnus-group-set-mode-line): Longer "modified". - - * gnus-uu.el (gnus-uu-grab-articles): Don't do any display hooks. - -Sun May 19 19:42:55 1996 Hallvard B. Furuseth - - * message.el (message-y-or-n-p, message-talkative-question, - message-flatten-list, message-flatten-list-1): New functions. - -Sun May 19 17:28:48 1996 Lars Magne Ingebrigtsen - - * message.el (message-mode-map): Define \t. - (message-newgroups-header-regexp): New variable. - (message-tab): New command. - (message-expand-group): New function. - - * gnus-msg.el (gnus-group-post-news): Don't prompt. - - * gnus.el (gnus-group-update-group-line): Preserve indentation. - - * gnus-msg.el (gnus-copy-article-buffer): Copy the head from the - original article buffer. - - * gnus-vm.el: Decimated. - - * gnus-mh.el (gnus-mh-mail-send-and-exit): Removed. - (gnus-mh-mail-setup): Removed. - - * message.el (message-send-mail-with-sendmail): Renamed. - (message-send-mail-with-mh): New function. - - * gnus-salt.el (gnus-pick-start-reading): Select the first - article. - -Sun May 19 09:58:30 1996 Lars Magne Ingebrigtsen - - * gnus.el: September Gnus v0.89 is released. - - * gnus.el (gnus-group-set-mode-line): Make sure we're in the group - buffer. - -Sun May 19 11:14:54 1996 Lars Magne Ingebrigtsen - - * gnus.el (gnus-group-set-mode-line): Empty dribble is unchanged. - (gnus-article-set-window-start): Search all frames. - (gnus-eval-in-buffer-window): Select window in different frame. - (gnus-get-unread-articles): Update info here. - -Sun May 19 07:30:07 1996 Lars Magne Ingebrigtsen - - * gnus.el (gnus-backlog-remove-article): Read-only. - - * gnus-xmas.el (gnus-xmas-put-text-property): New function. - - * gnus.el (gnus-subscribe-newsgroup-method): Doc fix. - -Sat May 18 14:33:37 1996 Lars Magne Ingebrigtsen - - * gnus.el (gnus-save-newsrc-file): Update mode line. - - * message.el (message-exit-actions, message-kill-actions, - message-postpone-actions): New variables. - (message-kill-buffer): New command and keystroke. - (message-bury): Changed keystroke. - (message-do-actions): New function. - (message-add-action): New function. - (message-send-news): Report failures. - (message-send-mail): Don't remove Message-ID already generated for - news. - -Sat May 18 08:20:03 1996 Lars Magne Ingebrigtsen - - * nnspool.el (nnspool-retrieve-headers-with-nov): Escape buggy nov - files. - -Sat May 18 08:42:34 1996 Lars Magne Ingebrigtsen - - * gnus.el: 0.88 is released. - - * gnus.el (gnus-group-set-mode-line): Say whether the dribble - buffer has been modified. - - * gnus-xmas.el (gnus-xmas-add-text-properties): New function. - (gnus-xmas-group-remove-excess-properties): Removed. - - * gnus-ems.el (gnus-add-text-properties): New alias. - - * gnus-xmas.el (gnus-xmas-group-remove-excess-properties): Open - text props. - -Fri May 17 16:27:42 1996 Lars Magne Ingebrigtsen - - * gnus.el (gnus-article-hide-headers): Would make headers - iinvisible under XEmacs. - - * gnus.el: 0.87 is released. - -Fri May 17 11:38:52 1996 Lars Magne Ingebrigtsen - - * gnus.el (gnus-summary-edit-article-done): Remove article from - backlog. - (gnus-group-update-group-line): Would indent oddly. - - * gnus-uu.el (gnus-uu-post-encoded): Use message. - (gnus-uu-post-encoded): Don't double-prompt. - - * message.el (message-mode): Do mailabbrev things here. - - * nntp.el (nntp-default-sentinel): Reset nntp-current-group when - losing connection. - - * gnus-score.el (gnus-score-load-file): Dumb downcasing. - -Fri May 17 06:16:00 1996 Lars Magne Ingebrigtsen - - * gnus.el (gnus-summary-delete-article): Better prompt. - - * gnus-score.el (gnus-score-load-file): Downcase all header - names. - -Thu May 16 14:04:30 1996 Lars Magne Ingebrigtsen - - * gnus.el (gnus-make-date-line): Separated into own function - and don't reply "Now" to bogus dates. - (gnus-summary-search-article): Bind `gnus-article-display-hook' to - nil. - -Thu May 16 07:40:24 1996 Lars Magne Ingebrigtsen - - * gnus.el: September Gnus v0.86 is released. - - * gnus-xmas.el (gnus-xmas-topic-remove-excess-properties): Remove - more excess props. - -Thu May 16 04:31:59 1996 Lars Magne Ingebrigtsen - - * gnus-vis.el (gnus-button-alist): Recognize more message-ids. - - * nnheader.el (nnheader-parse-head): Wouldn't get the first line - of naked heads. - - * gnus.el (gnus-summary-refer-article): Don't connect to the refer - method unless using a news method. - -Wed May 15 11:41:09 1996 Steven L Baur - - * nnmail.el (nnmail-get-spool-files): Fix typo. - -Wed May 15 03:52:50 1996 Lars Magne Ingebrigtsen - - * gnus.el: 0.85 is released. - - * nnspool.el (nnspool-open-server): Use directory file name. - - * gnus-topic.el (gnus-topic-create-topic): Changed prompt. - -Tue May 14 03:16:43 1996 Lars Magne Ingebrigtsen - - * gnus.el (gnus-decode-rfc1522): Only decode headers; changed - name. - - * nnmail.el (nnmail-get-spool-files): Anchor matches. - - * gnus.el (gnus-summary-expire-articles-now): Didn't work in group - with group params. - (gnus-summary-expire-articles): Accept `now' parameter. - -Sun May 12 01:29:12 1996 Lars Magne Ingebrigtsen - - * gnus.el: September Gnus v0.84 is released. - - * gnus-xmas.el (gnus-xmas-summary-recenter): Protect against evil. - -Sat May 11 23:23:15 1996 Michael Sperber - - * gnus-xmas.el (gnus-xmas-summary-recenter): Would act oddly. - -Fri May 10 22:49:46 1996 Lars Magne Ingebrigtsen - - * nnheader.el (nnheader-parse-head): Deal with naked heads. - - * nnml.el (nnml-parse-head): `naked' heads. - -Fri May 10 00:27:59 1996 Lars Magne Ingebrigtsen - - * gnus.el (gnus-group-mark-group): Didn't work well in topic - buffers. - (gnus-read-active-file-p): New function. - (gnus-group-list-killed): Read active file. - (gnus-group-list-active): Ditto. - (gnus-group-list-matching): Possibly read active file. - (gnus-get-killed-groups): Separated into own function. - (gnus-update-group-mark-positions): Don't define "dummy.group". - - * gnus-topic.el (gnus-topic-rename): Use topic under point. - (gnus-topic-create-topic): Don't prompt for parent topic. - (gnus-topic-create-topic): Go to the new topic. - - * gnus.el (gnus-mime-decode-quoted-printable): Preserve text - props. - (gnus-article-date-ut): Would bug out on read-only. - -Thu May 9 11:12:30 1996 Steven L Baur - - * message.el (message-followup): Correct typos in regular expression - matching ``Re:''. - -Thu May 9 20:38:10 1996 Lars Magne Ingebrigtsen - - * gnus-uu.el (gnus-uu-delete-work-dir): Don't message so much. - -Wed May 8 03:20:23 1996 Lars Magne Ingebrigtsen - - * nnmail.el (nnmail-process-unix-mail-format): Didn't nix out - bogus Message-ID headers properly. - - * nnml.el (nnml-parse-head): Use nnheader functions for parsing - and generating nov headers. - -Wed May 8 22:55:56 1996 Lars Magne Ingebrigtsen - - * gnus.el (gnus-execute-command): Make sure the buffer isn't - read-onl|y. - (gnus-article-prepare): Would perform hooks on pseudo articles. - - * gnus-uu.el (gnus-uu-mark-sparse): Would bug out on pseudos. - (gnus-uu-mark-all): Ditto. - - * gnus.el (gnus-request-article-this-buffer): Ignore canceled - articles. - (gnus-summary-next-page): Pass by canceled articles. - - * message.el (message-check-element): Reverse logic. - -Wed May 8 22:36:18 1996 Lars Magne Ingebrigtsen - - * gnus.el (gnus-tree-buffer): Moved from gnus-salt.el. - -Wed May 8 23:45:46 1996 Lars Magne Ingebrigtsen - - * gnus.el (gnus-no-server): New definition. - (gnus-group-default-level): Use permanent levels. - -Wed May 8 21:35:35 1996 Lars Magne Ingebrigtsen - - * gnus.el (gnus-summary-select-article): - -Tue May 7 21:49:30 1996 Lars Magne Ingebrigtsen - - * gnus.el: 0.83 is released. - - * gnus.el: September Gnus v0.83 is released. - - * gnus.el (gnus-summary-insert-subject): Would change article - number. - (gnus-summary-display-article): Go to the right article when - fetching sparse articles. - -Sun Apr 28 21:53:44 1996 Per Abrahamsen - - * nnml.el (nnml-active-number): Create and change the directory - before using any of the variables that requires the directory to - be created and change. - -Tue May 7 22:06:04 1996 Lars Magne Ingebrigtsen - - * gnus-xmas.el (gnus-xmas-setup-group-toolbar): Would bug out on - missing etc. - -Tue May 7 18:21:59 1996 Lars Magne Ingebrigtsen - - * gnus.el (gnus-kill-or-deaden-summary): Kill multiple buffers - here. - -Tue May 7 16:52:08 1996 Lars Magne Ingebrigtsen - - * gnus-cite.el (gnus-cite-add-face): Would bug out in obscure - cases. - -Mon May 6 09:16:02 1996 Per Abrahamsen - - * message.el (message-mode-map): Do not bind button3. - (message-mode-menu): Use easymenu. - (message-mode): Call `easy-menu-add'. - (message-make-menu-bar): Deleted. - - * message-xmas.el (message-mode-menu): Deleted. - -Mon May 6 20:51:43 1996 Lars Magne Ingebrigtsen - - * gnus.el: September Gnus v0.82 is released. - - * gnus-cite.el (gnus-dissect-cited-text): Sift single empty - lines. - - * gnus.el (gnus-id-to-article): Would bug out once in a while. - - * gnus-cite.el (gnus-article-hide-citation-in-followups): Really - hide citations in un-root articles. - (gnus-article-hide-citation): Place [...] consistently. - - * gnus.el (gnus-article-date-ut): Preserve faces. - - * gnus-cite.el (gnus-article-hide-citation): Would mess up - headers. - -Mon May 6 00:23:09 1996 Lars Magne Ingebrigtsen - - * gnus.el: 0.81 is released. - - * message-xmas.el (message-mode-menu): Moved to this file. - - * message.el (message-make-organization): Use env var. - - * gnus-xmas.el (gnus-xmas-topic-remove-excess-properties): - Wouldn't remove sufficient props. - - * message-xmas.el: New file. - - * gnus-cache.el (gnus-cache-read-active): Make sure the cache - directory exists. - - * gnus.el (gnus-summary-articles-in-thread): Would not give right - answer on the fine thread. - -Sun May 5 14:54:06 1996 Steven L Baur - - * message.el (message-mode-map): Added mode menu for XEmacs. - -Mon May 6 00:12:59 1996 Lars Magne Ingebrigtsen - - * gnus-xmas.el (gnus-xmas-summary-recenter): Wouldn't display the - last line. - -Sun May 5 23:54:04 1996 Lars Magne Ingebrigtsen - - * gnus.el (gnus-convert-old-newsrc): Would bomb when no - .newsrc.eld was loaded. - -Sun May 5 17:34:38 1996 Lars Magne Ingebrigtsen - - * gnus.el (gnus-set-mode-line): Use window width instead of frame - width. - -Sat May 4 22:18:05 1996 Per Abrahamsen - - * gnus.el (gnus-article-de-quoted-unreadable): Always decode - RFC1522-encoded headers. - -Sat May 4 22:03:39 1996 Lars Magne Ingebrigtsen - - * nntp.el (nntp-default-sentinel): Would bug out when closing - connections. - -Thu May 2 16:11:52 1996 Lars Magne Ingebrigtsen - - * message.el (message-mode-map): Changed. - -Mon Apr 29 19:09:19 1996 Lars Magne Ingebrigtsen - - * gnus-vis.el (gnus-button-mailto): Use message. - (gnus-button-mailto): Copy mail buffer. - -Mon Apr 29 18:32:19 1996 Kees de Bruin - - * gnus.el (gnus-current-copy-group): New variable. - -Mon Apr 29 18:29:18 1996 Lars Magne Ingebrigtsen - - * message.el (message-setup): Don't require Subject. - -Mon Apr 29 02:24:14 1996 Lars Magne Ingebrigtsen - - * gnus.el: September Gnus v0.80 is released. - - * message.el (message-check-news-syntax): Better `empty' check. - (message-checksum): Better checksums. - -Sun Apr 28 14:40:04 1996 Lars Magne Ingebrigtsen - - * message.el (message-ignored-bounced-headers): New default. - - * nnsoup.el (nnsoup-store-reply): Generate in mail buffer. - -Sun Apr 28 13:12:48 1996 Wes Hardaker - - * gnus-picon.el: Moved variables. - -Sun Apr 28 11:58:51 1996 Lars Magne Ingebrigtsen - - * nnml.el (nnml-active-number): Change group. - - * gnus.el (gnus-group-sort-by-rank): Reverse logic. - - * message.el (message-font-lock-keywords): New default. - - * gnus-cite.el (gnus-article-hide-citation-in-followups): Didn't - work. - - * gnus.el: Autoload gnus-article-hide-citation-in-followups. - - * nnml.el (nnml-active-number): Bugged out. - - * gnus-uu.el (gnus-uu-grab-articles): Override - `gnus-summary-display-article-function'. - - * gnus.el (gnus-summary-move-article): Didn't use proper defaults - when copying. - -Sun Apr 28 11:40:44 1996 ISO-2022-JP - - * nnheader.el (nnheader-insert-raw-file-contents): Ner alias. - -Sun Apr 28 11:19:58 1996 Lars Magne Ingebrigtsen - - * gnus.el (gnus-read-save-file-name): Use different prompt when - mulitple matches. - -Wed Apr 24 23:21:21 1996 Lars Magne Ingebrigtsen - - * gnus.el (gnus-summary-mode): Make gnus-summary-mark-positions - local. - - * gnus-vis.el (gnus-header-button-alist): Buttonize urls in - headers. - - * gnus-uu.el (gnus-uu-part-number): Check more. - -Wed Apr 24 04:04:54 1996 Lars Magne Ingebrigtsen - - * gnus.el: September Gnus v0.79 is released. - - * message.el (message-syntax-checks): Doc fix. - -Wed Apr 24 05:08:10 1996 Lars Magne Ingebrigtsen - - * gnus.el (gnus-group-process-prefix): Make sure `mark-active' is - bound. - -Wed Apr 24 05:06:42 1996 Lars Magne Ingebrigtsen - - * gnus-xmas.el (gnus-xmas-define): Would make compilation - difficult. - -Wed Apr 24 02:20:08 1996 Lars Magne Ingebrigtsen - - * message.el (message-unsent-separator): New variable. - - * gnus.el (gnus-summary-edit-article-done): Nix out original - article. - -Wed Apr 24 01:31:17 1996 Lars Magne Ingebrigtsen - - * gnus-vis.el (gnus-summary-make-menu-bar): Used - `region-exists-p'. - -Wed Apr 24 00:11:28 1996 Lars Magne Ingebrigtsen - - * message.el (message-unix-mail-delimiter): New variable. - - * nnbabyl.el (nnbabyl-check-mbox): New command. - - * nnspool.el (nnspool-insert-nov-head): New function. - (nnspool-retrieve-headers-with-nov): Use it to protect against - unsynched NOV files. - - * nnheader.el (nnheader-insert-nov): New function. - (nnheader-parse-head): New function. - (nnheader-insert-article-line): New function. - -Tue Apr 23 22:55:57 1996 Lars Magne Ingebrigtsen - - * message.el (message-cancel-news): Disable syntax checks. - (message-do-fcc): Didn't quote separator. - - * gnus.el (gnus-update-summary-mark-positions): Use local format - spec when computing. - - * gnus-msg.el (gnus-summary-cancel-article): Remove article from - cache after cancelling. - (gnus-summary-supersede-article): Ditto. - -Tue Apr 23 12:05:21 1996 Per Abrahamsen - - * gnus.el (gnus-group-history): New variable. - (gnus-completing-read): Handle null default arg. - (gnus-group-jump-to-group): Use them. - (gnus-group-unsubscribe-group): Ditto. - (gnus-read-move-group-name): Ditto. - - * gnus-msg.el (gnus-group-post-news): Use `gnus-group-history' and - `gnus-completing-read'. - -Tue Apr 23 22:39:37 1996 Lars Magne Ingebrigtsen - - * nnml.el (nnml-active-number): Protect against corrupt active - files. - - * nnvirtual.el (nnvirtual-open-server): Don't allow recursive - groups. - -Tue Apr 23 00:13:22 1996 Lars Magne Ingebrigtsen - - * gnus.el: September Gnus v0.78 is released. - - * gnus.el (gnus-get-newsgroup-headers): Run - `gnus-parse-headers-hook'. - (gnus-mime-decode-quoted-printable): Make interactive. - (gnus-setup-news): Don't scan nocem on gnus-no-server. - (gnus-read-header): Let `gnus-refer-article-method' override. - (gnus-rebuild-thread): Cut threads before inserting. - -Mon Apr 22 23:54:10 1996 Lars Magne Ingebrigtsen - - * message.el (message-check-news-syntax): Didn't check for - shortened Followup-To. - -Mon Apr 22 22:36:48 1996 Lars Magne Ingebrigtsen - - * gnus.el (gnus-group-catchup-current): Warn about dead groups. - -Mon Apr 22 21:41:51 1996 William Perry - - * gnus-xmas.el (gnus-xmas-define): Correct background mode under - XEmacs. - -Mon Apr 22 03:50:52 1996 Lars Magne Ingebrigtsen - - * message.el (message-mode-map): New keystroke for - `message-sort-headers'. - (message-syntax-checks): Reverse default. - (message-check-element): Use it. - - * nnbabyl.el (nnbabyl-read-mbox): Try to make sure that article - numbers aren't reused. - * nnmbox.el (nnmbox-read-mbox): Ditto. - - * gnus.el (gnus-continuum-version): New function. - (gnus-convert-old-newsrc): New function. - (gnus-convert-old-ticks): New function. - - * nnmbox.el (nnmbox-request-scan): Save active. - - * nnbabyl.el (nnbabyl-request-scan): Save the active file. - - * nnmbox.el (nnmbox-request-list): Odd logic. - - * nnbabyl.el (nnbabyl-request-list): Odd logic. - - * gnus-uu.el (gnus-uu-generated-file-list): Removed. - (gnus-uu-delete-work-dir): Delete recursively. - - * gnus.el (gnus-group-insert-group-line-info): Indent properly - when using topics. - (gnus-group-make-group): Place point on the newly created group. - - * gnus-vis.el (gnus-group-make-menu-bar): Would bug out when not - using gnus-topic-mode. - -Mon Apr 22 03:45:14 1996 Brad Miller - - * gnus-gl.el: New version. - -Mon Apr 22 02:34:05 1996 Lars Magne Ingebrigtsen - - * gnus-xmas.el (gnus-xmas-find-glyph-directory): Secure agains nil - path elements. - - * nnml.el (nnml-request-move-article): Change directory back to - source group before deleting. - -Sun Apr 21 19:59:58 1996 Lars Magne Ingebrigtsen - - * gnus.el: September Gnus v0.77 is released. - - * message.el (message-bounce): Wrong interactive spec. - (message-bounce): Handle mimeish bounces. - - * nnspool.el (nnspool-inews-switches): Suppress signature. - -Sun Apr 21 19:50:59 1996 Lars Magne Ingebrigtsen - - * gnus-msg.el (gnus-summary-cancel-article): Cancel using the - proper select method. - - * gnus.el (gnus-find-method-for-group): Allow methods without names. - -Sun Apr 21 16:34:35 1996 Lars Magne Ingebrigtsen - - * nnmh.el (nnmh-request-list-1): New function. - - * gnus.el (gnus-summary-articles-in-thread): Would respond badly - to dummy roots. - - * gnus-msg.el (gnus-article-mail): Use message. - - * gnus-vis.el (gnus-button-reply): Use message. - -Sat Apr 20 04:31:02 1996 Jens Lautenbacher - - * gnus-vis.el: Greyed out much more entries in group-mode's - menubar and started the same for summary-mode. - -Sun Apr 21 15:50:09 1996 Lars Magne Ingebrigtsen - - * gnus-msg.el (gnus-copy-article-buffer): Don't widen - permanently. - - * gnus.el (gnus-read-active-file): Don't nix out active stuff from - foreign servers. - (gnus-summary-find-next): Wouldn't respond properly to dummy - articles. - -Sun Apr 21 15:26:47 1996 Denis Howe - - * browse-url.el: New version installed. - -Sun Apr 21 15:16:07 1996 Lars Magne Ingebrigtsen - - * message.el (message-reply): Respond properly even when answering - to messages with no Message-ID. - -Sat Apr 20 18:16:21 1996 Lars Magne Ingebrigtsen - - * gnus.el (gnus-article-header-rank): Moved. - - * message.el (message-send-mail): Wouldn't resend. - -Sat Apr 20 00:20:09 1996 Lars Magne Ingebrigtsen - - * gnus.el: September Gnus v0.76 is released. - - * nntp.el (nntp-server-opened-hook): Use the default. - -Sat Apr 20 01:58:15 1996 Lars Magne Ingebrigtsen - - * nntp.el (nntp-open-server-semi-internal): Don't call - `cancel-timer' under XEmacs. - -Fri Apr 19 23:20:52 1996 Lars Magne Ingebrigtsen - - * gnus.el (gnus-ask-server-for-new-groups): Would call with wrong - hashtb. - -Fri Apr 19 20:42:16 1996 Lars Magne Ingebrigtsen - - * gnus.el (gnus-article-hide-headers): Use message sorting. - - * message.el (message-required-mail-headers): Changed sequence. - (message-sort-headers-1): New function. - (message-sort-headers): New command. - - * nnheader.el (nnheader-change-server-old): Removed. - (nnheader-file-error): New function. - - * nnspool.el (nnspool-request-list): Give a better error message. - - * message.el (message-use-followup-to): Doc fix. - - * gnus.el (gnus-summary-read-group): Dont limit unthreaded - groups. - -Fri Apr 19 15:05:19 1996 Lars Magne Ingebrigtsen - - * message.el (message-setup): Don't generate headers first. - - * nnmail.el (nnmail-message-id): Use message. - -Thu Apr 18 20:10:11 1996 Lars Magne Ingebrigtsen - - * gnus.el: September Gnus v0.75 is released. - - * gnus.el (gnus-summary-show-article): Stop page breaking when - given a prefix. - - * gnus-vis.el (gnus-summary-make-menu-bar): Removed obsolete - functions. - - * gnus-msg.el (gnus-summary-reply): Pass on `broken-reply-to'. - - * message.el (message-reply): Allow broken reply-to. - - * gnus.el (gnus-group-jump-to-group): Refuse to treat groups that - have control characters in them. - -Thu Apr 18 18:47:16 1996 Lars Magne Ingebrigtsen - - * gnus-vis.el (gnus-button-url-regexp): Allow "!" in URLs. - - * gnus.el (gnus-summary-exit): Always run - `gnus-summary-prepare-exit-hook'. - -Thu Apr 18 12:15:27 1996 Lars Magne Ingebrigtsen - - * gnus.el: September Gnus v0.74 is released. - - * gnus.el (gnus-summary-update-mark): Would but out on eob. - - * gnus-msg.el (gnus-post-method): Would bug out. - -Thu Apr 18 09:08:53 1996 Per Abrahamsen - - * gnus.el (gnus-get-newsgroup-headers-xover): Deleted duplicate - line. - -Thu Apr 18 11:06:10 1996 Lars Magne Ingebrigtsen - - * gnus.el (gnus-parse-headers-hook): Enable de-QP by default. - -Wed Apr 17 08:59:20 1996 Jan Vroonhof - - * gnus-nocem.el (gnus-nocem-enter-article): added some simple - error recovery for read calls on article content. - -Wed Apr 17 00:51:19 1996 Lars Magne Ingebrigtsen - - * gnus.el (gnus-error): New function. - - * nnsoup.el: Generate headers. - -Tue Apr 16 08:06:12 1996 Lars Magne Ingebrigtsen - - * message.el (message-user-mail-address): Use - `mail-extract-address-components'. - - * gnus.el (gnus-group-make-group): Use method history. - (gnus-group-browse-foreign-server): Ditto. - (gnus-ask-server-for-new-groups): Make sure symbols are bound. - -Tue Apr 16 00:07:47 1996 Per Abrahamsen - - * gnus.el (gnus-completing-read): New function. - (gnus-method-history): New variable. - (gnus-summary-respool-default-method): New user option. - (gnus-summary-respool-article): Use them. - -Tue Apr 16 07:36:18 1996 Lars Magne Ingebrigtsen - - * gnus.el (gnus-summary-mode): Make line format bufffer local. - -Mon Apr 15 08:41:35 1996 Lars Magne Ingebrigtsen - - * gnus-vis.el (gnus-button-url-regexp): "-" was not in the regexp. - - * nntp.el (nntp-open-server): Would choke on port numbers. - - * gnus-soup.el (gnus-soup-send-packet): Insert - X-Newsreader/X-Mailer. - - * nntp.el (nntp-open-server-semi-internal): Clear the server - buffer. - -Sun Apr 14 17:11:49 1996 Lars Magne Ingebrigtsen - - * gnus-msg.el (gnus-setup-message): Don't clobber - message-header-setup-hook. - - * nndoc.el (nndoc-type-alist): Would show end line in forwards. - - * gnus.el (gnus-window-to-buffer): Allow `mail' value. - - * message.el (message-send-mail): Would choke on Resent-to. - (message-generate-new-buffers): New variable. - (message-pop-to-buffer): Use it. - (message-kill-buffer-on-exit): New variable. - (message-send-and-exit): Use it. - -Sun Apr 14 08:54:37 1996 Lars Magne Ingebrigtsen - - * gnus.el: September Gnus v0.73 is released. - - * message.el (message-mode): Mail-hist isn't defined in XEmacs - 19.13. - - * gnus.el: September Gnus v0.72 is released. - - * nnoo.el (defvoo): Didn't work under XEmacs. - -Sun Apr 14 06:27:19 1996 Lars Magne Ingebrigtsen - - * gnus.el: September Gnus v0.71 is released. - - * nnvirtual.el (nnvirtual-open-server): Would return nil. - -Sat Apr 13 05:37:10 1996 Lars Magne Ingebrigtsen - - * gnus.el: September Gnus v0.70 is released. - - * nnvirtual.el (nnvirtual-component-regexp): New variable. - -Fri Apr 12 18:59:45 1996 Lars Magne Ingebrigtsen - - * nnoo.el: New file. All backends now use it. - -Wed Apr 10 11:39:15 1996 Jan Vroonhof - - * gnus-vis.el (gnus-summary-make-menu-bar): Entry for "Eddit - current score file" used nonexistant function. - -Fri Apr 12 04:57:03 1996 Lars Magne Ingebrigtsen - - * gnus.el (gnus-group-get-new-news-this-group): Would jump around - too much. - - * message.el (message-make-fqdm): Better `user-mail-address'. - -Thu Apr 11 00:32:33 1996 Steven L Baur - - * gnus-setup.el (gnus-use-mailcrypt): Attach mailcrypt - initialization to message-mode-hook. - -Fri Apr 12 03:30:38 1996 Lars Magne Ingebrigtsen - - * message.el (message-insert-to): Insert ", " if needed. - (message-bounce): Insert an undo boundary. - - * gnus.el (gnus-summary-local-variables): Make - gnus-thread-expunge-below a local variable. - - * message.el (message-setup): Insert default headers before - generating. - - * gnus-vis.el (gnus-button-url-regexp): Allow all word-constituent - characters. - -Thu Apr 11 04:27:19 1996 Lars Magne Ingebrigtsen - - * gnus-score.el (gnus-score-body): Would bug out when there were - no articles. - - * gnus-vis.el (gnus-summary-make-menu-bar): Wrong function - called. - -Wed Apr 10 12:48:59 1996 Lars Magne Ingebrigtsen - - * message.el (message-make-organization): Remove all newlines from - Organization files. - (message-setup): Use mailabbrev. - (message-send): Use mail-hist. - -Tue Apr 9 14:52:55 1996 Per Abrahamsen - - * custom.el ((fboundp 'event-point)): Was `event-closest-point'. - -Wed Apr 10 12:28:41 1996 Lars Magne Ingebrigtsen - - * message.el (message-mode-map): Moved Followup-to and Fcc. - (message-resend): Would bug out. - -Wed Apr 10 00:25:17 1996 Lars Magne Ingebrigtsen - - * gnus.el: September Gnus v0.69 is released. - - * nnvirtual.el (nnvirtual-close-group): Nix out variables. - - * gnus-cache.el (gnus-cache-possibly-remove-article): Didn't work - in virtual groups. - (gnus-cache-possibly-enter-article): Ditto. - - * message.el (message-do-fcc): Remove separator. - - * gnus-nocem.el (gnus-nocem-scan-groups): Use own dependencies - hash table. - -Tue Apr 9 23:37:36 1996 Brad Miller - - * gnus-gl.el: New version. - -Tue Apr 9 23:08:20 1996 Lars Magne Ingebrigtsen - - * gnus.el (gnus-article-de-quoted-unreadable): Downcase type. - (gnus-fetch-field): Inhibit point-motion hooks. - -Tue Apr 9 10:50:20 1996 Lars Magne Ingebrigtsen - - * message.el (message-user-mail-address): Pick out . - -Tue Apr 9 07:46:47 1996 Lars Magne Ingebrigtsen - - * gnus.el: September Gnus v0.68 is released. - -Tue Apr 9 00:15:43 1996 Brad Miller - - * gnus-gl.el: New version. - -Mon Apr 8 23:55:19 1996 Lars Magne Ingebrigtsen - - * nnvirtual.el (nnvirtual-create-mapping): Would include `(0 . 0)' - groups. - -Tue Apr 9 01:40:56 1996 Lars Magne Ingebrigtsen - - * gnus.el (gnus-article-goto-next-page): Would bug out under - XEmacs. - (gnus-get-unread-articles): Wouldn't update virtual groups. - - * gnus-ems.el ('gnus-character-to-event): New alias. - * gnus-xmas.el (gnus-xmas-redefine): Redefine. - -Mon Apr 8 21:55:15 1996 Lars Magne Ingebrigtsen - - * message.el (message-user-mail-address): New function. - (message-make-address): Use it. - -Mon Apr 8 19:18:14 1996 Lars Magne Ingebrigtsen - - * message.el (message-make-fqdm): mail-host-address may be - unbound. - - * nndoc.el (nndoc-type-alist): Unquote dashes in forwards. - -Mon Apr 8 19:14:05 1996 ISO-2022-JP - - * gnus-ems.el (gnus-mule-max-width-function): Use - `truncate-string'. - -Sat Apr 6 15:03:39 1996 Steven L. Baur - - * gnus-setup.el (gnus-use-sc): Arrange for autoload of supercite - if necessary. - - * nnml.el (nnml-server-variables): Obey user preferences for - nnml-prepare-save-mail-hook. - -Sun Apr 7 20:14:50 1996 Lars Magne Ingebrigtsen - - * gnus.el: September Gnus v0.67 is released. - - * gnus.el (gnus-group-get-new-news-this-group): Would update - groups twice. - - * gnus-cache.el (gnus-cache-possibly-enter-article): Use real - group name. - - * nnvirtual.el (nnvirtual-possibly-change-group): Faulty logic. - (nnvirtual-retrieve-headers): Don't force re-check. - -Sun Apr 7 01:11:57 1996 Lars Magne Ingebrigtsen - - * gnus.el: September Gnus v0.66 is released. - - * nnvirtual.el (nnvirtual-close-group): Don't nix out - group-relevant variables. - - * message.el (message-send-and-exit): Would choke on sending bug - reports. - -Sat Apr 6 19:03:10 1996 Lars Magne Ingebrigtsen - - * gnus.el: September Gnus v0.65 is released. - - * nnvirtual.el (nnvirtual-close-group): Don't update component - groups so much. - - * message.el (message-make-fqdm): Wouldn't pick out the address - from `user-mail-address'. - (message-generate-headers): Don't insert X-Mailer if there is an - X-Newsreader. - (message-followup): Set `message-reply-headers'. - (message-send-and-exit): Pass prefix argument. - (message-cancel-news): Don't check syntax. - -Sat Apr 6 03:04:58 1996 Lars Magne Ingebrigtsen - - * gnus.el (gnus-summary-last-article-p): Reverse logic. - - * message.el (message-make-fqdm): Try mail-host-address. - (message-fill-header): Would insert blank lines. - -Fri Apr 5 23:51:17 1996 Lars Magne Ingebrigtsen - - * gnus.el: September Gnus v0.64 is released. - - * message.el (message-send-and-exit): Don't bury buffer on - unsucessful sending. - -Fri Apr 5 21:10:55 1996 Jens Lautenbacher - - * gnus-vis.el (gnus-group-make-menu-bar): Grey out certain items. - -Fri Apr 5 20:05:19 1996 Lars Magne Ingebrigtsen - - * gnus.el (gnus-group-default-level): Would set - `gnus-group-default-list-level'. - - * gnus-score.el: Don't require gnus-scomo. - - * gnus-msg.el (gnus-inews-do-gcc): Remove mail header separator. - - * nndir.el (nndir-execute-nnml-command): Would set nnml - directory. - - * nnvirtual.el (nnvirtual-request-update-info): Would infloop. - -Fri Apr 5 17:53:08 1996 Lars Magne Ingebrigtsen - - * gnus.el (gnus-summary-best-unread-article): Return a proper - value. - (gnus-summary-read-group): Wouldn't configure windows properly - when the first article was canceled. - - * nnvirtual.el (nnvirtual-create-mapping): Inline function. - (nnvirtual-create-mapping): Don't set the marks lists. - (nnvirtual-possibly-change-group): Would add groups twice, - possibly. - (nnvirtual-update-reads): New function. - -Thu Apr 4 21:07:53 1996 Lars Magne Ingebrigtsen - - * nnspool.el (nnspool-inews-switches): Changed default back. - - * nnsoup.el (nnsoup-narrow-to-article): Would choke on fetching - non-existent articles. - (nnsoup-store-reply): Handle courtesy copies. - -Thu Apr 4 21:01:53 1996 Greg Stark - - * nnmail.el (nnmail-process-babyl-mail-format): Would parse empty - mails badly. - -Thu Apr 4 03:37:56 1996 Lars Magne Ingebrigtsen - - * gnus.el (gnus-servers-using-backend): New function. - (gnus-summary-respool-article): Use real methods instead of - backend names. - (gnus-summary-move-article): Use the method. - - * message.el (timezone): Require timezone. - (message-setup): Insert the separator before generating headers. - (message-goto-signature): Goto point-max if there is no signature - separator. - - * gnus.el (gnus-article-date-ut): Don't call - `gnus-article-highlight-headers'. - (gnus-server-get-method): Return the native select method when - needed. - -Thu Apr 4 03:12:04 1996 Richard Mlynarik - - * gnus-kill.el (gnus-apply-kill-file-unless-scored): New - function. - -Thu Apr 4 01:59:18 1996 Lars Magne Ingebrigtsen - - * message.el (message-send-mail): Don't do the mailalias thing. - (message-fill-header): Would fill long Message-IDs badly. - - * gnus.el (gnus-group-faq-directory): Wrong paths. - -Wed Apr 3 18:23:35 1996 Lars Magne Ingebrigtsen - - * gnus.el: September Gnus v0.63 is released. - - * message.el (message-insert-newsgroups): Capitilize Newsgroups. - - * gnus.el (gnus-make-hashtable-from-killed): Wouldn't use - `gnus-zombie-list'. - - * nnfolder.el (nnfolder-group-pathname): New function; return the - right folder. - - * gnus-score.el (gnus-score-find-bnews): Recognize "++" groups. - - * gnus-topic.el (gnus-topic-yank-group): Remain in the topic. - - * gnus.el (gnus-get-new-news-in-group): Removed function. - (gnus-group-get-new-news-this-group): Update all instances of the - group. - - * gnus-topic.el (gnus-topic-unindent): Insert at the right place. - (gnus-topic-next-topic): New function. - (gnus-topic-unindent): Would swallow sub-topics. - (gnus-topic-indent): Ditto. - -Wed Apr 3 17:18:08 1996 Lars Magne Ingebrigtsen - - * gnus-msg.el (gnus-bug): Wouldn't restore window conf. - - * gnus.el (gnus-buffer-configuration): `bug' configuration. - -Tue Apr 2 22:33:25 1996 Lars Magne Ingebrigtsen - - * gnus-scomo.el: New file. - -Tue Apr 2 12:31:48 1996 Per Abrahamsen - - * message.el (bold-region): New function. - (unbold-region): New function. - (message-face-alist): New variable. - (message-mode): Add facemenu support. - -Tue Apr 2 20:46:11 1996 Lars Magne Ingebrigtsen - - * message.el (message-required-mail-headers): `To' isn't - required. - (message-ignored-news-headers): Remove Fcc headers. - (message-ignored-mail-headers): Ditto. - - * gnus.el (gnus-request-article-this-buffer): Would bug out on - backlogs. - - * message.el (message-send-and-exit): Bury buffer. - - * gnus-uu.el (gnus-uu-digest-mail-forward): Use `message'. - - * nnfolder.el (nnfolder-close-group): Would try to `set-buffer' - nil. - - * gnus.el (gnus-server-get-method): Would return extended servers - too often. - - * nnml.el (nnml-request-accept-article): Accept a server - parameter. - -Tue Apr 2 15:05:14 1996 Lars Magne Ingebrigtsen - - * gnus.el: September Gnus v0.62 is released. - - * nnfolder.el (nnfolder-possibly-change-group): Make sure the - directory exists before writing file. - (nnfolder-request-accept-article): Give a better error messae. - -Sat Mar 30 18:45:51 1996 Lars Magne Ingebrigtsen - - * message.el (message-mode-map): Moved `goto-signature'. - - * nnfolder.el (nnfolder-request-delete-group): Respect - nnmail-use-long-file-name. - (nnfolder-request-rename-group): Ditto. - (nnfolder-possibly-change-group): Ditto. - - * message.el (message-send-and-exit): Bury buffer. - -Fri Mar 29 15:11:19 1996 Hallvard B. Furuseth - - * message.el (message-from-style): New `default' value. - (message-make-from): Use it. - -Fri Mar 29 13:50:55 1996 Lars Magne Ingebrigtsen - - * gnus-msg.el (gnus-bug-kill-buffer): New function. - (gnus-bug): Use message. - - * message.el (message-yank-original): Avoind `mark-marker'. - - * gnus-setup.el (gnus-use-bbdb): `message' changes. - (gnus-use-sc): Ditto. - - * message.el (message-user-organization): Use ORGANIZATION - environment variable. - - * nnfolder.el (nnfolder-request-list-newsgroups): Would read the - wrong file. - -Fri Mar 29 07:38:59 1996 Lars Magne Ingebrigtsen - - * gnus.el: September Gnus v0.61 is released. - - * gnus.el (gnus-read-active-file): Activate secondary groups. - -Fri Mar 29 07:44:06 1996 Lars Magne Ingebrigtsen - - * nneething.el (nneething-get-head): Would return nil on proper - heads. - -Sat Mar 23 22:19:09 1996 Per Abrahamsen - - * browse-url.el (browse-url-netscape): Start remote netscape in - the background. Use sentinel to start a new netscape if the - remote can't connect. - -Fri Mar 29 05:22:50 1996 Lars Magne Ingebrigtsen - - * message.el (message-send-mail): Would remove ignored news - headers. - - * gnus.el (gnus-news-group-p): Moved function here. - (gnus-summary-refer-article): Use it. - (gnus-group-best-unread-group): Wouldn't work under topics. - - * message.el (message-cite-function): New variable. - (message-cite-original): New function. - (message-yank-original): Use it. - (message-make-domain): New definition. - (message-make-address): Ditto. - (message-make-message-id): New definition. - (message-insert-signature): Interactive `force' of signature. - -Fri Mar 29 06:01:56 1996 Lars Magne Ingebrigtsen - - * gnus-msg.el (gnus-summary-mail-other-window): Restore window - conf. - -Thu Mar 28 10:15:06 1996 Lars Magne Ingebrigtsen - - * message.el (nnheader): Require nnheader. - (message-mode): Doc fix. - -Thu Mar 28 06:12:28 1996 Lars Magne Ingebrigtsen - - * gnus.el: September Gnus v0.60 is released. - - * message.el (message-send-mail): Remove Gcc header. - (message-setup): Would insert default headers in the body. - -Wed Mar 27 11:25:41 1996 Jack Vinson - - * message.el: Lots of small typos corrected. - (message-goto-signature): Added missing function. - (message-mode): Updated the description. - (message-send): Corrected format for first y-or-n-p. - (message-forward): Added description. - -Thu Mar 28 05:31:48 1996 Lars Magne Ingebrigtsen - - * message.el (message-send-mail): Make sure point is in the right - buffer. - (message-send-mail): Would remove Bcc headers. - (message-insert-courtesy-copy): Would bug out in non-news - buffers. - (message-send-news): Don't remove Gcc headers from the message - buffer. - (message-ignored-mail-headers): New variable. - -Thu Mar 28 05:30:02 1996 Lars Magne Ingebrigtsen - - * gnus-xmas.el (gnus-xmas-copy-article-buffer): Return the proper - value. - - * message.el (message-mode-map): Would make XEmacs barf. - -Thu Mar 28 03:49:32 1996 Lars Magne Ingebrigtsen - - * gnus.el (gnus-group-make-group): Wouldn't allow usage of virtual - server names. - - * message.el (message-cite-hook): New variable. - -Thu Mar 28 03:48:54 1996 Kai Grossjohann - - * message.el (message-yank-original): Run `message-cite-hook'. - -Wed Mar 27 05:06:16 1996 Lars Magne Ingebrigtsen - - * gnus.el: September Gnus v0.59 is released. - - * message.el (message-remove-header): Allow reverse removal. - (message-news-p): Narrow to headers first. - (message-checksum): New function. - (message-check-news-syntax): Check for new text. - (message-check-news-syntax): Do more checking. - (message-check-news-syntax): Deny posting of articles with empty - Subject lines or mangled From headers. - (message-generate-headers): Didn't treat optional headers - properly. - -Tue Mar 26 05:15:15 1996 Lars Magne Ingebrigtsen - - * gnus.el: September Gnus v0.58 is released. - - * gnus-cache.el (gnus-cache-retrieve-headers): Would bug out on - empty groups. - - * nnmail.el (nnmail-cache-open): Mark buffer as un-modified. - (nnmail-cache-close): Don't kill buffer. - - * gnus-msg.el: Cannibalized. - - * message.el: New file. - - * gnus-cache.el (gnus-cache-possibly-enter-article): Don't enter - sparse article into cache. - -Sun Mar 24 06:44:11 1996 Lars Magne Ingebrigtsen - - * gnus.el (gnus-article-hide-boring-headers): Use - `gnus-extract-address-components'. - -Sun Mar 24 00:00:33 1996 Lars Magne Ingebrigtsen - - * gnus.el: September Gnus v0.57 is released. - - * gnus-topic.el (gnus-topic-insert-topic-line): Would mess up the - `.' command. - (gnus-topic-mode-map): Moved `gnus-topic-indent' to `T TAB'. - - * gnus-msg.el (gnus-summary-resend-bounced-mail): Would do odd - things. - - * gnus.el (gnus-buffer-configuration): Add compose-bounce. - - * nnspool.el (nnspool-find-nov-line): Would cut off ends of NOV - files. - -Fri Mar 22 21:46:18 1996 David Kågedal - - * gnus.el (gnus-group-best-unread-group): Didn't work with topics. - -Sat Mar 23 05:45:38 1996 Lars Magne Ingebrigtsen - - * gnus.el (gnus-get-unread-articles): Inline - `gnus-get-unread-articles-in-group'. - (gnus-get-unread-articles-in-group): Inline - `gnus-cache-possibly-alter-active'. - -Sat Mar 23 01:26:10 1996 Lars Magne Ingebrigtsen - - * gnus.el (gnus-summary-insert-pseudos): Would print out tabs. - -Sat Mar 23 00:01:56 1996 Lars Magne Ingebrigtsen - - * gnus.el: September Gnus v0.56 is released. - - * gnus.el (gnus-group-add-score): Would bug out on dead groups. - -Fri Mar 22 22:30:32 1996 Lars Magne Ingebrigtsen - - * gnus.el (gnus-get-newsgroup-headers): Would ignore In-Reply-To - headers. - - * gnus-uu.el (gnus-uu-uustrip-article): Handle multiple uuencoded - files in each article. - - * gnus-msg.el (gnus-inews-article): Switch to buffer where - `gnus-inews-article-hook' is run to make ispelling possible. - - * gnus.el (gnus-summary-last-article-p): New function. - (gnus-summary-next-page): Wouldn't go past last article in - narrowed buffers. - (gnus-group-make-help-group): Would create under false name. - -Fri Mar 22 22:23:20 1996 Greg Stark - - * nneething.el (nneething-make-head): Create better heads. - -Fri Mar 22 18:58:17 1996 Lars Magne Ingebrigtsen - - * gnus-score.el (gnus-score-body): Would bug out. - - * nnfolder.el (nnfolder-retrieve-headers): Make sure the buffer - exists before setting it. - - * gnus.el (gnus-summary-exit): Don't run prepare-exit-hook when - exiting temporarliy. - -Fri Mar 22 00:38:28 1996 Lars Magne Ingebrigtsen - - * gnus.el: September Gnus v0.55 is released. - - * gnus.el (gnus-summary-update-article): Would make things bug out. - (gnus-summary-insert-subject): Remove articles that have changed - number. - (gnus-summary-exit): Nix out variables. - (gnus-summary-exit-no-update): Ditto. - (gnus-article-setup-buffer): Create original buffer on entry. - -Thu Mar 21 22:28:12 1996 Lars Magne Ingebrigtsen - - * gnus-nocem.el (gnus-nocem-enter-article): Would enter things - into the wrong hashtb. - - * nnml.el (nnml-inhibit-expiry): New variable. - (nnml-request-expire-articles): Use it. - - * gnus.el (gnus-summary-update-article): Would bug out. - - * nnml.el (nnml-possibly-change-directory): Also change server. - - * gnus-nocem.el (gnus-nocem-scan-groups): Don't create a gazillion - garbage buffers. - - * nnfolder.el (nnfolder-save-mail): Create new groups - automatically. - (nnfolder-request-scan): Change server first. - - * nnheader.el (nnheader-insert-head): Don't insert file contents - literally. - -Thu Mar 21 18:17:21 1996 Lars Magne Ingebrigtsen - - * gnus-score.el (gnus-score-body): Score in proper order. - -Wed Mar 20 20:06:08 1996 Lars Magne Ingebrigtsen - - * gnus.el (gnus-select-newsgroup): Better message. - - * gnus-uu.el (gnus-uu-save-article): Include multiple headers of - the same type. - -Tue Mar 19 16:26:13 1996 Roderick Schertler - - * gnus-msg.el (gnus-mail-reply): Would bug out given multiple - follow-to elements for the same header. - -Tue Mar 19 01:15:06 1996 Lars Magne Ingebrigtsen - - * gnus.el (gnus-cut-thread): Deal with old-fetched & sparse - threads at once. - (gnus-cut-threads): Make sure there are no nil threads. - (gnus-simplify-buffer-fuzzy): Tweaked implementation. - (gnus-gather-threads-by-subject): Check - gnus-summary-gather-exclude-subject after simplifying. - - * gnus-topic.el (gnus-topic-insert-topic-line): Store the number - of unread articles. - (gnus-group-topic-unread): New function. - (gnus-topic-update-topic-line): Faster implementation. - - * gnus.el (gnus-update-format-specifications): Would push too many - emacs-versions onto specs. - - * gnus-msg.el (gnus-default-post-news-buffer, - gnus-default-mail-buffer): New variables. - (gnus-mail-setup): Set gnus-mail-buffer here. - (gnus-news-followup): Set gnus-post-news-buffer here. - - * custom.el (custom-xmas-set-text-properties): New definition. - - * gnus-soup.el (gnus-soup-insert-idx): Throw the Xref header - away. - (gnus-soup-add-article): Ditto. - (gnus-soup-ignored-headers): New variable. - -Mon Mar 18 15:01:40 1996 Lars Magne Ingebrigtsen - - * gnus-msg.el (gnus-forward-insert-buffer): Wouldn't handle - continuation headers. - - * nnml.el (nnml-retrieve-headers-with-nov): Wouldn't strip excess - lines. - - * gnus-uu.el (gnus-uu-digest-mail-forward): Would reverse order. - - * nnsoup.el (nnsoup-make-active): Would bug out. - - * gnus-score.el (gnus-score-followup-thread): Make sure we are in - the summary buffer. - - * gnus.el (gnus-buffer-live-p): New function. - - * gnus-topic.el (gnus-topic-change-level): Would bug out on dead - groups. - - * gnus.el (gnus-summary-respool-article): Prompt better. - (gnus-add-marked-articles): Would create recursive lists. - (gnus-summary-move-article): Activate all groups that have been - moved to. - -Sun Mar 17 13:17:26 1996 Lars Magne Ingebrigtsen - - * gnus.el: September Gnus v0.54 is released. - - * gnus.el (gnus-article-hide-pgp): Would hide one char too many. - - * gnus-msg.el (gnus-inews-distribution): Fall back on the - Newsgroups header. - - * gnus.el (gnus-read-header): Read sparse threads. - -Sun Mar 17 11:23:53 1996 Lars Magne Ingebrigtsen - - * gnus.el (gnus-summary-scroll-up): Show threads. - - * gnus-msg.el (gnus-mail-reply): Use prefixed group name. - (gnus-news-followup): Ditto. - - * gnus-cache.el (gnus-cache-member-of-class): Would remove ticked - articles from the cache. - - * gnus.el (gnus-hide-text): Would bug out at bob. - (gnus-unhide-text): Ditto. - -Sat Mar 16 13:28:57 1996 Lars Magne Ingebrigtsen - - * gnus.el: 0.53 is released. - -Sat Mar 16 14:46:29 1996 Brad Miller - - * gnus-gl.el: New version. - -Sat Mar 16 13:28:57 1996 Lars Magne Ingebrigtsen - - * gnus-score.el (gnus-score-body): Would break on nil - `gnus-scores-articles'? - - * gnus.el: All the backend interface functions should take virtual - server names. - - * gnus-msg.el (gnus-post-method): Find the real method. - - * gnus.el (gnus-summary-go-to-next-thread): New definition. - (gnus-summary-next-thread): Use it. - (gnus-prefix-to-server): New function. - - * gnus-vis.el (gnus-signature-toggle): Use new substs. - (gnus-article-highlight-signature): Would make check point wrong. - - * gnus.el (gnus-hide-text): New subst. - (gnus-hide-text-type): New function. - (gnus-unhide-text): New subst. - (gnus-article-show-all-headers, gnus-article-hide-headers, - gnus-article-hide-pgp, gnus-article-hide-header, - gnus-article-hide-boring-headers): Use them. - -Fri Mar 15 07:39:10 1996 Lars Magne Ingebrigtsen - - * nntp.el (nntp-send-xover-command): Would bug out on - single-article groups. - - * gnus.el (gnus-group-prepare-flat): Deal with unactivated groups. - * gnus-topic.el (gnus-topic-find-groups): Ditto. - -Thu Mar 14 05:24:42 1996 Lars Magne Ingebrigtsen - - * nnspool.el (nnspool-retrieve-headers): Use default-directory to - avoid creating so many garbage strings. - - * nnmail.el (nnmail-split-incoming): Make sure the buffer isn't - empty before starting treatment. - (nnmail-get-new-mail): Open/close cache here. - - * gnus-msg.el (gnus-news-followup): Use markers for positions. - - * gnus.el (gnus-setup-news): Read NoCeM. - -Wed Mar 13 03:26:44 1996 Lars Magne Ingebrigtsen - - * gnus.el (gnus-functionp): Made into a subst. - (gnus-all-windows-visible-p): Non-recursive implementation. - - * nnsoup.el (nnsoup-request-list): Don't use `format'. - - * gnus.el (gnus-update-format-specifications): Would recompute all - specs every time. - (gnus-gnus-to-newsrc-format): Don't call `gnus-server-equal' for - each group. - - * nnspool.el (nnspool-retrieve-headers): Don't call so many - functions. - - * gnus-cache.el (gnus-cache-retrieve-headers): Would do too much - work. - - * gnus-topic.el (gnus-topic-goto-topic): Faster. - - * gnus.el: Don't downcase Message-IDs before threading. - -Tue Mar 12 01:42:11 1996 Lars Magne Ingebrigtsen - - * gnus.el: September Gnus v0.52 is released. - - * gnus.el (gnus-article-strip-leading-blank-lines): New command. - - * gnus-score.el (gnus-score-score-files-1): Message. - (gnus-score-score-files-1): Make sure this doesn't return a nil - value. - - * gnus-vis.el (gnus-article-add-button): Would make all buttons - visible. - -Mon Mar 11 03:04:15 1996 Lars Magne Ingebrigtsen - - * gnus-soup.el (gnus-soup-group-brew): Might lose articles? - - * gnus.el (gnus-request-article-this-buffer): Would set - `gnus-original-article' wrong. - - * nnmail.el (nnmail-search-unix-mail-delim): Secondary ">From " - lines would make messages stick. - (nnmail-check-duplication): Changed warning message - - * gnus-msg.el (gnus-inews-reject-message): Would prin1 to the echo - area. - - * gnus.el (gnus-no-server): Would make variable buffer-local to - the wrong buffer. - - * nnmail.el (nnmail-process-unix-mail-format): Doubled code. - - * nnvirtual.el (nnvirtual-retrieve-headers): Don't propagate - `fetch-old'. - - * gnus-msg.el (gnus-inews-cleanup-headers): Put "poster" in the - list of possible prompts. - -Sun Mar 10 00:13:48 1996 Lars Magne Ingebrigtsen - - * gnus-score.el (gnus-score-headers): Wouldn't score anything if - `gnus-save-score'. - - * gnus-cache.el (gnus-cache-remove-article): Change buffer. - - * gnus.el (gnus-add-shutdown, gnus-shutdown): New functions. - (gnus-clear-system): Nix out more variables. - - * gnus-*.el: Use the functions. - -Sat Mar 9 08:03:00 1996 Lars Magne Ingebrigtsen - - * gnus.el (gnus-group-delete-group): Remove the group from the - active hashtb. - - * gnus-topic.el (gnus-topic-yank-group): Yank sub-topics as well. - (gnus-topic-remove-group): New implementation. - - * gnus.el (gnus-gnus-to-newsrc-format): princ instead of - int-to-string. - -Sat Mar 9 07:36:22 1996 Thor Kristoffersen - - * nntp.el (nntp-request-article): New wait-for regexp to work with - rlogin. - -Sat Mar 9 07:21:57 1996 Lars Magne Ingebrigtsen - - * gnus.el (gnus-request-article-this-buffer): Would bug out when - no summary buffer. - - * gnus-topic.el (gnus-topic-mark-topic): Mark hidden groups in the - topic. - - * gnus-msg.el (gnus-summary-resend-message): Would bug out. - -Sat Mar 9 06:57:13 1996 Michael Cook - - * nnmail.el (nnmail-split-fancy-syntax-table): New variable. - -Fri Mar 8 12:58:37 1996 Wes Hardaker - - * gnus.el (gnus-summary-go-to-next-thread): Would always jump to - the next dummy-root if called on a dummy-root. - -Sat Mar 9 01:58:10 1996 Lars Magne Ingebrigtsen - - * gnus.el: 0.51 is released. - - * gnus-msg.el (gnus-tokenize-header): Wouldn't do the right thing - under XEmacs. - -Sat Mar 9 00:16:54 1996 Lars Magne Ingebrigtsen - - * gnus-topic.el (gnus-topic-change-level): Insert groups in the - proper topic. - (gnus-topic-group-indentation): New function. - (gnus-topic-prepare-topic): Would do incorrect tallies. - -Fri Mar 8 23:15:05 1996 Lars Magne Ingebrigtsen - - * nnvirtual.el (nnvirtual-create-mapping): Would enter each - article twice into the marks lists, possibly. - (nnvirtual-update-marked): Would "forget" marks. - - * gnus.el (gnus-select-newsgroup): Create unsingle article buffer - on group entry. - - * gnus-cache.el (gnus-cache-remove-article): Move forwards. - (gnus-cache-retrieve-headers): Would retrieve wrong headers. - -Fri Mar 8 19:18:29 1996 Lars Magne Ingebrigtsen - - * gnus-score.el (gnus-summary-increase-score): Defaults were used - incorrectly. - (gnus-score-edit-current-scores): Changed name. - - * gnus.el (gnus-gnus-to-quick-newsrc-format): Don't crete so much - string garbage. - - * gnus-xmas.el (gnus-xmas-menu-add): New macro. - -Fri Mar 8 00:03:14 1996 Lars Magne Ingebrigtsen - - * gnus.el: 0.50 is released. - - * gnus.el (gnus-group-yank-group): Would bug out on groups with - scores. - (gnus-summary-go-to-next-thread): Do dummies properly. - (gnus-summary-setup-buffer): Make `gnus-article-current' be - buffer-local. - - * gnus-topic.el (gnus-topic-update-topic): Don't update dead - groups. - - * gnus.el (gnus-clear-system): Clear list mode. - (gnus-group-list-groups): Might start out in the wrong buffer. - (gnus-clear-system): Clear topic variables. - - * gnus-msg.el (gnus-ignored-resent-headers): New variable. - (gnus-summary-resend-message): Use it. - -Thu Mar 7 23:38:35 1996 Lars Magne Ingebrigtsen - - * nnvirtual.el (nnvirtual-retrieve-headers): `princ' bugs. - - * gnus-uu.el (gnus-uu-decode-with-method): Check whether `save' is - nil. - -Thu Mar 7 21:38:31 1996 Lars Magne Ingebrigtsen - - * gnus-vis.el (gnus-article-next-button): Move point to the start - of the button when skipping backwards. - -Thu Mar 7 00:15:32 1996 Lars Magne Ingebrigtsen - - * gnus-soup.el (gnus-group-brew-soup): Don't pack ticked - articles. - - * gnus.el (gnus-eval-in-buffer-window): Use uninterned symbol. - (gnus-buffer-exists-p): `let'. - (gnus-summary-reparent-thread): Don't use `substring-no-props'. - (gnus-summary-edit-article-done): Ditto. - - * gnus-msg.el (gnus-news-followup): Don't ask about "poster". - (gnus-summary-followup): Bugged out on "poster". - (gnus-inews-set-point): Didn't reliably set point. - -Wed Mar 6 01:02:25 1996 Lars Magne Ingebrigtsen - - * gnus-cache.el (gnus-cache-enter-article): Advance point. - - * gnus.el (gnus-summary-copy-article): Would pass the `respool' - parameter. - - * nnmail.el (nnmail-search-unix-mail-delim): Accept a quoted From - as the second line. - - * nnvirtual.el (nnvirtual-retrieve-headers): Don't collect so much - garbage. - - * gnus.el (gnus-group-set-mark): Allow forcing. - (gnus-group-unmark-all-groups): Non-interactive. - -Tue Mar 5 15:21:21 1996 Lars Ingebrigtsen - - * gnus-topic.el (gnus-topic-mark-topic): Would skip the first group. - (gnus-topic-unmark-topic): New function and keystroke. - (gnus-topic-tallied-groups): New variable. - (gnus-topic-prepare-topic): Don't count groups twice. - - * gnus.el (gnus-get-split-value): Would return nil. - - * gnus-soup.el (gnus-soup-group-brew): Don't enter group with 0 - unread articles. - - * gnus.el (gnus-group-set-current-level): Don't error out when - point isn't on a group. - - * gnus-vis.el (gnus-article-highlight-headers): Would infollop on - illegal headers. - - * gnus-topic.el (gnus-topic-hide-topic): Toggle the parent topic. - - * nn*.el: Made sure all virtual server variables are saved. - -Mon Mar 4 19:18:57 1996 Lars Magne Ingebrigtsen - - * nntp.el (nntp-server-variables): Save more variables. - - * gnus.el (gnus-read-old-newsrc-el-file): Would bug out on - entering ticks into infos. - (gnus-gnus-to-newsrc-format): Write "native"-server groups to the - .newsrc. - - * nnsoup.el (nnsoup-store-reply): Make sure `expand-mail-aliases' - and `mail-swallows-etc' is bound. - - * nnvirtual.el (nnvirtual-marks): Made into a defsubst. - (nnvirtual-possibly-change-group): Would recreate the mapping - several times. - - * nnml.el (nnml-request-rename-group): Wouldn't allow renaming - non-leaf group name components. - - * gnus.el (gnus-group-change-level): Wouldn change levels of - living groups. - -Sun Mar 3 23:17:57 1996 Lars Ingebrigtsen - - * gnus-msg.el (gnus-sent-message-ids-file): New variable. - (gnus-sent-message-ids-length): New variable. - (gnus-inews-reject-message): New function. - -Sun Mar 3 22:03:47 1996 Jason L. Tibbitts, III - - * nnmail.el (nnmail-process-unix-mail-format): Better - Content-Length check. - -Sun Mar 3 21:53:12 1996 Lars Ingebrigtsen - - * nntp.el (nntp-end-of-line): New variable. - (nntp-request-close, nntp-encode-text, - nntp-send-strings-to-server, nntp-async-send-strings): Use it. - (nntp-read-server-type): Use slow wait-for-response. - -Sun Mar 3 21:50:22 1996 Thor Kristoffersen - - * nntp.el (nntp-open-rlogin): New definition. - -Sun Mar 3 21:39:20 1996 Lars Ingebrigtsen - - * gnus.el (gnus-get-new-news-in-group): Close group after opening - it. - -Sun Mar 3 02:27:17 1996 Jason L Tibbitts III - - * nnmail.el (nnmail-process-unix-mail-format): Rewrite of - Content-Length: header processing. - -Sun Mar 3 13:05:15 1996 Loren Schall - - * gnus.el (gnus-simplify-buffer-fuzzy): Regexp fix. - -Sun Mar 3 12:07:37 1996 Lars Ingebrigtsen - - * nnmail.el (nnmail-search-unix-mail-delim): Accept "From " as the - line after the delim. - - * gnus-kill.el (gnus-kill-file-enter-kill): Don't move point. - (gnus-kill-file-kill-by-subject, gnus-kill-file-kill-by-author, - gnus-kill-file-kill-by-thread, gnus-kill-file-kill-by-xref): Use - it. - -Sat Mar 2 16:39:34 1996 Lars Ingebrigtsen - - * gnus.el (gnus-summary-exit): Close the group. - - * nndoc.el (nndoc-type-alist): Be a bit slacker with digest head - ends. - - * gnus.el (gnus-select-newsgroup): Would kill the group buffer. - - * gnus-msg.el (gnus-group-post-news): Configure windows. - - * gnus.el (gnus-setup-news): Don't read the descriptions file when - started with `no-server'. - -Sat Mar 2 11:38:26 1996 Lars Magne Ingebrigtsen - - * gnus.el: 0.49 is released. - - * gnus-vis.el (gnus-article-button-next-page): New function. - (gnus-article-button-prev-page): New function. - (gnus-insert-next-page-button): Use them. - (gnus-article-next-button): Wrong function name. - - * gnus.el (gnus-get-unread-articles-in-group): Also reactivate - groups that alter their info. - (gnus-summary-next-thread): Would react badly to dummy roots. - - * nndraft.el (nndraft-request-update-info): Return success. - - * gnus.el (gnus-set-global-variables): Also copy the summary - buffer value. - - * gnus-cite.el (gnus-cited-text-button-line-format): New default. - (gnus-article-hide-citation): Would add invisible buttons under - XEmacs. - -Fri Mar 1 20:52:28 1996 Lars Ingebrigtsen - - * gnus-msg.el (gnus-summary-resend-bounced-mail): Use - `mail-unsent-separator'. - - * gnus.el (gnus-gather-threads-by-references): Change name. - -Fri Mar 1 20:25:21 1996 Brad Miller - - * gnus-gl.el: New version. - -Fri Mar 1 20:04:51 1996 Robert Pluim - - * gnus-msg.el (gnus-mail-reply): Would handle Mail-Copies-To - `always'. - -Fri Mar 1 08:17:01 1996 Lars Ingebrigtsen - - * gnus.el: Autoload `gnus-binary-mode'. - (gnus-group-prefixed-name): Would append "+" to group methods. - - * gnus-topic.el (gnus-topic-list-active): Use the `force' param. - - * gnus.el (gnus-group-change-level): Would bug out on ranks. - (gnus-backlog-request-article): Would choke on Message-IDs. - (gnus-group-change-level): Would bug out sometimes. - (gnus-configure-frame): Just push newly-created frames on the list - of frames to be closed on exit. - (gnus-method-equal): New function. - - * nndoc.el (nndoc-generate-clari-briefs-head): Peel off whitespace - from the subjects. - - * gnus-vis.el (gnus-group-make-menu-bar): Sorting entries were - wrong. - - * gnus-cache.el (gnus-cache-update-article): New function. - - * gnus.el (gnus-article-prev-page): Put point at first line. - (gnus-article-next-page): Ditto. - (gnus-get-unread-articles-in-group): Would bug out on dead - groups. - (gnus-summary-edit-article-done): Update cache. - -Thu Feb 29 10:50:02 1996 Steven L. Baur - - * gnus-xmas.el (gnus-xmas-redefine): Add wrapper to - mail-strip-quoted-names. - (gnus-xmas-mail-strip-quoted-names): New function. - - * gnus-msg.el (gnus-mail-reply): Use it. - - * gnus-soup.el (gnus-soup-store): Use it. - - * gnus-ems.el: mail-strip-quoted-names -> gnus-mail-strip-quoted-names. - -Fri Mar 1 07:12:38 1996 Lars Ingebrigtsen - - * gnus.el (gnus-read-newsrc-file): Make sure the .newsrc file - exists before reading it. - (gnus-group-restart): Ask before executing. - -Thu Feb 29 18:15:13 1996 Lars Ingebrigtsen - - * gnus-xmas.el (gnus-xmas-pick-menu-add, - gnus-xmas-binary-menu-add, gnus-xmas-tree-menu-add, - gnus-xmas-grouplens-menu-add): New functions. - (gnus-xmas-redefine): Use them. - -Thu Feb 29 18:10:05 1996 Brad Miller - - * gnus-gl.el: New version. - -Thu Feb 29 14:28:06 1996 Lars Magne Ingebrigtsen - - * gnus.el: 0.48 is released. - - * gnus.el (gnus-read-active-file): Wouldn't work on `some'. - -Thu Feb 29 09:15:05 1996 Lars Ingebrigtsen - - * gnus.el: 0.47 is released. - - * nnvirtual.el (nnvirtual-create-mapping): Copy article marks. - - * gnus.el (gnus-add-marked-articles): Would corrupt the - .newsrc.eld file. - - * gnus-vis.el (gnus-group-highlight-line): Make sure `level' and - `score' are numbers. - - * gnus-msg.el (gnus-inews-insert-archive-gcc): Group would be nil - when posting from the group buffer. - - * gnus.el (gnus-fetch-group): Really fetch the group. - (gnus-summary-recenter): Respect `vertical'. - (gnus-recenter): Heed the prefix. - -Thu Feb 29 08:58:59 1996 Roderick Schertler - - * gnus-score.el (gnus-score-after-write-file-function): New - variable. - -Thu Feb 29 08:00:08 1996 Lars Ingebrigtsen - - * gnus.el (gnus-after-getting-new-news-hook): New hook. - - * gnus-uu.el (gnus-uu-digest-mail-forward): Use normal - process/prefix convetions. - - * nnfolder.el (nnfolder-request-scan): Kill buffers after saving. - -Wed Feb 28 04:39:49 1996 Lars Ingebrigtsen - - * gnus.el: 0.46 is released. - - * gnus.el (gnus-read-active-file): Don't try to retrieve groups - when no can be found. - (gnus-find-method-for-group): Return "cleaner" select methods. - - * gnus-uu.el (gnus-uu-uustrip-article): Don't loop forever if the - uudecode is silent. - - * nnmail.el (nnmail-search-unix-mail-delim): Stricter 822-delim - format. - - * gnus.el (gnus-summary-local-variables): Didn't clear - `gnus-cache-removable-articles'. - (gnus-buffer-configuration): Display article-copy in reply and - followup. - - * nnvirtual.el (nnvirtual-retrieve-headers): Always insert new - Xref headers. - - * gnus.el (gnus-add-marked-articles): Remove empty mark lists. - - * nnvirtual.el (nnvirtual-retrieve-headers): Propagate - `fetch-old'. - - * gnus.el (gnus-check-server): Accept a `silent' parameter. - - * nnvirtual.el (nnvirtual-retrieve-headers): Make sure the proper - server is opened. - - * gnus.el (gnus-recenter): Don't do unconditional horizontal - recentering. - - * gnus-vis.el (gnus-article-next-button): Skip past intangible - buttons. - - * gnus-msg.el (gnus-inews-insert-archive-gcc): Don't do archiving - if `gnus-message-archive-method' is nil. - - * gnus.el (gnus-find-method-for-group): Don't add `*-address' - indiscriminately. - -Tue Feb 27 08:50:10 1996 Lars Ingebrigtsen - - * gnus-msg.el (gnus-draft-group): Would return a bogus group - name. - - * nndir.el (nndir-open-server): Escape ftp errors. - - * gnus-msg.el (gnus-mail-reply): Handle "always" Mail-Reply-To. - (gnus-debug): Produced messy bug reports. - -Tue Feb 27 04:04:17 1996 Lars Magne Ingebrigtsen - - * gnus.el: 0.45 is released. - - * nntp.el (nntp-retry-on-break): New variable. - (nntp-send-command): Use it. - - * gnus-gl.el: New version. - - * gnus.el (gnus-group-get-new-news): Don't NoCeM scan when given a - number. - - * gnus-nocem.el (gnus-nocem-save-active): Saved wrong alist. - - * gnus-msg.el (gnus-inews-check-post): Would bug out on non-new - articles. - - * gnus-nocem.el (gnus-nocem-check-article): Better message. - (gnus-nocem-save-active): New function. - (gnus-nocem-scan-groups): Use it. - (gnus-nocem-check-article): Don't request the article unless it is - newish. - - * gnus.el (gnus-request-article-this-buffer): Would bug out during - NoCeMing. - - * gnus-nocem.el (gnus-nocem-save-cache): Would save bad caches. - -Tue Feb 27 04:03:15 1996 Lars Magne Ingebrigtsen - - * gnus.el: 0.44 is released. - -Tue Feb 27 03:49:45 1996 Lars Magne Ingebrigtsen - - * gnus-vis.el (gnus-article-highlight-signature): Use a marker for - the signature. - -Tue Feb 27 01:29:53 1996 Lars Magne Ingebrigtsen - - * gnus-msg.el (gnus-inews-article): Always check all headers. - (gnus-mail-reply): Use the Gnus-Warning Message-ID, if possible. - (gnus-news-followup): Ditto. - - * gnus.el (gnus-summary-hide-thread): Would infloop on article - with no ":". - - * gnus-msg.el (gnus-mail-send-and-exit): Make sure we're in the - right buffer. - -Mon Feb 26 01:57:17 1996 Lars Ingebrigtsen - - * gnus-srvr.el (gnus-server-prepare): Do more checking for nil - methods. - - * nnsoup.el (nnsoup-request-expire-articles): Better message. - - * gnus-salt.el (gnus-generate-horizontal-tree): Use <> brackets on - adopted articles. - - * gnus-msg.el (gnus-inews-news): Don't allow posting when Gnus is - dead. - - * gnus.el (gnus-alive-p): New function. - - * gnus-msg.el (gnus-inews-modify-mail-mode-map): Use new macro; - moved `C-c C-k' to `C-c C-q'. - (gnus-kill-message-buffer): Return to the buffer from whence we - came. - - * gnus.el (gnus-created-frames): New variable. - (gnus-clear-system): Remove created frames. - (gnus-local-set-keys): New macro. - - * gnus-msg.el (gnus-inews-cleanup-headers): Remove empty lines. - (gnus-inews-check-post): Warn about empty headers. - (gnus-check-before-posting): New default. - - * nnmail.el (nnmail-search-unix-mail-delim): New function. - (nnmail-process-unix-mail-format): Use it. - - * nntp.el (nntp-open-server): Clear the nntp-server-buffer after - opening a connection. - (nntp-request-quit): Removed. - (nntp-request-group): Change server. - (nntp-kill-command): New function. - (nntp-send-command): Use it. - (nntp-command-timeout): New variable. - (nntp-send-command): Retry commands if `C-g'. - - * gnus.el (gnus-summary-mark-read-and-unread-as-read): Changed - name. - - * nntp.el (nntp-open-server-semi-internal): Better messages. - - * gnus-msg.el (gnus-debug): Did `quote' wrong. - -Sun Feb 25 01:37:49 1996 Lars Magne Ingebrigtsen - - * gnus.el: 0.43 is released. - - * gnus-topic.el (gnus-topic-prepare-topic): Would bug out on dead - groups. - (gnus-topic-grok-active): Read the active file if it hasn't been - read yet. - - * nnfolder.el (nnfolder-close-group): Always kill the folder. - (nnfolder-always-close): Removed variable. - - * gnus.el (gnus-update-format-specifications): Try to be in the - proper buffer before updating. - -Sat Feb 24 22:35:56 1996 Lars Magne Ingebrigtsen - - * gnus.el (gnus-group-exit): BBB logout. - - * gnus-gl.el (bbb-grouplens-group-p): New function. - - * gnus.el: Autoload the GroupLens functions. - (gnus-use-grouplens): New variable. - (gnus): Use it. - (gnus-group-line-format): Changed default to include GroupLens. - (gnus-group-insert-group-line): GroupLens enhanced. - - * gnus-gl.el: New version. - -Sat Feb 24 07:35:03 1996 Lars Ingebrigtsen - - * nnmail.el (nnmail-cache-close): Kill the cache buffer. - - * gnus-msg.el (gnus-post-news-buffer): Changed name. - - * nndir.el (nndir-execute-nnmh-command): Wouldn't allow entry into - nndir groups. - - * gnus.el (gnus-summary-prepare-threads): Don't low-mark sparse - articles. - -Sat Feb 24 07:24:03 1996 Mark Borges - - * gnus-edit.el: Replaced "~/News" with the proper variable. - -Thu Feb 22 14:27:58 1996 Wes Hardaker - - * gnus.el (gnus-ask-server-for-new-groups): Reset new-newsgroups - so it doesn't *censored*ing subscribe to newsgroups more than once. - - * gnus-picon.el (gnus-picons-remove-all): remove x-face icon on exit. - -Sat Feb 24 05:55:06 1996 Lars Ingebrigtsen - - * gnus.el (gnus-find-method-for-group): Reply with the proper - method. - - * nnmbox.el (nnmbox-request-post): Removed function. - * nnmh.el (nnmh-request-post): Ditto. - * nnml.el (nnml-request-post): Ditto. - * nnfolder.el (nnfolder-request-post): Ditto. - * nnbabyl.el (nnbabyl-request-post): Ditto. - - * gnus-uu.el (gnus-uu-decode-with-method): Create directory if it - doesn't exist. - (gnus-uu-default-dir): New default. - -Thu Feb 22 20:19:47 1996 Steven L. Baur - - * nnbabyl.el (nnbabyl-request-expire-articles): set-text-properties - should be called as gnus-set-text-properties. - -Sat Feb 24 01:08:55 1996 Lars Magne Ingebrigtsen - - * gnus.el: 0.42 is released. - - * nnml.el (nnml-find-id): Make sure the .overview file exists - before reading it. - - * gnus.el (gnus-article-children): New function. - (gnus-summary-limit-exclude-childless-dormant): Use it to exclude - all childless dormants. - - * gnus-nocem.el (gnus-nocem-check-article): Would narrow to wrong - region. - - * nndraft.el (nndraft-execute-nnmh-command): Make sure - `nnmail-keep-last-article' is nil. - -Sat Feb 24 00:27:34 1996 Lars Magne Ingebrigtsen - - * gnus.el (gnus-summary-set-local-parameters): Don't set - `to-address' local parameters etc. - (gnus-summary-exit): Would insert dummy lines in the group - buffer. - (gnus-summary-enter-digest-group): Would wipe out the quirt-config. - - * nndoc.el (nndoc-server-variables): Didn't save all variables. - -Fri Feb 23 00:24:55 1996 Lars Magne Ingebrigtsen - - * gnus.el: 0.41 is released. - - * gnus.el (gnus-read-active-file): Would put wrong method on - `gnus-have-read-active-file'. - - * gnus-srvr.el (gnus-browse-exit): Make sure all newly subscribed - groups are listed in the group buffer. - - * gnus-uu.el (gnus-uu-check-for-generated-files): New - implementation. - (gnus-uu-save-files): Save directories properly. - (gnus-uu-scan-directory): Scan directories properly. - - * gnus.el (gnus-configure-windows): Would create repeating - windows in multiple frames. - (gnus-group-make-group): Would bug out. - - * gnus-salt.el (gnus-generate-tree): Make sure the tree window is - displayed before selecting it. - (gnus-highlight-selected-tree): Ditto. - -Fri Feb 23 00:01:25 1996 Lars Magne Ingebrigtsen - - * gnus-srvr.el (gnus-server-yank-server): Would try to setcdr - nil. - - * nndraft.el (nndraft-request-post): Removed function. - - * gnus-score.el (gnus-score-followup): Apply "followup" scores - after generating them. - -Thu Feb 22 23:33:35 1996 Lars Magne Ingebrigtsen - - * gnus-score.el (gnus-score-followup): Change to the adapt score - file properly. - (gnus-summary-score-entry): Return the added score entry. - -Thu Feb 22 01:03:16 1996 Lars Ingebrigtsen - - * gnus.el (gnus-unread-mark-p): New function. - (gnus-read-mark-p): New function. - (gnus-summary-mark-unread-and-read-as-read): New function. - (gnus-mark-article-hook): New default value. - - * x-easymenu.el: Double up. - - * gnus-edit.el (gnus-score-custom-data): Use kill file directory. - - * gnus-msg.el (gnus-debug): Pp the entire setq. - -Wed Feb 21 04:10:12 1996 Lars Ingebrigtsen - - * nnspool.el: Use nnheader-report/nnheader-insert. - * nnml.el: Ditto. - * nnmbox.el: Ditto. - * nnkiboze.el: Ditto. - * nnbabyl.el: Ditto. - -Wed Feb 21 00:21:56 1996 Lars Magne Ingebrigtsen - - * gnus.el: 0.40 is released. - - * gnus.el (gnus-summary-refer-parent-article): Also check the NOV - references. - - * gnus-salt.el (gnus-possibly-generate-tree): Don't generate trees - for pseudo-articles. - - * nnvirtual.el (nnvirtual-retrieve-headers): Make sure the group - exists. - - * gnus.el (gnus-summary-read-group): Search all frames when - recentering the group buffer. - (gnus-summary-hide-thread): Didn't hide dummy threads. - - * gnus.el (gnus-summary-prepare-threads): Dummy roots would - swallow the following article. - - * gnus-msg.el (gnus-new-empty-mail): New function. - (gnus-summary-resend-bounced-mail): Use it. - - * gnus-picon.el (gnus-picons-display-x-face): Make sure buffer - exists. - -Tue Feb 20 04:45:34 1996 Lars Ingebrigtsen - - * gnus.el (gnus-group-set-current-level): Error if not a group on - the current line. - (gnus-summary-next-page): Don't go to the next article when 'never - and at the end of the group. - (gnus-group-make-group): Make sure the server is opened. - (gnus-read-descriptions-file): Make sure the method is a method - and not a server. - - * gnus-msg.el (gnus-copy-article-buffer): Ditto. - (gnus-forward-insert-buffer): Ditto. - - * gnus-cite.el (gnus-cite-parse): Use `gnus-set-text-properties'. - - * nnheader.el (nnheader-temp-write): Would bug out on nil files. - -Mon Feb 19 23:01:33 1996 Lars Magne Ingebrigtsen - - * browse-url.el: New version installed. - - * gnus.el: 0.39 is released. - -Mon Feb 19 01:00:33 1996 Lars Ingebrigtsen - - * gnus.el (gnus-group-read-ephemeral-group): Put the quit-config - in the group parameters. - (gnus-summary-subject-string): Alias for backwards compatibility. - - * gnus-nocem.el (gnus-nocem-hashtb): Moved here. - (gnus-nocem-check-article): Check whether the article is new. - (gnus-nocem-unwanted-article-p): Mew function. - - * gnus.el (gnus-summary-limit-children): Use NoCeM. - (gnus-summary-initial-limit): Ditto. - (gnus-get-newsgroup-headers): Don't use NoCeM. - -Sun Feb 18 00:03:03 1996 Lars Ingebrigtsen - - * nnsoup.el (nnsoup-request-expire-articles): Message better. - - * gnus.el (gnus-summary-read-group): Display all dormant articles - when `all'. - - * nndir.el (nndir-request-list): Would build to wide. - (nndir-execute-nnmh-command): Allow reading from nndir servers. - - * nnmh.el (nnmh-open-server): Report errors.o - - * nnml.el (nnml-open-server): Report errors. - - * nnsoup.el (nnsoup-open-server): Report errors. - - * nnspool.el (nnspool-open-server): Report errors. - -Sat Feb 17 11:08:16 1996 Lars Ingebrigtsen - - * nnfolder.el (nnfolder-open-server): Report errors. - - * nndraft.el (nndraft-open-server): Report errors. - (nndraft-close-server): Close. - - * nndir.el (nndir-open-server): Report errors. - (nndir-close-server): Close. - - * nnmbox.el (nnmbox-open-server): Report errors. - (nnmbox-close-server): Kill buffer. - - * nnbabyl.el (nnbabyl-open-server): Report errors. - - * nndir.el: New-stylee backquotes. - - * nnml.el (nnml-generate-nov-file): Make sure numerical files are - files. - - * gnus.el (gnus-check-server): Give a better message. - - * nndoc.el (nndoc-babyl-body-begin-function): New function. - (nndoc-type-alist): Find beginning of babyl articles. - - * nnsoup.el (nnsoup-unpack-packets): Message better. - - * gnus.el (gnus-article-mark-lists): Don't save the cache marks. - -Fri Feb 16 19:14:26 1996 Lars Ingebrigtsen - - * nndoc.el (nndoc-type-alist): Recognize the end of digests. - -Fri Feb 16 06:46:48 1996 Per Abrahamsen - - * gnus-score.el (gnus-summary-score-effect): Didn't correctly - escape meta charcters for substring and exact match types. - -Fri Feb 16 00:50:35 1996 Lars Ingebrigtsen - - * gnus.el (gnus-article-setup-buffer): Set global counterparts. - (gnus-valid-select-methods): All methods should use address. - (gnus-article-show-hidden-text): Hide all hidden text. - - * gnus-kill.el (gnus-kill-file-mode-map): New implementation. - - * gnus-salt.el (gnus-pick-mode): Install proper minor mode map. - - * gnus.el (gnus-summary-exit): Kill article buffer when using - non-single ones. - (gnus-set-global-variables): Copy the original buffer to global - value. - - * nnspool.el (nnspool-open-server): Simplify. - * nnmbox.el (nnmbox-open-server): Ditto. - * nnbabyl.el (nnbabyl-open-server): Ditto. - * nnml.el (nnml-open-server): Ditto. - * nnfolder.el (nnfolder-open-server): Ditto. - * nnmh.el (nnmh-open-server): Ditto. - - * gnus-msg.el (gnus-debug): Pretty-print variables. - - * gnus-srvr.el (gnus-server-kill-server): Don't allow killing - opened-only servers. - (gnus-server-edit-server): Would create duplicate servers. - - * gnus.el (gnus-get-unread-articles): Close groups after opening - them. - (gnus-server-to-method): Search the opened servers for matches. - - * gnus-vm.el (gnus-summary-save-in-vm): Use the split methods. - - * gnus.el (gnus-summary-skip-intangible): Don't use `when'. - -Thu Feb 15 11:02:08 1996 Lars Ingebrigtsen - - * nndoc.el (nndoc-type-alist): Allow several newlines in - 937-digests. - - * gnus.el (gnus-select-newsgroup): Don't message when quitting. - - * nnfolder.el (nnfolder-request-close): Close the server. - - * gnus.el (gnus-group-method): Changed name. - (gnus-group-method): Return the real select method, if possible. - -Wed Feb 14 15:01:57 1996 Lars Ingebrigtsen - - * gnus-score.el (gnus-summary-increase-score): Regexp-quote regexp - matches. - - * gnus-msg.el (gnus-forward-insert-buffer): Remove all text - properties. - (gnus-forward-included-headers): Buggy regexp. - - * gnus-salt.el (gnus-possibly-generate-tree): Don't generate trees - unless threads are used. - - * nnheader.el (nnheader-insert-head): Would almost laways stop - after the first kb. - -Wed Feb 14 07:41:58 1996 Colin Rafferty - - * gnus.el (gnus-group-add-parameter): Remove old versions of the - parameter. - -Wed Feb 14 07:28:50 1996 Lars Ingebrigtsen - - * gnus-msg.el (gnus-news-followup): Don't query if Followup-To and - Newsgroups are the same. - (gnus-inews-check-post): Reversed check for Followup-To. - - * gnus.el (gnus-group-kill-group): Kill lots of zombie groups. - (gnus-article-hide-headers): Check whether `gnus-visible-headers' - is nil. - -Tue Feb 13 06:29:47 1996 Lars Ingebrigtsen - - * gnus.el (gnus-add-configuration): Autoload. - (gnus-summary-tick-article): Made interactive. - - * nntp.el (nntp-open-server-internal): Don't bug out when the - server hangs up during initial negotiations. - -Mon Feb 12 04:47:14 1996 Lars Ingebrigtsen - - * nntp.el (nntp-default-directories): New variable. - (nntp-open-server-internal): Use it. - - * nnsoup.el (nnsoup-read-areas): Delete AREAS file. - (nnsoup-read-areas): Check whether the MSG file exists. - - * gnus.el (gnus-summary-move-article): Only mark as canceled when - moving. - - * gnus-ems.el (gnus-set-text-properties): New alias. - -Sun Feb 11 13:53:23 1996 Lars Ingebrigtsen - - * gnus-msg.el (gnus-inews-remove-signature): New function. - -Sun Feb 11 09:29:06 1996 Lars Magne Ingebrigtsen - - * gnus.el (gnus-request-article-this-buffer): Make sure the - article buffer exists. - -Sun Feb 11 09:28:46 1996 Lars Magne Ingebrigtsen - - * gnus.el: 0.38 is released. - -Sun Feb 11 04:49:16 1996 Mark Borges - - * gnus-xmas.el (gnus-xmas-define): Conditionally redefine - `set-text-properties'. - -Sun Feb 11 04:40:39 1996 Lars Ingebrigtsen - - * gnus.el (gnus-summary-limit-to-subject): Limit to any header. - -Sat Feb 10 03:26:10 1996 Lars Ingebrigtsen - - * nnmail.el (nnmail-days-to-time): Don't bug out on large - numbers. - -Fri Feb 9 22:17:55 1996 Lars Ingebrigtsen - - * gnus-msg.el (gnus-forward-included-headers): Include Message-ID - and References. - (gnus-post-news): Make sure the parent group is a news group. - -Fri Feb 9 09:56:45 1996 Lars Magne Ingebrigtsen - - * gnus-picon.el (gnus-picons-convert-x-face): Changed to use - pbmplus. - - * gnus.el (gnus-buffer-configuration): One quote too many. - - * gnus-kill.el (gnus-execute): Allow searching bodies. - - * gnus.el (gnus-summary-execute-command): Accept "Body" searches. - - * gnus.el: 0.37 is released. - -Fri Feb 9 09:44:04 1996 Lars Magne Ingebrigtsen - - * nnmail.el (nnmail-time-since): Reversed time. - - * nnml.el (nnml-request-expire-articles): Set lower limit - correctly. - -Fri Feb 9 05:40:39 1996 Lars Ingebrigtsen - - * nntp.el (nntp-open-server-semi-internal): Report errors better. - -Thu Feb 8 00:36:09 1996 Lars Ingebrigtsen - - * gnus.el (gnus-group-jump-to-group): Don't jump to ephemeral - groups. - (gnus-summary-catchup-and-goto-next-group): Allow quiet going. - - * gnus-topic.el (gnus-topic-move-group): Allow removal of groups. - (gnus-topic-remove-group): New command and keystroke. - - * nnsoup.el (nnsoup-read-areas): Message. - - * nndoc.el (nndoc-possibly-change-buffer): Return nil when the - file doesn't exist. - (nndoc-close-server): Really close. - - * gnus.el (gnus-update-format-specifications): Would not update - format specs. - - * gnus-topic.el (gnus-topic-remove-topic): Accept a list-level. - (gnus-group-prepare-topics): List dead groups. - -Wed Feb 7 00:04:23 1996 Lars Ingebrigtsen - - * gnus.el (gnus-summary-hide-thread): Hide the last thread. - - * gnus-kill.el (gnus-kill): Provide. - (gnus-execute-1): Accept forms. - - * nnheader.el (nnheader-temp-write): New macro. - - * gnus-soup.el (gnus-soup-group-brew): Pack ticked. - (gnus-soup-write-replies): Be silent. - - * gnus-msg.el (gnus-bug-mail-send-and-exit): Kill gnus-bug buffer - after sending. - - * gnus.el (gnus-setup-news): Find new newsgroups even if - gnus-read-active-file is nil. - - * gnus-soup.el (gnus-soup-group-brew): Would pack too few - articles. - - * nneething.el (nneething-request-type): New function. - (nneething-request-post): Removed. - - * nnvirtual.el (nnvirtual-find-group-art): Never return `(nil)'. - - * nndoc.el (nndoc-rnews-body-end): Really go to the end. - - * nnsoup.el (nnsoup-read-areas): Would calculate new article - boundary +1. - (nnsoup-index-buffer): Check whether the file exists before - reading it. - (nnsoup-retrieve-headers): Ditto. - - * gnus-topic.el (gnus-topic-goto-missing-group): New function. - -Tue Feb 6 22:33:50 1996 Lars Ingebrigtsen - - * gnus.el (gnus-goto-missing-group-function): New variable. - - * nnmail.el (nnmail-time-since): Don't alter time. - (nnmail-days-to-time): Would give wrong result. - - * gnus.el (gnus-article-de-quoted-unreadable): Decode headers - before body. - -Tue Feb 6 09:51:14 1996 Morioka Tomohiko - - * gnus.el (gnus-article-show-hidden-text): Don't use `(1+ - (point))'. It does not work in Mule. - -Mon Feb 5 13:03:47 1996 Wes Hardaker - - * gnus-picon.el (gnus-group-display-picons): Delete buffer on exit. - (gnus-article-display-picons): Ditto. - -Tue Feb 6 00:26:44 1996 Lars Ingebrigtsen - - * gnus-salt.el (gnus-tree-recenter): Recenter the tree buffer. - - * gnus-cite.el (gnus-article-toggle-cited-text): Bind - `buffer-read-only'. - - * gnus.el (gnus-configure-windows): Don't search all frames unless - when using a frame split. - (gnus-summary-mode-map): Change `W t'. - -Mon Feb 5 23:41:09 1996 Lars Ingebrigtsen - - * gnus-score.el (gnus-short-name-score-file-cache): New variable. - (gnus-score-score-files): Use it. - (gnus-score-flush-cache): Ditto. - -Mon Feb 4 23:55:30 1996 Morioka Tomohiko - - * gnus.el (gnus-configure-windows): Check minibuffer only frame. - -Mon Feb 5 22:36:24 1996 Lars Ingebrigtsen - - * nnsoup.el (nnsoup-old-functions): New variable. - (nnsoup-revert-variables): New command. - -Mon Feb 5 17:54:07 1996 Lars Magne Ingebrigtsen - - * nnvirtual.el (nnvirtual-update-marked): Copy empty mark lists. - - * gnus.el (gnus-summary-read-group): Allow entry with no-display. - - * gnus.el: 0.36 is released. - -Sat Feb 3 11:56:53 1996 Steven L. Baur - - * gnus-uu.el (gnus-uu-default-view-rules): Added rule for playing of - decoded midi files. - -Mon Feb 5 05:08:54 1996 Lars Ingebrigtsen - - * gnus.el (gnus-summary-mode-map): Move `v' to `W v'. - - * gnus-cache.el (gnus-cache-possibly-enter-article): Request the - buffer to the nntp buffer. - - * gnus.el (gnus-recenter): Allow a prefix. - -Mon Feb 5 04:56:35 1996 Michael Cook - - * gnus.el (gnus-configure-windows): Return to the original frame. - -Mon Feb 5 03:49:34 1996 Lars Ingebrigtsen - - * gnus-topic.el (gnus-topic-kill-group): Update topics. - (gnus-topic-yank-group): Ditto. - - * nnfolder.el (nnfolder-directory): Doc fix. - - * gnus.el (gnus-summary-move-article): Add marks when moving - articles. - (gnus-summary-recenter): Don't do horizontal recenter unless the - buffer is visible. - -Sun Feb 4 16:22:20 1996 Lars Magne Ingebrigtsen - - * gnus.el (gnus-summary-edit-article): Make sure we're in the - summary buffer. - - * gnus.el: 0.35 is released. - -Sun Feb 4 14:05:20 1996 Lars Magne Ingebrigtsen - - * nndoc.el (nndoc-guess-digest-type): Too strict body-begin for - MIME digests. - - * gnus-msg.el (gnus-removable-headers): Don't remove Bcc header. - (gnus-mail-send): Accept a parameter. - (gnus-inews-send-mail-copy): Use it. - - * gnus-salt.el (gnus-tree-close): Don't kill the tree buffer. - - * gnus.el (gnus-summary-select-article): Changed return value. - (gnus-summary-scroll-up): Use it. - -Sat Feb 3 20:39:59 1996 Lars Ingebrigtsen - - * gnus.el (gnus-summary-dummy-line-format): Included tabs. - (gnus-summary-prepare-threads): Insert dummy lines properly. - (gnus-summary-hide-thread): Hide dummies better. - - * gnus-uu.el (gnus-uu-get-actions): Escape special characters. - - * gnus-soup.el (gnus-soup-group-brew): Add articles in right - order; don't generate display. - - * gnus.el (gnus-summary-sort): Allow sorting in reverse order. - (gnus-summary-pop-limit): Don't pop if there isn't anything to - pop. - (gnus-sort-articles): Would destroy the newsgroup data. - - * gnus-soup.el (gnus-soup-unpack-packet): Return the process value. - - * gnus.el (gnus-summary-exit): Don't bury buffers that don't exist. - (gnus-summary-exit-no-update): Ditto. - -Sat Feb 3 14:37:31 1996 Lars Magne Ingebrigtsen - - * gnus-soup.el (gnus-soup-add-article): Would bug out on - non-existent articles. - - * gnus.el (gnus-configure-windows): Delete windows on all frames. - -Sat Feb 3 15:07:38 1996 Lars Magne Ingebrigtsen - - * gnus.el (gnus-summary-read-group): Wouldn't score anything. - - * gnus.el: 0.34 is released. - -Sat Feb 3 13:08:48 1996 Lars Magne Ingebrigtsen - - * gnus-msg.el (gnus-summary-resend-bounced-mail): Strip more - gruft. - - * gnus.el: 0.33 is released. - -Fri Feb 2 20:19:07 1996 Lars Ingebrigtsen - - * gnus.el (gnus-summary-exit): Bury the article buffer. - - * gnus-score.el (gnus-score-followup-article): Don't do - `score-effect'. - -Fri Feb 2 20:07:31 1996 Jason L. Tibbitts, III - - * nnmail.el (nnmail-process-babyl-mail-format): Allow many spaces - after ":". - -Fri Feb 2 20:05:02 1996 Lars Ingebrigtsen - - * gnus.el (gnus-summary-select-article): Return t on success. - -Thu Feb 1 00:50:54 1996 Lars Ingebrigtsen - - * nnfolder.el (nnfolder-request-group): Give a better error - message. - - * nnfolder.el: Really use virtual servers. - - * gnus.el (gnus-select-newsgroup): Moved score file processing to - an earlier point. - - * gnus-msg.el (gnus-post-method): Use `gnus-post-method' from the - group buffer. - - * nnsoup.el (nnsoup-request-expire-articles): Bombed. - (nnsoup-delete-unreferenced-message-files): New command. - - * gnus-cache.el (gnus-cache-possibly-enter-article): Update cache - mark. - (gnus-cache-possibly-remove-article): Ditto. - - * gnus-srvr.el (gnus-server-prepare): Weed out nil servers. - - * gnus-msg.el (gnus-mail-reply): Respect - `rmail-dont-reply-to-names'. - -Wed Jan 31 19:25:50 1996 Per Abrahamsen - - * gnus-msg.el (gnus-inews-insert-mime-headers): `(widen)' before - searching for 8-bit characters. - - * gnus-vis.el (gnus-article-highlight-headers): Make it ignore - the `intangible' text property. - -Thu Feb 1 00:33:37 1996 Lars Ingebrigtsen - - * gnus.el (gnus-summary-limit-to-unread): Remove sparse articles. - -Wed Jan 31 15:54:38 1996 Lars Ingebrigtsen - - * gnus-score.el (gnus-summary-score-map): Recursive map. - - * gnus-msg.el (gnus-dissociate-buffer-from-draft): Didn't run hook - properly. - - * gnus-kill.el (gnus-execute): Don't use `gnus-header-*'. - - * gnus-msg.el (gnus-kill-message-buffer): New command and - keystroke. - (gnus-mail-setup): Use the gnus-mail-*-method variables. - - * gnus-topic.el (gnus-topic-rename): Default to current topic. - (gnus-topic-create-topic): Ditto. - - * gnus-vis.el (gnus-group-highlight-line): Offer ticked number. - - * gnus-uu.el (gnus-uu-grab-articles): Remove the message. - - * gnus-vis.el (gnus-group-highlight): New default for dark - backgrounds. - - * gnus-topic.el (gnus-group-prepare-topics): Don't do anything - about dead groups. - - * gnus.el (gnus-summary-mode-map): Clobbered "D". - -Mon Jan 29 19:06:00 1996 Kim-Minh Kaplan - - * gnus.el (gnus-simplify-subject-fuzzy): Fold case. - -Mon Jan 29 17:48:12 1996 Lars Ingebrigtsen - - * gnus.el (gnus-summary-limit): Hide any threads, possibly. - - * gnus-msg.el (gnus-forward-insert-buffer): Really delete unwanted - headers. - - * gnus-vis.el (gnus-insert-prev-page-button): Allow clicking. - (gnus-insert-next-page-button): Ditto. - - * nntp.el (nntp-send-region-to-server): Copy text to a temp buffer - before sending. - -Sun Jan 28 10:28:39 1996 Lars Magne Ingebrigtsen - - * gnus-cite.el (gnus-dissect-cited-text): Don't push a nil on the - list. - -Sat Jan 27 20:32:29 1996 Lars Ingebrigtsen - - * gnus-topic.el (gnus-group-topic-topics-only): Removed variable. - - * nnbabyl.el (nnbabyl-request-group): Don't report failures on - empty groups. - * nnmbox.el (nnmbox-request-group): Ditto. - - * gnus.el (gnus-simplify-buffer-fuzzy): Simplify [x/x]. - - * gnus-score.el (gnus-score-default-header): Duplicate defvars. - (gnus-summary-increase-score): Default variables should be - symbols, not chars. - - * gnus.el (gnus-summary-mode-map): Wrong name for `t' keystroke. - -Sat Jan 27 20:29:45 1996 Marc Auslander - - * gnus-score.el (gnus-summary-increase-score): Didn't work for - non-temporary score entries. - -Fri Jan 26 17:24:00 1996 David K}gedal - - * nnmail.el (nnmail-check-duplication): Don't tread 'delete as a - function - -Sat Jan 27 19:51:08 1996 Lars Ingebrigtsen - - * gnus-topic.el (gnus-topic-prepare-topic): Number of groups would - be 0. - (gnus-topic-update-topic-line): Ditto. - -Fri Jan 26 15:10:09 1996 Steven L. Baur - - * gnus-vis.el (gnus-article-add-buttons): Need to reset point to top - of article before trying the next regexp in the gnus-button-alist. - -Sat Jan 27 19:22:24 1996 Lars Ingebrigtsen - - * gnus-vis.el (gnus-button-alist): Allow space after " - - * gnus-topic.el (gnus-topic-indent-level): New variable. - (gnus-topic-yank-group): Use it. - (gnus-topic-insert-topic-line): Ditto. - (gnus-topic-prepare-topic): Ditto. - -Fri Jan 26 17:18:25 1996 ISO-2022-JP - - * gnus-vis.el (gnus-article-highlight-headers): Would infloop. - -Fri Jan 26 14:10:19 1996 Lars Ingebrigtsen - - * gnus.el (gnus-dribble-read-file): Set file modes on the dribble - file. - (gnus-article-check-hidden-text): Only checked signature. - (gnus-article-check-hidden-text): Do things in the article - buffer. - (gnus-group-line-format-alist): Let N have its old definition. - (gnus-group-catchup-group-hook): New variable. - (gnus-group-catchup): Use it. - (gnus-group-remove-mark): Give a useful return value. - (gnus-group-kill-group): Would bug out when killing lots of dead - groups. - -Thu Jan 25 09:32:19 1996 Jack Vinson - - * gnus.el (gnus-group-insert-group-line) : Changed "header" to - "gnus-tmp-header" for parameter that gets passed to user - functions. Set to the group name, but may not necessarily want - this. - (gnus-group-set-mode-line) : ditto, gnus-tmp-header set to nil. - (gnus-set-mode-line) : ditto, gnus-tmp-header set to nil. - -Fri Jan 26 07:47:59 1996 Lars Magne Ingebrigtsen - - * gnus.el (gnus): Goto the first unread group. - - * gnus.el: 0.32 is released. - -Thu Jan 25 18:27:03 1996 Lars Ingebrigtsen - - * gnus.el: Autoload `gnus-group-highlight-line'. - - * gnus-vis.el (gnus-article-highlight-headers): Wrap the regexp in - parentheses. - - * nnmbox.el (nnmbox-request-group): Don't bug out on non-existant - groups. - * nnbabyl.el (nnbabyl-request-group): Ditto. - (nnbabyl-possibly-change-newsgroup): Return t. - - * gnus.el (gnus-group-insert-group-line): Define gnus-tmp-header. - - * gnus-msg.el (gnus-mail-parse-comma-list): New function. - (gnus-mail-reply): Use it. - (gnus-mail-reply): Merge follow-to headers. - - * gnus-score.el (gnus-summary-score-map): New implementation. - - * gnus.el (gnus-summary-exit): Remove articles before updating. - (gnus-summary-next-article): Accept a param to force slightly. - -Thu Jan 25 08:41:44 1996 Lars Magne Ingebrigtsen - - * nnml.el (nnml-deletable-article-p): Always responed with nil. - -Thu Jan 25 08:45:52 1996 Lars Magne Ingebrigtsen - - * gnus.el: 0.31 is released. - - * nnmail.el (nnmail-insert-lines): Would return negative lines - numbers. - - * gnus-xmas.el (gnus-xmas-extent-start-open): New function. - - * gnus-topic.el (gnus-topic-insert-topic-line): Remove excess - properties. - - * gnus-xmas.el (gnus-xmas-topic-remove-excess-properties): New - function. - -Thu Jan 25 07:34:05 1996 Lars Magne Ingebrigtsen - - * gnus-ems.el (gnus-extent-detached-p): New alias. - - * gnus-xmas.el (gnus-xmas-find-glyph-directory): Changed from - "etc" to "etc/gnus". - -Tue Jan 23 13:40:35 1996 Lars Ingebrigtsen - - * gnus-score.el (gnus-score-make-menu-bar): New function. - (gnus-score-menu-hook): New variable. - - * gnus-vis.el (gnus-article-next-button): Move point. - - * nndoc.el (nndoc-type-alist): Recognize ends of digests. - (nndoc-retrieve-headers): Don't bug out on non-existant articles. - - * gnus-msg.el (gnus-mail-buffer): Renamed. - - * gnus-cache.el (gnus-cache-possibly-remove-articles): Check some - more. - - * nnmail.el (nnmail-insert-lines): Off by 1. - - * nnml.el (nnml-deletable-article-p): Check for file writability. - * nnmh.el (nnml-deletable-article-p): Ditto. - - * gnus-msg.el (gnus-associate-buffer-with-draft): Allow - disabling. - (gnus-use-draft): New variable. - - * gnus.el (gnus-summary-move-article): Use `move' action by - default. - - * nnmail.el (nnmail-get-split-group): Be more restrictive in - selecting procmail spools. - (nnmail-get-spool-files): Don't return the spool file when doing a - single procmail file. - - * gnus.el (gnus-summary-move-article): Allow moving to the same - group. - - * gnus-score.el (gnus-score-pretty-print): New command and - keystroke. - (gnus-summary-increase-score): Would always bug out. - (gnus-score-edit-done): Change windows before loading score file. - - * gnus.el (gnus-summary-reparent-thread): Rethread after - reparenting. - - * gnus-xmas.el (gnus-xmas-make-overlay): Don't make extents - undetachable. - - * nndoc.el (nndoc-post-type): New variable. - -Tue Jan 23 13:39:11 1996 Eberhard Mattes - - * nndoc.el (nndoc-request-type): New function. - -Tue Jan 23 00:13:10 1996 Lars Ingebrigtsen - - * gnus.el (gnus-group-group-indentation): New function. - (gnus-group-update-group-line): Use it. - (gnus-group-update-group): Indent. - - * gnus-topic.el (gnus-topic-hide-subtopics): Removed variable. - (gnus-topic-prepare-topic): Indent group lines. - (gnus-topic-yank-group): Indent groups. - - * gnus.el (gnus-group-update-hook): New variable. - (gnus-group-insert-group-line): Use it. - - * gnus-vis.el (gnus-group-highlight-line): New function. - - * gnus.el (gnus-group-entry): New macro. - - * gnus-vis.el (gnus-group-highlight): New variable. - - * gnus-topic.el (gnus-topic-insert-topic-line): Would show "..." - too often. - (gnus-topic-indent): Don't move point. - (gnus-topic-unindent): Ditto. - (gnus-topic-prepare-topic): Display unread articles in sub-topics. - - * nnsoup.el (nnsoup-next-prefix): New function. - (nnsoup-read-areas): Use it. - - * gnus-soup.el (gnus-soup-set-area-prefix): New macro. - - * nnsoup.el (nnsoup-tmp-directory): New directory. - (nnsoup-write-active-file): Save it. - (nnsoup-unpack-packets): Use it. - - * gnus-msg.el (gnus-dissociate-buffer-from-draft): New command and - keystroke. - - * gnus.el (gnus-group-list-groups): Goto last group if at eob. - - * gnus-topic.el (gnus-topic-mode): Use it. - (gnus-topic-goto-next-group): New function. - - * gnus.el (gnus-group-list-groups): Allow positioning point in - topic buffers. - (gnus-group-goto-next-group-function): New internal variable. - - * nnsoup.el (nnsoup-read-active-file): Give a proper return - value. - - * gnus.el (gnus-start-news-server): Give a better error message. - -Mon Jan 21 23:34:55 1996 Morioka Tomohiko - - * gnus-mh.el (gnus-mh-mail-setup): It didn't work when pressing - `R' or yanking because of lack of setting to variable - `mail-reply-buffer' and mh-sent-from-folder buffer local variable - `mh-show-buffer'. - -Mon Jan 22 02:58:42 1996 Lars Ingebrigtsen - - * nntp.el (nntp-open-server-internal): Make sure that the server - was successfully opened. - - * gnus.el (gnus-read-active-file): Wouldn't activate properly. - (gnus-read-active-file): Ignore errors from the archive server. - - * nnbabyl.el (nnbabyl-request-group): Ditto. - - * nnmbox.el (nnmbox-request-group): Would bug out. - -Sat Jan 20 20:39:03 1996 Steven L. Baur - - * nnmbox.el (nnmbox-read-mbox): find-file-noselect -> - nnheader-find-file-noselect. - -Mon Jan 22 01:15:52 1996 Lars Ingebrigtsen - - * gnus.el (gnus-group-mark-buffer): Optional param. - - * nnsoup.el (nnsoup-request-expire-articles): Message more. - (nnsoup-read-active-file): Add proper active info. - (nnsoup-request-group): New implementation. - (nnsoup-request-list): Ditto. - -Sun Jan 21 08:22:47 1996 Lars Ingebrigtsen - - * gnus.el (gnus-request-article-this-buffer): Update sparse - articles. - (gnus-data-set-number): New macro. - (gnus-summary-update-article): Use it. - -Sun Jan 21 03:54:18 1996 Lars Magne Ingebrigtsen - - * gnus-soup.el (gnus-soup-add-article): Don't save canceled - articles. - diff -r ad457d5f7d04 -r 0293115a14e9 lisp/gnus/Makefile --- a/lisp/gnus/Makefile Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/gnus/Makefile Mon Aug 13 08:49:20 2007 +0200 @@ -2,9 +2,15 @@ EMACS=emacs FLAGS=-batch -q -no-site-file -l ./dgnushack.el +total: + rm -f *.elc ; $(EMACS) $(FLAGS) -f dgnushack-compile + all: rm -f *.elc ; $(EMACS) $(FLAGS) -f dgnushack-compile +clever: + $(EMACS) $(FLAGS) -f dgnushack-compile + some: $(EMACS) $(FLAGS) -f dgnushack-recompile @@ -13,3 +19,18 @@ separately: rm -f *.elc ; for i in *.el; do $(EMACS) $(FLAGS) -f batch-byte-compile $$i; done + +pot: + xpot -drgnus -r`cat ./version` *.el > rgnus.pot + +gnus-load.el: + echo ";;; gnus-load.el --- automatically extracted custom dependencies" > gnus-load.el + echo ";;" >> gnus-load.el + echo ";;; Code:" >> gnus-load.el + echo >> gnus-load.el + $(EMACS) $(FLAGS) -l ./dgnushack.el -l custom-edit.el *.el \ + -f custom-make-dependencies >> gnus-load.el + echo >> gnus-load.el + echo "(provide 'gnus-load)" >> gnus-load.el + echo >> gnus-load.el + echo ";;; gnus-load.el ends here" >> gnus-load.el diff -r ad457d5f7d04 -r 0293115a14e9 lisp/gnus/custom-edit.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus/custom-edit.el Mon Aug 13 08:49:20 2007 +0200 @@ -0,0 +1,1634 @@ +;;; custom-edit.el --- Tools for customization Emacs. +;; +;; Copyright (C) 1996 Free Software Foundation, Inc. +;; +;; Author: Per Abrahamsen +;; Keywords: help, faces +;; Version: 1.20 +;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ + +;;; Commentary: +;; +;; See `custom.el'. + +;;; Code: + +(require 'custom) +(require 'widget-edit) +(require 'easymenu) + +(define-widget-keywords :custom-prefixes :custom-menu :custom-show + :custom-magic :custom-state :custom-level :custom-form + :custom-set :custom-save :custom-reset-current :custom-reset-saved + :custom-reset-factory) + +;;; Utilities. + +(defun custom-quote (sexp) + "Quote SEXP iff it is not self quoting." + (if (or (memq sexp '(t nil)) + (and (symbolp sexp) + (eq (aref (symbol-name sexp) 0) ?:)) + (and (listp sexp) + (memq (car sexp) '(lambda))) + (stringp sexp) + (numberp sexp) + (and (fboundp 'characterp) + (funcall (intern "characterp") sexp))) + sexp + (list 'quote sexp))) + +(defun custom-split-regexp-maybe (regexp) + "If REGEXP is a string, split it to a list at `\\|'. +You can get the original back with from the result with: + (mapconcat 'identity result \"\\|\") + +IF REGEXP is not a string, return it unchanged." + (if (stringp regexp) + (let ((start 0) + all) + (while (string-match "\\\\|" regexp start) + (setq all (cons (substring regexp start (match-beginning 0)) all) + start (match-end 0))) + (nreverse (cons (substring regexp start) all))) + regexp)) + +(defvar custom-prefix-list nil + "List of prefixes that should be ignored by `custom-unlispify'") + +(defcustom custom-unlispify-menu-entries t + "Display menu entries as words instead of symbols if non nil." + :group 'customize + :type 'boolean) + +(defun custom-unlispify-menu-entry (symbol &optional no-suffix) + "Convert symbol into a menu entry." + (cond ((not custom-unlispify-menu-entries) + (symbol-name symbol)) + ((get symbol 'custom-tag) + (if no-suffix + (get symbol 'custom-tag) + (concat (get symbol 'custom-tag) "..."))) + (t + (save-excursion + (set-buffer (get-buffer-create " *Custom-Work*")) + (erase-buffer) + (princ symbol (current-buffer)) + (goto-char (point-min)) + (let ((prefixes custom-prefix-list) + prefix) + (while prefixes + (setq prefix (car prefixes)) + (if (search-forward prefix (+ (point) (length prefix)) t) + (progn + (setq prefixes nil) + (delete-region (point-min) (point))) + (setq prefixes (cdr prefixes))))) + (subst-char-in-region (point-min) (point-max) ?- ?\ t) + (capitalize-region (point-min) (point-max)) + (unless no-suffix + (goto-char (point-max)) + (insert "...")) + (buffer-string))))) + +(defcustom custom-unlispify-tag-names t + "Display tag names as words instead of symbols if non nil." + :group 'customize + :type 'boolean) + +(defun custom-unlispify-tag-name (symbol) + "Convert symbol into a menu entry." + (let ((custom-unlispify-menu-entries custom-unlispify-tag-names)) + (custom-unlispify-menu-entry symbol t))) + +(defun custom-prefix-add (symbol prefixes) + ;; Addd SYMBOL to list of ignored PREFIXES. + (cons (or (get symbol 'custom-prefix) + (concat (symbol-name symbol) "-")) + prefixes)) + +;;; The Custom Mode. + +(defvar custom-options nil + "Customization widgets in the current buffer.") + +(defvar custom-mode-map nil + "Keymap for `custom-mode'.") + +(unless custom-mode-map + (setq custom-mode-map (make-sparse-keymap)) + (set-keymap-parent custom-mode-map widget-keymap)) + +(easy-menu-define custom-mode-menu + custom-mode-map + "Menu used in customization buffers." + '("Custom" + ["Set" custom-set t] + ["Save" custom-save t] + ["Reset to Current" custom-reset-current t] + ["Reset to Saved" custom-reset-saved t] + ["Reset to Factory Settings" custom-reset-factory t] + ["Info" (Info-goto-node "(custom)The Customization Buffer") t])) + +(defcustom custom-mode-hook nil + "Hook called when entering custom-mode." + :type 'hook + :group 'customize) + +(defun custom-mode () + "Major mode for editing customization buffers. + +The following commands are available: + +\\[widget-forward] Move to next button or editable field. +\\[widget-backward] Move to previous button or editable field. +\\[widget-button-click] Activate button under the mouse pointer. +\\[widget-button-press] Activate button under point. +\\[custom-set] Set all modifications. +\\[custom-save] Make all modifications default. +\\[custom-reset-current] Reset all modified options. +\\[custom-reset-saved] Reset all modified or set options. +\\[custom-reset-factory] Reset all options. + +Entry to this mode calls the value of `custom-mode-hook' +if that value is non-nil." + (kill-all-local-variables) + (setq major-mode 'custom-mode + mode-name "Custom") + (use-local-map custom-mode-map) + (make-local-variable 'custom-options) + (run-hooks 'custom-mode-hook)) + +;;; Custom Mode Commands. + +(defun custom-set () + "Set changes in all modified options." + (interactive) + (let ((children custom-options)) + (mapcar (lambda (child) + (when (eq (widget-get child :custom-state) 'modified) + (widget-apply child :custom-set))) + children))) + +(defun custom-save () + "Set all modified group members and save them." + (interactive) + (let ((children custom-options)) + (mapcar (lambda (child) + (when (memq (widget-get child :custom-state) '(modified set)) + (widget-apply child :custom-save))) + children)) + (custom-save-all)) + +(defvar custom-reset-menu + '(("Current" . custom-reset-current) + ("Saved" . custom-reset-saved) + ("Factory Settings" . custom-reset-factory)) + "Alist of actions for the `Reset' button. +The key is a string containing the name of the action, the value is a +lisp function taking the widget as an element which will be called +when the action is chosen.") + +(defun custom-reset (event) + "Select item from reset menu." + (let* ((completion-ignore-case t) + (answer (widget-choose "Reset to" + custom-reset-menu + event))) + (if answer + (funcall answer)))) + +(defun custom-reset-current () + "Reset all modified group members to their current value." + (interactive) + (let ((children custom-options)) + (mapcar (lambda (child) + (when (eq (widget-get child :custom-state) 'modified) + (widget-apply child :custom-reset-current))) + children))) + +(defun custom-reset-saved () + "Reset all modified or set group members to their saved value." + (interactive) + (let ((children custom-options)) + (mapcar (lambda (child) + (when (eq (widget-get child :custom-state) 'modified) + (widget-apply child :custom-reset-current))) + children))) + +(defun custom-reset-factory () + "Reset all modified, set, or saved group members to their factory settings." + (interactive) + (let ((children custom-options)) + (mapcar (lambda (child) + (when (eq (widget-get child :custom-state) 'modified) + (widget-apply child :custom-reset-current))) + children))) + +;;; The Customize Commands + +;;;###autoload +(defun customize (symbol) + "Customize SYMBOL, which must be a customization group." + (interactive (list (completing-read "Customize group: (default emacs) " + obarray + (lambda (symbol) + (get symbol 'custom-group)) + t))) + + (when (stringp symbol) + (if (string-equal "" symbol) + (setq symbol 'emacs) + (setq symbol (intern symbol)))) + (custom-buffer-create (list (list symbol 'custom-group)))) + +;;;###autoload +(defun customize-variable (symbol) + "Customize SYMBOL, which must be a variable." + (interactive + ;; Code stolen from `help.el'. + (let ((v (variable-at-point)) + (enable-recursive-minibuffers t) + val) + (setq val (completing-read + (if v + (format "Customize variable (default %s): " v) + "Customize variable: ") + obarray 'boundp t)) + (list (if (equal val "") + v (intern val))))) + (custom-buffer-create (list (list symbol 'custom-variable)))) + +;;;###autoload +(defun customize-face (symbol) + "Customize FACE." + (interactive (list (completing-read "Customize face: " + obarray 'custom-facep))) + (if (stringp symbol) + (setq symbol (intern symbol))) + (unless (symbolp symbol) + (error "Should be a symbol %S" symbol)) + (custom-buffer-create (list (list symbol 'custom-face)))) + +;;;###autoload +(defun customize-customized () + "Customize all already customized user options." + (interactive) + (let ((found nil)) + (mapatoms (lambda (symbol) + (and (get symbol 'saved-face) + (custom-facep symbol) + (setq found (cons (list symbol 'custom-face) found))) + (and (get symbol 'saved-value) + (boundp symbol) + (setq found + (cons (list symbol 'custom-variable) found))))) + (if found + (custom-buffer-create found) + (error "No customized user options")))) + +;;;###autoload +(defun customize-apropos (regexp &optional all) + "Customize all user options matching REGEXP. +If ALL (e.g., started with a prefix key), include options which are not +user-settable." + (interactive "sCustomize regexp: \nP") + (let ((found nil)) + (mapatoms (lambda (symbol) + (when (string-match regexp (symbol-name symbol)) + (when (get symbol 'custom-group) + (setq found (cons (list symbol 'custom-group) found))) + (when (custom-facep symbol) + (setq found (cons (list symbol 'custom-face) found))) + (when (and (boundp symbol) + (or (get symbol 'saved-value) + (get symbol 'factory-value) + (if all + (get symbol 'variable-documentation) + (user-variable-p symbol)))) + (setq found + (cons (list symbol 'custom-variable) found)))))) + (if found + (custom-buffer-create found) + (error "No matches")))) + +;;;###autoload +(defun custom-buffer-create (options) + "Create a buffer containing OPTIONS. +OPTIONS should be an alist of the form ((SYMBOL WIDGET)...), where +SYMBOL is a customization option, and WIDGET is a widget for editing +that option." + (kill-buffer (get-buffer-create "*Customization*")) + (switch-to-buffer (get-buffer-create "*Customization*")) + (custom-mode) + (widget-insert "This is a customization buffer. +Push RET or click mouse-2 on the word ") + (widget-create 'info-link + :tag "help" + :help-echo "Push me for help." + "(custom)The Customization Buffer") + (widget-insert " for more information.\n\n") + (setq custom-options + (mapcar (lambda (entry) + (prog1 + (if (> (length options) 1) + (widget-create (nth 1 entry) + :tag (custom-unlispify-tag-name + (nth 0 entry)) + :value (nth 0 entry)) + ;; If there is only one entry, don't hide it! + (widget-create (nth 1 entry) + :custom-state 'unknown + :tag (custom-unlispify-tag-name + (nth 0 entry)) + :value (nth 0 entry))) + (unless (eq (preceding-char) ?\n) + (widget-insert "\n")) + (widget-insert "\n"))) + options)) + (mapcar 'custom-magic-reset custom-options) + (widget-create 'push-button + :tag "Set" + :help-echo "Push me to set all modifications." + :action (lambda (widget &optional event) + (custom-set))) + (widget-insert " ") + (widget-create 'push-button + :tag "Save" + :help-echo "Push me to make the modifications default." + :action (lambda (widget &optional event) + (custom-save))) + (widget-insert " ") + (widget-create 'push-button + :tag "Reset" + :help-echo "Push me to undo all modifications.." + :action (lambda (widget &optional event) + (custom-reset event))) + (widget-insert "\n") + (widget-setup)) + +;;; Modification of Basic Widgets. +;; +;; We add extra properties to the basic widgets needed here. This is +;; fine, as long as we are careful to stay within out own namespace. +;; +;; We want simple widgets to be displayed by default, but complex +;; widgets to be hidden. + +(widget-put (get 'item 'widget-type) :custom-show t) +(widget-put (get 'editable-field 'widget-type) + :custom-show (lambda (widget value) + (let ((pp (pp-to-string value))) + (cond ((string-match "\n" pp) + nil) + ((> (length pp) 40) + nil) + (t t))))) +(widget-put (get 'menu-choice 'widget-type) :custom-show t) + +;;; The `custom-manual' Widget. + +(define-widget 'custom-manual 'info-link + "Link to the manual entry for this customization option." + :help-echo "Push me to read the manual." + :tag "Manual") + +;;; The `custom-magic' Widget. + +(defface custom-invalid-face '((((class color)) + (:foreground "yellow" :background "red")) + (t + (:bold t :italic t :underline t))) + "Face used when the customize item is invalid.") + +(defface custom-rogue-face '((((class color)) + (:foreground "pink" :background "black")) + (t + (:underline t))) + "Face used when the customize item is not defined for customization.") + +(defface custom-modified-face '((((class color)) + (:foreground "white" :background "blue")) + (t + (:italic t :bold))) + "Face used when the customize item has been modified.") + +(defface custom-set-face '((((class color)) + (:foreground "blue" :background "white")) + (t + (:italic t))) + "Face used when the customize item has been set.") + +(defface custom-changed-face '((((class color)) + (:foreground "white" :background "blue")) + (t + (:italic t))) + "Face used when the customize item has been changed.") + +(defface custom-saved-face '((t (:underline t))) + "Face used when the customize item has been saved.") + +(defcustom custom-magic-alist '((nil "#" underline "\ +uninitialized, you should not see this.") + (unknown "?" italic "\ +unknown, you should not see this.") + (hidden "-" default "\ +hidden, press the state button to show.") + (invalid "x" custom-invalid-face "\ +the value displayed for this item is invalid and cannot be set.") + (modified "*" custom-modified-face "\ +you have edited the item, and can now set it.") + (set "+" custom-set-face "\ +you have set this item, but not saved it.") + (changed ":" custom-changed-face "\ +this item has been changed outside customize.") + (saved "!" custom-saved-face "\ +this item has been saved.") + (rogue "@" custom-rogue-face "\ +this item is not prepared for customization.") + (factory " " nil "\ +this item is unchanged from its factory setting.")) + "Alist of customize option states. +Each entry is of the form (STATE MAGIC FACE DESCRIPTION), where + +STATE is one of the following symbols: + +`nil' + For internal use, should never occur. +`unknown' + For internal use, should never occur. +`hidden' + This item is not being displayed. +`invalid' + This item is modified, but has an invalid form. +`modified' + This item is modified, and has a valid form. +`set' + This item has been set but not saved. +`changed' + The current value of this item has been changed temporarily. +`saved' + This item is marked for saving. +`rogue' + This item has no customization information. +`factory' + This item is unchanged from the factory default. + +MAGIC is a string used to present that state. + +FACE is a face used to present the state. + +DESCRIPTION is a string describing the state. + +The list should be sorted most significant first." + :type '(list (checklist :inline t + (group (const nil) + (string :tag "Magic") + face + (string :tag "Description")) + (group (const unknown) + (string :tag "Magic") + face + (string :tag "Description")) + (group (const hidden) + (string :tag "Magic") + face + (string :tag "Description")) + (group (const invalid) + (string :tag "Magic") + face + (string :tag "Description")) + (group (const modified) + (string :tag "Magic") + face + (string :tag "Description")) + (group (const set) + (string :tag "Magic") + face + (string :tag "Description")) + (group (const changed) + (string :tag "Magic") + face + (string :tag "Description")) + (group (const saved) + (string :tag "Magic") + face + (string :tag "Description")) + (group (const rogue) + (string :tag "Magic") + face + (string :tag "Description")) + (group (const factory) + (string :tag "Magic") + face + (string :tag "Description"))) + (editable-list :inline t + (group symbol + (string :tag "Magic") + face + (string :tag "Description")))) + :group 'customize) + +(defcustom custom-magic-show 'long + "Show long description of the state of each customization option." + :type '(choice (const :tag "no" nil) + (const short) + (const long)) + :group 'customize) + +(defcustom custom-magic-show-button t + "Show a magic button indicating the state of each customization option." + :type 'boolean + :group 'customize) + +(define-widget 'custom-magic 'default + "Show and manipulate state for a customization option." + :format "%v" + :action 'widget-choice-item-action + :value-get 'ignore + :value-create 'custom-magic-value-create + :value-delete 'widget-children-value-delete) + +(defun custom-magic-value-create (widget) + ;; Create compact status report for WIDGET. + (let* ((parent (widget-get widget :parent)) + (state (widget-get parent :custom-state)) + (entry (assq state custom-magic-alist)) + (magic (nth 1 entry)) + (face (nth 2 entry)) + (text (nth 3 entry)) + (lisp (eq (widget-get parent :custom-form) 'lisp)) + children) + (when custom-magic-show + (push (widget-create-child-and-convert widget 'choice-item + :help-echo "\ +Push me to change the state of this item." + :format "%[%t%]" + :tag "State") + children) + (insert ": ") + (if (eq custom-magic-show 'long) + (insert text) + (insert (symbol-name state))) + (when lisp + (insert " (lisp)")) + (insert "\n")) + (when custom-magic-show-button + (when custom-magic-show + (let ((indent (widget-get parent :indent))) + (when indent + (insert-char ? indent)))) + (push (widget-create-child-and-convert widget 'choice-item + :button-face face + :help-echo "\ +Push me to change the state." + :format "%[%t%]" + :tag (if lisp + (concat "(" magic ")") + (concat "[" magic "]"))) + children) + (insert " ")) + (widget-put widget :children children))) + +(defun custom-magic-reset (widget) + "Redraw the :custom-magic property of WIDGET." + (let ((magic (widget-get widget :custom-magic))) + (widget-value-set magic (widget-value magic)))) + +;;; The `custom-level' Widget. + +(define-widget 'custom-level 'item + "The custom level buttons." + :format "%[%t%]" + :help-echo "Push me to expand or collapse this item." + :action 'custom-level-action) + +(defun custom-level-action (widget &optional event) + "Toggle visibility for parent to WIDGET." + (let* ((parent (widget-get widget :parent)) + (state (widget-get parent :custom-state))) + (cond ((memq state '(invalid modified)) + (error "There are unset changes")) + ((eq state 'hidden) + (widget-put parent :custom-state 'unknown)) + (t + (widget-put parent :custom-state 'hidden))) + (custom-redraw parent))) + +;;; The `custom' Widget. + +(define-widget 'custom 'default + "Customize a user option." + :convert-widget 'custom-convert-widget + :format "%l%[%t%]: %v%m%h%a" + :format-handler 'custom-format-handler + :notify 'custom-notify + :custom-level 1 + :custom-state 'hidden + :documentation-property 'widget-subclass-responsibility + :value-create 'widget-subclass-responsibility + :value-delete 'widget-children-value-delete + :value-get 'widget-item-value-get + :validate 'widget-editable-list-validate + :match (lambda (widget value) (symbolp value))) + +(defun custom-convert-widget (widget) + ;; Initialize :value and :tag from :args in WIDGET. + (let ((args (widget-get widget :args))) + (when args + (widget-put widget :value (widget-apply widget + :value-to-internal (car args))) + (widget-put widget :tag (custom-unlispify-tag-name (car args))) + (widget-put widget :args nil))) + widget) + +(defun custom-format-handler (widget escape) + ;; We recognize extra escape sequences. + (let* ((buttons (widget-get widget :buttons)) + (state (widget-get widget :custom-state)) + (level (widget-get widget :custom-level))) + (cond ((eq escape ?l) + (when level + (push (widget-create-child-and-convert + widget 'custom-level (make-string level ?*)) + buttons) + (widget-insert " ") + (widget-put widget :buttons buttons))) + ((eq escape ?L) + (when (eq state 'hidden) + (widget-insert " ..."))) + ((eq escape ?m) + (and (eq (preceding-char) ?\n) + (widget-get widget :indent) + (insert-char ? (widget-get widget :indent))) + (let ((magic (widget-create-child-and-convert + widget 'custom-magic nil))) + (widget-put widget :custom-magic magic) + (push magic buttons) + (widget-put widget :buttons buttons))) + ((eq escape ?a) + (let* ((symbol (widget-get widget :value)) + (links (get symbol 'custom-links)) + (many (> (length links) 2))) + (when links + (and (eq (preceding-char) ?\n) + (widget-get widget :indent) + (insert-char ? (widget-get widget :indent))) + (insert "See also ") + (while links + (push (widget-create-child-and-convert widget (car links)) + buttons) + (setq links (cdr links)) + (cond ((null links) + (insert ".\n")) + ((null (cdr links)) + (if many + (insert ", and ") + (insert " and "))) + (t + (insert ", ")))) + (widget-put widget :buttons buttons)))) + (t + (widget-default-format-handler widget escape))))) + +(defun custom-notify (widget &rest args) + "Keep track of changes." + (widget-put widget :custom-state 'modified) + (let ((buffer-undo-list t)) + (custom-magic-reset widget)) + (apply 'widget-default-notify widget args)) + +(defun custom-redraw (widget) + "Redraw WIDGET with current settings." + (widget-value-set widget (widget-value widget)) + (custom-redraw-magic widget)) + +(defun custom-redraw-magic (widget) + "Redraw WIDGET state with current settings." + (while widget + (let ((magic (widget-get widget :custom-magic))) + (unless magic + (debug)) + (widget-value-set magic (widget-value magic)) + (when (setq widget (widget-get widget :group)) + (custom-group-state-update widget)))) + (widget-setup)) + +(defun custom-show (widget value) + "Non-nil if WIDGET should be shown with VALUE by default." + (let ((show (widget-get widget :custom-show))) + (cond ((null show) + nil) + ((eq t show) + t) + (t + (funcall show widget value))))) + +(defun custom-load-symbol (symbol) + "Load all dependencies for SYMBOL." + (let ((loads (get symbol 'custom-loads)) + load) + (while loads + (setq load (car loads) + loads (cdr loads)) + (cond ((symbolp load) + (condition-case nil + (require load) + (error nil))) + ((assoc load load-history)) + (t + (condition-case nil + (load-library load) + (error nil))))))) + +(defun custom-load-widget (widget) + "Load all dependencies for WIDGET." + (custom-load-symbol (widget-value widget))) + +;;; The `custom-variable' Widget. + +(defface custom-variable-sample-face '((t (:underline t))) + "Face used for unpushable variable tags." + :group 'customize) + +(defface custom-variable-button-face '((t (:underline t :bold t))) + "Face used for pushable variable tags." + :group 'customize) + +(define-widget 'custom-variable 'custom + "Customize variable." + :format "%l%v%m%h%a" + :help-echo "Push me to set or reset this variable." + :documentation-property 'variable-documentation + :custom-state nil + :custom-menu 'custom-variable-menu-create + :custom-form 'edit + :value-create 'custom-variable-value-create + :action 'custom-variable-action + :custom-set 'custom-variable-set + :custom-save 'custom-variable-save + :custom-reset-current 'custom-redraw + :custom-reset-saved 'custom-variable-reset-saved + :custom-reset-factory 'custom-variable-reset-factory) + +(defun custom-variable-value-create (widget) + "Here is where you edit the variables value." + (custom-load-widget widget) + (let* ((buttons (widget-get widget :buttons)) + (children (widget-get widget :children)) + (form (widget-get widget :custom-form)) + (state (widget-get widget :custom-state)) + (symbol (widget-get widget :value)) + (options (get symbol 'custom-options)) + (child-type (or (get symbol 'custom-type) 'sexp)) + (tag (widget-get widget :tag)) + (type (let ((tmp (if (listp child-type) + (copy-list child-type) + (list child-type)))) + (when options + (widget-put tmp :options options)) + tmp)) + (conv (widget-convert type)) + (value (if (default-boundp symbol) + (default-value symbol) + (widget-get conv :value)))) + ;; If the widget is new, the child determine whether it is hidden. + (cond (state) + ((custom-show type value) + (setq state 'unknown)) + (t + (setq state 'hidden))) + ;; If we don't know the state, see if we need to edit it in lisp form. + (when (eq state 'unknown) + (unless (widget-apply conv :match value) + ;; (widget-apply (widget-convert type) :match value) + (setq form 'lisp))) + ;; Now we can create the child widget. + (cond ((eq state 'hidden) + ;; Indicate hidden value. + (push (widget-create-child-and-convert + widget 'item + :format "%{%t%}: ..." + :sample-face 'custom-variable-sample-face + :tag tag + :parent widget) + children)) + ((eq form 'lisp) + ;; In lisp mode edit the saved value when possible. + (let* ((value (cond ((get symbol 'saved-value) + (car (get symbol 'saved-value))) + ((get symbol 'factory-value) + (car (get symbol 'factory-value))) + ((default-boundp symbol) + (custom-quote (default-value symbol))) + (t + (custom-quote (widget-get conv :value)))))) + (push (widget-create-child-and-convert + widget 'sexp + :button-face 'custom-variable-button-face + :tag (symbol-name symbol) + :parent widget + :value value) + children))) + (t + ;; Edit mode. + (push (widget-create-child-and-convert + widget type + :tag tag + :button-face 'custom-variable-button-face + :sample-face 'custom-variable-sample-face + :value value) + children))) + ;; Now update the state. + (unless (eq (preceding-char) ?\n) + (widget-insert "\n")) + (if (eq state 'hidden) + (widget-put widget :custom-state state) + (custom-variable-state-set widget)) + (widget-put widget :custom-form form) + (widget-put widget :buttons buttons) + (widget-put widget :children children))) + +(defun custom-variable-state-set (widget) + "Set the state of WIDGET." + (let* ((symbol (widget-value widget)) + (value (if (default-boundp symbol) + (default-value symbol) + (widget-get widget :value))) + tmp + (state (cond ((setq tmp (get symbol 'customized-value)) + (if (condition-case nil + (equal value (eval (car tmp))) + (error nil)) + 'saved + 'set)) + ((setq tmp (get symbol 'saved-value)) + (if (condition-case nil + (equal value (eval (car tmp))) + (error nil)) + 'saved + 'set)) + ((setq tmp (get symbol 'factory-value)) + (if (condition-case nil + (equal value (eval (car tmp))) + (error nil)) + 'factory + 'set)) + (t 'rogue)))) + (widget-put widget :custom-state state))) + +(defvar custom-variable-menu + '(("Edit" . custom-variable-edit) + ("Edit Lisp" . custom-variable-edit-lisp) + ("Set" . custom-variable-set) + ("Save" . custom-variable-save) + ("Reset to Current" . custom-redraw) + ("Reset to Saved" . custom-variable-reset-saved) + ("Reset to Factory Settings" . custom-variable-reset-factory)) + "Alist of actions for the `custom-variable' widget. +The key is a string containing the name of the action, the value is a +lisp function taking the widget as an element which will be called +when the action is chosen.") + +(defun custom-variable-action (widget &optional event) + "Show the menu for `custom-variable' WIDGET. +Optional EVENT is the location for the menu." + (if (eq (widget-get widget :custom-state) 'hidden) + (progn + (widget-put widget :custom-state 'unknown) + (custom-redraw widget)) + (let* ((completion-ignore-case t) + (answer (widget-choose (symbol-name (widget-get widget :value)) + custom-variable-menu + event))) + (if answer + (funcall answer widget))))) + +(defun custom-variable-edit (widget) + "Edit value of WIDGET." + (widget-put widget :custom-state 'unknown) + (widget-put widget :custom-form 'edit) + (custom-redraw widget)) + +(defun custom-variable-edit-lisp (widget) + "Edit the lisp representation of the value of WIDGET." + (widget-put widget :custom-state 'unknown) + (widget-put widget :custom-form 'lisp) + (custom-redraw widget)) + +(defun custom-variable-set (widget) + "Set the current value for the variable being edited by WIDGET." + (let ((form (widget-get widget :custom-form)) + (state (widget-get widget :custom-state)) + (child (car (widget-get widget :children))) + (symbol (widget-value widget)) + val) + (cond ((eq state 'hidden) + (error "Cannot set hidden variable.")) + ((setq val (widget-apply child :validate)) + (error "Invalid %S" val)) + ((eq form 'lisp) + (set symbol (eval (setq val (widget-value child)))) + (put symbol 'customized-value (list val))) + (t + (set symbol (widget-value child)) + (put symbol 'customized-value (list (custom-quote val))))) + (custom-variable-state-set widget) + (custom-redraw-magic widget))) + +(defun custom-variable-save (widget) + "Set the default value for the variable being edited by WIDGET." + (let ((form (widget-get widget :custom-form)) + (state (widget-get widget :custom-state)) + (child (car (widget-get widget :children))) + (symbol (widget-value widget)) + val) + (cond ((eq state 'hidden) + (error "Cannot set hidden variable.")) + ((setq val (widget-apply child :validate)) + (error "Invalid %S" val)) + ((eq form 'lisp) + (put symbol 'saved-value (list (widget-value child))) + (set symbol (eval (widget-value child)))) + (t + (put symbol + 'saved-value (list (custom-quote (widget-value + child)))) + (set symbol (widget-value child)))) + (put symbol 'customized-value nil) + (custom-save-all) + (custom-variable-state-set widget) + (custom-redraw-magic widget))) + +(defun custom-variable-reset-saved (widget) + "Restore the saved value for the variable being edited by WIDGET." + (let ((symbol (widget-value widget))) + (if (get symbol 'saved-value) + (condition-case nil + (set symbol (eval (car (get symbol 'saved-value)))) + (error nil)) + (error "No saved value for %s" symbol)) + (put symbol 'customized-value nil) + (widget-put widget :custom-state 'unknown) + (custom-redraw widget))) + +(defun custom-variable-reset-factory (widget) + "Restore the factory setting for the variable being edited by WIDGET." + (let ((symbol (widget-value widget))) + (if (get symbol 'factory-value) + (set symbol (eval (car (get symbol 'factory-value)))) + (error "No factory default for %S" symbol)) + (put symbol 'customized-value nil) + (when (get symbol 'saved-value) + (put symbol 'saved-value nil) + (custom-save-all)) + (widget-put widget :custom-state 'unknown) + (custom-redraw widget))) + +;;; The `custom-face-edit' Widget. + +(defvar custom-face-edit-args + (mapcar (lambda (att) + (list 'group + :inline t + (list 'const :format "" :value (nth 0 att)) + (nth 1 att))) + custom-face-attributes)) + +(define-widget 'custom-face-edit 'checklist + "Edit face attributes." + :format "%t: %v" + :tag "Attributes" + :extra-offset 12 + :args (mapcar (lambda (att) + (list 'group + :inline t + (list 'const :format "" :value (nth 0 att)) + (nth 1 att))) + custom-face-attributes)) + +;;; The `custom-display' Widget. + +(define-widget 'custom-display 'menu-choice + "Select a display type." + :tag "Display" + :value t + :args '((const :tag "all" t) + (checklist :offset 0 + :extra-offset 9 + :args ((group (const :format "Type: " type) + (checklist :inline t + :offset 0 + (const :format "X " + x) + (const :format "PM " + pm) + (const :format "Win32 " + win32) + (const :format "DOS " + pc) + (const :format "TTY%n" + tty))) + (group (const :format "Class: " class) + (checklist :inline t + :offset 0 + (const :format "Color " + color) + (const :format + "Grayscale " + grayscale) + (const :format "Monochrome%n" + mono))) + (group (const :format "Background: " background) + (checklist :inline t + :offset 0 + (const :format "Light " + light) + (const :format "Dark\n" + dark))))))) + +;;; The `custom-face' Widget. + +(defface custom-face-tag-face '((t (:underline t))) + "Face used for face tags." + :group 'customize) + +(define-widget 'custom-face 'custom + "Customize face." + :format "%l%{%t%}: %s%m%h%a%v" + :format-handler 'custom-face-format-handler + :sample-face 'custom-face-tag-face + :help-echo "Push me to set or reset this face." + :documentation-property 'face-documentation + :value-create 'custom-face-value-create + :action 'custom-face-action + :custom-set 'custom-face-set + :custom-save 'custom-face-save + :custom-reset-current 'custom-redraw + :custom-reset-saved 'custom-face-reset-saved + :custom-reset-factory 'custom-face-reset-factory + :custom-menu 'custom-face-menu-create) + +(defun custom-face-format-handler (widget escape) + ;; We recognize extra escape sequences. + (let (child + (state (widget-get widget :custom-state)) + (symbol (widget-get widget :value))) + (cond ((eq escape ?s) + (and (string-match "XEmacs" emacs-version) + ;; XEmacs cannot display initialized faces. + (not (custom-facep symbol)) + (copy-face 'custom-face-empty symbol)) + (setq child (widget-create-child-and-convert + widget 'item + :format "(%{%t%})\n" + :sample-face symbol + :tag "sample"))) + (t + (custom-format-handler widget escape))) + (when child + (widget-put widget + :buttons (cons child (widget-get widget :buttons)))))) + +(defun custom-face-value-create (widget) + ;; Create a list of the display specifications. + (unless (eq (preceding-char) ?\n) + (insert "\n")) + (when (not (eq (widget-get widget :custom-state) 'hidden)) + (custom-load-widget widget) + (let* ((symbol (widget-value widget)) + (edit (widget-create-child-and-convert + widget 'editable-list + :entry-format "%i %d %v" + :value (or (get symbol 'saved-face) + (get symbol 'factory-face)) + '(group :format "%v" + custom-display custom-face-edit)))) + (custom-face-state-set widget) + (widget-put widget :children (list edit))))) + +(defvar custom-face-menu + '(("Set" . custom-face-set) + ("Save" . custom-face-save) + ("Reset to Saved" . custom-face-reset-saved) + ("Reset to Factory Setting" . custom-face-reset-factory)) + "Alist of actions for the `custom-face' widget. +The key is a string containing the name of the action, the value is a +lisp function taking the widget as an element which will be called +when the action is chosen.") + +(defun custom-face-state-set (widget) + "Set the state of WIDGET." + (let ((symbol (widget-value widget))) + (widget-put widget :custom-state (cond ((get symbol 'customized-face) + 'set) + ((get symbol 'saved-face) + 'saved) + ((get symbol 'factory-face) + 'factory) + (t + 'rogue))))) + +(defun custom-face-action (widget &optional event) + "Show the menu for `custom-face' WIDGET. +Optional EVENT is the location for the menu." + (if (eq (widget-get widget :custom-state) 'hidden) + (progn + (widget-put widget :custom-state 'unknown) + (custom-redraw widget)) + (let* ((completion-ignore-case t) + (symbol (widget-get widget :value)) + (answer (widget-choose (symbol-name symbol) + custom-face-menu event))) + (if answer + (funcall answer widget))))) + +(defun custom-face-set (widget) + "Make the face attributes in WIDGET take effect." + (let* ((symbol (widget-value widget)) + (child (car (widget-get widget :children))) + (value (widget-value child))) + (put symbol 'customized-face value) + (custom-face-display-set symbol value) + (custom-face-state-set widget) + (custom-redraw-magic widget))) + +(defun custom-face-save (widget) + "Make the face attributes in WIDGET default." + (let* ((symbol (widget-value widget)) + (child (car (widget-get widget :children))) + (value (widget-value child))) + (custom-face-display-set symbol value) + (put symbol 'saved-face value) + (put symbol 'customized-face nil) + (custom-face-state-set widget) + (custom-redraw-magic widget))) + +(defun custom-face-reset-saved (widget) + "Restore WIDGET to the face's default attributes." + (let* ((symbol (widget-value widget)) + (child (car (widget-get widget :children))) + (value (get symbol 'saved-face))) + (unless value + (error "No saved value for this face")) + (put symbol 'customized-face nil) + (custom-face-display-set symbol value) + (widget-value-set child value) + (custom-face-state-set widget) + (custom-redraw-magic widget))) + +(defun custom-face-reset-factory (widget) + "Restore WIDGET to the face's factory settings." + (let* ((symbol (widget-value widget)) + (child (car (widget-get widget :children))) + (value (get symbol 'factory-face))) + (unless value + (error "No factory default for this face")) + (put symbol 'customized-face nil) + (when (get symbol 'saved-face) + (put symbol 'saved-face nil) + (custom-save-all)) + (custom-face-display-set symbol value) + (widget-value-set child value) + (custom-face-state-set widget) + (custom-redraw-magic widget))) + +;;; The `face' Widget. + +(define-widget 'face 'default + "Select and customize a face." + :convert-widget 'widget-item-convert-widget + :format "%[%t%]: %v" + :tag "Face" + :value 'default + :value-create 'widget-face-value-create + :value-delete 'widget-face-value-delete + :value-get 'widget-item-value-get + :validate 'widget-editable-list-validate + :action 'widget-face-action + :match '(lambda (widget value) (symbolp value))) + +(defun widget-face-value-create (widget) + ;; Create a `custom-face' child. + (let* ((symbol (widget-value widget)) + (child (widget-create-child-and-convert + widget 'custom-face + :format "%t %s%m%h%v" + :custom-level nil + :value symbol))) + (custom-magic-reset child) + (setq custom-options (cons child custom-options)) + (widget-put widget :children (list child)))) + +(defun widget-face-value-delete (widget) + ;; Remove the child from the options. + (let ((child (car (widget-get widget :children)))) + (setq custom-options (delq child custom-options)) + (widget-children-value-delete widget))) + +(defvar face-history nil + "History of entered face names.") + +(defun widget-face-action (widget &optional event) + "Prompt for a face." + (let ((answer (completing-read "Face: " + (mapcar (lambda (face) + (list (symbol-name face))) + (face-list)) + nil nil nil + 'face-history))) + (unless (zerop (length answer)) + (widget-value-set widget (intern answer)) + (widget-apply widget :notify widget event) + (widget-setup)))) + +;;; The `hook' Widget. + +(define-widget 'hook 'list + "A emacs lisp hook" + :convert-widget 'custom-hook-convert-widget + :tag "Hook") + +(defun custom-hook-convert-widget (widget) + ;; Handle `:custom-options'. + (let* ((options (widget-get widget :options)) + (other `(editable-list :inline t + :entry-format "%i %d%v" + (function :format " %v"))) + (args (if options + (list `(checklist :inline t + ,@(mapcar (lambda (entry) + `(function-item ,entry)) + options)) + other) + (list other)))) + (widget-put widget :args args) + widget)) + +;;; The `custom-group' Widget. + +(defcustom custom-group-tag-faces '(custom-group-tag-face-1) + ;; In XEmacs, this ought to play games with font size. + "Face used for group tags. +The first member is used for level 1 groups, the second for level 2, +and so forth. The remaining group tags are shown with +`custom-group-tag-face'." + :type '(repeat face) + :group 'customize) + +(defface custom-group-tag-face-1 '((((class color) + (background dark)) + (:foreground "pink" :underline t)) + (((class color) + (background light)) + (:foreground "red" :underline t)) + (t (:underline t))) + "Face used for group tags.") + +(defface custom-group-tag-face '((((class color) + (background dark)) + (:foreground "light blue" :underline t)) + (((class color) + (background light)) + (:foreground "blue" :underline t)) + (t (:underline t))) + "Face used for low level group tags." + :group 'customize) + +(define-widget 'custom-group 'custom + "Customize group." + :format "%l%{%t%}:%L\n%m%h%a%v" + :sample-face-get 'custom-group-sample-face-get + :documentation-property 'group-documentation + :help-echo "Push me to set or reset all members of this group." + :value-create 'custom-group-value-create + :action 'custom-group-action + :custom-set 'custom-group-set + :custom-save 'custom-group-save + :custom-reset-current 'custom-group-reset-current + :custom-reset-saved 'custom-group-reset-saved + :custom-reset-factory 'custom-group-reset-factory + :custom-menu 'custom-group-menu-create) + +(defun custom-group-sample-face-get (widget) + ;; Use :sample-face. + (or (nth (1- (widget-get widget :custom-level)) custom-group-tag-faces) + 'custom-group-tag-face)) + +(defun custom-group-value-create (widget) + (let ((state (widget-get widget :custom-state))) + (unless (eq state 'hidden) + (custom-load-widget widget) + (let* ((level (widget-get widget :custom-level)) + (symbol (widget-value widget)) + (members (get symbol 'custom-group)) + (prefixes (widget-get widget :custom-prefixes)) + (custom-prefix-list (custom-prefix-add symbol prefixes)) + (children (mapcar (lambda (entry) + (widget-insert "\n") + (prog1 + (widget-create-child-and-convert + widget (nth 1 entry) + :group widget + :tag (custom-unlispify-tag-name + (nth 0 entry)) + :custom-prefixes custom-prefix-list + :custom-level (1+ level) + :value (nth 0 entry)) + (unless (eq (preceding-char) ?\n) + (widget-insert "\n")))) + members))) + (mapcar 'custom-magic-reset children) + (widget-put widget :children children) + (custom-group-state-update widget))))) + +(defvar custom-group-menu + '(("Set" . custom-group-set) + ("Save" . custom-group-save) + ("Reset to Current" . custom-group-reset-current) + ("Reset to Saved" . custom-group-reset-saved) + ("Reset to Factory" . custom-group-reset-factory)) + "Alist of actions for the `custom-group' widget. +The key is a string containing the name of the action, the value is a +lisp function taking the widget as an element which will be called +when the action is chosen.") + +(defun custom-group-action (widget &optional event) + "Show the menu for `custom-group' WIDGET. +Optional EVENT is the location for the menu." + (if (eq (widget-get widget :custom-state) 'hidden) + (progn + (widget-put widget :custom-state 'unknown) + (custom-redraw widget)) + (let* ((completion-ignore-case t) + (answer (widget-choose (symbol-name (widget-get widget :value)) + custom-group-menu + event))) + (if answer + (funcall answer widget))))) + +(defun custom-group-set (widget) + "Set changes in all modified group members." + (let ((children (widget-get widget :children))) + (mapcar (lambda (child) + (when (eq (widget-get child :custom-state) 'modified) + (widget-apply child :custom-set))) + children ))) + +(defun custom-group-save (widget) + "Save all modified group members." + (let ((children (widget-get widget :children))) + (mapcar (lambda (child) + (when (memq (widget-get child :custom-state) '(modified set)) + (widget-apply child :custom-save))) + children ))) + +(defun custom-group-reset-current (widget) + "Reset all modified group members." + (let ((children (widget-get widget :children))) + (mapcar (lambda (child) + (when (eq (widget-get child :custom-state) 'modified) + (widget-apply child :custom-reset-current))) + children ))) + +(defun custom-group-reset-saved (widget) + "Reset all modified or set group members." + (let ((children (widget-get widget :children))) + (mapcar (lambda (child) + (when (memq (widget-get child :custom-state) '(modified set)) + (widget-apply child :custom-reset-saved))) + children ))) + +(defun custom-group-reset-factory (widget) + "Reset all modified, set, or saved group members." + (let ((children (widget-get widget :children))) + (mapcar (lambda (child) + (when (memq (widget-get child :custom-state) + '(modified set saved)) + (widget-apply child :custom-reset-factory))) + children ))) + +(defun custom-group-state-update (widget) + "Update magic." + (unless (eq (widget-get widget :custom-state) 'hidden) + (let* ((children (widget-get widget :children)) + (states (mapcar (lambda (child) + (widget-get child :custom-state)) + children)) + (magics custom-magic-alist) + (found 'factory)) + (while magics + (let ((magic (car (car magics)))) + (if (and (not (eq magic 'hidden)) + (memq magic states)) + (setq found magic + magics nil) + (setq magics (cdr magics))))) + (widget-put widget :custom-state found))) + (custom-magic-reset widget)) + +;;; The `custom-save-all' Function. + +(defcustom custom-file "~/.emacs" + "File used for storing customization information. +If you change this from the default \"~/.emacs\" you need to +explicitly load that file for the settings to take effect." + :type 'file + :group 'customize) + +(defun custom-save-delete (symbol) + "Delete the call to SYMBOL form `custom-file'. +Leave point at the location of the call, or after the last expression." + (set-buffer (find-file-noselect custom-file)) + (goto-char (point-min)) + (catch 'found + (while t + (let ((sexp (condition-case nil + (read (current-buffer)) + (end-of-file (throw 'found nil))))) + (when (and (listp sexp) + (eq (car sexp) symbol)) + (delete-region (save-excursion + (backward-sexp) + (point)) + (point)) + (throw 'found nil)))))) + +(defun custom-save-variables () + "Save all customized variables in `custom-file'." + (save-excursion + (custom-save-delete 'custom-set-variables) + (let ((standard-output (current-buffer))) + (unless (bolp) + (princ "\n")) + (princ "(custom-set-variables") + (mapatoms (lambda (symbol) + (let ((value (get symbol 'saved-value))) + (when value + (princ "\n '(") + (princ symbol) + (princ " ") + (prin1 (car value)) + (if (or (get symbol 'factory-value) + (and (not (boundp symbol)) + (not (get symbol 'force-value)))) + (princ ")") + (princ " t)")))))) + (princ ")") + (unless (eolp) + (princ "\n"))))) + +(defun custom-save-faces () + "Save all customized faces in `custom-file'." + (save-excursion + (custom-save-delete 'custom-set-faces) + (let ((standard-output (current-buffer))) + (unless (bolp) + (princ "\n")) + (princ "(custom-set-faces") + (mapatoms (lambda (symbol) + (let ((value (get symbol 'saved-face))) + (when value + (princ "\n '(") + (princ symbol) + (princ " ") + (prin1 value) + (if (or (get symbol 'factory-face) + (and (not (custom-facep symbol)) + (not (get symbol 'force-face)))) + (princ ")") + (princ " t)")))))) + (princ ")") + (unless (eolp) + (princ "\n"))))) + +(defun custom-save-all () + "Save all customizations in `custom-file'." + (custom-save-variables) + (custom-save-faces) + (save-excursion + (set-buffer (find-file-noselect custom-file)) + (save-buffer))) + +;;; The Customize Menu. + +(defcustom custom-menu-nesting 2 + "Maximum nesting in custom menus." + :type 'integer + :group 'customize) + +(defun custom-face-menu-create (widget symbol) + "Ignoring WIDGET, create a menu entry for customization face SYMBOL." + (vector (custom-unlispify-menu-entry symbol) + `(custom-buffer-create '((,symbol custom-face))) + t)) + +(defun custom-variable-menu-create (widget symbol) + "Ignoring WIDGET, create a menu entry for customization variable SYMBOL." + (let ((type (get symbol 'custom-type))) + (unless (listp type) + (setq type (list type))) + (if (and type (widget-get type :custom-menu)) + (widget-apply type :custom-menu symbol) + (vector (custom-unlispify-menu-entry symbol) + `(custom-buffer-create '((,symbol custom-variable))) + t)))) + +(widget-put (get 'boolean 'widget-type) + :custom-menu (lambda (widget symbol) + (vector (custom-unlispify-menu-entry symbol) + `(custom-buffer-create + '((,symbol custom-variable))) + ':style 'toggle + ':selected symbol))) + +(defun custom-group-menu-create (widget symbol) + "Ignoring WIDGET, create a menu entry for customization group SYMBOL." + (custom-menu-create symbol)) + +(defun custom-menu-create (symbol &optional name) + "Create menu for customization group SYMBOL. +If optional NAME is given, use that as the name of the menu. +Otherwise make up a name from SYMBOL. +The menu is in a format applicable to `easy-menu-define'." + (unless name + (setq name (custom-unlispify-menu-entry symbol))) + (let ((item (vector name + `(custom-buffer-create '((,symbol custom-group))) + t))) + (if (and (> custom-menu-nesting 0) + (< (length (get symbol 'custom-group)) widget-menu-max-size)) + (let ((custom-menu-nesting (1- custom-menu-nesting)) + (custom-prefix-list (custom-prefix-add symbol + custom-prefix-list))) + (custom-load-symbol symbol) + `(,(custom-unlispify-menu-entry symbol t) + ,item + "--" + ,@(mapcar (lambda (entry) + (widget-apply (if (listp (nth 1 entry)) + (nth 1 entry) + (list (nth 1 entry))) + :custom-menu (nth 0 entry))) + (get symbol 'custom-group)))) + item))) + +;;;###autoload +(defun custom-menu-update () + "Update customize menu." + (interactive) + (add-hook 'custom-define-hook 'custom-menu-reset) + (let ((menu `(,(car custom-help-menu) + ,(widget-apply '(custom-group) :custom-menu 'emacs) + ,@(cdr (cdr custom-help-menu))))) + (if (fboundp 'add-submenu) + (add-submenu '("Help") menu) + (define-key global-map [menu-bar help-menu customize-menu] + (cons (car menu) (easy-menu-create-keymaps (car menu) (cdr menu))))))) + +;;; Dependencies. + +;;;###autoload +(defun custom-make-dependencies () + "Batch function to extract custom dependencies from .el files. +Usage: emacs -batch *.el -f custom-make-dependencies > deps.el" + (let ((buffers (buffer-list))) + (while buffers + (set-buffer (car buffers)) + (setq buffers (cdr buffers)) + (let ((file (buffer-file-name))) + (when (and file (string-match "\\`\\(.*\\)\\.el\\'" file)) + (goto-char (point-min)) + (condition-case nil + (let ((name (file-name-nondirectory (match-string 1 file)))) + (while t + (let ((expr (read (current-buffer)))) + (when (and (listp expr) + (memq (car expr) '(defcustom defface defgroup))) + (eval expr) + (put (nth 1 expr) 'custom-where name))))) + (error nil)))))) + (mapatoms (lambda (symbol) + (let ((members (get symbol 'custom-group)) + item where found) + (when members + (princ "(put '") + (princ symbol) + (princ " 'custom-loads '(") + (while members + (setq item (car (car members)) + members (cdr members) + where (get item 'custom-where)) + (unless (or (null where) + (member where found)) + (when found + (princ " ")) + (prin1 where) + (push where found))) + (princ "))\n")))))) + +;;; The End. + +(provide 'custom-edit) + +;; custom-edit.el ends here diff -r ad457d5f7d04 -r 0293115a14e9 lisp/gnus/custom-opt.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus/custom-opt.el Mon Aug 13 08:49:20 2007 +0200 @@ -0,0 +1,45 @@ +;;; custom-opt.el --- An option group. +;; +;; Copyright (C) 1996 Free Software Foundation, Inc. +;; +;; Author: Per Abrahamsen +;; Keywords: help, faces +;; Version: 1.20 +;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ + +;;; Code: + +(require 'custom) + +(defgroup options nil + "This group contains often used customization options." + :group 'emacs) + +(defvar custom-options + '((line-number-mode boolean) + (column-number-mode boolean) + (debug-on-error boolean) + (debug-on-quit boolean) + (case-fold-search boolean) + (case-replace boolean) + (transient-mark-mode boolean)) + "Alist of customization options. +The first element of each entry should be a variable name, the second +a widget type.") + +(let ((options custom-options) + option name type) + (while options + (setq option (car options) + options (cdr options) + name (nth 0 option) + type (nth 1 option)) + (put name 'custom-type type) + (custom-add-to-group 'options name 'custom-variable)) + (run-hooks 'custom-define-hook)) + +;;; The End. + +(provide 'custom-opt) + +;; custom-edit.el ends here diff -r ad457d5f7d04 -r 0293115a14e9 lisp/gnus/custom.el --- a/lisp/gnus/custom.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/gnus/custom.el Mon Aug 13 08:49:20 2007 +0200 @@ -1,2400 +1,584 @@ -;;; custom.el --- User friendly customization support. - -;; Copyright (C) 1995, 1996 Free Software Foundation, Inc. - -;; Author: Per Abrahamsen -;; Keywords: help -;; Version: 0.5 - -;; 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 2, or (at your option) -;; any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;;; custom.el -- Tools for declaring and initializing options. +;; +;; Copyright (C) 1996 Free Software Foundation, Inc. +;; +;; Author: Per Abrahamsen +;; Keywords: help, faces +;; Version: 1.20 +;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ ;;; Commentary: - -;; WARNING: This package is still under construction and not all of -;; the features below are implemented. ;; -;; This package provides a framework for adding user friendly -;; customization support to Emacs. Having to do customization by -;; editing a text file in some arcane syntax is user hostile in the -;; extreme, and to most users emacs lisp definitely count as arcane. -;; -;; The intent is that authors of emacs lisp packages declare the -;; variables intended for user customization with `custom-declare'. -;; Custom can then automatically generate a customization buffer with -;; `custom-buffer-create' where the user can edit the package -;; variables in a simple and intuitive way, as well as a menu with -;; `custom-menu-create' where he can set the more commonly used -;; variables interactively. -;; -;; It is also possible to use custom for modifying the properties of -;; other objects than the package itself, by specifying extra optional -;; arguments to `custom-buffer-create'. +;; If you want to use this code, please visit the URL above. ;; -;; Custom is inspired by OPEN LOOK property windows. - -;;; Todo: -;; -;; - Toggle documentation in three states `none', `one-line', `full'. -;; - Function to generate an XEmacs menu from a CUSTOM. -;; - Write TeXinfo documentation. -;; - Make it possible to hide sections by clicking at the level. -;; - Declare AUC TeX variables. -;; - Declare (ding) Gnus variables. -;; - Declare Emacs variables. -;; - Implement remaining types. -;; - XEmacs port. -;; - Allow `URL', `info', and internal hypertext buttons. -;; - Support meta-variables and goal directed customization. -;; - Make it easy to declare custom types independently. -;; - Make it possible to declare default value and type for a single -;; variable, storing the data in a symbol property. -;; - Syntactic sugar for CUSTOM declarations. -;; - Use W3 for variable documentation. +;; This file only contain the code needed to declare and initialize +;; user options. The code to customize options is autoloaded from +;; `custom-edit.el'. ;;; Code: -(eval-when-compile - (require 'cl)) - -;;; Compatibility: - -(defun custom-xmas-add-text-properties (start end props &optional object) - (add-text-properties start end props object) - (put-text-property start end 'start-open t object) - (put-text-property start end 'end-open t object)) - -(defun custom-xmas-put-text-property (start end prop value &optional object) - (put-text-property start end prop value object) - (put-text-property start end 'start-open t object) - (put-text-property start end 'end-open t object)) +(require 'widget) -(defun custom-xmas-extent-start-open () - (map-extents (lambda (extent arg) - (set-extent-property extent 'start-open t)) - nil (point) (min (1+ (point)) (point-max)))) - -(if (string-match "XEmacs\\|Lucid" emacs-version) - (progn - (fset 'custom-add-text-properties 'custom-xmas-add-text-properties) - (fset 'custom-put-text-property 'custom-xmas-put-text-property) - (fset 'custom-extent-start-open 'custom-xmas-extent-start-open) - (fset 'custom-set-text-properties - (if (fboundp 'set-text-properties) - 'set-text-properties)) - (fset 'custom-buffer-substring-no-properties - (if (fboundp 'buffer-substring-no-properties) - 'buffer-substring-no-properties - 'custom-xmas-buffer-substring-no-properties))) - (fset 'custom-add-text-properties 'add-text-properties) - (fset 'custom-put-text-property 'put-text-property) - (fset 'custom-extent-start-open 'ignore) - (fset 'custom-set-text-properties 'set-text-properties) - (fset 'custom-buffer-substring-no-properties - 'buffer-substring-no-properties)) - -(defun custom-xmas-buffer-substring-no-properties (beg end) - "Return the text from BEG to END, without text properties, as a string." - (let ((string (buffer-substring beg end))) - (custom-set-text-properties 0 (length string) nil string) - string)) - -;; XEmacs and Emacs 19.29 facep does different things. -(defalias 'custom-facep - (cond ((fboundp 'find-face) - 'find-face) - ((fboundp 'facep) - 'facep) - (t - 'ignore))) +(define-widget-keywords :prefix :tag :load :link :options :type :group) -(if (custom-facep 'underline) - () - ;; No underline face in XEmacs 19.12. - (and (fboundp 'make-face) - (funcall (intern "make-face") 'underline)) - ;; Must avoid calling set-face-underline-p directly, because it - ;; is a defsubst in emacs19, and will make the .elc files non - ;; portable! - (or (and (fboundp 'face-differs-from-default-p) - (face-differs-from-default-p 'underline)) - (and (fboundp 'set-face-underline-p) - (funcall 'set-face-underline-p 'underline t)))) - -(defun custom-xmas-set-text-properties (start end props &optional buffer) - (if (null buffer) - (if props - (while props - (custom-put-text-property - start end (car props) (nth 1 props) buffer) - (setq props (nthcdr 2 props))) - (remove-text-properties start end ())))) - -(or (fboundp 'event-point) - ;; Missing in Emacs 19.29. - (defun event-point (event) - "Return the character position of the given mouse-motion, button-press, -or button-release event. If the event did not occur over a window, or did -not occur over text, then this returns nil. Otherwise, it returns an index -into the buffer visible in the event's window." - (posn-point (event-start event)))) +;; These autoloads should be deleted when the file is added to Emacs +(autoload 'customize "custom-edit" nil t) +(autoload 'customize-variable "custom-edit" nil t) +(autoload 'customize-face "custom-edit" nil t) +(autoload 'customize-apropos "custom-edit" nil t) +(autoload 'customize-customized "custom-edit" nil t) +(autoload 'custom-buffer-create "custom-edit") +(autoload 'custom-menu-update "custom-edit") +(autoload 'custom-make-dependencies "custom-edit") -(eval-when-compile - (defvar x-colors nil) - (defvar custom-button-face nil) - (defvar custom-field-uninitialized-face nil) - (defvar custom-field-invalid-face nil) - (defvar custom-field-modified-face nil) - (defvar custom-field-face nil) - (defvar custom-mouse-face nil) - (defvar custom-field-active-face nil)) +;;; Compatibility. -;; We can't easily check for a working intangible. -(defconst intangible (if (and (boundp 'emacs-minor-version) - (or (> emacs-major-version 19) - (and (> emacs-major-version 18) - (> emacs-minor-version 28)))) - (setq intangible 'intangible) - (setq intangible 'intangible-if-it-had-been-working)) - "The symbol making text intangible.") - -(defconst rear-nonsticky (if (string-match "XEmacs" emacs-version) - 'end-open - 'rear-nonsticky) - "The symbol making text properties non-sticky in the rear end.") - -(defconst front-sticky (if (string-match "XEmacs" emacs-version) - 'front-closed - 'front-sticky) - "The symbol making text properties sticky in the front.") - -(defconst mouse-face (if (string-match "XEmacs" emacs-version) - 'highlight - 'mouse-face) - "Symbol used for highlighting text under mouse.") +(unless (fboundp 'x-color-values) + ;; Emacs function missing in XEmacs 19.14. + (defun x-color-values (color) + "Return a description of the color named COLOR on frame FRAME. +The value is a list of integer RGB values--(RED GREEN BLUE). +These values appear to range from 0 to 65280 or 65535, depending +on the system; white is (65280 65280 65280) or (65535 65535 65535). +If FRAME is omitted or nil, use the selected frame." + (color-instance-rgb-components (make-color-instance color)))) -;; Put it in the Help menu, if possible. -(if (string-match "XEmacs" emacs-version) - (if (featurep 'menubar) - ;; XEmacs (disabled because it doesn't work) - (and current-menubar - (add-menu-item '("Help") "Customize..." 'customize t))) - ;; Emacs 19.28 and earlier - (global-set-key [ menu-bar help customize ] - '("Customize..." . customize)) - ;; Emacs 19.29 and later - (global-set-key [ menu-bar help-menu customize ] - '("Customize..." . customize))) - -;; XEmacs popup-menu stolen from w3.el. -(defun custom-x-really-popup-menu (pos title menudesc) - "My hacked up function to do a blocking popup menu..." - (let ((echo-keystrokes 0) - event menu) - (while menudesc - (setq menu (cons (vector (car (car menudesc)) - (list (car (car menudesc))) t) menu) - menudesc (cdr menudesc))) - (setq menu (cons title menu)) - (popup-menu menu) - (catch 'popup-done - (while t - (setq event (next-command-event event)) - (cond ((and (misc-user-event-p event) (stringp (car-safe (event-object event)))) - (throw 'popup-done (event-object event))) - ((and (misc-user-event-p event) - (or (eq (event-object event) 'abort) - (eq (event-object event) 'menu-no-selection-hook))) - nil) - ((not (popup-menu-up-p)) - (throw 'popup-done nil)) - ((button-release-event-p event);; don't beep twice - nil) - (t - (beep) - (message "please make a choice from the menu."))))))) - -;;; Categories: -;; -;; XEmacs use inheritable extents for the same purpose as Emacs uses -;; the category text property. - -(if (string-match "XEmacs" emacs-version) - (progn - ;; XEmacs categories. - (defun custom-category-create (name) - (set name (make-extent nil nil)) - "Create a text property category named NAME.") - - (defun custom-category-put (name property value) - "In CATEGORY set PROPERTY to VALUE." - (set-extent-property (symbol-value name) property value)) - - (defun custom-category-get (name property) - "In CATEGORY get PROPERTY." - (extent-property (symbol-value name) property)) - - (defun custom-category-set (from to category) - "Make text between FROM and TWO have category CATEGORY." - (let ((extent (make-extent from to))) - (set-extent-parent extent (symbol-value category))))) - - ;; Emacs categories. - (defun custom-category-create (name) - "Create a text property category named NAME." - (set name name)) +(unless (fboundp 'frame-property) + ;; XEmacs function missing in Emacs 19.34. + (defun frame-property (frame property &optional default) + "Return FRAME's value for property PROPERTY." + (or (cdr (assq property (frame-parameters frame))) + default))) - (defun custom-category-put (name property value) - "In CATEGORY set PROPERTY to VALUE." - (put name property value)) - - (defun custom-category-get (name property) - "In CATEGORY get PROPERTY." - (get name property)) - - (defun custom-category-set (from to category) - "Make text between FROM and TWO have category CATEGORY." - (custom-put-text-property from to 'category category))) - -;;; External Data: -;; -;; The following functions and variables defines the interface for -;; connecting a CUSTOM with an external entity, by default an emacs -;; lisp variable. - -(defvar custom-external 'default-value - "Function returning the external value of NAME.") - -(defvar custom-external-set 'set-default - "Function setting the external value of NAME to VALUE.") - -(defun custom-external (name) - "Get the external value associated with NAME." - (funcall custom-external name)) - -(defun custom-external-set (name value) - "Set the external value associated with NAME to VALUE." - (funcall custom-external-set name value)) - -(defvar custom-name-fields nil - "Alist of custom names and their associated editing field.") -(make-variable-buffer-local 'custom-name-fields) - -(defun custom-name-enter (name field) - "Associate NAME with FIELD." - (if (null name) - () - (custom-assert 'field) - (setq custom-name-fields (cons (cons name field) custom-name-fields)))) - -(defun custom-name-field (name) - "The editing field associated with NAME." - (cdr (assq name custom-name-fields))) - -(defun custom-name-value (name) - "The value currently displayed for NAME in the customization buffer." - (let* ((field (custom-name-field name)) - (custom (custom-field-custom field))) - (custom-field-parse field) - (funcall (custom-property custom 'export) custom - (car (custom-field-extract custom field))))) - -(defvar custom-save 'custom-save - "Function that will save current customization buffer.") - -;;; Custom Functions: -;; -;; The following functions are part of the public interface to the -;; CUSTOM datastructure. Each CUSTOM describes a group of variables, -;; a single variable, or a component of a structured variable. The -;; CUSTOM instances are part of two hierarchies, the first is the -;; `part-of' hierarchy in which each CUSTOM is a component of another -;; CUSTOM, except for the top level CUSTOM which is contained in -;; `custom-data'. The second hierarchy is a `is-a' type hierarchy -;; where each CUSTOM is a leaf in the hierarchy defined by the `type' -;; property and `custom-type-properties'. - -(defvar custom-file "~/.custom.el" - "Name of file with customization information.") +(defun custom-background-mode () + "Kludge to detext background mode." + (let* ((bg-resource + (condition-case () + (x-get-resource ".backgroundMode" "BackgroundMode" 'string) + (error nil))) + color + (mode (cond (bg-resource + (intern (downcase bg-resource))) + ((and (setq color (condition-case () + (or (frame-property + (selected-frame) + 'background-color) + (color-instance-name + (specifier-instance + (face-background 'default)))) + (error nil))) + (< (apply '+ (x-color-values color)) + (/ (apply '+ (x-color-values "white")) + 3))) + 'dark) + (t 'light)))) + (modify-frame-parameters (selected-frame) + (list (cons 'background-mode mode))) + mode)) -(defconst custom-data - '((tag . "Emacs") - (doc . "The extensible self-documenting text editor.") - (type . group) - (data "\n" - ((header . nil) - (compact . t) - (type . group) - (doc . "\ -Press [Save] to save any changes permanently after you are done editing. -You can load customization information from other files by editing the -`File' field and pressing the [Load] button. When you press [Save] the -customization information of all files you have loaded, plus any -changes you might have made manually, will be stored in the file -specified by the `File' field.") - (data ((tag . "Load") - (type . button) - (query . custom-load)) - ((tag . "Save") - (type . button) - (query . custom-save)) - ((name . custom-file) - (default . "~/.custom.el") - (doc . "Name of file with customization information.\n") - (tag . "File") - (type . file)))))) - "The global customization information. -A custom association list.") - -(defun custom-declare (path custom) - "Declare variables for customization. -PATH is a list of tags leading to the place in the customization -hierarchy the new entry should be added. CUSTOM is the entry to add." - (custom-initialize custom) - (let ((current (custom-travel-path custom-data path))) - (or (member custom (custom-data current)) - (nconc (custom-data current) (list custom))))) - -(put 'custom-declare 'lisp-indent-hook 1) +;; XEmacs and Emacs have different definitions of `facep'. +;; The Emacs definition is the useful one, so emulate that. +(cond ((not (fboundp 'facep)) + (defun custom-facep (face) + "No faces" + nil)) + ((string-match "XEmacs" emacs-version) + (defun custom-facep (face) + "Face symbol or object." + (or (facep face) + (find-face face)))) + (t + (defalias 'custom-facep 'facep))) -(defconst custom-type-properties - '((repeat (type . default) - ;; See `custom-match'. - (import . custom-repeat-import) - (eval . custom-repeat-eval) - (quote . custom-repeat-quote) - (accept . custom-repeat-accept) - (extract . custom-repeat-extract) - (validate . custom-repeat-validate) - (insert . custom-repeat-insert) - (match . custom-repeat-match) - (query . custom-repeat-query) - (prefix . "") - (del-tag . "[DEL]") - (add-tag . "[INS]")) - (pair (type . group) - ;; A cons-cell. - (accept . custom-pair-accept) - (eval . custom-pair-eval) - (import . custom-pair-import) - (quote . custom-pair-quote) - (valid . (lambda (c d) (consp d))) - (extract . custom-pair-extract)) - (list (type . group) - ;; A lisp list. - (quote . custom-list-quote) - (valid . (lambda (c d) - (listp d))) - (extract . custom-list-extract)) - (group (type . default) - ;; See `custom-match'. - (face-tag . nil) - (eval . custom-group-eval) - (import . custom-group-import) - (initialize . custom-group-initialize) - (apply . custom-group-apply) - (reset . custom-group-reset) - (factory-reset . custom-group-factory-reset) - (extract . nil) - (validate . custom-group-validate) - (query . custom-toggle-hide) - (accept . custom-group-accept) - (insert . custom-group-insert) - (find . custom-group-find)) - (toggle (type . choice) - ;; Booleans. - (data ((type . const) - (tag . "On ") - (default . t)) - ((type . const) - (tag . "Off") - (default . nil)))) - (triggle (type . choice) - ;; On/Off/Default. - (data ((type . const) - (tag . "On ") - (default . t)) - ((type . const) - (tag . "Off") - (default . nil)) - ((type . const) - (tag . "Def") - (default . custom:asis)))) - (choice (type . default) - ;; See `custom-match'. - (query . custom-choice-query) - (accept . custom-choice-accept) - (extract . custom-choice-extract) - (validate . custom-choice-validate) - (insert . custom-choice-insert) - (none (tag . "Unknown") - (default . __uninitialized__) - (type . const))) - (const (type . default) - ;; A `const' only matches a single lisp value. - (extract . (lambda (c f) (list (custom-default c)))) - (validate . (lambda (c f) nil)) - (valid . custom-const-valid) - (update . custom-const-update) - (insert . custom-const-insert)) - (face-doc (type . doc) - ;; A variable containing a face. - (doc . "\ -You can customize the look of Emacs by deciding which faces should be -used when. If you push one of the face buttons below, you will be -given a choice between a number of standard faces. The name of the -selected face is shown right after the face button, and it is -displayed its own face so you can see how it looks. If you know of -another standard face not listed and want to use it, you can select -`Other' and write the name in the editing field. +;;; The `defcustom' Macro. -If none of the standard faces suits you, you can select `Customize' to -create your own face. This will make six fields appear under the face -button. The `Fg' and `Bg' fields are the foreground and background -colors for the face, respectively. You should type the name of the -color in the field. You can use any X11 color name. A list of X11 -color names may be available in the file `/usr/lib/X11/rgb.txt' on -your system. The special color name `default' means that the face -will not change the color of the text. The `Stipple' field is weird, -so just ignore it. The three remaining fields are toggles, which will -make the text `bold', `italic', or `underline' respectively. For some -fonts `bold' or `italic' will not make any visible change.")) - (face (type . choice) - (eval . custom-face-eval) - (import . custom-face-import) - (data ((tag . "None") - (default . nil) - (type . const)) - ((tag . "Default") - (default . default) - (face . custom-const-face) - (type . const)) - ((tag . "Bold") - (default . bold) - (face . custom-const-face) - (type . const)) - ((tag . "Bold-italic") - (default . bold-italic) - (face . custom-const-face) - (type . const)) - ((tag . "Italic") - (default . italic) - (face . custom-const-face) - (type . const)) - ((tag . "Underline") - (default . underline) - (face . custom-const-face) - (type . const)) - ((tag . "Highlight") - (default . highlight) - (face . custom-const-face) - (type . const)) - ((tag . "Modeline") - (default . modeline) - (face . custom-const-face) - (type . const)) - ((tag . "Region") - (default . region) - (face . custom-const-face) - (type . const)) - ((tag . "Secondary Selection") - (default . secondary-selection) - (face . custom-const-face) - (type . const)) - ((tag . "Customized") - (compact . t) - (face-tag . custom-face-hack) - (eval . custom-face-eval) - (data ((hidden . t) - (tag . "") - (doc . "\ -Select the properties you want this face to have.") - (default . custom-face-lookup) - (type . const)) - "\n" - ((tag . "Fg") - (hidden . t) - (default . "default") - (width . 20) - (type . string)) - ((tag . "Bg") - (default . "default") - (width . 20) - (type . string)) - ((tag . "Stipple") - (default . "default") - (width . 20) - (type . string)) - "\n" - ((tag . "Bold") - (default . custom:asis) - (type . triggle)) - " " - ((tag . "Italic") - (default . custom:asis) - (type . triggle)) - " " - ((tag . "Underline") - (hidden . t) - (default . custom:asis) - (type . triggle))) - (default . (custom-face-lookup "default" "default" "default" - nil nil nil)) - (type . list)) - ((prompt . "Other") - (face . custom-field-value) - (default . __uninitialized__) - (type . symbol)))) - (file (type . string) - ;; A string containing a file or directory name. - (directory . nil) - (default-file . nil) - (query . custom-file-query)) - (sexp (type . default) - ;; Any lisp expression. - (width . 40) - (default . (__uninitialized__ . "Uninitialized")) - (read . custom-sexp-read) - (write . custom-sexp-write)) - (symbol (type . sexp) - ;; A lisp symbol. - (width . 40) - (valid . (lambda (c d) (symbolp d)))) - (integer (type . sexp) - ;; A lisp integer. - (width . 10) - (valid . (lambda (c d) (integerp d)))) - (string (type . default) - ;; A lisp string. - (width . 40) - (valid . (lambda (c d) (stringp d))) - (read . custom-string-read) - (write . custom-string-write)) - (button (type . default) - ;; Push me. - (accept . ignore) - (extract . nil) - (validate . ignore) - (insert . custom-button-insert)) - (doc (type . default) - ;; A documentation only entry with no value. - (header . nil) - (reset . ignore) - (extract . nil) - (validate . ignore) - (insert . custom-documentation-insert)) - (default (width . 20) - (valid . (lambda (c v) t)) - (insert . custom-default-insert) - (update . custom-default-update) - (query . custom-default-query) - (tag . nil) - (prompt . nil) - (doc . nil) - (header . t) - (padding . ? ) - (quote . custom-default-quote) - (eval . (lambda (c v) nil)) - (export . custom-default-export) - (import . (lambda (c v) (list v))) - (synchronize . ignore) - (initialize . custom-default-initialize) - (extract . custom-default-extract) - (validate . custom-default-validate) - (apply . custom-default-apply) - (reset . custom-default-reset) - (factory-reset . custom-default-factory-reset) - (accept . custom-default-accept) - (match . custom-default-match) - (name . nil) - (compact . nil) - (hidden . nil) - (face . custom-default-face) - (data . nil) - (calculate . nil) - (default . __uninitialized__))) - "Alist of default properties for type symbols. -The format is `((SYMBOL (PROPERTY . VALUE)... )... )'.") +;;;###autoload +(defun custom-declare-variable (symbol value doc &rest args) + "Like `defcustom', but SYMBOL and VALUE are evaluated as notmal arguments." + (unless (and (default-boundp symbol) + (not (get symbol 'saved-value))) + (set-default symbol (if (get symbol 'saved-value) + (eval (car (get symbol 'saved-value))) + (eval value)))) + (put symbol 'factory-value (list value)) + (when doc + (put symbol 'variable-documentation doc)) + (while args + (let ((arg (car args))) + (setq args (cdr args)) + (unless (symbolp arg) + (error "Junk in args %S" args)) + (let ((keyword arg) + (value (car args))) + (unless args + (error "Keyword %s is missing an argument" keyword)) + (setq args (cdr args)) + (cond ((eq keyword :type) + (put symbol 'custom-type value)) + ((eq keyword :options) + (if (get symbol 'custom-options) + ;; Slow safe code to avoid duplicates. + (mapcar (lambda (option) + (custom-add-option symbol option)) + value) + ;; Fast code for the common case. + (put symbol 'custom-options (copy-list value)))) + (t + (custom-handle-keyword symbol keyword value + 'custom-variable)))))) + (run-hooks 'custom-define-hook) + symbol) -(defconst custom-local-type-properties nil - "Local type properties. -Entries in this list take precedence over `custom-type-properties'.") +;;;###autoload +(defmacro defcustom (symbol value doc &rest args) + "Declare SYMBOL as a customizable variable that defaults to VALUE. +DOC is the variable documentation. + +Neither SYMBOL nor VALUE needs to be quoted. +If SYMBOL is not already bound, initialize it to VALUE. +The remaining arguments should have the form + + [KEYWORD VALUE]... -(make-variable-buffer-local 'custom-local-type-properties) +The following KEYWORD's are defined: + +:type VALUE should be a widget type. +:options VALUE should be a list of valid members of the widget type. +:group VALUE should be a customization group. + Add SYMBOL to that group. -(defconst custom-nil '__uninitialized__ - "Special value representing an uninitialized field.") +Read the section about customization in the emacs lisp manual for more +information." + `(eval-and-compile + (custom-declare-variable (quote ,symbol) (quote ,value) ,doc ,@args))) + +;;; The `defface' Macro. -(defconst custom-invalid '__invalid__ - "Special value representing an invalid field.") - -(defconst custom:asis 'custom:asis) -;; Bad, ugly, and horrible kludge. - -(defun custom-property (custom property) - "Extract from CUSTOM property PROPERTY." - (let ((entry (assq property custom))) - (while (null entry) - ;; Look in superclass. - (let ((type (custom-type custom))) - (setq custom (cdr (or (assq type custom-local-type-properties) - (assq type custom-type-properties))) - entry (assq property custom)) - (custom-assert 'custom))) - (cdr entry))) - -(defun custom-super (custom property) - "Extract from CUSTOM property PROPERTY. Start with CUSTOM's superclass." - (let ((entry nil)) - (while (null entry) - ;; Look in superclass. - (let ((type (custom-type custom))) - (setq custom (cdr (or (assq type custom-local-type-properties) - (assq type custom-type-properties))) - entry (assq property custom)) - (custom-assert 'custom))) - (cdr entry))) - -(defun custom-property-set (custom property value) - "Set CUSTOM PROPERTY to VALUE by side effect. -CUSTOM must have at least one property already." - (let ((entry (assq property custom))) - (if entry - (setcdr entry value) - (setcdr custom (cons (cons property value) (cdr custom)))))) - -(defun custom-type (custom) - "Extract `type' from CUSTOM." - (cdr (assq 'type custom))) - -(defun custom-name (custom) - "Extract `name' from CUSTOM." - (custom-property custom 'name)) - -(defun custom-tag (custom) - "Extract `tag' from CUSTOM." - (custom-property custom 'tag)) - -(defun custom-face-tag (custom) - "Extract `face-tag' from CUSTOM." - (custom-property custom 'face-tag)) - -(defun custom-prompt (custom) - "Extract `prompt' from CUSTOM. -If none exist, default to `tag' or, failing that, `type'." - (or (custom-property custom 'prompt) - (custom-property custom 'tag) - (capitalize (symbol-name (custom-type custom))))) +;;;###autoload +(defun custom-declare-face (face spec doc &rest args) + "Like `defface', but FACE is evaluated as a normal argument." + (put face 'factory-face spec) + (when (fboundp 'facep) + (unless (and (custom-facep face) + (not (get face 'saved-face))) + ;; If the user has already created the face, respect that. + (let ((value (or (get face 'saved-face) spec))) + (custom-face-display-set face value)))) + (when doc + (put face 'face-documentation doc)) + (custom-handle-all-keywords face args 'custom-face) + (run-hooks 'custom-define-hook) + face) -(defun custom-default (custom) - "Extract `default' from CUSTOM." - (let ((value (custom-property custom 'calculate))) - (if value - (eval value) - (custom-property custom 'default)))) - -(defun custom-data (custom) - "Extract the `data' from CUSTOM." - (custom-property custom 'data)) - -(defun custom-documentation (custom) - "Extract `doc' from CUSTOM." - (custom-property custom 'doc)) +;;;###autoload +(defmacro defface (face spec doc &rest args) + "Declare FACE as a customizable face that defaults to SPEC. +FACE does not need to be quoted. -(defun custom-width (custom) - "Extract `width' from CUSTOM." - (custom-property custom 'width)) - -(defun custom-compact (custom) - "Extract `compact' from CUSTOM." - (custom-property custom 'compact)) - -(defun custom-padding (custom) - "Extract `padding' from CUSTOM." - (custom-property custom 'padding)) - -(defun custom-valid (custom value) - "Non-nil if CUSTOM may validly be set to VALUE." - (and (not (and (listp value) (eq custom-invalid (car value)))) - (funcall (custom-property custom 'valid) custom value))) - -(defun custom-import (custom value) - "Import CUSTOM VALUE from external variable. +Third argument DOC is the face documentation. -This function change VALUE into a form that makes it easier to edit -internally. What the internal form is exactly depends on CUSTOM. -The internal form is returned." - (if (eq custom-nil value) - (list custom-nil) - (funcall (custom-property custom 'import) custom value))) - -(defun custom-eval (custom value) - "Return non-nil if CUSTOM's VALUE needs to be evaluated." - (funcall (custom-property custom 'eval) custom value)) - -(defun custom-quote (custom value) - "Quote CUSTOM's VALUE if necessary." - (funcall (custom-property custom 'quote) custom value)) +If FACE has been set with `custom-set-face', set the face attributes +as specified by that function, otherwise set the face attributes +according to SPEC. -(defun custom-write (custom value) - "Convert CUSTOM VALUE to a string." - (cond ((eq value custom-nil) - "") - ((and (listp value) (eq (car value) custom-invalid)) - (cdr value)) - (t - (funcall (custom-property custom 'write) custom value)))) +The remaining arguments should have the form -(defun custom-read (custom string) - "Convert CUSTOM field content STRING into lisp." - (condition-case nil - (funcall (custom-property custom 'read) custom string) - (error (cons custom-invalid string)))) + [KEYWORD VALUE]... -(defun custom-match (custom values) - "Match CUSTOM with a list of VALUES. - -Return a cons-cell where the car is the sublist of VALUES matching CUSTOM, -and the cdr is the remaining VALUES. - -A CUSTOM is actually a regular expression over the alphabet of lisp -types. Most CUSTOM types are just doing a literal match, e.g. the -`symbol' type matches any lisp symbol. The exceptions are: +The following KEYWORD's are defined: -group: which corresponds to a `(' and `)' group in a regular expression. -choice: which corresponds to a group of `|' in a regular expression. -repeat: which corresponds to a `*' in a regular expression. -optional: which corresponds to a `?', and isn't implemented yet." - (if (memq values (list custom-nil nil)) - ;; Nothing matches the uninitialized or empty list. - (cons custom-nil nil) - (funcall (custom-property custom 'match) custom values))) - -(defun custom-initialize (custom) - "Initialize `doc' and `default' attributes of CUSTOM." - (funcall (custom-property custom 'initialize) custom)) +:group VALUE should be a customization group. + Add FACE to that group. -(defun custom-find (custom tag) - "Find child in CUSTOM with `tag' TAG." - (funcall (custom-property custom 'find) custom tag)) - -(defun custom-travel-path (custom path) - "Find decedent of CUSTOM by looking through PATH." - (if (null path) - custom - (custom-travel-path (custom-find custom (car path)) (cdr path)))) - -(defun custom-field-extract (custom field) - "Extract CUSTOM's value in FIELD." - (if (stringp custom) - nil - (funcall (custom-property (custom-field-custom field) 'extract) - custom field))) +SPEC should be an alist of the form ((DISPLAY ATTS)...). -(defun custom-field-validate (custom field) - "Validate CUSTOM's value in FIELD. -Return nil if valid, otherwise return a cons-cell where the car is the -position of the error, and the cdr is a text describing the error." - (if (stringp custom) - nil - (funcall (custom-property custom 'validate) custom field))) - -;;; Field Functions: -;; -;; This section defines the public functions for manipulating the -;; FIELD datatype. The FIELD instance hold information about a -;; specific editing field in the customization buffer. -;; -;; Each FIELD can be seen as an instantiation of a CUSTOM. - -(defvar custom-field-last nil) -;; Last field containing point. -(make-variable-buffer-local 'custom-field-last) +ATTS is a list of face attributes and their values. The possible +attributes are defined in the variable `custom-face-attributes'. +Alternatively, ATTS can be a face in which case the attributes of that +face is used. -(defvar custom-modified-list nil) -;; List of modified fields. -(make-variable-buffer-local 'custom-modified-list) - -(defun custom-field-create (custom value) - "Create a field structure of type CUSTOM containing VALUE. - -A field structure is an array [ CUSTOM VALUE ORIGINAL START END ], where -CUSTOM defines the type of the field, -VALUE is the current value of the field, -ORIGINAL is the original value when created, and -START and END are markers to the start and end of the field." - (vector custom value custom-nil nil nil)) - -(defun custom-field-custom (field) - "Return the `custom' attribute of FIELD." - (aref field 0)) - -(defun custom-field-value (field) - "Return the `value' attribute of FIELD." - (aref field 1)) +The ATTS of the first entry in SPEC where the DISPLAY matches the +frame should take effect in that frame. DISPLAY can either be the +symbol `t', which will match all frames, or an alist of the form +\((REQ ITEM...)...) -(defun custom-field-original (field) - "Return the `original' attribute of FIELD." - (aref field 2)) - -(defun custom-field-start (field) - "Return the `start' attribute of FIELD." - (aref field 3)) - -(defun custom-field-end (field) - "Return the `end' attribute of FIELD." - (aref field 4)) - -(defun custom-field-value-set (field value) - "Set the `value' attribute of FIELD to VALUE." - (aset field 1 value)) +For the DISPLAY to match a FRAME, the REQ property of the frame must +match one of the ITEM. The following REQ are defined: -(defun custom-field-original-set (field original) - "Set the `original' attribute of FIELD to ORIGINAL." - (aset field 2 original)) - -(defun custom-field-move (field start end) - "Set the `start'and `end' attributes of FIELD to START and END." - (set-marker (or (aref field 3) (aset field 3 (make-marker))) start) - (set-marker (or (aref field 4) (aset field 4 (make-marker))) end)) +`type' (the value of (window-system)) + Should be one of `x' or `tty'. -(defun custom-field-query (field) - "Query user for content of current field." - (funcall (custom-property (custom-field-custom field) 'query) field)) - -(defun custom-field-accept (field value &optional original) - "Store a new value into field FIELD, taking it from VALUE. -If optional ORIGINAL is non-nil, consider VALUE for the original value." - (let ((inhibit-point-motion-hooks t)) - (funcall (custom-property (custom-field-custom field) 'accept) - field value original))) +`class' (the frame's color support) + Should be one of `color', `grayscale', or `mono'. -(defun custom-field-face (field) - "The face used for highlighting FIELD." - (let ((custom (custom-field-custom field))) - (if (stringp custom) - nil - (let ((face (funcall (custom-property custom 'face) field))) - (if (custom-facep face) face nil))))) - -(defun custom-field-update (field) - "Update the screen appearance of FIELD to correspond with the field's value." - (let ((custom (custom-field-custom field))) - (if (stringp custom) - nil - (funcall (custom-property custom 'update) field)))) - -;;; Types: -;; -;; The following functions defines type specific actions. +`background' (what color is used for the background text) + Should be one of `light' or `dark'. -(defun custom-repeat-eval (custom value) - "Non-nil if CUSTOM's VALUE needs to be evaluated." - (if (eq value custom-nil) - nil - (let ((child (custom-data custom)) - (found nil)) - (mapcar (lambda (v) (if (custom-eval child v) (setq found t))) - value)))) +Read the section about customization in the emacs lisp manual for more +information." + `(custom-declare-face (quote ,face) ,spec ,doc ,@args)) -(defun custom-repeat-quote (custom value) - "A list of CUSTOM's VALUEs quoted." - (let ((child (custom-data custom))) - (apply 'append (mapcar (lambda (v) (custom-quote child v)) - value)))) - - -(defun custom-repeat-import (custom value) - "Modify CUSTOM's VALUE to match internal expectations." - (let ((child (custom-data custom))) - (apply 'append (mapcar (lambda (v) (custom-import child v)) - value)))) +;;; The `defgroup' Macro. -(defun custom-repeat-accept (field value &optional original) - "Store a new value into field FIELD, taking it from VALUE." - (let ((values (copy-sequence (custom-field-value field))) - (all (custom-field-value field)) - (start (custom-field-start field)) - current new) - (if original - (custom-field-original-set field value)) - (while (consp value) - (setq new (car value) - value (cdr value)) - (if values - ;; Change existing field. - (setq current (car values) - values (cdr values)) - ;; Insert new field if series has grown. - (goto-char start) - (setq current (custom-repeat-insert-entry field)) - (setq all (custom-insert-before all nil current)) - (custom-field-value-set field all)) - (custom-field-accept current new original)) - (while (consp values) - ;; Delete old field if series has scrunk. - (setq current (car values) - values (cdr values)) - (let ((pos (custom-field-start current)) - data) - (while (not data) - (setq pos (previous-single-property-change pos 'custom-data)) - (custom-assert 'pos) - (setq data (get-text-property pos 'custom-data)) - (or (and (arrayp data) - (> (length data) 1) - (eq current (aref data 1))) - (setq data nil))) - (custom-repeat-delete data))))) - -(defun custom-repeat-insert (custom level) - "Insert field for CUSTOM at nesting LEVEL in customization buffer." - (let* ((field (custom-field-create custom nil)) - (add-tag (custom-property custom 'add-tag)) - (start (make-marker)) - (data (vector field nil start nil))) - (custom-text-insert "\n") - (let ((pos (point))) - (custom-text-insert (custom-property custom 'prefix)) - (custom-tag-insert add-tag 'custom-repeat-add data) - (set-marker start pos)) - (custom-field-move field start (point)) - (custom-documentation-insert custom) - field)) +;;;###autoload +(defun custom-declare-group (symbol members doc &rest args) + "Like `defgroup', but SYMBOL is evaluated as a normal argument." + (put symbol 'custom-group (nconc members (get symbol 'custom-group))) + (when doc + (put symbol 'group-documentation doc)) + (while args + (let ((arg (car args))) + (setq args (cdr args)) + (unless (symbolp arg) + (error "Junk in args %S" args)) + (let ((keyword arg) + (value (car args))) + (unless args + (error "Keyword %s is missing an argument" keyword)) + (setq args (cdr args)) + (cond ((eq keyword :prefix) + (put symbol 'custom-prefix value)) + (t + (custom-handle-keyword symbol keyword value + 'custom-group)))))) + (run-hooks 'custom-define-hook) + symbol) -(defun custom-repeat-insert-entry (repeat) - "Insert entry at point in the REPEAT field." - (let* ((inhibit-point-motion-hooks t) - (inhibit-read-only t) - (before-change-functions nil) - (after-change-functions nil) - (custom (custom-field-custom repeat)) - (add-tag (custom-property custom 'add-tag)) - (del-tag (custom-property custom 'del-tag)) - (start (make-marker)) - (end (make-marker)) - (data (vector repeat nil start end)) - field) - (custom-extent-start-open) - (insert-before-markers "\n") - (backward-char 1) - (set-marker start (point)) - (custom-text-insert " ") - (aset data 1 (setq field (custom-insert (custom-data custom) nil))) - (custom-text-insert " ") - (set-marker end (point)) - (goto-char start) - (custom-text-insert (custom-property custom 'prefix)) - (custom-tag-insert add-tag 'custom-repeat-add data) - (custom-text-insert " ") - (custom-tag-insert del-tag 'custom-repeat-delete data) - (forward-char 1) - field)) +;;;###autoload +(defmacro defgroup (symbol members doc &rest args) + "Declare SYMBOL as a customization group containing MEMBERS. +SYMBOL does not need to be quoted. -(defun custom-repeat-add (data) - "Add list entry." - (let ((parent (aref data 0)) - (field (aref data 1)) - (at (aref data 2)) - new) - (goto-char at) - (setq new (custom-repeat-insert-entry parent)) - (custom-field-value-set parent - (custom-insert-before (custom-field-value parent) - field new)))) +Third arg DOC is the group documentation. -(defun custom-repeat-delete (data) - "Delete list entry." - (let ((inhibit-point-motion-hooks t) - (inhibit-read-only t) - (before-change-functions nil) - (after-change-functions nil) - (parent (aref data 0)) - (field (aref data 1))) - (delete-region (aref data 2) (1+ (aref data 3))) - (custom-field-untouch (aref data 1)) - (custom-field-value-set parent - (delq field (custom-field-value parent))))) - -(defun custom-repeat-match (custom values) - "Match CUSTOM with VALUES." - (let* ((child (custom-data custom)) - (match (custom-match child values)) - matches) - (while (not (eq (car match) custom-nil)) - (setq matches (cons (car match) matches) - values (cdr match) - match (custom-match child values))) - (cons (nreverse matches) values))) +MEMBERS should be an alist of the form ((NAME WIDGET)...) where +NAME is a symbol and WIDGET is a widget is a widget for editing that +symbol. Useful widgets are `custom-variable' for editing variables, +`custom-face' for edit faces, and `custom-group' for editing groups. -(defun custom-repeat-extract (custom field) - "Extract list of children's values." - (let ((values (custom-field-value field)) - (data (custom-data custom)) - result) - (if (eq values custom-nil) - () - (while values - (setq result (append result (custom-field-extract data (car values))) - values (cdr values)))) - result)) - -(defun custom-repeat-validate (custom field) - "Validate children." - (let ((values (custom-field-value field)) - (data (custom-data custom)) - result) - (if (eq values custom-nil) - (setq result (cons (custom-field-start field) "Uninitialized list"))) - (while (and values (not result)) - (setq result (custom-field-validate data (car values)) - values (cdr values))) - result)) +The remaining arguments should have the form -(defun custom-pair-accept (field value &optional original) - "Store a new value into field FIELD, taking it from VALUE." - (custom-group-accept field (list (car value) (cdr value)) original)) - -(defun custom-pair-eval (custom value) - "Non-nil if CUSTOM's VALUE needs to be evaluated." - (custom-group-eval custom (list (car value) (cdr value)))) + [KEYWORD VALUE]... -(defun custom-pair-import (custom value) - "Modify CUSTOM's VALUE to match internal expectations." - (let ((result (car (custom-group-import custom - (list (car value) (cdr value)))))) - (custom-assert '(eq (length result) 2)) - (list (cons (nth 0 result) (nth 1 result))))) - -(defun custom-pair-quote (custom value) - "Quote CUSTOM's VALUE if necessary." - (if (custom-eval custom value) - (let ((v (car (custom-group-quote custom - (list (car value) (cdr value)))))) - (list (list 'cons (nth 0 v) (nth 1 v)))) - (custom-default-quote custom value))) +The following KEYWORD's are defined: -(defun custom-pair-extract (custom field) - "Extract cons of children's values." - (let ((values (custom-field-value field)) - (data (custom-data custom)) - result) - (custom-assert '(eq (length values) (length data))) - (while values - (setq result (append result - (custom-field-extract (car data) (car values))) - data (cdr data) - values (cdr values))) - (custom-assert '(null data)) - (list (cons (nth 0 result) (nth 1 result))))) - -(defun custom-list-quote (custom value) - "Quote CUSTOM's VALUE if necessary." - (if (custom-eval custom value) - (let ((v (car (custom-group-quote custom value)))) - (list (cons 'list v))) - (custom-default-quote custom value))) +:group VALUE should be a customization group. + Add SYMBOL to that group. -(defun custom-list-extract (custom field) - "Extract list of children's values." - (let ((values (custom-field-value field)) - (data (custom-data custom)) - result) - (custom-assert '(eq (length values) (length data))) - (while values - (setq result (append result - (custom-field-extract (car data) (car values))) - data (cdr data) - values (cdr values))) - (custom-assert '(null data)) - (list result))) - -(defun custom-group-validate (custom field) - "Validate children." - (let ((values (custom-field-value field)) - (data (custom-data custom)) - result) - (if (eq values custom-nil) - (setq result (cons (custom-field-start field) "Uninitialized list")) - (custom-assert '(eq (length values) (length data)))) - (while (and values (not result)) - (setq result (custom-field-validate (car data) (car values)) - data (cdr data) - values (cdr values))) - result)) +Read the section about customization in the emacs lisp manual for more +information." + `(custom-declare-group (quote ,symbol) ,members ,doc ,@args)) -(defun custom-group-eval (custom value) - "Non-nil if CUSTOM's VALUE needs to be evaluated." - (let ((found nil)) - (mapcar (lambda (c) - (or (stringp c) - (let ((match (custom-match c value))) - (if (custom-eval c (car match)) - (setq found t)) - (setq value (cdr match))))) - (custom-data custom)) - found)) +;;;###autoload +(defun custom-add-to-group (group option widget) + "To existing GROUP add a new OPTION of type WIDGET, +If there already is an entry for that option, overwrite it." + (let* ((members (get group 'custom-group)) + (old (assq option members))) + (if old + (setcar (cdr old) widget) + (put group 'custom-group (nconc members (list (list option widget))))))) -(defun custom-group-quote (custom value) - "A list of CUSTOM's VALUE members, quoted." - (list (apply 'append - (mapcar (lambda (c) - (if (stringp c) - () - (let ((match (custom-match c value))) - (prog1 (custom-quote c (car match)) - (setq value (cdr match)))))) - (custom-data custom))))) - -(defun custom-group-import (custom value) - "Modify CUSTOM's VALUE to match internal expectations." - (list (apply 'append - (mapcar (lambda (c) - (if (stringp c) - () - (let ((match (custom-match c value))) - (prog1 (custom-import c (car match)) - (setq value (cdr match)))))) - (custom-data custom))))) +;;; Properties. -(defun custom-group-initialize (custom) - "Initialize `doc' and `default' entries in CUSTOM." - (if (custom-name custom) - (custom-default-initialize custom) - (mapcar 'custom-initialize (custom-data custom)))) - -(defun custom-group-apply (field) - "Reset `value' in FIELD to `original'." - (let ((custom (custom-field-custom field)) - (values (custom-field-value field))) - (if (custom-name custom) - (custom-default-apply field) - (mapcar 'custom-field-apply values)))) - -(defun custom-group-reset (field) - "Reset `value' in FIELD to `original'." - (let ((custom (custom-field-custom field)) - (values (custom-field-value field))) - (if (custom-name custom) - (custom-default-reset field) - (mapcar 'custom-field-reset values)))) - -(defun custom-group-factory-reset (field) - "Reset `value' in FIELD to `default'." - (let ((custom (custom-field-custom field)) - (values (custom-field-value field))) - (if (custom-name custom) - (custom-default-factory-reset field) - (mapcar 'custom-field-factory-reset values)))) - -(defun custom-group-find (custom tag) - "Find child in CUSTOM with `tag' TAG." - (let ((data (custom-data custom)) - (result nil)) - (while (not result) - (custom-assert 'data) - (if (equal (custom-tag (car data)) tag) - (setq result (car data)) - (setq data (cdr data)))))) +(defun custom-handle-all-keywords (symbol args type) + "For customization option SYMBOL, handle keyword arguments ARGS. +Third argument TYPE is the custom option type." + (while args + (let ((arg (car args))) + (setq args (cdr args)) + (unless (symbolp arg) + (error "Junk in args %S" args)) + (let ((keyword arg) + (value (car args))) + (unless args + (error "Keyword %s is missing an argument" keyword)) + (setq args (cdr args)) + (custom-handle-keyword symbol keyword value type))))) -(defun custom-group-accept (field value &optional original) - "Store a new value into field FIELD, taking it from VALUE." - (let* ((values (custom-field-value field)) - (custom (custom-field-custom field)) - (from (custom-field-start field)) - (face-tag (custom-face-tag custom)) - current) - (if face-tag - (custom-put-text-property from (+ from (length (custom-tag custom))) - 'face (funcall face-tag field value))) - (if original - (custom-field-original-set field value)) - (while values - (setq current (car values) - values (cdr values)) - (if current - (let* ((custom (custom-field-custom current)) - (match (custom-match custom value))) - (setq value (cdr match)) - (custom-field-accept current (car match) original)))))) - -(defun custom-group-insert (custom level) - "Insert field for CUSTOM at nesting LEVEL in customization buffer." - (let* ((field (custom-field-create custom nil)) - fields hidden - (from (point)) - (compact (custom-compact custom)) - (tag (custom-tag custom)) - (face-tag (custom-face-tag custom))) - (cond (face-tag (custom-text-insert tag)) - (tag (custom-tag-insert tag field))) - (or compact (custom-documentation-insert custom)) - (or compact (custom-text-insert "\n")) - (let ((data (custom-data custom))) - (while data - (setq fields (cons (custom-insert (car data) (if level (1+ level))) - fields)) - (setq hidden (or (stringp (car data)) - (custom-property (car data) 'hidden))) - (setq data (cdr data)) - (if data (custom-text-insert (cond (hidden "") - (compact " ") - (t "\n")))))) - (if compact (custom-documentation-insert custom)) - (custom-field-value-set field (nreverse fields)) - (custom-field-move field from (point)) - field)) - -(defun custom-choice-insert (custom level) - "Insert field for CUSTOM at nesting LEVEL in customization buffer." - (let* ((field (custom-field-create custom nil)) - (from (point))) - (custom-text-insert "lars er en nisse") - (custom-field-move field from (point)) - (custom-documentation-insert custom) - (custom-field-reset field) - field)) +(defun custom-handle-keyword (symbol keyword value type) + "For customization option SYMBOL, handle KEYWORD with VALUE. +Fourth argument TYPE is the custom option type." + (cond ((eq keyword :group) + (custom-add-to-group value symbol type)) + ((eq keyword :link) + (custom-add-link symbol value)) + ((eq keyword :load) + (custom-add-load symbol value)) + ((eq keyword :tag) + (put symbol 'custom-tag value)) + (t + (error "Unknown keyword %s" symbol)))) -(defun custom-choice-accept (field value &optional original) - "Store a new value into field FIELD, taking it from VALUE." - (let ((custom (custom-field-custom field)) - (start (custom-field-start field)) - (end (custom-field-end field)) - (inhibit-read-only t) - (before-change-functions nil) - (after-change-functions nil) - from) - (cond (original - (setq custom-modified-list (delq field custom-modified-list)) - (custom-field-original-set field value)) - ((equal value (custom-field-original field)) - (setq custom-modified-list (delq field custom-modified-list))) - (t - (add-to-list 'custom-modified-list field))) - (custom-field-untouch (custom-field-value field)) - (delete-region start end) - (goto-char start) - (setq from (point)) - (insert-before-markers " ") - (backward-char 1) - (custom-category-set (point) (1+ (point)) 'custom-hidden-properties) - (custom-tag-insert (custom-tag custom) field) - (custom-text-insert ": ") - (let ((data (custom-data custom)) - found begin) - (while (and data (not found)) - (if (not (custom-valid (car data) value)) - (setq data (cdr data)) - (setq found (custom-insert (car data) nil)) - (setq data nil))) - (if found - () - (setq begin (point) - found (custom-insert (custom-property custom 'none) nil)) - (custom-add-text-properties - begin (point) - (list rear-nonsticky t - 'face custom-field-uninitialized-face))) - (or original - (custom-field-original-set found (custom-field-original field))) - (custom-field-accept found value original) - (custom-field-value-set field found) - (custom-field-move field from end)))) +(defun custom-add-option (symbol option) + "To the variable SYMBOL add OPTION. -(defun custom-choice-extract (custom field) - "Extract child's value." - (let ((value (custom-field-value field))) - (custom-field-extract (custom-field-custom value) value))) +If SYMBOL is a hook variable, OPTION should be a hook member. +For other types variables, the effect is undefined." + (let ((options (get symbol 'custom-options))) + (unless (member option options) + (put symbol 'custom-options (cons option options))))) -(defun custom-choice-validate (custom field) - "Validate child's value." - (let ((value (custom-field-value field)) - (custom (custom-field-custom field))) - (if (or (eq value custom-nil) - (eq (custom-field-custom value) (custom-property custom 'none))) - (cons (custom-field-start field) "Make a choice") - (custom-field-validate (custom-field-custom value) value)))) +(defun custom-add-link (symbol widget) + "To the custom option SYMBOL add the link WIDGET." + (let ((links (get symbol 'custom-links))) + (unless (member widget links) + (put symbol 'custom-links (cons widget links))))) -(defun custom-choice-query (field) - "Choose a child." - (let* ((custom (custom-field-custom field)) - (old (custom-field-custom (custom-field-value field))) - (default (custom-prompt old)) - (tag (custom-prompt custom)) - (data (custom-data custom)) - current alist) - (if (eq (length data) 2) - (custom-field-accept field (custom-default (if (eq (nth 0 data) old) - (nth 1 data) - (nth 0 data)))) - (while data - (setq current (car data) - data (cdr data)) - (setq alist (cons (cons (custom-prompt current) current) alist))) - (let ((answer (cond ((and (fboundp 'button-press-event-p) - (fboundp 'popup-menu) - (button-press-event-p last-input-event)) - (cdr (assoc (car (custom-x-really-popup-menu - last-input-event tag - (reverse alist))) - alist))) - ((listp last-input-event) - (x-popup-menu last-input-event - (list tag (cons "" (reverse alist))))) - (t - (let ((choice (completing-read (concat tag - " (default " - default - "): ") - alist nil t))) - (if (or (null choice) (string-equal choice "")) - (setq choice default)) - (cdr (assoc choice alist))))))) - (if answer - (custom-field-accept field (custom-default answer))))))) +(defun custom-add-load (symbol load) + "To the custom option SYMBOL add the dependency LOAD. +LOAD should be either a library file name, or a feature name." + (let ((loads (get symbol 'custom-loads))) + (unless (member load loads) + (put symbol 'custom-loads (cons load loads))))) -(defun custom-file-query (field) - "Prompt for a file name" - (let* ((value (custom-field-value field)) - (custom (custom-field-custom field)) - (valid (custom-valid custom value)) - (directory (custom-property custom 'directory)) - (default (and (not valid) - (custom-property custom 'default-file))) - (tag (custom-tag custom)) - (prompt (if default - (concat tag " (" default "): ") - (concat tag ": ")))) - (custom-field-accept field - (if (custom-valid custom value) - (read-file-name prompt - (if (file-name-absolute-p value) - "" - directory) - default nil value) - (read-file-name prompt directory default))))) +;;; Face Utilities. -(defun custom-face-eval (custom value) - "Return non-nil if CUSTOM's VALUE needs to be evaluated." - (not (symbolp value))) - -(defun custom-face-import (custom value) - "Modify CUSTOM's VALUE to match internal expectations." - (let ((name (or (and (facep value) (symbol-name (face-name value))) - (symbol-name value)))) - (list (if (string-match "\ -custom-face-\\(.*\\)-\\(.*\\)-\\(.*\\)-\\(.*\\)-\\(.*\\)-\\(.*\\)" - name) - (list 'custom-face-lookup - (match-string 1 name) - (match-string 2 name) - (match-string 3 name) - (intern (match-string 4 name)) - (intern (match-string 5 name)) - (intern (match-string 6 name))) - value)))) +(and (fboundp 'make-face) + (make-face 'custom-face-empty)) -(defun custom-face-lookup (&optional fg bg stipple bold italic underline) - "Lookup or create a face with specified attributes." - (let ((name (intern (format "custom-face-%s-%s-%s-%S-%S-%S" - (or fg "default") - (or bg "default") - (or stipple "default") - bold italic underline)))) - (if (and (custom-facep name) - (fboundp 'make-face)) - () - (copy-face 'default name) - (when (and fg - (not (string-equal fg "default"))) - (condition-case () - (set-face-foreground name fg) - (error nil))) - (when (and bg - (not (string-equal bg "default"))) - (condition-case () - (set-face-background name bg) - (error nil))) - (when (and stipple - (not (string-equal stipple "default")) - (not (eq stipple 'custom:asis)) - (fboundp 'set-face-stipple)) - (set-face-stipple name stipple)) - (when (and bold - (not (eq bold 'custom:asis))) - (condition-case () - (make-face-bold name) - (error nil))) - (when (and italic - (not (eq italic 'custom:asis))) - (condition-case () - (make-face-italic name) - (error nil))) - (when (and underline - (not (eq underline 'custom:asis))) - (condition-case () - (set-face-underline-p name t) - (error nil)))) - name)) +(defun custom-face-display-set (face spec &optional frame) + "Set FACE to the attributes to the first matching entry in SPEC. +Iff optional FRAME is non-nil, set it for that frame only. +See `defface' for information about SPEC." + (when (fboundp 'copy-face) + (copy-face 'custom-face-empty face) + (while spec + (let* ((entry (car spec)) + (display (nth 0 entry)) + (atts (nth 1 entry))) + (setq spec (cdr spec)) + (when (custom-display-match-frame display frame) + (apply 'custom-face-attribites-set face frame atts) + (setq spec nil)))))) -(defun custom-face-hack (field value) - "Face that should be used for highlighting FIELD containing VALUE." - (let* ((custom (custom-field-custom field)) - (form (funcall (custom-property custom 'export) custom value)) - (face (apply (car form) (cdr form)))) - (if (custom-facep face) face nil))) - -(defun custom-const-insert (custom level) - "Insert field for CUSTOM at nesting LEVEL in customization buffer." - (let* ((field (custom-field-create custom custom-nil)) - (face (custom-field-face field)) - (from (point))) - (custom-text-insert (custom-tag custom)) - (custom-add-text-properties from (point) - (list 'face face - rear-nonsticky t)) - (custom-documentation-insert custom) - (custom-field-move field from (point)) - field)) - -(defun custom-const-update (field) - "Update face of FIELD." - (let ((from (custom-field-start field)) - (custom (custom-field-custom field))) - (custom-put-text-property from (+ from (length (custom-tag custom))) - 'face (custom-field-face field)))) - -(defun custom-const-valid (custom value) - "Non-nil if CUSTOM can validly have the value VALUE." - (equal (custom-default custom) value)) - -(defun custom-const-face (field) - "Face used for a FIELD." - (custom-default (custom-field-custom field))) - -(defun custom-sexp-read (custom string) - "Read from CUSTOM an STRING." - (save-match-data - (save-excursion - (set-buffer (get-buffer-create " *Custom Scratch*")) - (erase-buffer) - (insert string) - (goto-char (point-min)) - (prog1 (read (current-buffer)) - (or (looking-at - (concat (regexp-quote (char-to-string - (custom-padding custom))) - "*\\'")) - (error "Junk at end of expression")))))) - -(autoload 'pp-to-string "pp") +(defcustom custom-background-mode nil + "The brightness of the background. +Set this to the symbol dark if your background color is dark, light if +your background is light, or nil (default) if you want Emacs to +examine the brightness for you." + :group 'customize + :type '(choice (choice-item dark) + (choice-item light) + (choice-item :tag "default" nil))) -(defun custom-sexp-write (custom sexp) - "Write CUSTOM SEXP as string." - (let ((string (prin1-to-string sexp))) - (if (<= (length string) (custom-width custom)) - string - (setq string (pp-to-string sexp)) - (string-match "[ \t\n]*\\'" string) - (concat "\n" (substring string 0 (match-beginning 0)))))) - -(defun custom-string-read (custom string) - "Read string by ignoring trailing padding characters." - (let ((last (length string)) - (padding (custom-padding custom))) - (while (and (> last 0) - (eq (aref string (1- last)) padding)) - (setq last (1- last))) - (substring string 0 last))) - -(defun custom-string-write (custom string) - "Write raw string." - string) - -(defun custom-button-insert (custom level) - "Insert field for CUSTOM at nesting LEVEL in customization buffer." - (custom-tag-insert (concat "[" (custom-tag custom) "]") - (custom-property custom 'query)) - (custom-documentation-insert custom) - nil) - -(defun custom-default-export (custom value) - ;; Convert CUSTOM's VALUE to external representation. - ;; See `custom-import'. - (if (custom-eval custom value) - (eval (car (custom-quote custom value))) - value)) - -(defun custom-default-quote (custom value) - "Quote CUSTOM's VALUE if necessary." - (list (if (and (not (custom-eval custom value)) - (or (and (symbolp value) - value - (not (eq t value))) - (and (listp value) - value - (not (memq (car value) '(quote function lambda)))))) - (list 'quote value) - value))) - -(defun custom-default-initialize (custom) - "Initialize `doc' and `default' entries in CUSTOM." - (let ((name (custom-name custom))) - (if (null name) - () - (let ((default (custom-default custom)) - (doc (custom-documentation custom)) - (vdoc (documentation-property name 'variable-documentation t))) - (if doc - (or vdoc (put name 'variable-documentation doc)) - (if vdoc (custom-property-set custom 'doc vdoc))) - (if (eq default custom-nil) - (if (boundp name) - (custom-property-set custom 'default (symbol-value name))) - (or (boundp name) - (set name default))))))) - -(defun custom-default-insert (custom level) - "Insert field for CUSTOM at nesting LEVEL in customization buffer." - (let ((field (custom-field-create custom custom-nil)) - (tag (custom-tag custom))) - (if (null tag) - () - (custom-tag-insert tag field) - (custom-text-insert ": ")) - (custom-field-insert field) - (custom-documentation-insert custom) - field)) - -(defun custom-default-accept (field value &optional original) - "Store a new value into field FIELD, taking it from VALUE." - (if original - (custom-field-original-set field value)) - (custom-field-value-set field value) - (custom-field-update field)) - -(defun custom-default-apply (field) - "Apply any changes in FIELD since the last apply." - (let* ((custom (custom-field-custom field)) - (name (custom-name custom))) - (if (null name) - (error "This field cannot be applied alone")) - (custom-external-set name (custom-name-value name)) - (custom-field-reset field))) - -(defun custom-default-reset (field) - "Reset content of editing FIELD to `original'." - (custom-field-accept field (custom-field-original field) t)) - -(defun custom-default-factory-reset (field) - "Reset content of editing FIELD to `default'." - (let* ((custom (custom-field-custom field)) - (default (car (custom-import custom (custom-default custom))))) - (or (eq default custom-nil) - (custom-field-accept field default nil)))) - -(defun custom-default-query (field) - "Prompt for a FIELD" - (let* ((custom (custom-field-custom field)) - (value (custom-field-value field)) - (initial (custom-write custom value)) - (prompt (concat (custom-prompt custom) ": "))) - (custom-field-accept field - (custom-read custom - (if (custom-valid custom value) - (read-string prompt (cons initial 1)) - (read-string prompt)))))) - -(defun custom-default-match (custom values) - "Match CUSTOM with VALUES." - values) - -(defun custom-default-extract (custom field) - "Extract CUSTOM's content in FIELD." - (list (custom-field-value field))) - -(defun custom-default-validate (custom field) - "Validate FIELD." - (let ((value (custom-field-value field)) - (start (custom-field-start field))) - (cond ((eq value custom-nil) - (cons start "Uninitialized field")) - ((and (consp value) (eq (car value) custom-invalid)) - (cons start "Unparsable field content")) - ((custom-valid custom value) - nil) - (t - (cons start "Wrong type of field content"))))) +(defun custom-display-match-frame (display frame) + "Non-nil iff DISPLAY matches FRAME. +If FRAME is nil, the current FRAME is used." + ;; This is a kludge to get started, we really should use specifiers! + (unless frame + (setq frame (selected-frame))) + (if (eq display t) + t + (let ((match t)) + (while (and display match) + (let* ((entry (car display)) + (req (car entry)) + (options (cdr entry))) + (setq display (cdr display)) + (cond ((eq req 'type) + (let ((type (if (fboundp 'device-type) + (device-type (frame-device frame)) + window-system))) + (setq match (memq type options)))) + ((eq req 'class) + (let ((class (if (fboundp 'device-class) + (device-class (frame-device frame)) + (frame-property frame 'display-type)))) + (setq match (memq class options)))) + ((eq req 'background) + (let ((background (or custom-background-mode + (frame-property frame 'background-mode) + (custom-background-mode)))) + (setq match (memq background options)))) + (t + (error "Unknown req `%S' with options `%S'" req options))))) + match))) -(defun custom-default-face (field) - "Face used for a FIELD." - (let ((value (custom-field-value field))) - (cond ((eq value custom-nil) - custom-field-uninitialized-face) - ((not (custom-valid (custom-field-custom field) value)) - custom-field-invalid-face) - ((not (equal (custom-field-original field) value)) - custom-field-modified-face) - (t - custom-field-face)))) +(defconst custom-face-attributes + '((:bold (toggle :format "Bold: %v") custom-set-face-bold) + (:italic (toggle :format "Italic: %v") custom-set-face-italic) + (:underline + (toggle :format "Underline: %v") set-face-underline-p) + (:foreground (color :tag "Foreground") set-face-foreground) + (:background (color :tag "Background") set-face-background) + (:stipple (editable-field :format "Stipple: %v") set-face-stipple)) + "Alist of face attributes. -(defun custom-default-update (field) - "Update the content of FIELD." - (let ((inhibit-point-motion-hooks t) - (before-change-functions nil) - (after-change-functions nil) - (start (custom-field-start field)) - (end (custom-field-end field)) - (pos (point))) - ;; Keep track of how many modified fields we have. - (cond ((equal (custom-field-value field) (custom-field-original field)) - (setq custom-modified-list (delq field custom-modified-list))) - ((memq field custom-modified-list)) - (t - (setq custom-modified-list (cons field custom-modified-list)))) - ;; Update the field. - (goto-char end) - (insert-before-markers " ") - (delete-region start (1- end)) - (goto-char start) - (custom-field-insert field) - (goto-char end) - (delete-char 1) - (goto-char pos) - (and (<= start pos) - (<= pos end) - (custom-field-enter field)))) +The elements are of the form (KEY TYPE SET) where KEY is a symbol +identifying the attribute, TYPE is a widget type for editing the +attibute, SET is a function for setting the attribute value. -;;; Create Buffer: -;; -;; Public functions to create a customization buffer and to insert -;; various forms of text, fields, and buttons in it. - -(defun customize () - "Customize GNU Emacs. -Create a *Customize* buffer with editable customization information -about GNU Emacs." - (interactive) - (custom-buffer-create "*Customize*") - (custom-reset-all)) +The SET function should take three arguments, the face to modify, the +value of the attribute, and optionally the frame where the face should +be changed.") -(defun custom-buffer-create (name &optional custom types set get save) - "Create a customization buffer named NAME. -If the optional argument CUSTOM is non-nil, use that as the custom declaration. -If the optional argument TYPES is non-nil, use that as the local types. -If the optional argument SET is non-nil, use that to set external data. -If the optional argument GET is non-nil, use that to get external data. -If the optional argument SAVE is non-nil, use that for saving changes." - (switch-to-buffer name) - (buffer-disable-undo (current-buffer)) - (custom-mode) - (setq custom-local-type-properties types) - (if (null custom) - () - (make-local-variable 'custom-data) - (setq custom-data custom)) - (if (null set) - () - (make-local-variable 'custom-external-set) - (setq custom-external-set set)) - (if (null get) - () - (make-local-variable 'custom-external) - (setq custom-external get)) - (if (null save) - () - (make-local-variable 'custom-save) - (setq custom-save save)) - (let ((inhibit-point-motion-hooks t) - (before-change-functions nil) - (after-change-functions nil)) - (erase-buffer) - (insert "\n") - (goto-char (point-min)) - (custom-text-insert "This is a customization buffer.\n") - (custom-help-insert "\n") - (custom-help-button 'custom-forward-field) - (custom-help-button 'custom-backward-field) - (custom-help-button 'custom-enter-value) - (custom-help-button 'custom-field-factory-reset) - (custom-help-button 'custom-field-reset) - (custom-help-button 'custom-field-apply) - (custom-help-button 'custom-save-and-exit) - (custom-help-button 'custom-toggle-documentation) - (custom-help-insert "\nClick mouse-2 on any button to activate it.\n") - (custom-text-insert "\n") - (custom-insert custom-data 0) - (goto-char (point-min)))) +(when (string-match "XEmacs" emacs-version) + ;; Support for special XEmacs font attributes. + (require 'font) + + (unless (fboundp 'face-font-name) + (defun face-font-name (face &rest args) + (apply 'face-font face args))) -(defun custom-insert (custom level) - "Insert custom declaration CUSTOM in current buffer at level LEVEL." - (if (stringp custom) - (progn - (custom-text-insert custom) - nil) - (and level (null (custom-property custom 'header)) - (setq level nil)) - (and level - (> level 0) - (custom-text-insert (concat "\n" (make-string level ?*) " "))) - (let ((field (funcall (custom-property custom 'insert) custom level))) - (custom-name-enter (custom-name custom) field) - field))) - -(defun custom-text-insert (text) - "Insert TEXT in current buffer." - (insert text)) - -(defun custom-tag-insert (tag field &optional data) - "Insert TAG for FIELD in current buffer." - (let ((from (point))) - (insert tag) - (custom-category-set from (point) 'custom-button-properties) - (custom-put-text-property from (point) 'custom-tag field) - (if data - (custom-add-text-properties from (point) (list 'custom-data data))))) + (defun set-face-font-size (face size &rest args) + "Set the font of FACE to SIZE" + (let* ((font (apply 'face-font-name face args)) + (fontobj (font-create-object font))) + (set-font-size fontobj size) + (apply 'set-face-font face fontobj args))) -(defun custom-documentation-insert (custom &rest ignore) - "Insert documentation from CUSTOM in current buffer." - (let ((doc (custom-documentation custom))) - (if (null doc) - () - (custom-help-insert "\n" doc)))) - -(defun custom-help-insert (&rest args) - "Insert ARGS as documentation text." - (let ((from (point))) - (apply 'insert args) - (custom-category-set from (point) 'custom-documentation-properties))) - -(defun custom-help-button (command) - "Describe how to execute COMMAND." - (let ((from (point))) - (insert "`" (key-description (where-is-internal command nil t)) "'") - (custom-set-text-properties from (point) - (list 'face custom-button-face - mouse-face custom-mouse-face - 'custom-jump t ;Make TAB jump over it. - 'custom-tag command - 'start-open t - 'end-open t)) - (custom-category-set from (point) 'custom-documentation-properties)) - (custom-help-insert ": " (custom-first-line (documentation command)) "\n")) - -;;; Mode: -;; -;; The Customization major mode and interactive commands. + (defun set-face-font-family (face family &rest args) + "Set the font of FACE to FAMILY" + (let* ((font (apply 'face-font-name face args)) + (fontobj (font-create-object font))) + (set-font-family fontobj family) + (apply 'set-face-font face fontobj args))) -(defvar custom-mode-map nil - "Keymap for Custom Mode.") -(if custom-mode-map - nil - (setq custom-mode-map (make-sparse-keymap)) - (define-key custom-mode-map (if (string-match "XEmacs" emacs-version) [button2] [mouse-2]) 'custom-push-button) - (define-key custom-mode-map "\t" 'custom-forward-field) - (define-key custom-mode-map "\M-\t" 'custom-backward-field) - (define-key custom-mode-map "\r" 'custom-enter-value) - (define-key custom-mode-map "\C-k" 'custom-kill-line) - (define-key custom-mode-map "\C-c\C-r" 'custom-field-reset) - (define-key custom-mode-map "\C-c\M-\C-r" 'custom-reset-all) - (define-key custom-mode-map "\C-c\C-z" 'custom-field-factory-reset) - (define-key custom-mode-map "\C-c\M-\C-z" 'custom-factory-reset-all) - (define-key custom-mode-map "\C-c\C-a" 'custom-field-apply) - (define-key custom-mode-map "\C-c\M-\C-a" 'custom-apply-all) - (define-key custom-mode-map "\C-c\C-c" 'custom-save-and-exit) - (define-key custom-mode-map "\C-c\C-d" 'custom-toggle-documentation)) + (nconc custom-face-attributes + '((:family (editable-field :format "Family: %v") + set-face-font-family) + (:size (editable-field :format "Size: %v") + set-face-font-size)))) -;; C-c keymap ideas: C-a field-beginning, C-e field-end, C-f -;; forward-field, C-b backward-field, C-n next-field, C-p -;; previous-field, ? describe-field. - -(defun custom-mode () - "Major mode for doing customizations. - -\\{custom-mode-map}" - (kill-all-local-variables) - (setq major-mode 'custom-mode - mode-name "Custom") - (use-local-map custom-mode-map) - (make-local-variable 'before-change-functions) - (setq before-change-functions '(custom-before-change)) - (make-local-variable 'after-change-functions) - (setq after-change-functions '(custom-after-change)) - (if (not (fboundp 'make-local-hook)) - ;; Emacs 19.28 and earlier. - (add-hook 'post-command-hook - (lambda () - (if (eq major-mode 'custom-mode) - (custom-post-command)))) - ;; Emacs 19.29. - (make-local-hook 'post-command-hook) - (add-hook 'post-command-hook 'custom-post-command nil t))) +(defun custom-face-attribites-set (face frame &rest atts) + "For FACE on FRAME set the attributes [KEYWORD VALUE].... +Each keyword should be listed in `custom-face-attributes'. -(defun custom-forward-field (arg) - "Move point to the next field or button. -With optional ARG, move across that many fields." - (interactive "p") - (while (> arg 0) - (let ((next (if (get-text-property (point) 'custom-tag) - (next-single-property-change (point) 'custom-tag) - (point)))) - (setq next (or (next-single-property-change next 'custom-tag) - (next-single-property-change (point-min) 'custom-tag))) - (if next - (goto-char next) - (error "No customization fields in this buffer."))) - (or (get-text-property (point) 'custom-jump) - (setq arg (1- arg)))) - (while (< arg 0) - (let ((previous (if (get-text-property (1- (point)) 'custom-tag) - (previous-single-property-change (point) 'custom-tag) - (point)))) - (setq previous - (or (previous-single-property-change previous 'custom-tag) - (previous-single-property-change (point-max) 'custom-tag))) - (if previous - (goto-char previous) - (error "No customization fields in this buffer."))) - (or (get-text-property (1- (point)) 'custom-jump) - (setq arg (1+ arg))))) - -(defun custom-backward-field (arg) - "Move point to the previous field or button. -With optional ARG, move across that many fields." - (interactive "p") - (custom-forward-field (- arg))) +If FRAME is nil, set the default face." + (while atts + (let* ((name (nth 0 atts)) + (value (nth 1 atts)) + (fun (nth 2 (assq name custom-face-attributes)))) + (setq atts (cdr (cdr atts))) + (condition-case nil + (funcall fun face value) + (error nil))))) -(defun custom-toggle-documentation (&optional arg) - "Toggle display of documentation text. -If the optional argument is non-nil, show text iff the argument is positive." - (interactive "P") - (let ((hide (or (and (null arg) - (null (custom-category-get - 'custom-documentation-properties 'invisible))) - (<= (prefix-numeric-value arg) 0)))) - (custom-category-put 'custom-documentation-properties 'invisible hide) - (custom-category-put 'custom-documentation-properties intangible hide)) - (redraw-display)) - -(defun custom-enter-value (field data) - "Enter value for current customization field or push button." - (interactive (list (get-text-property (point) 'custom-tag) - (get-text-property (point) 'custom-data))) - (cond (data - (funcall field data)) - ((eq field 'custom-enter-value) - (error "Don't be silly")) - ((and (symbolp field) (fboundp field)) - (call-interactively field)) - (field - (custom-field-query field)) - (t - (message "Nothing to enter here")))) +(defun custom-set-face-bold (face value &optional frame) + "Set the bold property of FACE to VALUE." + (if value + (make-face-bold face frame) + (make-face-unbold face frame))) -(defun custom-kill-line () - "Kill to end of field or end of line, whichever is first." - (interactive) - (let ((field (get-text-property (point) 'custom-field)) - (newline (save-excursion (search-forward "\n"))) - (next (next-single-property-change (point) 'custom-field))) - (if (and field (> newline next)) - (kill-region (point) next) - (call-interactively 'kill-line)))) - -(defun custom-push-button (event) - "Activate button below mouse pointer." - (interactive "@e") - (let* ((pos (event-point event)) - (field (get-text-property pos 'custom-field)) - (tag (get-text-property pos 'custom-tag)) - (data (get-text-property pos 'custom-data))) - (cond (data - (funcall tag data)) - ((and (symbolp tag) (fboundp tag)) - (call-interactively tag)) - (field - (call-interactively (lookup-key global-map (this-command-keys)))) - (tag - (custom-enter-value tag data)) - (t - (error "Nothing to click on here."))))) +(defun custom-set-face-italic (face value &optional frame) + "Set the italic property of FACE to VALUE." + (if value + (make-face-italic face frame) + (make-face-unitalic face frame))) -(defun custom-reset-all () - "Undo any changes since the last apply in all fields." - (interactive (and custom-modified-list - (not (y-or-n-p "Discard all changes? ")) - (error "Reset aborted"))) - (let ((all custom-name-fields) - current field) - (while all - (setq current (car all) - field (cdr current) - all (cdr all)) - (custom-field-reset field)))) - -(defun custom-field-reset (field) - "Undo any changes in FIELD since the last apply." - (interactive (list (or (get-text-property (point) 'custom-field) - (get-text-property (point) 'custom-tag)))) - (if (arrayp field) - (let* ((custom (custom-field-custom field)) - (name (custom-name custom))) - (save-excursion - (if name - (custom-field-original-set - field (car (custom-import custom (custom-external name))))) - (if (not (custom-valid custom (custom-field-original field))) - (error "This field cannot be reset alone") - (funcall (custom-property custom 'reset) field) - (funcall (custom-property custom 'synchronize) field)))))) +;;;###autoload +(defun custom-initialize-faces (&optional frame) + "Initialize all custom faces for FRAME. +If FRAME is nil or omitted, initialize them for all frames." + (mapatoms (lambda (symbol) + (let ((spec (or (get symbol 'saved-face) + (get symbol 'factory-face)))) + (when spec + (custom-face-display-set symbol spec frame)))))) -(defun custom-factory-reset-all () - "Reset all field to their default values." - (interactive (and custom-modified-list - (not (y-or-n-p "Discard all changes? ")) - (error "Reset aborted"))) - (let ((all custom-name-fields) - field) - (while all - (setq field (cdr (car all)) - all (cdr all)) - (custom-field-factory-reset field)))) - -(defun custom-field-factory-reset (field) - "Reset FIELD to its default value." - (interactive (list (or (get-text-property (point) 'custom-field) - (get-text-property (point) 'custom-tag)))) - (if (arrayp field) - (save-excursion - (funcall (custom-property (custom-field-custom field) 'factory-reset) - field)))) +;;; Initializing. -(defun custom-apply-all () - "Apply any changes since the last reset in all fields." - (interactive (if custom-modified-list - nil - (error "No changes to apply."))) - (custom-field-parse custom-field-last) - (let ((all custom-name-fields) - field) - (while all - (setq field (cdr (car all)) - all (cdr all)) - (let ((error (custom-field-validate (custom-field-custom field) field))) - (if (null error) - () - (goto-char (car error)) - (error (cdr error)))))) - (let ((all custom-name-fields) - field) - (while all - (setq field (cdr (car all)) - all (cdr all)) - (custom-field-apply field)))) +;;;###autoload +(defun custom-set-variables (&rest args) + "Initialize variables according to user preferences. + +The arguments should be a list where each entry has the form: + + (SYMBOL VALUE [NOW]) -(defun custom-field-apply (field) - "Apply any changes in FIELD since the last apply." - (interactive (list (or (get-text-property (point) 'custom-field) - (get-text-property (point) 'custom-tag)))) - (custom-field-parse custom-field-last) - (if (arrayp field) - (let* ((custom (custom-field-custom field)) - (error (custom-field-validate custom field))) - (if error - (error (cdr error))) - (funcall (custom-property custom 'apply) field)))) - -(defun custom-toggle-hide (&rest ignore) - "Hide or show entry." - (interactive) - (error "This button is not yet implemented")) - -(defun custom-save-and-exit () - "Save and exit customization buffer." - (interactive "@") - (save-excursion - (funcall custom-save)) - (kill-buffer (current-buffer))) - -(defun custom-save () - "Save customization information." - (interactive) - (custom-apply-all) - (let ((new custom-name-fields)) - (set-buffer (find-file-noselect custom-file)) - (goto-char (point-min)) - (save-excursion - (let ((old (condition-case nil - (read (current-buffer)) - (end-of-file (append '(setq custom-dummy - 'custom-dummy) ()))))) - (or (eq (car old) 'setq) - (error "Invalid customization file: %s" custom-file)) - (while new - (let* ((field (cdr (car new))) - (custom (custom-field-custom field)) - (value (custom-field-original field)) - (default (car (custom-import custom (custom-default custom)))) - (name (car (car new)))) - (setq new (cdr new)) - (custom-assert '(eq name (custom-name custom))) - (if (equal default value) - (setcdr old (custom-plist-delq name (cdr old))) - (setcdr old (plist-put (cdr old) name - (car (custom-quote custom value))))))) - (erase-buffer) - (insert ";; " custom-file "\ - --- Automatically generated customization information. -;; -;; Feel free to edit by hand, but the entire content should consist of -;; a single setq. Any other lisp expressions will confuse the -;; automatic configuration engine. - -\(setq ") - (setq old (cdr old)) - (while old - (prin1 (car old) (current-buffer)) - (setq old (cdr old)) - (insert " ") - (pp (car old) (current-buffer)) - (setq old (cdr old)) - (if old (insert "\n "))) - (insert ")\n") - (save-buffer) - (kill-buffer (current-buffer)))))) - -(defun custom-load () - "Save customization information." - (interactive (and custom-modified-list - (not (equal (list (custom-name-field 'custom-file)) - custom-modified-list)) - (not (y-or-n-p "Discard all changes? ")) - (error "Load aborted"))) - (load-file (custom-name-value 'custom-file)) - (custom-reset-all)) - -;;; Field Editing: -;; -;; Various internal functions for implementing the direct editing of -;; fields in the customization buffer. +The unevaluated VALUE is stored as the saved value for SYMBOL. +If NOW is present and non-nil, VALUE is also evaluated and bound as +the default value for the SYMBOL." + (while args + (let ((entry (car args))) + (if (listp entry) + (let ((symbol (nth 0 entry)) + (value (nth 1 entry)) + (now (nth 2 entry))) + (put symbol 'saved-value (list value)) + (when now + (put symbol 'force-value t) + (set-default symbol (eval value))) + (setq args (cdr args))) + ;; Old format, a plist of SYMBOL VALUE pairs. + (let ((symbol (nth 0 args)) + (value (nth 1 args))) + (put symbol 'saved-value (list value))) + (setq args (cdr (cdr args))))))) -(defun custom-field-untouch (field) - ;; Remove FIELD and its children from `custom-modified-list'. - (setq custom-modified-list (delq field custom-modified-list)) - (if (arrayp field) - (let ((value (custom-field-value field))) - (cond ((null (custom-data (custom-field-custom field)))) - ((arrayp value) - (custom-field-untouch value)) - ((listp value) - (mapcar 'custom-field-untouch value)))))) - - -(defun custom-field-insert (field) - ;; Insert editing FIELD in current buffer. - (let ((from (point)) - (custom (custom-field-custom field)) - (value (custom-field-value field))) - (insert (custom-write custom value)) - (insert-char (custom-padding custom) - (- (custom-width custom) (- (point) from))) - (custom-field-move field from (point)) - (custom-set-text-properties - from (point) - (list 'custom-field field - 'custom-tag field - 'face (custom-field-face field) - 'start-open t - 'end-open t)))) +;;;###autoload +(defun custom-set-faces (&rest args) + "Initialize faces according to user preferences. +The arguments should be a list where each entry has the form: -(defun custom-field-read (field) - ;; Read the screen content of FIELD. - (custom-read (custom-field-custom field) - (custom-buffer-substring-no-properties (custom-field-start field) - (custom-field-end field)))) - -;; Fields are shown in a special `active' face when point is inside -;; it. You activate the field by moving point inside (entering) it -;; and deactivate the field by moving point outside (leaving) it. - -(defun custom-field-leave (field) - ;; Deactivate FIELD. - (let ((before-change-functions nil) - (after-change-functions nil)) - (custom-put-text-property (custom-field-start field) (custom-field-end field) - 'face (custom-field-face field)))) + (FACE SPEC [NOW]) -(defun custom-field-enter (field) - ;; Activate FIELD. - (let* ((start (custom-field-start field)) - (end (custom-field-end field)) - (custom (custom-field-custom field)) - (padding (custom-padding custom)) - (before-change-functions nil) - (after-change-functions nil)) - (or (eq this-command 'self-insert-command) - (let ((pos end)) - (while (and (< start pos) - (eq (char-after (1- pos)) padding)) - (setq pos (1- pos))) - (if (< pos (point)) - (goto-char pos)))) - (custom-put-text-property start end 'face custom-field-active-face))) +SPEC will be stored as the saved value for FACE. If NOW is present +and non-nil, FACE will also be created according to SPEC. -(defun custom-field-resize (field) - ;; Resize FIELD after change. - (let* ((custom (custom-field-custom field)) - (begin (custom-field-start field)) - (end (custom-field-end field)) - (pos (point)) - (padding (custom-padding custom)) - (width (custom-width custom)) - (size (- end begin))) - (cond ((< size width) - (goto-char end) - (if (fboundp 'insert-before-markers-and-inherit) - ;; Emacs 19. - (insert-before-markers-and-inherit - (make-string (- width size) padding)) - ;; XEmacs: BUG: Doesn't work! - (insert-before-markers (make-string (- width size) padding))) - (goto-char pos)) - ((> size width) - (let ((start (if (and (< (+ begin width) pos) (<= pos end)) - pos - (+ begin width)))) - (goto-char end) - (while (and (< start (point)) (= (preceding-char) padding)) - (backward-delete-char 1)) - (goto-char pos)))))) - -(defvar custom-field-changed nil) -;; List of fields changed on the screen but whose VALUE attribute has -;; not yet been updated to reflect the new screen content. -(make-variable-buffer-local 'custom-field-changed) +See `defface' for the format of SPEC." + (while args + (let ((entry (car args))) + (if (listp entry) + (let ((face (nth 0 entry)) + (spec (nth 1 entry)) + (now (nth 2 entry))) + (put face 'saved-face spec) + (when now + (put face 'force-face t) + (custom-face-display-set face spec)) + (setq args (cdr args))) + ;; Old format, a plist of FACE SPEC pairs. + (let ((face (nth 0 args)) + (spec (nth 1 args))) + (put face 'saved-face spec)) + (setq args (cdr (cdr args))))))) -(defun custom-field-parse (field) - ;; Parse FIELD content iff changed. - (if (memq field custom-field-changed) - (progn - (setq custom-field-changed (delq field custom-field-changed)) - (custom-field-value-set field (custom-field-read field)) - (custom-field-update field)))) +;;; Meta Customization -(defun custom-post-command () - ;; Keep track of their active field. - (custom-assert '(eq major-mode 'custom-mode)) - (let ((field (custom-field-property (point)))) - (if (eq field custom-field-last) - (if (memq field custom-field-changed) - (custom-field-resize field)) - (custom-field-parse custom-field-last) - (if custom-field-last - (custom-field-leave custom-field-last)) - (if field - (custom-field-enter field)) - (setq custom-field-last field)) - (set-buffer-modified-p (or custom-modified-list - custom-field-changed)))) - -(defvar custom-field-was nil) -;; The custom data before the change. -(make-variable-buffer-local 'custom-field-was) - -(defun custom-before-change (begin end) - ;; Check that we the modification is allowed. - (if (not (eq major-mode 'custom-mode)) - (message "Aargh! Why is custom-before-change called here?") - (let ((from (custom-field-property begin)) - (to (custom-field-property end))) - (cond ((or (null from) (null to)) - (error "You can only modify the fields")) - ((not (eq from to)) - (error "Changes must be limited to a single field.")) - (t - (setq custom-field-was from)))))) +(defgroup emacs nil + "Customization of the One True Editor." + :link '(custom-manual "(emacs)Top")) -(defun custom-after-change (begin end length) - ;; Keep track of field content. - (if (not (eq major-mode 'custom-mode)) - (message "Aargh! Why is custom-after-change called here?") - (let ((field custom-field-was)) - (custom-assert '(prog1 field (setq custom-field-was nil))) - ;; Prevent mixing fields properties. - (custom-put-text-property begin end 'custom-field field) - ;; Update the field after modification. - (if (eq (custom-field-property begin) field) - (let ((field-end (custom-field-end field))) - (if (> end field-end) - (set-marker field-end end)) - (add-to-list 'custom-field-changed field)) - ;; We deleted the entire field, reinsert it. - (custom-assert '(eq begin end)) - (save-excursion - (goto-char begin) - (custom-field-value-set field - (custom-read (custom-field-custom field) "")) - (custom-field-insert field)))))) - -(defun custom-field-property (pos) - ;; The `custom-field' text property valid for POS. - (or (get-text-property pos 'custom-field) - (and (not (eq pos (point-min))) - (get-text-property (1- pos) 'custom-field)))) - -;;; Generic Utilities: -;; -;; Some utility functions that are not really specific to custom. - -(defun custom-assert (expr) - "Assert that EXPR evaluates to non-nil at this point" - (or (eval expr) - (error "Assertion failed: %S" expr))) +(defgroup customize nil + "Customization of the Customization support." + :link '(custom-manual "(custom)Top") + :link '(url-link :tag "Development Page" + "http://www.dina.kvl.dk/~abraham/custom/") + :prefix "custom-" + :group 'emacs) -(defun custom-first-line (string) - "Return the part of STRING before the first newline." - (let ((pos 0) - (len (length string))) - (while (and (< pos len) (not (eq (aref string pos) ?\n))) - (setq pos (1+ pos))) - (if (eq pos len) - string - (substring string 0 pos)))) +(defcustom custom-define-hook nil + "Hook called after defining each customize option." + :group 'customize + :type 'hook) -(defun custom-insert-before (list old new) - "In LIST insert before OLD a NEW element." - (cond ((null list) - (list new)) - ((null old) - (nconc list (list new))) - ((eq old (car list)) - (cons new list)) - (t - (let ((list list)) - (while (not (eq old (car (cdr list)))) - (setq list (cdr list)) - (custom-assert '(cdr list))) - (setcdr list (cons new (cdr list)))) - list))) - -(defun custom-strip-padding (string padding) - "Remove padding from STRING." - (let ((regexp (concat (regexp-quote (char-to-string padding)) "+"))) - (while (string-match regexp string) - (setq string (concat (substring string 0 (match-beginning 0)) - (substring string (match-end 0)))))) - string) - -(defun custom-plist-memq (prop plist) - "Return non-nil if PROP is a property of PLIST. Comparison done with EQ." - (let (result) - (while plist - (if (eq (car plist) prop) - (setq result plist - plist nil) - (setq plist (cdr (cdr plist))))) - result)) +;;; Menu support -(defun custom-plist-delq (prop plist) - "Delete property PROP from property list PLIST." - (while (eq (car plist) prop) - (setq plist (cdr (cdr plist)))) - (let ((list plist) - (next (cdr (cdr plist)))) - (while next - (if (eq (car next) prop) - (progn - (setq next (cdr (cdr next))) - (setcdr (cdr list) next)) - (setq list next - next (cdr (cdr next)))))) - plist) - -;;; Meta Customization: +(defconst custom-help-menu '("Customize" + ["Update menu..." custom-menu-update t] + ["Group..." customize t] + ["Variable..." customize-variable t] + ["Face..." customize-face t] + ["Saved..." customize-customized t] + ["Apropos..." customize-apropos t]) + "Customize menu") -(custom-declare '() - '((tag . "Meta Customization") - (doc . "Customization of the customization support.") - (type . group) - (data ((type . face-doc)) - ((tag . "Button Face") - (default . bold) - (doc . "Face used for tags in customization buffers.") - (name . custom-button-face) - (synchronize . (lambda (f) - (custom-category-put 'custom-button-properties - 'face custom-button-face))) - (type . face)) - ((tag . "Mouse Face") - (default . highlight) - (doc . "\ -Face used when mouse is above a button in customization buffers.") - (name . custom-mouse-face) - (synchronize . (lambda (f) - (custom-category-put 'custom-button-properties - mouse-face - custom-mouse-face))) - (type . face)) - ((tag . "Field Face") - (default . italic) - (doc . "Face used for customization fields.") - (name . custom-field-face) - (type . face)) - ((tag . "Uninitialized Face") - (default . modeline) - (doc . "Face used for uninitialized customization fields.") - (name . custom-field-uninitialized-face) - (type . face)) - ((tag . "Invalid Face") - (default . highlight) - (doc . "\ -Face used for customization fields containing invalid data.") - (name . custom-field-invalid-face) - (type . face)) - ((tag . "Modified Face") - (default . bold-italic) - (doc . "Face used for modified customization fields.") - (name . custom-field-modified-face) - (type . face)) - ((tag . "Active Face") - (default . underline) - (doc . "\ -Face used for customization fields while they are being edited.") - (name . custom-field-active-face) - (type . face))))) +(defun custom-menu-reset () + "Reset customize menu." + (remove-hook 'custom-define-hook 'custom-menu-reset) + (if (fboundp 'add-submenu) + (add-submenu '("Help") custom-help-menu) + (define-key global-map [menu-bar help-menu customize-menu] + (cons (car custom-help-menu) + (easy-menu-create-keymaps (car custom-help-menu) + (cdr custom-help-menu)))))) -;; custom.el uses two categories. - -(custom-category-create 'custom-documentation-properties) -(custom-category-put 'custom-documentation-properties rear-nonsticky t) +(custom-menu-reset) -(custom-category-create 'custom-button-properties) -(custom-category-put 'custom-button-properties 'face custom-button-face) -(custom-category-put 'custom-button-properties mouse-face custom-mouse-face) -(custom-category-put 'custom-button-properties rear-nonsticky t) - -(custom-category-create 'custom-hidden-properties) -(custom-category-put 'custom-hidden-properties 'invisible - (not (string-match "XEmacs" emacs-version))) -(custom-category-put 'custom-hidden-properties intangible t) - -(if (file-readable-p custom-file) - (load-file custom-file)) +;;; The End. (provide 'custom) -;;; custom.el ends here +;; custom.el ends here diff -r ad457d5f7d04 -r 0293115a14e9 lisp/gnus/dgnushack.el --- a/lisp/gnus/dgnushack.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/gnus/dgnushack.el Mon Aug 13 08:49:20 2007 +0200 @@ -1,5 +1,5 @@ ;;; dgnushack.el --- a hack to set the load path for byte-compiling -;; Copyright (C) 1994,95,96 Free Software Foundation, Inc. +;; Copyright (C) 1994,95,96,97 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; Version: 4.19 @@ -26,25 +26,37 @@ ;;; Code: +(fset 'facep 'ignore) + (require 'cl) -(setq load-path (cons "." load-path)) - -(setq custom-file "/THIS FILE DOES NOT eXiST!") +(require 'bytecomp) +(push "." load-path) +(require 'lpath) (defalias 'device-sound-enabled-p 'ignore) (defalias 'play-sound-file 'ignore) (defalias 'nndb-request-article 'ignore) (defalias 'efs-re-read-dir 'ignore) (defalias 'ange-ftp-re-read-dir 'ignore) +(defalias 'define-mail-user-agent 'ignore) + +(eval-and-compile + (unless (string-match "XEmacs" emacs-version) + (fset 'get-popup-menu-response 'ignore) + (fset 'event-object 'ignore) + (fset 'x-defined-colors 'ignore) + (fset 'read-color 'ignore))) (defun dgnushack-compile () - ;(setq byte-compile-dynamic t) + ;;(setq byte-compile-dynamic t) (let ((files (directory-files "." nil ".el$")) (xemacs (string-match "XEmacs" emacs-version)) - byte-compile-warnings file) - (while files - (setq file (car files) - files (cdr files)) + ;;(byte-compile-generate-call-tree t) + byte-compile-warnings file elc) + (condition-case () + (require 'w3-forms) + (error (setq files (delete "nnweb.el" files)))) + (while (setq file (pop files)) (cond ((or (string= file "custom.el") (string= file "browse-url.el")) (setq byte-compile-warnings nil)) @@ -58,9 +70,10 @@ "messagexmas.el" "nnheaderxm.el" "smiley.el"))) xemacs) - (condition-case () - (byte-compile-file file) - (error nil)))))) + (when (or (not (file-exists-p (setq elc (concat file "c")))) + (file-newer-than-file-p file elc)) + (ignore-errors + (byte-compile-file file))))))) (defun dgnushack-recompile () (require 'gnus) diff -r ad457d5f7d04 -r 0293115a14e9 lisp/gnus/earcon.el --- a/lisp/gnus/earcon.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/gnus/earcon.el Mon Aug 13 08:49:20 2007 +0200 @@ -30,19 +30,30 @@ (defvar running-xemacs (string-match "XEmacs\\|Lucid" emacs-version))) (require 'gnus) -(require 'gnus-sound) +(require 'gnus-audio) +(require 'gnus-art) (eval-when-compile (require 'cl)) -(defvar earcon-auto-play nil - "When True, automatially play sounds as well as buttonize them.") +(defgroup earcon nil + "Turn ** sounds ** into noise." + :group 'gnus-visual) + +(defcustom earcon-auto-play nil + "When True, automatically play sounds as well as buttonize them." + :type 'boolean + :group 'earcon) -(defvar earcon-prefix "**" - "The start of an earcon") +(defcustom earcon-prefix "**" + "String denoting the start of an earcon." + :type 'string + :group 'earcon) -(defvar earcon-suffix "**" - "The end of an earcon") +(defcustom earcon-suffix "**" + "String denoting the end of an earcon." + :type 'string + :group 'earcon) -(defvar earcon-regexp-alist +(defcustom earcon-regexp-alist '(("boring" 1 "Boring.au") ("evil[ \t]+laugh" 1 "Evil_Laugh.au") ("gag\\|puke" 1 "Puke.au") @@ -51,7 +62,7 @@ ("sob\\|boohoo" 1 "cry.wav") ("drum[ \t]*roll" 1 "drumroll.au") ("blast" 1 "explosion.au") - ("flush" 1 "flush.au") + ("flush\\|plonk!*" 1 "flush.au") ("kiss" 1 "kiss.wav") ("tee[ \t]*hee" 1 "laugh.au") ("shoot" 1 "shotgun.wav") @@ -59,7 +70,11 @@ ("cackle" 1 "witch.au") ("yell\\|roar" 1 "yell2.au") ("whoop-de-doo" 1 "whistle.au")) - "A list of regexps to map earcons to real sounds.") + "A list of regexps to map earcons to real sounds." + :type '(repeat (list regexp + (integer :tag "Match") + (string :tag "Sound"))) + :group 'earcon) (defvar earcon-button-marker-list nil) (make-variable-buffer-local 'earcon-button-marker-list) @@ -154,7 +169,7 @@ (goto-char marker) (let* ((entry (earcon-button-entry)) (inhibit-point-motion-hooks t) - (fun 'gnus-sound-play) + (fun 'gnus-audio-play) (args (list (nth 2 entry)))) (cond ((fboundp fun) @@ -193,10 +208,10 @@ (setq beg (point)) (while (setq entry (pop alist)) (setq regexp (concat (regexp-quote earcon-prefix) - ".*\\(" - (car entry) - "\\).*" - (regexp-quote earcon-suffix))) + ".*\\(" + (car entry) + "\\).*" + (regexp-quote earcon-suffix))) (goto-char beg) (while (re-search-forward regexp nil t) (let* ((start (and entry (match-beginning 1))) @@ -206,7 +221,7 @@ start end 'earcon-button-push (car (push (set-marker (make-marker) from) earcon-button-marker-list))) - (gnus-sound-play (caddr entry)))))))) + (gnus-audio-play (caddr entry)))))))) ;;;###autoload (defun gnus-earcon-display () diff -r ad457d5f7d04 -r 0293115a14e9 lisp/gnus/gnus-art.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus/gnus-art.el Mon Aug 13 08:49:20 2007 +0200 @@ -0,0 +1,2995 @@ +;;; gnus-art.el --- article mode commands for Gnus +;; Copyright (C) 1996,97 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen +;; Keywords: news + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;;; Code: + +(require 'custom) +(require 'gnus) +(require 'gnus-sum) +(require 'gnus-spec) +(require 'gnus-int) +(require 'browse-url) + +(defgroup gnus-article nil + "Article display." + :link '(custom-manual "(gnus)The Article Buffer") + :group 'gnus) + +(defgroup gnus-article-hiding nil + "Hiding article parts." + :link '(custom-manual "(gnus)Article Hiding") + :group 'gnus-article) + +(defgroup gnus-article-highlight nil + "Article highlighting." + :link '(custom-manual "(gnus)Article Highlighting") + :group 'gnus-article + :group 'gnus-visual) + +(defgroup gnus-article-signature nil + "Article signatures." + :link '(custom-manual "(gnus)Article Signature") + :group 'gnus-article) + +(defgroup gnus-article-headers nil + "Article headers." + :link '(custom-manual "(gnus)Hiding Headers") + :group 'gnus-article) + +(defgroup gnus-article-washing nil + "Special commands on articles." + :link '(custom-manual "(gnus)Article Washing") + :group 'gnus-article) + +(defgroup gnus-article-emphasis nil + "Fontisizing articles." + :link '(custom-manual "(gnus)Article Fontisizing") + :group 'gnus-article) + +(defgroup gnus-article-saving nil + "Saving articles." + :link '(custom-manual "(gnus)Saving Articles") + :group 'gnus-article) + +(defgroup gnus-article-mime nil + "Worshiping the MIME wonder." + :link '(custom-manual "(gnus)Using MIME") + :group 'gnus-article) + +(defgroup gnus-article-buttons nil + "Pushable buttons in the article buffer." + :link '(custom-manual "(gnus)Article Buttons") + :group 'gnus-article) + +(defgroup gnus-article-various nil + "Other article options." + :link '(custom-manual "(gnus)Misc Article") + :group 'gnus-article) + +(defcustom gnus-ignored-headers + '("^Path:" "^Posting-Version:" "^Article-I.D.:" "^Expires:" + "^Date-Received:" "^References:" "^Control:" "^Xref:" "^Lines:" + "^Posted:" "^Relay-Version:" "^Message-ID:" "^Nf-ID:" "^Nf-From:" + "^Approved:" "^Sender:" "^Received:" "^Mail-from:") + "All headers that match this regexp will be hidden. +This variable can also be a list of regexps of headers to be ignored. +If `gnus-visible-headers' is non-nil, this variable will be ignored." + :type '(choice :custom-show nil + regexp + (repeat regexp)) + :group 'gnus-article-hiding) + +(defcustom gnus-visible-headers + "^From:\\|^Newsgroups:\\|^Subject:\\|^Date:\\|^Followup-To:\\|^Reply-To:\\|^Organization:\\|^Summary:\\|^Keywords:\\|^To:\\|^Cc:\\|^Posted-To:\\|^Mail-Copies-To:\\|^Apparently-To:\\|^Gnus-Warning:\\|^Resent-From" + "All headers that do not match this regexp will be hidden. +This variable can also be a list of regexp of headers to remain visible. +If this variable is non-nil, `gnus-ignored-headers' will be ignored." + :type '(repeat :value-to-internal (lambda (widget value) + (custom-split-regexp-maybe value)) + :match (lambda (widget value) + (or (stringp value) + (widget-editable-list-match widget value))) + regexp) + :group 'gnus-article-hiding) + +(defcustom gnus-sorted-header-list + '("^From:" "^Subject:" "^Summary:" "^Keywords:" "^Newsgroups:" "^To:" + "^Cc:" "^Date:" "^Organization:") + "This variable is a list of regular expressions. +If it is non-nil, headers that match the regular expressions will +be placed first in the article buffer in the sequence specified by +this list." + :type '(repeat regexp) + :group 'gnus-article-hiding) + +(defcustom gnus-boring-article-headers '(empty followup-to reply-to) + "Headers that are only to be displayed if they have interesting data. +Possible values in this list are `empty', `newsgroups', `followup-to', +`reply-to', and `date'." + :type '(set (const :tag "Headers with no content." empty) + (const :tag "Newsgroups with only one group." newsgroups) + (const :tag "Followup-to identical to newsgroups." followup-to) + (const :tag "Reply-to identical to from." reply-to) + (const :tag "Date less than four days old." date)) + :group 'gnus-article-hiding) + +(defcustom gnus-signature-separator '("^-- $" "^-- *$") + "Regexp matching signature separator. +This can also be a list of regexps. In that case, it will be checked +from head to tail looking for a separator. Searches will be done from +the end of the buffer." + :type '(repeat string) + :group 'gnus-article-signature) + +(defcustom gnus-signature-limit nil + "Provide a limit to what is considered a signature. +If it is a number, no signature may not be longer (in characters) than +that number. If it is a floating point number, no signature may be +longer (in lines) than that number. If it is a function, the function +will be called without any parameters, and if it returns nil, there is +no signature in the buffer. If it is a string, it will be used as a +regexp. If it matches, the text in question is not a signature." + :type '(choice integer number function regexp) + :group 'gnus-article-signature) + +(defcustom gnus-hidden-properties '(invisible t intangible t) + "Property list to use for hiding text." + :type 'sexp + :group 'gnus-article-hiding) + +(defcustom gnus-article-x-face-command + "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | xv -quit -" + "String or function to be executed to display an X-Face header. +If it is a string, the command will be executed in a sub-shell +asynchronously. The compressed face will be piped to this command." + :type 'string ;Leave function case to Lisp. + :group 'gnus-article-washing) + +(defcustom gnus-article-x-face-too-ugly nil + "Regexp matching posters whose face shouldn't be shown automatically." + :type 'regexp + :group 'gnus-article-washing) + +(defcustom gnus-emphasis-alist + (let ((format + "\\(\\s-\\|^\\|[-\"\(]\\)\\(%s\\(\\w+\\(\\s-+\\w+\\)*[.,]?\\)%s\\)\\(\\s-\\|[-?!.,;:\"\)]\\)") + (types + '(("_" "_" underline) + ("/" "/" italic) + ("\\*" "\\*" bold) + ("_/" "/_" underline-italic) + ("_\\*" "\\*_" underline-bold) + ("\\*/" "/\\*" bold-italic) + ("_\\*/" "/\\*_" underline-bold-italic)))) + `(("\\(\\s-\\|^\\)\\(_\\(\\(\\w\\|_[^_]\\)+\\)_\\)\\(\\s-\\|[?!.,;]\\)" + 2 3 gnus-emphasis-underline) + ,@(mapcar + (lambda (spec) + (list + (format format (car spec) (cadr spec)) + 2 3 (intern (format "gnus-emphasis-%s" (caddr spec))))) + types))) + "Alist that says how to fontify certain phrases. +Each item looks like this: + + (\"_\\\\(\\\\w+\\\\)_\" 0 1 'underline) + +The first element is a regular expression to be matched. The second +is a number that says what regular expression grouping used to find +the entire emphasized word. The third is a number that says what +regexp grouping should be displayed and highlighted. The fourth +is the face used for highlighting." + :type '(repeat (list :value ("" 0 0 default) + regexp + (integer :tag "Match group") + (integer :tag "Emphasize group") + face)) + :group 'gnus-article-emphasis) + +(defface gnus-emphasis-bold '((t (:bold t))) + "Face used for displaying strong emphasized text (*word*)." + :group 'gnus-article-emphasis) + +(defface gnus-emphasis-italic '((t (:italic t))) + "Face used for displaying italic emphasized text (/word/)." + :group 'gnus-article-emphasis) + +(defface gnus-emphasis-underline '((t (:underline t))) + "Face used for displaying underlined emphasized text (_word_)." + :group 'gnus-article-emphasis) + +(defface gnus-emphasis-underline-bold '((t (:bold t :underline t))) + "Face used for displaying underlined bold emphasized text (_*word*_)." + :group 'gnus-article-emphasis) + +(defface gnus-emphasis-underline-italic '((t (:italic t :underline t))) + "Face used for displaying underlined italic emphasized text (_*word*_)." + :group 'gnus-article-emphasis) + +(defface gnus-emphasis-bold-italic '((t (:bold t :italic t))) + "Face used for displaying bold italic emphasized text (/*word*/)." + :group 'gnus-article-emphasis) + +(defface gnus-emphasis-underline-bold-italic + '((t (:bold t :italic t :underline t))) + "Face used for displaying underlined bold italic emphasized text. +Esample: (_/*word*/_)." + :group 'gnus-article-emphasis) + +(defcustom gnus-article-time-format "%a, %b %d %Y %T %Z" + "Format for display of Date headers in article bodies. +See `format-time-zone' for the possible values." + :type 'string + :link '(custom-manual "(gnus)Article Date") + :group 'gnus-article-washing) + +(eval-and-compile + (autoload 'hexl-hex-string-to-integer "hexl") + (autoload 'timezone-make-date-arpa-standard "timezone") + (autoload 'mail-extract-address-components "mail-extr")) + +(defcustom gnus-article-save-directory gnus-directory + "*Name of the directory articles will be saved in (default \"~/News\")." + :group 'gnus-article-saving + :type 'directory) + +(defcustom gnus-save-all-headers t + "*If non-nil, don't remove any headers before saving." + :group 'gnus-article-saving + :type 'boolean) + +(defcustom gnus-prompt-before-saving 'always + "*This variable says how much prompting is to be done when saving articles. +If it is nil, no prompting will be done, and the articles will be +saved to the default files. If this variable is `always', each and +every article that is saved will be preceded by a prompt, even when +saving large batches of articles. If this variable is neither nil not +`always', there the user will be prompted once for a file name for +each invocation of the saving commands." + :group 'gnus-article-saving + :type '(choice (item always) + (item :tag "never" nil) + (sexp :tag "once" :format "%t"))) + +(defcustom gnus-saved-headers gnus-visible-headers + "Headers to keep if `gnus-save-all-headers' is nil. +If `gnus-save-all-headers' is non-nil, this variable will be ignored. +If that variable is nil, however, all headers that match this regexp +will be kept while the rest will be deleted before saving." + :group 'gnus-article-saving + :type '(repeat string)) + +(defcustom gnus-default-article-saver 'gnus-summary-save-in-rmail + "A function to save articles in your favourite format. +The function must be interactively callable (in other words, it must +be an Emacs command). + +Gnus provides the following functions: + +* gnus-summary-save-in-rmail (Rmail format) +* gnus-summary-save-in-mail (Unix mail format) +* gnus-summary-save-in-folder (MH folder) +* gnus-summary-save-in-file (article format) +* gnus-summary-save-in-vm (use VM's folder format) +* gnus-summary-write-to-file (article format -- overwrite)." + :group 'gnus-article-saving + :type '(radio (function-item gnus-summary-save-in-rmail) + (function-item gnus-summary-save-in-mail) + (function-item gnus-summary-save-in-folder) + (function-item gnus-summary-save-in-file) + (function-item gnus-summary-save-in-vm) + (function-item gnus-summary-write-to-file))) + +(defcustom gnus-rmail-save-name 'gnus-plain-save-name + "A function generating a file name to save articles in Rmail format. +The function is called with NEWSGROUP, HEADERS, and optional LAST-FILE." + :group 'gnus-article-saving + :type 'function) + +(defcustom gnus-mail-save-name 'gnus-plain-save-name + "A function generating a file name to save articles in Unix mail format. +The function is called with NEWSGROUP, HEADERS, and optional LAST-FILE." + :group 'gnus-article-saving + :type 'function) + +(defcustom gnus-folder-save-name 'gnus-folder-save-name + "A function generating a file name to save articles in MH folder. +The function is called with NEWSGROUP, HEADERS, and optional LAST-FOLDER." + :group 'gnus-article-saving + :type 'function) + +(defcustom gnus-file-save-name 'gnus-numeric-save-name + "A function generating a file name to save articles in article format. +The function is called with NEWSGROUP, HEADERS, and optional +LAST-FILE." + :group 'gnus-article-saving + :type 'function) + +(defcustom gnus-split-methods + '((gnus-article-archive-name)) + "Variable used to suggest where articles are to be saved. +For instance, if you would like to save articles related to Gnus in +the file \"gnus-stuff\", and articles related to VM in \"vm-stuff\", +you could set this variable to something like: + + '((\"^Subject:.*gnus\\|^Newsgroups:.*gnus\" \"gnus-stuff\") + (\"^Subject:.*vm\\|^Xref:.*vm\" \"vm-stuff\")) + +This variable is an alist where the where the key is the match and the +value is a list of possible files to save in if the match is non-nil. + +If the match is a string, it is used as a regexp match on the +article. If the match is a symbol, that symbol will be funcalled +from the buffer of the article to be saved with the newsgroup as the +parameter. If it is a list, it will be evaled in the same buffer. + +If this form or function returns a string, this string will be used as +a possible file name; and if it returns a non-nil list, that list will +be used as possible file names." + :group 'gnus-article-saving + :type '(repeat (choice (list function) + (cons regexp (repeat string)) + sexp))) + +(defcustom gnus-strict-mime t + "*If nil, MIME-decode even if there is no Mime-Version header." + :group 'gnus-article-mime + :type 'boolean) + +(defcustom gnus-show-mime-method 'metamail-buffer + "Function to process a MIME message. +The function is called from the article buffer." + :group 'gnus-article-mime + :type 'function) + +(defcustom gnus-decode-encoded-word-method 'gnus-article-de-quoted-unreadable + "*Function to decode MIME encoded words. +The function is called from the article buffer." + :group 'gnus-article-mime + :type 'function) + +(defcustom gnus-page-delimiter "^\^L" + "*Regexp describing what to use as article page delimiters. +The default value is \"^\^L\", which is a form linefeed at the +beginning of a line." + :type 'regexp + :group 'gnus-article-various) + +(defcustom gnus-article-mode-line-format "Gnus: %%b %S" + "*The format specification for the article mode line. +See `gnus-summary-mode-line-format' for a closer description." + :type 'string + :group 'gnus-article-various) + +(defcustom gnus-article-mode-hook nil + "*A hook for Gnus article mode." + :type 'hook + :group 'gnus-article-various) + +(defcustom gnus-article-menu-hook nil + "*Hook run after the creation of the article mode menu." + :type 'hook + :group 'gnus-article-various) + +(defcustom gnus-article-prepare-hook nil + "*A hook called after an article has been prepared in the article buffer. +If you want to run a special decoding program like nkf, use this hook." + :type 'hook + :group 'gnus-article-various) + +(defcustom gnus-article-button-face 'bold + "Face used for highlighting buttons in the article buffer. + +An article button is a piece of text that you can activate by pressing +`RET' or `mouse-2' above it." + :type 'face + :group 'gnus-article-buttons) + +(defcustom gnus-article-mouse-face 'highlight + "Face used for mouse highlighting in the article buffer. + +Article buttons will be displayed in this face when the cursor is +above them." + :type 'face + :group 'gnus-article-buttons) + +(defcustom gnus-signature-face 'italic + "Face used for highlighting a signature in the article buffer." + :type 'face + :group 'gnus-article-highlight + :group 'gnus-article-signature) + +(defface gnus-header-from-face + '((((class color) + (background dark)) + (:foreground "light blue" :bold t :italic t)) + (((class color) + (background light)) + (:foreground "MidnightBlue" :bold t :italic t)) + (t + (:bold t :italic t))) + "Face used for displaying from headers." + :group 'gnus-article-headers + :group 'gnus-article-highlight) + +(defface gnus-header-subject-face + '((((class color) + (background dark)) + (:foreground "pink" :bold t :italic t)) + (((class color) + (background light)) + (:foreground "firebrick" :bold t :italic t)) + (t + (:bold t :italic t))) + "Face used for displaying subject headers." + :group 'gnus-article-headers + :group 'gnus-article-highlight) + +(defface gnus-header-newsgroups-face + '((((class color) + (background dark)) + (:foreground "yellow" :bold t :italic t)) + (((class color) + (background light)) + (:foreground "indianred" :bold t :italic t)) + (t + (:bold t :italic t))) + "Face used for displaying newsgroups headers." + :group 'gnus-article-headers + :group 'gnus-article-highlight) + +(defface gnus-header-name-face + '((((class color) + (background dark)) + (:foreground "cyan" :bold t)) + (((class color) + (background light)) + (:foreground "DarkGreen" :bold t)) + (t + (:bold t))) + "Face used for displaying header names." + :group 'gnus-article-headers + :group 'gnus-article-highlight) + +(defface gnus-header-content-face + '((((class color) + (background dark)) + (:foreground "forest green" :italic t)) + (((class color) + (background light)) + (:foreground "DarkGreen" :italic t)) + (t + (:italic t))) "Face used for displaying header content." + :group 'gnus-article-headers + :group 'gnus-article-highlight) + +(defcustom gnus-header-face-alist + '(("From" nil gnus-header-from-face) + ("Subject" nil gnus-header-subject-face) + ("Newsgroups:.*," nil gnus-header-newsgroups-face) + ("" gnus-header-name-face gnus-header-content-face)) + "Controls highlighting of article header. + +An alist of the form (HEADER NAME CONTENT). + +HEADER is a regular expression which should match the name of an +header header and NAME and CONTENT are either face names or nil. + +The name of each header field will be displayed using the face +specified by the first element in the list where HEADER match the +header name and NAME is non-nil. Similarly, the content will be +displayed by the first non-nil matching CONTENT face." + :group 'gnus-article-headers + :group 'gnus-article-highlight + :type '(repeat (list (regexp :tag "Header") + (choice :tag "Name" + (item :tag "skip" nil) + (face :value default)) + (choice :tag "Content" + (item :tag "skip" nil) + (face :value default))))) + +;;; Internal variables + +(defvar gnus-article-mode-syntax-table + (let ((table (copy-syntax-table text-mode-syntax-table))) + ;;(modify-syntax-entry ?_ "w" table) + table) + "Syntax table used in article mode buffers. +Initialized from `text-mode-syntax-table.") + +(defvar gnus-save-article-buffer nil) + +(defvar gnus-article-mode-line-format-alist + (nconc '((?w (gnus-article-wash-status) ?s)) + gnus-summary-mode-line-format-alist)) + +(defvar gnus-number-of-articles-to-be-saved nil) + +(defvar gnus-inhibit-hiding nil) +(defvar gnus-newsgroup-name) + +(defsubst gnus-article-hide-text (b e props) + "Set text PROPS on the B to E region, extending `intangible' 1 past B." + (add-text-properties b e props) + (when (memq 'intangible props) + (put-text-property + (max (1- b) (point-min)) + b 'intangible (cddr (memq 'intangible props))))) + +(defsubst gnus-article-unhide-text (b e) + "Remove hidden text properties from region between B and E." + (remove-text-properties b e gnus-hidden-properties) + (when (memq 'intangible gnus-hidden-properties) + (put-text-property (max (1- b) (point-min)) + b 'intangible nil))) + +(defun gnus-article-hide-text-type (b e type) + "Hide text of TYPE between B and E." + (gnus-article-hide-text + b e (cons 'article-type (cons type gnus-hidden-properties)))) + +(defun gnus-article-unhide-text-type (b e type) + "Hide text of TYPE between B and E." + (remove-text-properties + b e (cons 'article-type (cons type gnus-hidden-properties))) + (when (memq 'intangible gnus-hidden-properties) + (put-text-property (max (1- b) (point-min)) + b 'intangible nil))) + +(defun gnus-article-hide-text-of-type (type) + "Hide text of TYPE in the current buffer." + (save-excursion + (let ((b (point-min)) + (e (point-max))) + (while (setq b (text-property-any b e 'article-type type)) + (add-text-properties b (incf b) gnus-hidden-properties))))) + +(defun gnus-article-delete-text-of-type (type) + "Delete text of TYPE in the current buffer." + (save-excursion + (let ((b (point-min))) + (while (setq b (text-property-any b (point-max) 'article-type type)) + (delete-region b (incf b)))))) + +(defun gnus-article-delete-invisible-text () + "Delete all invisible text in the current buffer." + (save-excursion + (let ((b (point-min))) + (while (setq b (text-property-any b (point-max) 'invisible t)) + (delete-region b (incf b)))))) + +(defun gnus-article-text-type-exists-p (type) + "Say whether any text of type TYPE exists in the buffer." + (text-property-any (point-min) (point-max) 'article-type type)) + +(defsubst gnus-article-header-rank () + "Give the rank of the string HEADER as given by `gnus-sorted-header-list'." + (let ((list gnus-sorted-header-list) + (i 0)) + (while list + (when (looking-at (car list)) + (setq list nil)) + (setq list (cdr list)) + (incf i)) + i)) + +(defun article-hide-headers (&optional arg delete) + "Toggle whether to hide unwanted headers and possibly sort them as well. +If given a negative prefix, always show; if given a positive prefix, +always hide." + (interactive (gnus-article-hidden-arg)) + (if (gnus-article-check-hidden-text 'headers arg) + ;; Show boring headers as well. + (gnus-article-show-hidden-text 'boring-headers) + ;; This function might be inhibited. + (unless gnus-inhibit-hiding + (save-excursion + (save-restriction + (let ((buffer-read-only nil) + (props (nconc (list 'article-type 'headers) + gnus-hidden-properties)) + (max (1+ (length gnus-sorted-header-list))) + (ignored (when (not gnus-visible-headers) + (cond ((stringp gnus-ignored-headers) + gnus-ignored-headers) + ((listp gnus-ignored-headers) + (mapconcat 'identity gnus-ignored-headers + "\\|"))))) + (visible + (cond ((stringp gnus-visible-headers) + gnus-visible-headers) + ((and gnus-visible-headers + (listp gnus-visible-headers)) + (mapconcat 'identity gnus-visible-headers "\\|")))) + (inhibit-point-motion-hooks t) + want-list beg) + ;; First we narrow to just the headers. + (widen) + (goto-char (point-min)) + ;; Hide any "From " lines at the beginning of (mail) articles. + (while (looking-at "From ") + (forward-line 1)) + (unless (bobp) + (if delete + (delete-region (point-min) (point)) + (gnus-article-hide-text (point-min) (point) props))) + ;; Then treat the rest of the header lines. + (narrow-to-region + (point) + (if (search-forward "\n\n" nil t) ; if there's a body + (progn (forward-line -1) (point)) + (point-max))) + ;; Then we use the two regular expressions + ;; `gnus-ignored-headers' and `gnus-visible-headers' to + ;; select which header lines is to remain visible in the + ;; article buffer. + (goto-char (point-min)) + (while (re-search-forward "^[^ \t]*:" nil t) + (beginning-of-line) + ;; Mark the rank of the header. + (put-text-property + (point) (1+ (point)) 'message-rank + (if (or (and visible (looking-at visible)) + (and ignored + (not (looking-at ignored)))) + (gnus-article-header-rank) + (+ 2 max))) + (forward-line 1)) + (message-sort-headers-1) + (when (setq beg (text-property-any + (point-min) (point-max) 'message-rank (+ 2 max))) + ;; We make the unwanted headers invisible. + (if delete + (delete-region beg (point-max)) + ;; Suggested by Sudish Joseph . + (gnus-article-hide-text-type beg (point-max) 'headers)) + ;; Work around XEmacs lossage. + (put-text-property (point-min) beg 'invisible nil)))))))) + +(defun article-hide-boring-headers (&optional arg) + "Toggle hiding of headers that aren't very interesting. +If given a negative prefix, always show; if given a positive prefix, +always hide." + (interactive (gnus-article-hidden-arg)) + (when (and (not (gnus-article-check-hidden-text 'boring-headers arg)) + (not gnus-show-all-headers)) + (save-excursion + (save-restriction + (let ((buffer-read-only nil) + (list gnus-boring-article-headers) + (inhibit-point-motion-hooks t) + elem) + (nnheader-narrow-to-headers) + (while list + (setq elem (pop list)) + (goto-char (point-min)) + (cond + ;; Hide empty headers. + ((eq elem 'empty) + (while (re-search-forward "^[^:]+:[ \t]*\n[^ \t]" nil t) + (forward-line -1) + (gnus-article-hide-text-type + (progn (beginning-of-line) (point)) + (progn + (end-of-line) + (if (re-search-forward "^[^ \t]" nil t) + (match-beginning 0) + (point-max))) + 'boring-headers))) + ;; Hide boring Newsgroups header. + ((eq elem 'newsgroups) + (when (equal (gnus-fetch-field "newsgroups") + (gnus-group-real-name + (if (boundp 'gnus-newsgroup-name) + gnus-newsgroup-name + ""))) + (gnus-article-hide-header "newsgroups"))) + ((eq elem 'followup-to) + (when (equal (message-fetch-field "followup-to") + (message-fetch-field "newsgroups")) + (gnus-article-hide-header "followup-to"))) + ((eq elem 'reply-to) + (let ((from (message-fetch-field "from")) + (reply-to (message-fetch-field "reply-to"))) + (when (and + from reply-to + (ignore-errors + (equal + (nth 1 (mail-extract-address-components from)) + (nth 1 (mail-extract-address-components reply-to))))) + (gnus-article-hide-header "reply-to")))) + ((eq elem 'date) + (let ((date (message-fetch-field "date"))) + (when (and date + (< (gnus-days-between (current-time-string) date) + 4)) + (gnus-article-hide-header "date"))))))))))) + +(defun gnus-article-hide-header (header) + (save-excursion + (goto-char (point-min)) + (when (re-search-forward (concat "^" header ":") nil t) + (gnus-article-hide-text-type + (progn (beginning-of-line) (point)) + (progn + (end-of-line) + (if (re-search-forward "^[^ \t]" nil t) + (match-beginning 0) + (point-max))) + 'boring-headers)))) + +;; Written by Per Abrahamsen . +(defun article-treat-overstrike () + "Translate overstrikes into bold text." + (interactive) + (save-excursion + (let ((buffer-read-only nil)) + (while (search-forward "\b" nil t) + (let ((next (following-char)) + (previous (char-after (- (point) 2)))) + ;; We do the boldification/underlining by hiding the + ;; overstrikes and putting the proper text property + ;; on the letters. + (cond + ((eq next previous) + (gnus-article-hide-text-type (- (point) 2) (point) 'overstrike) + (put-text-property (point) (1+ (point)) 'face 'bold)) + ((eq next ?_) + (gnus-article-hide-text-type (1- (point)) (1+ (point)) 'overstrike) + (put-text-property + (- (point) 2) (1- (point)) 'face 'underline)) + ((eq previous ?_) + (gnus-article-hide-text-type (- (point) 2) (point) 'overstrike) + (put-text-property + (point) (1+ (point)) 'face 'underline)))))))) + +(defun article-fill () + "Format too long lines." + (interactive) + (save-excursion + (let ((buffer-read-only nil)) + (widen) + (goto-char (point-min)) + (search-forward "\n\n" nil t) + (end-of-line 1) + (let ((paragraph-start "^[>|#:<;* ]*[ \t]*$") + (adaptive-fill-regexp "[ \t]*\\([|#:<;>*]+ *\\)?") + (adaptive-fill-mode t)) + (while (not (eobp)) + (and (>= (current-column) (min fill-column (window-width))) + (/= (preceding-char) ?:) + (fill-paragraph nil)) + (end-of-line 2)))))) + +(defun article-remove-cr () + "Remove carriage returns from an article." + (interactive) + (save-excursion + (let ((buffer-read-only nil)) + (goto-char (point-min)) + (while (search-forward "\r" nil t) + (replace-match "" t t))))) + +(defun article-remove-trailing-blank-lines () + "Remove all trailing blank lines from the article." + (interactive) + (save-excursion + (let ((buffer-read-only nil)) + (goto-char (point-max)) + (delete-region + (point) + (progn + (while (and (not (bobp)) + (looking-at "^[ \t]*$")) + (forward-line -1)) + (forward-line 1) + (point)))))) + +(defun article-display-x-face (&optional force) + "Look for an X-Face header and display it if present." + (interactive (list 'force)) + (save-excursion + ;; Delete the old process, if any. + (when (process-status "article-x-face") + (delete-process "article-x-face")) + (let ((inhibit-point-motion-hooks t) + (case-fold-search nil) + from) + (save-restriction + (nnheader-narrow-to-headers) + (setq from (message-fetch-field "from")) + (goto-char (point-min)) + (when (and gnus-article-x-face-command + (or force + ;; Check whether this face is censored. + (not gnus-article-x-face-too-ugly) + (and gnus-article-x-face-too-ugly from + (not (string-match gnus-article-x-face-too-ugly + from)))) + ;; Has to be present. + (re-search-forward "^X-Face: " nil t)) + ;; We now have the area of the buffer where the X-Face is stored. + (let ((beg (point)) + (end (1- (re-search-forward "^\\($\\|[^ \t]\\)" nil t)))) + ;; We display the face. + (if (symbolp gnus-article-x-face-command) + ;; The command is a lisp function, so we call it. + (if (gnus-functionp gnus-article-x-face-command) + (funcall gnus-article-x-face-command beg end) + (error "%s is not a function" gnus-article-x-face-command)) + ;; The command is a string, so we interpret the command + ;; as a, well, command, and fork it off. + (let ((process-connection-type nil)) + (process-kill-without-query + (start-process + "article-x-face" nil shell-file-name shell-command-switch + gnus-article-x-face-command)) + (process-send-region "article-x-face" beg end) + (process-send-eof "article-x-face"))))))))) + +(defalias 'gnus-decode-rfc1522 'article-decode-rfc1522) +(defalias 'gnus-article-decode-rfc1522 'article-decode-rfc1522) +(defun article-decode-rfc1522 () + "Hack to remove QP encoding from headers." + (let ((case-fold-search t) + (inhibit-point-motion-hooks t) + (buffer-read-only nil) + string) + (save-restriction + (narrow-to-region + (goto-char (point-min)) + (or (search-forward "\n\n" nil t) (point-max))) + (goto-char (point-min)) + (while (re-search-forward + "=\\?iso-8859-1\\?q\\?\\([^?\t\n]*\\)\\?=" nil t) + (setq string (match-string 1)) + (save-restriction + (narrow-to-region (match-beginning 0) (match-end 0)) + (delete-region (point-min) (point-max)) + (insert string) + (article-mime-decode-quoted-printable + (goto-char (point-min)) (point-max)) + (subst-char-in-region (point-min) (point-max) ?_ ? ) + (goto-char (point-max))) + (goto-char (point-min)))))) + +(defun article-de-quoted-unreadable (&optional force) + "Do a naive translation of a quoted-printable-encoded article. +This is in no way, shape or form meant as a replacement for real MIME +processing, but is simply a stop-gap measure until MIME support is +written. +If FORCE, decode the article whether it is marked as quoted-printable +or not." + (interactive (list 'force)) + (save-excursion + (let ((case-fold-search t) + (buffer-read-only nil) + (type (gnus-fetch-field "content-transfer-encoding"))) + (gnus-article-decode-rfc1522) + (when (or force + (and type (string-match "quoted-printable" (downcase type)))) + (goto-char (point-min)) + (search-forward "\n\n" nil 'move) + (article-mime-decode-quoted-printable (point) (point-max)))))) + +(defun article-mime-decode-quoted-printable-buffer () + "Decode Quoted-Printable in the current buffer." + (article-mime-decode-quoted-printable (point-min) (point-max))) + +(defun article-mime-decode-quoted-printable (from to) + "Decode Quoted-Printable in the region between FROM and TO." + (interactive "r") + (goto-char from) + (while (search-forward "=" to t) + (cond ((eq (following-char) ?\n) + (delete-char -1) + (delete-char 1)) + ((looking-at "[0-9A-F][0-9A-F]") + (subst-char-in-region + (1- (point)) (point) ?= + (hexl-hex-string-to-integer + (buffer-substring (point) (+ 2 (point))))) + (delete-char 2)) + ((looking-at "=") + (delete-char 1)) + ((gnus-message 3 "Malformed MIME quoted-printable message"))))) + +(defun article-hide-pgp (&optional arg) + "Toggle hiding of any PGP headers and signatures in the current article. +If given a negative prefix, always show; if given a positive prefix, +always hide." + (interactive (gnus-article-hidden-arg)) + (unless (gnus-article-check-hidden-text 'pgp arg) + (save-excursion + (let ((inhibit-point-motion-hooks t) + buffer-read-only beg end) + (widen) + (goto-char (point-min)) + ;; Hide the "header". + (when (search-forward "\n-----BEGIN PGP SIGNED MESSAGE-----\n" nil t) + (gnus-article-hide-text-type (match-beginning 0) (match-end 0) 'pgp)) + (setq beg (point)) + ;; Hide the actual signature. + (and (search-forward "\n-----BEGIN PGP SIGNATURE-----\n" nil t) + (setq end (1+ (match-beginning 0))) + (gnus-article-hide-text-type + end + (if (search-forward "\n-----END PGP SIGNATURE-----\n" nil t) + (match-end 0) + ;; Perhaps we shouldn't hide to the end of the buffer + ;; if there is no end to the signature? + (point-max)) + 'pgp)) + ;; Hide "- " PGP quotation markers. + (when (and beg end) + (narrow-to-region beg end) + (goto-char (point-min)) + (while (re-search-forward "^- " nil t) + (gnus-article-hide-text-type + (match-beginning 0) (match-end 0) 'pgp)) + (widen)))))) + +(defun article-hide-pem (&optional arg) + "Toggle hiding of any PEM headers and signatures in the current article. +If given a negative prefix, always show; if given a positive prefix, +always hide." + (interactive (gnus-article-hidden-arg)) + (unless (gnus-article-check-hidden-text 'pem arg) + (save-excursion + (let (buffer-read-only end) + (widen) + (goto-char (point-min)) + ;; hide the horrendously ugly "header". + (and (search-forward "\n-----BEGIN PRIVACY-ENHANCED MESSAGE-----\n" + nil + t) + (setq end (1+ (match-beginning 0))) + (gnus-article-hide-text-type + end + (if (search-forward "\n\n" nil t) + (match-end 0) + (point-max)) + 'pem)) + ;; hide the trailer as well + (and (search-forward "\n-----END PRIVACY-ENHANCED MESSAGE-----\n" + nil + t) + (gnus-article-hide-text-type + (match-beginning 0) (match-end 0) 'pem)))))) + +(defun article-hide-signature (&optional arg) + "Hide the signature in the current article. +If given a negative prefix, always show; if given a positive prefix, +always hide." + (interactive (gnus-article-hidden-arg)) + (unless (gnus-article-check-hidden-text 'signature arg) + (save-excursion + (save-restriction + (let ((buffer-read-only nil)) + (when (gnus-article-narrow-to-signature) + (gnus-article-hide-text-type + (point-min) (point-max) 'signature))))))) + +(defun article-strip-leading-blank-lines () + "Remove all blank lines from the beginning of the article." + (interactive) + (save-excursion + (let ((inhibit-point-motion-hooks t) + buffer-read-only) + (goto-char (point-min)) + (when (search-forward "\n\n" nil t) + (while (and (not (eobp)) + (looking-at "[ \t]*$")) + (gnus-delete-line)))))) + +(defun article-strip-multiple-blank-lines () + "Replace consecutive blank lines with one empty line." + (interactive) + (save-excursion + (let (buffer-read-only) + ;; First make all blank lines empty. + (goto-char (point-min)) + (while (re-search-forward "^[ \t]+$" nil t) + (replace-match "" nil t)) + ;; Then replace multiple empty lines with a single empty line. + (goto-char (point-min)) + (while (re-search-forward "\n\n\n+" nil t) + (replace-match "\n\n" t t))))) + +(defun article-strip-blank-lines () + "Strip leading, trailing and multiple blank lines." + (interactive) + (article-strip-leading-blank-lines) + (article-remove-trailing-blank-lines) + (article-strip-multiple-blank-lines)) + +(defvar mime::preview/content-list) +(defvar mime::preview-content-info/point-min) +(defun gnus-article-narrow-to-signature () + "Narrow to the signature; return t if a signature is found, else nil." + (widen) + (when (and (boundp 'mime::preview/content-list) + mime::preview/content-list) + ;; We have a MIMEish article, so we use the MIME data to narrow. + (let ((pcinfo (car (last mime::preview/content-list)))) + (ignore-errors + (narrow-to-region + (funcall (intern "mime::preview-content-info/point-min") pcinfo) + (point-max))))) + + (when (gnus-article-search-signature) + (forward-line 1) + ;; Check whether we have some limits to what we consider + ;; to be a signature. + (let ((limits (if (listp gnus-signature-limit) gnus-signature-limit + (list gnus-signature-limit))) + limit limited) + (while (setq limit (pop limits)) + (if (or (and (integerp limit) + (< (- (point-max) (point)) limit)) + (and (floatp limit) + (< (count-lines (point) (point-max)) limit)) + (and (gnus-functionp limit) + (funcall limit)) + (and (stringp limit) + (not (re-search-forward limit nil t)))) + () ; This limit did not succeed. + (setq limited t + limits nil))) + (unless limited + (narrow-to-region (point) (point-max)) + t)))) + +(defun gnus-article-search-signature () + "Search the current buffer for the signature separator. +Put point at the beginning of the signature separator." + (let ((cur (point))) + (goto-char (point-max)) + (if (if (stringp gnus-signature-separator) + (re-search-backward gnus-signature-separator nil t) + (let ((seps gnus-signature-separator)) + (while (and seps + (not (re-search-backward (car seps) nil t))) + (pop seps)) + seps)) + t + (goto-char cur) + nil))) + +(defun gnus-article-hidden-arg () + "Return the current prefix arg as a number, or 0 if no prefix." + (list (if current-prefix-arg + (prefix-numeric-value current-prefix-arg) + 0))) + +(defun gnus-article-check-hidden-text (type arg) + "Return nil if hiding is necessary. +Arg can be nil or a number. Nil and positive means hide, negative +means show, 0 means toggle." + (save-excursion + (save-restriction + (widen) + (let ((hide (gnus-article-hidden-text-p type))) + (cond + ((or (null arg) + (> arg 0)) + nil) + ((< arg 0) + (gnus-article-show-hidden-text type)) + (t + (if (eq hide 'hidden) + (gnus-article-show-hidden-text type) + nil))))))) + +(defun gnus-article-hidden-text-p (type) + "Say whether the current buffer contains hidden text of type TYPE." + (let ((pos (text-property-any (point-min) (point-max) 'article-type type))) + (when pos + (if (get-text-property pos 'invisible) + 'hidden + 'shown)))) + +(defun gnus-article-show-hidden-text (type &optional hide) + "Show all hidden text of type TYPE. +If HIDE, hide the text instead." + (save-excursion + (let ((buffer-read-only nil) + (inhibit-point-motion-hooks t) + (end (point-min)) + beg) + (while (setq beg (text-property-any end (point-max) 'article-type type)) + (goto-char beg) + (setq end (or + (text-property-not-all beg (point-max) 'article-type type) + (point-max))) + (if hide + (gnus-article-hide-text beg end gnus-hidden-properties) + (gnus-article-unhide-text beg end)) + (goto-char end)) + t))) + +(defconst article-time-units + `((year . ,(* 365.25 24 60 60)) + (week . ,(* 7 24 60 60)) + (day . ,(* 24 60 60)) + (hour . ,(* 60 60)) + (minute . 60) + (second . 1)) + "Mapping from time units to seconds.") + +(defun article-date-ut (&optional type highlight header) + "Convert DATE date to universal time in the current article. +If TYPE is `local', convert to local time; if it is `lapsed', output +how much time has lapsed since DATE." + (interactive (list 'ut t)) + (let* ((header (or header + (mail-header-date gnus-current-headers) + (message-fetch-field "date") + "")) + (date (if (vectorp header) (mail-header-date header) + header)) + (date-regexp "^Date:[ \t]\\|^X-Sent:[ \t]") + (inhibit-point-motion-hooks t) + bface eface) + (when (and date (not (string= date ""))) + (save-excursion + (save-restriction + (nnheader-narrow-to-headers) + (let ((buffer-read-only nil)) + ;; Delete any old Date headers. + (if (re-search-forward date-regexp nil t) + (progn + (setq bface (get-text-property (point-at-bol) 'face) + eface (get-text-property (1- (point-at-eol)) + 'face)) + (message-remove-header date-regexp t) + (beginning-of-line)) + (goto-char (point-max))) + (insert (article-make-date-line date type)) + ;; Do highlighting. + (forward-line -1) + (when (looking-at "\\([^:]+\\): *\\(.*\\)$") + (put-text-property (match-beginning 1) (match-end 1) + 'face bface) + (put-text-property (match-beginning 2) (match-end 2) + 'face eface)))))))) + +(defun article-make-date-line (date type) + "Return a DATE line of TYPE." + (cond + ;; Convert to the local timezone. We have to slap a + ;; `condition-case' round the calls to the timezone + ;; functions since they aren't particularly resistant to + ;; buggy dates. + ((eq type 'local) + (concat "Date: " (condition-case () + (timezone-make-date-arpa-standard date) + (error date)) + "\n")) + ;; Convert to Universal Time. + ((eq type 'ut) + (concat "Date: " + (condition-case () + (timezone-make-date-arpa-standard date nil "UT") + (error date)) + "\n")) + ;; Get the original date from the article. + ((eq type 'original) + (concat "Date: " date "\n")) + ;; Let the user define the format. + ((eq type 'user) + (format-time-string gnus-article-time-format + (ignore-errors + (gnus-encode-date + (timezone-make-date-arpa-standard + date nil "UT"))))) + ;; Do an X-Sent lapsed format. + ((eq type 'lapsed) + ;; If the date is seriously mangled, the timezone functions are + ;; liable to bug out, so we ignore all errors. + (let* ((now (current-time)) + (real-time + (ignore-errors + (gnus-time-minus + (gnus-encode-date + (timezone-make-date-arpa-standard + (current-time-string now) + (current-time-zone now) "UT")) + (gnus-encode-date + (timezone-make-date-arpa-standard + date nil "UT"))))) + (real-sec (and real-time + (+ (* (float (car real-time)) 65536) + (cadr real-time)))) + (sec (and real-time (abs real-sec))) + num prev) + (cond + ((null real-time) + "X-Sent: Unknown\n") + ((zerop sec) + "X-Sent: Now\n") + (t + (concat + "X-Sent: " + ;; This is a bit convoluted, but basically we go + ;; through the time units for years, weeks, etc, + ;; and divide things to see whether that results + ;; in positive answers. + (mapconcat + (lambda (unit) + (if (zerop (setq num (ffloor (/ sec (cdr unit))))) + ;; The (remaining) seconds are too few to + ;; be divided into this time unit. + "" + ;; It's big enough, so we output it. + (setq sec (- sec (* num (cdr unit)))) + (prog1 + (concat (if prev ", " "") (int-to-string + (floor num)) + " " (symbol-name (car unit)) + (if (> num 1) "s" "")) + (setq prev t)))) + article-time-units "") + ;; If dates are odd, then it might appear like the + ;; article was sent in the future. + (if (> real-sec 0) + " ago\n" + " in the future\n")))))) + (t + (error "Unknown conversion type: %s" type)))) + +(defun article-date-local (&optional highlight) + "Convert the current article date to the local timezone." + (interactive (list t)) + (article-date-ut 'local highlight)) + +(defun article-date-original (&optional highlight) + "Convert the current article date to what it was originally. +This is only useful if you have used some other date conversion +function and want to see what the date was before converting." + (interactive (list t)) + (article-date-ut 'original highlight)) + +(defun article-date-lapsed (&optional highlight) + "Convert the current article date to time lapsed since it was sent." + (interactive (list t)) + (article-date-ut 'lapsed highlight)) + +(defun article-date-user (&optional highlight) + "Convert the current article date to the user-defined format." + (interactive (list t)) + (article-date-ut 'user highlight)) + +(defun article-show-all () + "Show all hidden text in the article buffer." + (interactive) + (save-excursion + (let ((buffer-read-only nil)) + (gnus-article-unhide-text (point-min) (point-max))))) + +(defun article-emphasize (&optional arg) + "Emphasize text according to `gnus-emphasis-alist'." + (interactive (gnus-article-hidden-arg)) + (unless (gnus-article-check-hidden-text 'emphasis arg) + (save-excursion + (let ((alist gnus-emphasis-alist) + (buffer-read-only nil) + (props (append '(article-type emphasis) + gnus-hidden-properties)) + regexp elem beg invisible visible face) + (goto-char (point-min)) + (search-forward "\n\n" nil t) + (setq beg (point)) + (while (setq elem (pop alist)) + (goto-char beg) + (setq regexp (car elem) + invisible (nth 1 elem) + visible (nth 2 elem) + face (nth 3 elem)) + (while (re-search-forward regexp nil t) + (when (and (match-beginning visible) (match-beginning invisible)) + (gnus-article-hide-text + (match-beginning invisible) (match-end invisible) props) + (gnus-article-unhide-text-type + (match-beginning visible) (match-end visible) 'emphasis) + (gnus-put-text-property-excluding-newlines + (match-beginning visible) (match-end visible) 'face face) + (goto-char (match-end invisible))))))))) + +(defvar gnus-summary-article-menu) +(defvar gnus-summary-post-menu) + +;;; Saving functions. + +(defun gnus-article-save (save-buffer file &optional num) + "Save the currently selected article." + (unless gnus-save-all-headers + ;; Remove headers according to `gnus-saved-headers'. + (let ((gnus-visible-headers + (or gnus-saved-headers gnus-visible-headers)) + (gnus-article-buffer save-buffer)) + (gnus-article-hide-headers 1 t))) + (save-window-excursion + (if (not gnus-default-article-saver) + (error "No default saver is defined.") + ;; !!! Magic! The saving functions all save + ;; `gnus-original-article-buffer' (or so they think), but we + ;; bind that variable to our save-buffer. + (set-buffer gnus-article-buffer) + (let* ((gnus-save-article-buffer save-buffer) + (filename + (cond + ((not gnus-prompt-before-saving) 'default) + ((eq gnus-prompt-before-saving 'always) nil) + (t file))) + (gnus-number-of-articles-to-be-saved + (when (eq gnus-prompt-before-saving t) + num))) ; Magic + (set-buffer gnus-summary-buffer) + (funcall gnus-default-article-saver filename))))) + +(defun gnus-read-save-file-name (prompt default-name &optional filename) + (cond + ((eq filename 'default) + default-name) + (filename filename) + (t + (let* ((split-name (gnus-get-split-value gnus-split-methods)) + (prompt + (format prompt (if (and gnus-number-of-articles-to-be-saved + (> gnus-number-of-articles-to-be-saved 1)) + (format "these %d articles" + gnus-number-of-articles-to-be-saved) + "this article"))) + (file + ;; Let the split methods have their say. + (cond + ;; No split name was found. + ((null split-name) + (read-file-name + (concat prompt " (default " + (file-name-nondirectory default-name) ") ") + (file-name-directory default-name) + default-name)) + ;; A single split name was found + ((= 1 (length split-name)) + (let* ((name (car split-name)) + (dir (cond ((file-directory-p name) + (file-name-as-directory name)) + ((file-exists-p name) name) + (t gnus-article-save-directory)))) + (read-file-name + (concat prompt " (default " name ") ") + dir name))) + ;; A list of splits was found. + (t + (setq split-name (nreverse split-name)) + (let (result) + (let ((file-name-history (nconc split-name file-name-history))) + (setq result + (expand-file-name + (read-file-name + (concat prompt " (`M-p' for defaults) ") + gnus-article-save-directory + (car split-name)) + gnus-article-save-directory))) + (car (push result file-name-history))))))) + ;; Create the directory. + (gnus-make-directory (file-name-directory file)) + ;; If we have read a directory, we append the default file name. + (when (file-directory-p file) + (setq file (concat (file-name-as-directory file) + (file-name-nondirectory default-name)))) + ;; Possibly translate some characters. + (nnheader-translate-file-chars file))))) + +(defun gnus-article-archive-name (group) + "Return the first instance of an \"Archive-name\" in the current buffer." + (let ((case-fold-search t)) + (when (re-search-forward "archive-name: *\\([^ \n\t]+\\)[ \t]*$" nil t) + (nnheader-concat gnus-article-save-directory + (match-string 1))))) + +(defun gnus-summary-save-in-rmail (&optional filename) + "Append this article to Rmail file. +Optional argument FILENAME specifies file name. +Directory to save to is default to `gnus-article-save-directory'." + (interactive) + (gnus-set-global-variables) + (let ((default-name + (funcall gnus-rmail-save-name gnus-newsgroup-name + gnus-current-headers gnus-newsgroup-last-rmail))) + (setq filename (gnus-read-save-file-name + "Save %s in rmail file:" default-name filename)) + (gnus-make-directory (file-name-directory filename)) + (gnus-eval-in-buffer-window gnus-save-article-buffer + (save-excursion + (save-restriction + (widen) + (gnus-output-to-rmail filename)))) + ;; Remember the directory name to save articles + (setq gnus-newsgroup-last-rmail filename))) + +(defun gnus-summary-save-in-mail (&optional filename) + "Append this article to Unix mail file. +Optional argument FILENAME specifies file name. +Directory to save to is default to `gnus-article-save-directory'." + (interactive) + (gnus-set-global-variables) + (let ((default-name + (funcall gnus-mail-save-name gnus-newsgroup-name + gnus-current-headers gnus-newsgroup-last-mail))) + (setq filename (gnus-read-save-file-name + "Save %s in Unix mail file:" default-name filename)) + (setq filename + (expand-file-name filename + (and default-name + (file-name-directory default-name)))) + (gnus-make-directory (file-name-directory filename)) + (gnus-eval-in-buffer-window gnus-save-article-buffer + (save-excursion + (save-restriction + (widen) + (if (and (file-readable-p filename) + (mail-file-babyl-p filename)) + (gnus-output-to-rmail filename t) + (gnus-output-to-mail filename t))))) + ;; Remember the directory name to save articles. + (setq gnus-newsgroup-last-mail filename))) + +(defun gnus-summary-save-in-file (&optional filename overwrite) + "Append this article to file. +Optional argument FILENAME specifies file name. +Directory to save to is default to `gnus-article-save-directory'." + (interactive) + (gnus-set-global-variables) + (let ((default-name + (funcall gnus-file-save-name gnus-newsgroup-name + gnus-current-headers gnus-newsgroup-last-file))) + (setq filename (gnus-read-save-file-name + "Save %s in file:" default-name filename)) + (gnus-make-directory (file-name-directory filename)) + (gnus-eval-in-buffer-window gnus-save-article-buffer + (save-excursion + (save-restriction + (widen) + (when (and overwrite + (file-exists-p filename)) + (delete-file filename)) + (gnus-output-to-file filename)))) + ;; Remember the directory name to save articles. + (setq gnus-newsgroup-last-file filename))) + +(defun gnus-summary-write-to-file (&optional filename) + "Write this article to a file. +Optional argument FILENAME specifies file name. +The directory to save in defaults to `gnus-article-save-directory'." + (interactive) + (gnus-summary-save-in-file nil t)) + +(defun gnus-summary-save-body-in-file (&optional filename) + "Append this article body to a file. +Optional argument FILENAME specifies file name. +The directory to save in defaults to `gnus-article-save-directory'." + (interactive) + (gnus-set-global-variables) + (let ((default-name + (funcall gnus-file-save-name gnus-newsgroup-name + gnus-current-headers gnus-newsgroup-last-file))) + (setq filename (gnus-read-save-file-name + "Save %s body in file:" default-name filename)) + (gnus-make-directory (file-name-directory filename)) + (gnus-eval-in-buffer-window gnus-save-article-buffer + (save-excursion + (save-restriction + (widen) + (goto-char (point-min)) + (when (search-forward "\n\n" nil t) + (narrow-to-region (point) (point-max))) + (gnus-output-to-file filename)))) + ;; Remember the directory name to save articles. + (setq gnus-newsgroup-last-file filename))) + +(defun gnus-summary-save-in-pipe (&optional command) + "Pipe this article to subprocess." + (interactive) + (gnus-set-global-variables) + (setq command + (cond ((eq command 'default) + gnus-last-shell-command) + (command command) + (t (read-string + (format + "Shell command on %s: " + (if (and gnus-number-of-articles-to-be-saved + (> gnus-number-of-articles-to-be-saved 1)) + (format "these %d articles" + gnus-number-of-articles-to-be-saved) + "this article")) + gnus-last-shell-command)))) + (when (string-equal command "") + (setq command gnus-last-shell-command)) + (gnus-eval-in-buffer-window gnus-article-buffer + (save-restriction + (widen) + (shell-command-on-region (point-min) (point-max) command nil))) + (setq gnus-last-shell-command command)) + +;;; Article file names when saving. + +(defun gnus-capitalize-newsgroup (newsgroup) + "Capitalize NEWSGROUP name." + (when (not (zerop (length newsgroup))) + (concat (char-to-string (upcase (aref newsgroup 0))) + (substring newsgroup 1)))) + +(defun gnus-Numeric-save-name (newsgroup headers &optional last-file) + "Generate file name from NEWSGROUP, HEADERS, and optional LAST-FILE. +If variable `gnus-use-long-file-name' is non-nil, it is ~/News/News.group/num. +Otherwise, it is like ~/News/news/group/num." + (let ((default + (expand-file-name + (concat (if (gnus-use-long-file-name 'not-save) + (gnus-capitalize-newsgroup newsgroup) + (gnus-newsgroup-directory-form newsgroup)) + "/" (int-to-string (mail-header-number headers))) + gnus-article-save-directory))) + (if (and last-file + (string-equal (file-name-directory default) + (file-name-directory last-file)) + (string-match "^[0-9]+$" (file-name-nondirectory last-file))) + default + (or last-file default)))) + +(defun gnus-numeric-save-name (newsgroup headers &optional last-file) + "Generate file name from NEWSGROUP, HEADERS, and optional LAST-FILE. +If variable `gnus-use-long-file-name' is non-nil, it is +~/News/news.group/num. Otherwise, it is like ~/News/news/group/num." + (let ((default + (expand-file-name + (concat (if (gnus-use-long-file-name 'not-save) + newsgroup + (gnus-newsgroup-directory-form newsgroup)) + "/" (int-to-string (mail-header-number headers))) + gnus-article-save-directory))) + (if (and last-file + (string-equal (file-name-directory default) + (file-name-directory last-file)) + (string-match "^[0-9]+$" (file-name-nondirectory last-file))) + default + (or last-file default)))) + +(defun gnus-Plain-save-name (newsgroup headers &optional last-file) + "Generate file name from NEWSGROUP, HEADERS, and optional LAST-FILE. +If variable `gnus-use-long-file-name' is non-nil, it is +~/News/News.group. Otherwise, it is like ~/News/news/group/news." + (or last-file + (expand-file-name + (if (gnus-use-long-file-name 'not-save) + (gnus-capitalize-newsgroup newsgroup) + (concat (gnus-newsgroup-directory-form newsgroup) "/news")) + gnus-article-save-directory))) + +(defun gnus-plain-save-name (newsgroup headers &optional last-file) + "Generate file name from NEWSGROUP, HEADERS, and optional LAST-FILE. +If variable `gnus-use-long-file-name' is non-nil, it is +~/News/news.group. Otherwise, it is like ~/News/news/group/news." + (or last-file + (expand-file-name + (if (gnus-use-long-file-name 'not-save) + newsgroup + (concat (gnus-newsgroup-directory-form newsgroup) "/news")) + gnus-article-save-directory))) + +(eval-and-compile + (mapcar + (lambda (func) + (let (afunc gfunc) + (if (consp func) + (setq afunc (car func) + gfunc (cdr func)) + (setq afunc func + gfunc (intern (format "gnus-%s" func)))) + (fset gfunc + (if (not (fboundp afunc)) + nil + `(lambda (&optional interactive &rest args) + ,(documentation afunc t) + (interactive (list t)) + (save-excursion + (set-buffer gnus-article-buffer) + (if interactive + (call-interactively ',afunc) + (apply ',afunc args)))))))) + '(article-hide-headers + article-hide-boring-headers + article-treat-overstrike + (article-fill . gnus-article-word-wrap) + article-remove-cr + article-display-x-face + article-de-quoted-unreadable + article-mime-decode-quoted-printable + article-hide-pgp + article-hide-pem + article-hide-signature + article-remove-trailing-blank-lines + article-strip-leading-blank-lines + article-strip-multiple-blank-lines + article-strip-blank-lines + article-date-local + article-date-original + article-date-ut + article-date-user + article-date-lapsed + article-emphasize + (article-show-all . gnus-article-show-all-headers)))) + +;;; +;;; Gnus article mode +;;; + +(put 'gnus-article-mode 'mode-class 'special) + +(when t + (gnus-define-keys gnus-article-mode-map + " " gnus-article-goto-next-page + "\177" gnus-article-goto-prev-page + [delete] gnus-article-goto-prev-page + "\C-c^" gnus-article-refer-article + "h" gnus-article-show-summary + "s" gnus-article-show-summary + "\C-c\C-m" gnus-article-mail + "?" gnus-article-describe-briefly + gnus-mouse-2 gnus-article-push-button + "\r" gnus-article-press-button + "\t" gnus-article-next-button + "\M-\t" gnus-article-prev-button + "e" gnus-article-edit + "<" beginning-of-buffer + ">" end-of-buffer + "\C-c\C-i" gnus-info-find-node + "\C-c\C-b" gnus-bug + + "\C-d" gnus-article-read-summary-keys + "\M-*" gnus-article-read-summary-keys + "\M-#" gnus-article-read-summary-keys + "\M-^" gnus-article-read-summary-keys + "\M-g" gnus-article-read-summary-keys) + + (substitute-key-definition + 'undefined 'gnus-article-read-summary-keys gnus-article-mode-map)) + +(defun gnus-article-make-menu-bar () + (gnus-turn-off-edit-menu 'article) + (unless (boundp 'gnus-article-article-menu) + (easy-menu-define + gnus-article-article-menu gnus-article-mode-map "" + '("Article" + ["Scroll forwards" gnus-article-goto-next-page t] + ["Scroll backwards" gnus-article-goto-prev-page t] + ["Show summary" gnus-article-show-summary t] + ["Fetch Message-ID at point" gnus-article-refer-article t] + ["Mail to address at point" gnus-article-mail t])) + + (easy-menu-define + gnus-article-treatment-menu gnus-article-mode-map "" + '("Treatment" + ["Hide headers" gnus-article-hide-headers t] + ["Hide signature" gnus-article-hide-signature t] + ["Hide citation" gnus-article-hide-citation t] + ["Treat overstrike" gnus-article-treat-overstrike t] + ["Remove carriage return" gnus-article-remove-cr t] + ["Remove quoted-unreadable" gnus-article-de-quoted-unreadable t])) + + (when (boundp 'gnus-summary-article-menu) + (define-key gnus-article-mode-map [menu-bar commands] + (cons "Commands" gnus-summary-article-menu))) + + (when (boundp 'gnus-summary-post-menu) + (define-key gnus-article-mode-map [menu-bar post] + (cons "Post" gnus-summary-post-menu))) + + (run-hooks 'gnus-article-menu-hook))) + +(defun gnus-article-mode () + "Major mode for displaying an article. + +All normal editing commands are switched off. + +The following commands are available in addition to all summary mode +commands: +\\ +\\[gnus-article-next-page]\t Scroll the article one page forwards +\\[gnus-article-prev-page]\t Scroll the article one page backwards +\\[gnus-article-refer-article]\t Go to the article referred to by an article id near point +\\[gnus-article-show-summary]\t Display the summary buffer +\\[gnus-article-mail]\t Send a reply to the address near point +\\[gnus-article-describe-briefly]\t Describe the current mode briefly +\\[gnus-info-find-node]\t Go to the Gnus info node" + (interactive) + (when (gnus-visual-p 'article-menu 'menu) + (gnus-article-make-menu-bar)) + (kill-all-local-variables) + (gnus-simplify-mode-line) + (setq mode-name "Article") + (setq major-mode 'gnus-article-mode) + (make-local-variable 'minor-mode-alist) + (unless (assq 'gnus-show-mime minor-mode-alist) + (push (list 'gnus-show-mime " MIME") minor-mode-alist)) + (use-local-map gnus-article-mode-map) + (gnus-update-format-specifications nil 'article-mode) + (set (make-local-variable 'page-delimiter) gnus-page-delimiter) + (gnus-set-default-directory) + (buffer-disable-undo (current-buffer)) + (setq buffer-read-only t) + (set-syntax-table gnus-article-mode-syntax-table) + (run-hooks 'gnus-article-mode-hook)) + +(defun gnus-article-setup-buffer () + "Initialize the article buffer." + (let* ((name (if gnus-single-article-buffer "*Article*" + (concat "*Article " gnus-newsgroup-name "*"))) + (original + (progn (string-match "\\*Article" name) + (concat " *Original Article" + (substring name (match-end 0)))))) + (setq gnus-article-buffer name) + (setq gnus-original-article-buffer original) + ;; This might be a variable local to the summary buffer. + (unless gnus-single-article-buffer + (save-excursion + (set-buffer gnus-summary-buffer) + (setq gnus-article-buffer name) + (setq gnus-original-article-buffer original) + (gnus-set-global-variables))) + ;; Init original article buffer. + (save-excursion + (set-buffer (get-buffer-create gnus-original-article-buffer)) + (buffer-disable-undo (current-buffer)) + (setq major-mode 'gnus-original-article-mode) + (gnus-add-current-to-buffer-list) + (make-local-variable 'gnus-original-article)) + (if (get-buffer name) + (save-excursion + (set-buffer name) + (buffer-disable-undo (current-buffer)) + (setq buffer-read-only t) + (gnus-add-current-to-buffer-list) + (unless (eq major-mode 'gnus-article-mode) + (gnus-article-mode)) + (current-buffer)) + (save-excursion + (set-buffer (get-buffer-create name)) + (gnus-add-current-to-buffer-list) + (gnus-article-mode) + (make-local-variable 'gnus-summary-buffer) + (current-buffer))))) + +;; Set article window start at LINE, where LINE is the number of lines +;; from the head of the article. +(defun gnus-article-set-window-start (&optional line) + (set-window-start + (get-buffer-window gnus-article-buffer t) + (save-excursion + (set-buffer gnus-article-buffer) + (goto-char (point-min)) + (if (not line) + (point-min) + (gnus-message 6 "Moved to bookmark") + (search-forward "\n\n" nil t) + (forward-line line) + (point))))) + +(defun gnus-article-prepare (article &optional all-headers header) + "Prepare ARTICLE in article mode buffer. +ARTICLE should either be an article number or a Message-ID. +If ARTICLE is an id, HEADER should be the article headers. +If ALL-HEADERS is non-nil, no headers are hidden." + (save-excursion + ;; Make sure we start in a summary buffer. + (unless (eq major-mode 'gnus-summary-mode) + (set-buffer gnus-summary-buffer)) + (setq gnus-summary-buffer (current-buffer)) + ;; Make sure the connection to the server is alive. + (unless (gnus-server-opened + (gnus-find-method-for-group gnus-newsgroup-name)) + (gnus-check-server (gnus-find-method-for-group gnus-newsgroup-name)) + (gnus-request-group gnus-newsgroup-name t)) + (let* ((gnus-article (if header (mail-header-number header) article)) + (summary-buffer (current-buffer)) + (internal-hook gnus-article-internal-prepare-hook) + (group gnus-newsgroup-name) + result) + (save-excursion + (gnus-article-setup-buffer) + (set-buffer gnus-article-buffer) + ;; Deactivate active regions. + (when (and (boundp 'transient-mark-mode) + transient-mark-mode) + (setq mark-active nil)) + (if (not (setq result (let ((buffer-read-only nil)) + (gnus-request-article-this-buffer + article group)))) + ;; There is no such article. + (save-excursion + (when (and (numberp article) + (not (memq article gnus-newsgroup-sparse))) + (setq gnus-article-current + (cons gnus-newsgroup-name article)) + (set-buffer gnus-summary-buffer) + (setq gnus-current-article article) + (gnus-summary-mark-article article gnus-canceled-mark)) + (unless (memq article gnus-newsgroup-sparse) + (gnus-error + 1 "No such article (may have expired or been canceled)"))) + (if (or (eq result 'pseudo) (eq result 'nneething)) + (progn + (save-excursion + (set-buffer summary-buffer) + (setq gnus-last-article gnus-current-article + gnus-newsgroup-history (cons gnus-current-article + gnus-newsgroup-history) + gnus-current-article 0 + gnus-current-headers nil + gnus-article-current nil) + (if (eq result 'nneething) + (gnus-configure-windows 'summary) + (gnus-configure-windows 'article)) + (gnus-set-global-variables)) + (gnus-set-mode-line 'article)) + ;; The result from the `request' was an actual article - + ;; or at least some text that is now displayed in the + ;; article buffer. + (when (and (numberp article) + (not (eq article gnus-current-article))) + ;; Seems like a new article has been selected. + ;; `gnus-current-article' must be an article number. + (save-excursion + (set-buffer summary-buffer) + (setq gnus-last-article gnus-current-article + gnus-newsgroup-history (cons gnus-current-article + gnus-newsgroup-history) + gnus-current-article article + gnus-current-headers + (gnus-summary-article-header gnus-current-article) + gnus-article-current + (cons gnus-newsgroup-name gnus-current-article)) + (unless (vectorp gnus-current-headers) + (setq gnus-current-headers nil)) + (gnus-summary-show-thread) + (run-hooks 'gnus-mark-article-hook) + (gnus-set-mode-line 'summary) + (when (gnus-visual-p 'article-highlight 'highlight) + (run-hooks 'gnus-visual-mark-article-hook)) + ;; Set the global newsgroup variables here. + ;; Suggested by Jim Sisolak + ;; . + (gnus-set-global-variables) + (setq gnus-have-all-headers + (or all-headers gnus-show-all-headers)) + (and gnus-use-cache + (vectorp (gnus-summary-article-header article)) + (gnus-cache-possibly-enter-article + group article + (gnus-summary-article-header article) + (memq article gnus-newsgroup-marked) + (memq article gnus-newsgroup-dormant) + (memq article gnus-newsgroup-unreads))))) + (when (or (numberp article) + (stringp article)) + ;; Hooks for getting information from the article. + ;; This hook must be called before being narrowed. + (let (buffer-read-only) + (run-hooks 'internal-hook) + (run-hooks 'gnus-article-prepare-hook) + ;; Decode MIME message. + (when gnus-show-mime + (if (or (not gnus-strict-mime) + (gnus-fetch-field "Mime-Version")) + (funcall gnus-show-mime-method) + (funcall gnus-decode-encoded-word-method))) + ;; Perform the article display hooks. + (run-hooks 'gnus-article-display-hook)) + ;; Do page break. + (goto-char (point-min)) + (when gnus-break-pages + (gnus-narrow-to-page))) + (gnus-set-mode-line 'article) + (gnus-configure-windows 'article) + (goto-char (point-min)) + t)))))) + +(defun gnus-article-wash-status () + "Return a string which display status of article washing." + (save-excursion + (set-buffer gnus-article-buffer) + (let ((cite (gnus-article-hidden-text-p 'cite)) + (headers (gnus-article-hidden-text-p 'headers)) + (boring (gnus-article-hidden-text-p 'boring-headers)) + (pgp (gnus-article-hidden-text-p 'pgp)) + (pem (gnus-article-hidden-text-p 'pem)) + (signature (gnus-article-hidden-text-p 'signature)) + (overstrike (gnus-article-hidden-text-p 'overstrike)) + (emphasis (gnus-article-hidden-text-p 'emphasis)) + (mime gnus-show-mime)) + (format "%c%c%c%c%c%c%c" + (if cite ?c ? ) + (if (or headers boring) ?h ? ) + (if (or pgp pem) ?p ? ) + (if signature ?s ? ) + (if overstrike ?o ? ) + (if mime ?m ? ) + (if emphasis ?e ? ))))) + +(defun gnus-article-hide-headers-if-wanted () + "Hide unwanted headers if `gnus-have-all-headers' is nil. +Provided for backwards compatibility." + (or (save-excursion (set-buffer gnus-summary-buffer) gnus-have-all-headers) + gnus-inhibit-hiding + (gnus-article-hide-headers))) + +;;; Article savers. + +(defun gnus-output-to-file (file-name) + "Append the current article to a file named FILE-NAME." + (let ((artbuf (current-buffer))) + (nnheader-temp-write nil + (insert-buffer-substring artbuf) + ;; Append newline at end of the buffer as separator, and then + ;; save it to file. + (goto-char (point-max)) + (insert "\n") + (append-to-file (point-min) (point-max) file-name)))) + +(defun gnus-narrow-to-page (&optional arg) + "Narrow the article buffer to a page. +If given a numerical ARG, move forward ARG pages." + (interactive "P") + (setq arg (if arg (prefix-numeric-value arg) 0)) + (save-excursion + (set-buffer gnus-article-buffer) + (goto-char (point-min)) + (widen) + ;; Remove any old next/prev buttons. + (when (gnus-visual-p 'page-marker) + (let ((buffer-read-only nil)) + (gnus-remove-text-with-property 'gnus-prev) + (gnus-remove-text-with-property 'gnus-next))) + (when + (cond ((< arg 0) + (re-search-backward page-delimiter nil 'move (1+ (abs arg)))) + ((> arg 0) + (re-search-forward page-delimiter nil 'move arg))) + (goto-char (match-end 0))) + (narrow-to-region + (point) + (if (re-search-forward page-delimiter nil 'move) + (match-beginning 0) + (point))) + (when (and (gnus-visual-p 'page-marker) + (not (= (point-min) 1))) + (save-excursion + (goto-char (point-min)) + (gnus-insert-prev-page-button))) + (when (and (gnus-visual-p 'page-marker) + (< (+ (point-max) 2) (buffer-size))) + (save-excursion + (goto-char (point-max)) + (gnus-insert-next-page-button))))) + +;; Article mode commands + +(defun gnus-article-goto-next-page () + "Show the next page of the article." + (interactive) + (when (gnus-article-next-page) + (gnus-article-read-summary-keys nil (gnus-character-to-event ?n)))) + +(defun gnus-article-goto-prev-page () + "Show the next page of the article." + (interactive) + (if (bobp) (gnus-article-read-summary-keys nil (gnus-character-to-event ?p)) + (gnus-article-prev-page nil))) + +(defun gnus-article-next-page (&optional lines) + "Show the next page of the current article. +If end of article, return non-nil. Otherwise return nil. +Argument LINES specifies lines to be scrolled up." + (interactive "p") + (move-to-window-line -1) + (if (save-excursion + (end-of-line) + (and (pos-visible-in-window-p) ;Not continuation line. + (eobp))) + ;; Nothing in this page. + (if (or (not gnus-break-pages) + (save-excursion + (save-restriction + (widen) (forward-line 1) (eobp)))) ;Real end-of-buffer? + t ;Nothing more. + (gnus-narrow-to-page 1) ;Go to next page. + nil) + ;; More in this page. + (let ((scroll-in-place nil)) + (condition-case () + (scroll-up lines) + (end-of-buffer + ;; Long lines may cause an end-of-buffer error. + (goto-char (point-max))))) + (move-to-window-line 0) + nil)) + +(defun gnus-article-prev-page (&optional lines) + "Show previous page of current article. +Argument LINES specifies lines to be scrolled down." + (interactive "p") + (move-to-window-line 0) + (if (and gnus-break-pages + (bobp) + (not (save-restriction (widen) (bobp)))) ;Real beginning-of-buffer? + (progn + (gnus-narrow-to-page -1) ;Go to previous page. + (goto-char (point-max)) + (recenter -1)) + (let ((scroll-in-place nil)) + (prog1 + (ignore-errors + (scroll-down lines)) + (move-to-window-line 0))))) + +(defun gnus-article-refer-article () + "Read article specified by message-id around point." + (interactive) + (let ((point (point))) + (search-forward ">" nil t) ;Move point to end of "<....>". + (if (re-search-backward "\\(<[^<> \t\n]+>\\)" nil t) + (let ((message-id (match-string 1))) + (goto-char point) + (set-buffer gnus-summary-buffer) + (gnus-summary-refer-article message-id)) + (goto-char (point)) + (error "No references around point")))) + +(defun gnus-article-show-summary () + "Reconfigure windows to show summary buffer." + (interactive) + (gnus-configure-windows 'article) + (gnus-summary-goto-subject gnus-current-article)) + +(defun gnus-article-describe-briefly () + "Describe article mode commands briefly." + (interactive) + (gnus-message 6 + (substitute-command-keys "\\\\[gnus-article-goto-next-page]:Next page \\[gnus-article-goto-prev-page]:Prev page \\[gnus-article-show-summary]:Show summary \\[gnus-info-find-node]:Run Info \\[gnus-article-describe-briefly]:This help"))) + +(defun gnus-article-summary-command () + "Execute the last keystroke in the summary buffer." + (interactive) + (let ((obuf (current-buffer)) + (owin (current-window-configuration)) + func) + (switch-to-buffer gnus-summary-buffer 'norecord) + (setq func (lookup-key (current-local-map) (this-command-keys))) + (call-interactively func) + (set-buffer obuf) + (set-window-configuration owin) + (set-window-point (get-buffer-window (current-buffer)) (point)))) + +(defun gnus-article-summary-command-nosave () + "Execute the last keystroke in the summary buffer." + (interactive) + (let (func) + (pop-to-buffer gnus-summary-buffer 'norecord) + (setq func (lookup-key (current-local-map) (this-command-keys))) + (call-interactively func))) + +(defun gnus-article-read-summary-keys (&optional arg key not-restore-window) + "Read a summary buffer key sequence and execute it from the article buffer." + (interactive "P") + (let ((nosaves + '("q" "Q" "c" "r" "R" "\C-c\C-f" "m" "a" "f" "F" + "Zc" "ZC" "ZE" "ZQ" "ZZ" "Zn" "ZR" "ZG" "ZN" "ZP" + "=" "^" "\M-^" "|")) + (nosave-but-article + '("A\r")) + (nosave-in-article + '("\C-d")) + keys) + (save-excursion + (set-buffer gnus-summary-buffer) + (let (gnus-pick-mode) + (push (or key last-command-event) unread-command-events) + (setq keys (read-key-sequence nil)))) + (message "") + + (if (or (member keys nosaves) + (member keys nosave-but-article) + (member keys nosave-in-article)) + (let (func) + (save-window-excursion + (pop-to-buffer gnus-summary-buffer 'norecord) + ;; We disable the pick minor mode commands. + (let (gnus-pick-mode) + (setq func (lookup-key (current-local-map) keys)))) + (if (not func) + (ding) + (unless (member keys nosave-in-article) + (set-buffer gnus-summary-buffer)) + (call-interactively func)) + (when (member keys nosave-but-article) + (pop-to-buffer gnus-article-buffer 'norecord))) + ;; These commands should restore window configuration. + (let ((obuf (current-buffer)) + (owin (current-window-configuration)) + (opoint (point)) + func in-buffer) + (if not-restore-window + (pop-to-buffer gnus-summary-buffer 'norecord) + (switch-to-buffer gnus-summary-buffer 'norecord)) + (setq in-buffer (current-buffer)) + ;; We disable the pick minor mode commands. + (if (setq func (let (gnus-pick-mode) + (lookup-key (current-local-map) keys))) + (call-interactively func) + (ding)) + (when (eq in-buffer (current-buffer)) + (set-buffer obuf) + (unless not-restore-window + (set-window-configuration owin)) + (set-window-point (get-buffer-window (current-buffer)) opoint)))))) + +(defun gnus-article-hide (&optional arg force) + "Hide all the gruft in the current article. +This means that PGP stuff, signatures, cited text and (some) +headers will be hidden. +If given a prefix, show the hidden text instead." + (interactive (list current-prefix-arg 'force)) + (gnus-article-hide-headers arg) + (gnus-article-hide-pgp arg) + (gnus-article-hide-citation-maybe arg force) + (gnus-article-hide-signature arg)) + +(defun gnus-article-maybe-highlight () + "Do some article highlighting if `article-visual' is non-nil." + (when (gnus-visual-p 'article-highlight 'highlight) + (gnus-article-highlight-some))) + +(defun gnus-request-article-this-buffer (article group) + "Get an article and insert it into this buffer." + (let (do-update-line) + (prog1 + (save-excursion + (erase-buffer) + (gnus-kill-all-overlays) + (setq group (or group gnus-newsgroup-name)) + + ;; Open server if it has closed. + (gnus-check-server (gnus-find-method-for-group group)) + + ;; Using `gnus-request-article' directly will insert the article into + ;; `nntp-server-buffer' - so we'll save some time by not having to + ;; copy it from the server buffer into the article buffer. + + ;; We only request an article by message-id when we do not have the + ;; headers for it, so we'll have to get those. + (when (stringp article) + (let ((gnus-override-method gnus-refer-article-method)) + (gnus-read-header article))) + + ;; If the article number is negative, that means that this article + ;; doesn't belong in this newsgroup (possibly), so we find its + ;; message-id and request it by id instead of number. + (when (and (numberp article) + gnus-summary-buffer + (get-buffer gnus-summary-buffer) + (buffer-name (get-buffer gnus-summary-buffer))) + (save-excursion + (set-buffer gnus-summary-buffer) + (let ((header (gnus-summary-article-header article))) + (when (< article 0) + (cond + ((memq article gnus-newsgroup-sparse) + ;; This is a sparse gap article. + (setq do-update-line article) + (setq article (mail-header-id header)) + (let ((gnus-override-method gnus-refer-article-method)) + (gnus-read-header article)) + (setq gnus-newsgroup-sparse + (delq article gnus-newsgroup-sparse))) + ((vectorp header) + ;; It's a real article. + (setq article (mail-header-id header))) + (t + ;; It is an extracted pseudo-article. + (setq article 'pseudo) + (gnus-request-pseudo-article header)))) + + (let ((method (gnus-find-method-for-group + gnus-newsgroup-name))) + (if (not (eq (car method) 'nneething)) + () + (let ((dir (concat (file-name-as-directory (nth 1 method)) + (mail-header-subject header)))) + (when (file-directory-p dir) + (setq article 'nneething) + (gnus-group-enter-directory dir)))))))) + + (cond + ;; Refuse to select canceled articles. + ((and (numberp article) + gnus-summary-buffer + (get-buffer gnus-summary-buffer) + (buffer-name (get-buffer gnus-summary-buffer)) + (eq (cdr (save-excursion + (set-buffer gnus-summary-buffer) + (assq article gnus-newsgroup-reads))) + gnus-canceled-mark)) + nil) + ;; We first check `gnus-original-article-buffer'. + ((and (get-buffer gnus-original-article-buffer) + (numberp article) + (save-excursion + (set-buffer gnus-original-article-buffer) + (and (equal (car gnus-original-article) group) + (eq (cdr gnus-original-article) article)))) + (insert-buffer-substring gnus-original-article-buffer) + 'article) + ;; Check the backlog. + ((and gnus-keep-backlog + (gnus-backlog-request-article group article (current-buffer))) + 'article) + ;; Check asynchronous pre-fetch. + ((gnus-async-request-fetched-article group article (current-buffer)) + (gnus-async-prefetch-next group article gnus-summary-buffer) + 'article) + ;; Check the cache. + ((and gnus-use-cache + (numberp article) + (gnus-cache-request-article article group)) + 'article) + ;; Get the article and put into the article buffer. + ((or (stringp article) (numberp article)) + (let ((gnus-override-method + (and (stringp article) gnus-refer-article-method)) + (buffer-read-only nil)) + (erase-buffer) + (gnus-kill-all-overlays) + (when (gnus-request-article article group (current-buffer)) + (when (numberp article) + (gnus-async-prefetch-next group article gnus-summary-buffer) + (when gnus-keep-backlog + (gnus-backlog-enter-article + group article (current-buffer)))) + 'article))) + ;; It was a pseudo. + (t article))) + + ;; Take the article from the original article buffer + ;; and place it in the buffer it's supposed to be in. + (when (and (get-buffer gnus-article-buffer) + ;;(numberp article) + (equal (buffer-name (current-buffer)) + (buffer-name (get-buffer gnus-article-buffer)))) + (save-excursion + (if (get-buffer gnus-original-article-buffer) + (set-buffer (get-buffer gnus-original-article-buffer)) + (set-buffer (get-buffer-create gnus-original-article-buffer)) + (buffer-disable-undo (current-buffer)) + (setq major-mode 'gnus-original-article-mode) + (setq buffer-read-only t) + (gnus-add-current-to-buffer-list)) + (let (buffer-read-only) + (erase-buffer) + (insert-buffer-substring gnus-article-buffer)) + (setq gnus-original-article (cons group article)))) + + ;; Update sparse articles. + (when (and do-update-line + (or (numberp article) + (stringp article))) + (let ((buf (current-buffer))) + (set-buffer gnus-summary-buffer) + (gnus-summary-update-article do-update-line) + (gnus-summary-goto-subject do-update-line nil t) + (set-window-point (get-buffer-window (current-buffer) t) + (point)) + (set-buffer buf)))))) + +;;; +;;; Article editing +;;; + +(defcustom gnus-article-edit-mode-hook nil + "Hook run in article edit mode buffers." + :group 'gnus-article-various + :type 'hook) + +(defvar gnus-article-edit-done-function nil) + +(defvar gnus-article-edit-mode-map nil) + +(unless gnus-article-edit-mode-map + (setq gnus-article-edit-mode-map (copy-keymap text-mode-map)) + + (gnus-define-keys gnus-article-edit-mode-map + "\C-c\C-c" gnus-article-edit-done + "\C-c\C-k" gnus-article-edit-exit) + + (gnus-define-keys (gnus-article-edit-wash-map + "\C-c\C-w" gnus-article-edit-mode-map) + "f" gnus-article-edit-full-stops)) + +(defun gnus-article-edit-mode () + "Major mode for editing articles. +This is an extended text-mode. + +\\{gnus-article-edit-mode-map}" + (interactive) + (kill-all-local-variables) + (setq major-mode 'gnus-article-edit-mode) + (setq mode-name "Article Edit") + (use-local-map gnus-article-edit-mode-map) + (make-local-variable 'gnus-article-edit-done-function) + (make-local-variable 'gnus-prev-winconf) + (setq buffer-read-only nil) + (buffer-enable-undo) + (widen) + (run-hooks 'text-mode 'gnus-article-edit-mode-hook)) + +(defun gnus-article-edit (&optional force) + "Edit the current article. +This will have permanent effect only in mail groups. +If FORCE is non-nil, allow editing of articles even in read-only +groups." + (interactive "P") + (when (and (not force) + (gnus-group-read-only-p)) + (error "The current newsgroup does not support article editing.")) + (gnus-article-edit-article + `(lambda () + (gnus-summary-edit-article-done + ,(or (mail-header-references gnus-current-headers) "") + ,(gnus-group-read-only-p) ,gnus-summary-buffer)))) + +(defun gnus-article-edit-article (exit-func) + "Start editing the contents of the current article buffer." + (let ((winconf (current-window-configuration))) + (set-buffer gnus-article-buffer) + (gnus-article-edit-mode) + (set-text-properties (point-min) (point-max) nil) + (gnus-configure-windows 'edit-article) + (setq gnus-article-edit-done-function exit-func) + (setq gnus-prev-winconf winconf) + (gnus-message 6 "C-c C-c to end edits"))) + +(defun gnus-article-edit-done () + "Update the article edits and exit." + (interactive) + (let ((func gnus-article-edit-done-function) + (buf (current-buffer)) + (start (window-start))) + (gnus-article-edit-exit) + (save-excursion + (set-buffer buf) + (let ((buffer-read-only nil)) + (funcall func))) + (set-buffer buf) + (set-window-start (get-buffer-window buf) start) + (set-window-point (get-buffer-window buf) (point)))) + +(defun gnus-article-edit-exit () + "Exit the article editing without updating." + (interactive) + ;; We remove all text props from the article buffer. + (let ((buf (format "%s" (buffer-string))) + (curbuf (current-buffer)) + (p (point)) + (window-start (window-start))) + (erase-buffer) + (insert buf) + (let ((winconf gnus-prev-winconf)) + (gnus-article-mode) + ;; The cache and backlog have to be flushed somewhat. + (when gnus-use-cache + (gnus-cache-update-article + (car gnus-article-current) (cdr gnus-article-current))) + (when gnus-keep-backlog + (gnus-backlog-remove-article + (car gnus-article-current) (cdr gnus-article-current))) + ;; Flush original article as well. + (save-excursion + (when (get-buffer gnus-original-article-buffer) + (set-buffer gnus-original-article-buffer) + (setq gnus-original-article nil))) + (set-window-configuration winconf) + ;; Tippy-toe some to make sure that point remains where it was. + (let ((buf (current-buffer))) + (set-buffer curbuf) + (set-window-start (get-buffer-window (current-buffer)) window-start) + (goto-char p) + (set-buffer buf))))) + +(defun gnus-article-edit-full-stops () + "Interactively repair spacing at end of sentences." + (interactive) + (save-excursion + (goto-char (point-min)) + (search-forward-regexp "^$" nil t) + (let ((case-fold-search nil)) + (query-replace-regexp "\\([.!?][])}]* \\)\\([[({A-Z]\\)" "\\1 \\2")))) + +;;; +;;; Article highlights +;;; + +;; Written by Per Abrahamsen . + +;;; Internal Variables: + +(defcustom gnus-button-url-regexp "\\b\\(s?https?\\|ftp\\|file\\|gopher\\|news\\|telnet\\|wais\\|mailto\\):\\(//[-a-zA-Z0-9_.]+:[0-9]*\\)?\\([-a-zA-Z0-9_=!?#$@~`%&*+|\\/:;.,]\\|\\w\\)+\\([-a-zA-Z0-9_=#$@~`%&*+|\\/]\\|\\w\\)" + "Regular expression that matches URLs." + :group 'gnus-article-buttons + :type 'regexp) + +(defcustom gnus-button-alist + `(("\\(\\b<\\(url: ?\\)?news:\\([^>\n\t ]*\\)>\\)" 1 t + gnus-button-message-id 3) + ("\\bnews:\\([^\n\t ]+\\)" 0 t gnus-button-message-id 1) + ("\\(\\b<\\(url: ?\\)?news:\\(//\\)?\\([^>\n\t ]*\\)>\\)" 1 t + gnus-button-fetch-group 4) + ("\\bnews:\\(//\\)?\\([^>\n\t ]+\\)" 0 t gnus-button-fetch-group 2) + ("\\bin\\( +article\\)? +\\(<\\([^\n @<>]+@[^\n @<>]+\\)>\\)" 2 + t gnus-button-message-id 3) + ("\\( \n\t]+\\)>" 0 t gnus-url-mailto 1) + ("\\bmailto:\\([^ \n\t]+\\)" 0 t gnus-url-mailto 2) + ;; This is how URLs _should_ be embedded in text... + ("]*\\)>" 0 t gnus-button-embedded-url 1) + ;; Raw URLs. + (,gnus-button-url-regexp 0 t gnus-button-url 0)) + "Alist of regexps matching buttons in article bodies. + +Each entry has the form (REGEXP BUTTON FORM CALLBACK PAR...), where +REGEXP: is the string matching text around the button, +BUTTON: is the number of the regexp grouping actually matching the button, +FORM: is a lisp expression which must eval to true for the button to +be added, +CALLBACK: is the function to call when the user push this button, and each +PAR: is a number of a regexp grouping whose text will be passed to CALLBACK. + +CALLBACK can also be a variable, in that case the value of that +variable it the real callback function." + :group 'gnus-article-buttons + :type '(repeat (list regexp + (integer :tag "Button") + (sexp :tag "Form") + (function :tag "Callback") + (repeat :tag "Par" + :inline t + (integer :tag "Regexp group"))))) + +(defcustom gnus-header-button-alist + `(("^\\(References\\|Message-I[Dd]\\):" "<[^>]+>" + 0 t gnus-button-message-id 0) + ("^\\(From\\|Reply-To\\):" ": *\\(.+\\)$" 1 t gnus-button-reply 1) + ("^\\(Cc\\|To\\):" "[^ \t\n<>,()\"]+@[^ \t\n<>,()\"]+" + 0 t gnus-button-mailto 0) + ("^X-[Uu][Rr][Ll]:" ,gnus-button-url-regexp 0 t gnus-button-url 0) + ("^[^:]+:" ,gnus-button-url-regexp 0 t gnus-button-url 0) + ("^[^:]+:" "\\(<\\(url: \\)?news:\\([^>\n ]*\\)>\\)" 1 t + gnus-button-message-id 3)) + "Alist of headers and regexps to match buttons in article heads. + +This alist is very similar to `gnus-button-alist', except that each +alist has an additional HEADER element first in each entry: + +\(HEADER REGEXP BUTTON FORM CALLBACK PAR) + +HEADER is a regexp to match a header. For a fuller explanation, see +`gnus-button-alist'." + :group 'gnus-article-buttons + :group 'gnus-article-headers + :type '(repeat (list (regexp :tag "Header") + regexp + (integer :tag "Button") + (sexp :tag "Form") + (function :tag "Callback") + (repeat :tag "Par" + :inline t + (integer :tag "Regexp group"))))) + +(defvar gnus-button-regexp nil) +(defvar gnus-button-marker-list nil) +;; Regexp matching any of the regexps from `gnus-button-alist'. + +(defvar gnus-button-last nil) +;; The value of `gnus-button-alist' when `gnus-button-regexp' was build. + +;;; Commands: + +(defun gnus-article-push-button (event) + "Check text under the mouse pointer for a callback function. +If the text under the mouse pointer has a `gnus-callback' property, +call it with the value of the `gnus-data' text property." + (interactive "e") + (set-buffer (window-buffer (posn-window (event-start event)))) + (let* ((pos (posn-point (event-start event))) + (data (get-text-property pos 'gnus-data)) + (fun (get-text-property pos 'gnus-callback))) + (when fun + (funcall fun data)))) + +(defun gnus-article-press-button () + "Check text at point for a callback function. +If the text at point has a `gnus-callback' property, +call it with the value of the `gnus-data' text property." + (interactive) + (let* ((data (get-text-property (point) 'gnus-data)) + (fun (get-text-property (point) 'gnus-callback))) + (when fun + (funcall fun data)))) + +(defun gnus-article-prev-button (n) + "Move point to N buttons backward. +If N is negative, move forward instead." + (interactive "p") + (gnus-article-next-button (- n))) + +(defun gnus-article-next-button (n) + "Move point to N buttons forward. +If N is negative, move backward instead." + (interactive "p") + (let ((function (if (< n 0) 'previous-single-property-change + 'next-single-property-change)) + (inhibit-point-motion-hooks t) + (backward (< n 0)) + (limit (if (< n 0) (point-min) (point-max)))) + (setq n (abs n)) + (while (and (not (= limit (point))) + (> n 0)) + ;; Skip past the current button. + (when (get-text-property (point) 'gnus-callback) + (goto-char (funcall function (point) 'gnus-callback nil limit))) + ;; Go to the next (or previous) button. + (gnus-goto-char (funcall function (point) 'gnus-callback nil limit)) + ;; Put point at the start of the button. + (when (and backward (not (get-text-property (point) 'gnus-callback))) + (goto-char (funcall function (point) 'gnus-callback nil limit))) + ;; Skip past intangible buttons. + (when (get-text-property (point) 'intangible) + (incf n)) + (decf n)) + (unless (zerop n) + (gnus-message 5 "No more buttons")) + n)) + +(defun gnus-article-highlight (&optional force) + "Highlight current article. +This function calls `gnus-article-highlight-headers', +`gnus-article-highlight-citation', +`gnus-article-highlight-signature', and `gnus-article-add-buttons' to +do the highlighting. See the documentation for those functions." + (interactive (list 'force)) + (gnus-article-highlight-headers) + (gnus-article-highlight-citation force) + (gnus-article-highlight-signature) + (gnus-article-add-buttons force) + (gnus-article-add-buttons-to-head)) + +(defun gnus-article-highlight-some (&optional force) + "Highlight current article. +This function calls `gnus-article-highlight-headers', +`gnus-article-highlight-signature', and `gnus-article-add-buttons' to +do the highlighting. See the documentation for those functions." + (interactive (list 'force)) + (gnus-article-highlight-headers) + (gnus-article-highlight-signature) + (gnus-article-add-buttons)) + +(defun gnus-article-highlight-headers () + "Highlight article headers as specified by `gnus-header-face-alist'." + (interactive) + (save-excursion + (set-buffer gnus-article-buffer) + (save-restriction + (let ((alist gnus-header-face-alist) + (buffer-read-only nil) + (case-fold-search t) + (inhibit-point-motion-hooks t) + entry regexp header-face field-face from hpoints fpoints) + (goto-char (point-min)) + (when (search-forward "\n\n" nil t) + (narrow-to-region (1- (point)) (point-min)) + (while (setq entry (pop alist)) + (goto-char (point-min)) + (setq regexp (concat "^\\(" + (if (string-equal "" (nth 0 entry)) + "[^\t ]" + (nth 0 entry)) + "\\)") + header-face (nth 1 entry) + field-face (nth 2 entry)) + (while (and (re-search-forward regexp nil t) + (not (eobp))) + (beginning-of-line) + (setq from (point)) + (unless (search-forward ":" nil t) + (forward-char 1)) + (when (and header-face + (not (memq (point) hpoints))) + (push (point) hpoints) + (gnus-put-text-property from (point) 'face header-face)) + (when (and field-face + (not (memq (setq from (point)) fpoints))) + (push from fpoints) + (if (re-search-forward "^[^ \t]" nil t) + (forward-char -2) + (goto-char (point-max))) + (gnus-put-text-property from (point) 'face field-face))))))))) + +(defun gnus-article-highlight-signature () + "Highlight the signature in an article. +It does this by highlighting everything after +`gnus-signature-separator' using `gnus-signature-face'." + (interactive) + (save-excursion + (set-buffer gnus-article-buffer) + (let ((buffer-read-only nil) + (inhibit-point-motion-hooks t)) + (save-restriction + (when (and gnus-signature-face + (gnus-article-narrow-to-signature)) + (gnus-overlay-put (gnus-make-overlay (point-min) (point-max)) + 'face gnus-signature-face) + (widen) + (gnus-article-search-signature) + (let ((start (match-beginning 0)) + (end (set-marker (make-marker) (1+ (match-end 0))))) + (gnus-article-add-button start (1- end) 'gnus-signature-toggle + end))))))) + +(defun gnus-article-add-buttons (&optional force) + "Find external references in the article and make buttons of them. +\"External references\" are things like Message-IDs and URLs, as +specified by `gnus-button-alist'." + (interactive (list 'force)) + (save-excursion + (set-buffer gnus-article-buffer) + ;; Remove all old markers. + (while gnus-button-marker-list + (set-marker (pop gnus-button-marker-list) nil)) + (let ((buffer-read-only nil) + (inhibit-point-motion-hooks t) + (case-fold-search t) + (alist gnus-button-alist) + beg entry regexp) + (goto-char (point-min)) + ;; We skip the headers. + (unless (search-forward "\n\n" nil t) + (goto-char (point-max))) + (setq beg (point)) + (while (setq entry (pop alist)) + (setq regexp (car entry)) + (goto-char beg) + (while (re-search-forward regexp nil t) + (let* ((start (and entry (match-beginning (nth 1 entry)))) + (end (and entry (match-end (nth 1 entry)))) + (from (match-beginning 0))) + (when (and (or (eq t (nth 1 entry)) + (eval (nth 1 entry))) + (not (get-text-property (point) 'gnus-callback))) + ;; That optional form returned non-nil, so we add the + ;; button. + (gnus-article-add-button + start end 'gnus-button-push + (car (push (set-marker (make-marker) from) + gnus-button-marker-list)))))))))) + +;; Add buttons to the head of an article. +(defun gnus-article-add-buttons-to-head () + "Add buttons to the head of the article." + (interactive) + (save-excursion + (set-buffer gnus-article-buffer) + (let ((buffer-read-only nil) + (inhibit-point-motion-hooks t) + (case-fold-search t) + (alist gnus-header-button-alist) + entry beg end) + (nnheader-narrow-to-headers) + (while alist + ;; Each alist entry. + (setq entry (car alist) + alist (cdr alist)) + (goto-char (point-min)) + (while (re-search-forward (car entry) nil t) + ;; Each header matching the entry. + (setq beg (match-beginning 0)) + (setq end (or (and (re-search-forward "^[^ \t]" nil t) + (match-beginning 0)) + (point-max))) + (goto-char beg) + (while (re-search-forward (nth 1 entry) end t) + ;; Each match within a header. + (let* ((entry (cdr entry)) + (start (match-beginning (nth 1 entry))) + (end (match-end (nth 1 entry))) + (form (nth 2 entry))) + (goto-char (match-end 0)) + (when (eval form) + (gnus-article-add-button + start end (nth 3 entry) + (buffer-substring (match-beginning (nth 4 entry)) + (match-end (nth 4 entry))))))) + (goto-char end)))) + (widen))) + +;;; External functions: + +(defun gnus-article-add-button (from to fun &optional data) + "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) + 'face gnus-article-button-face)) + (gnus-add-text-properties + from to + (nconc (and gnus-article-mouse-face + (list gnus-mouse-face-prop gnus-article-mouse-face)) + (list 'gnus-callback fun) + (and data (list 'gnus-data data))))) + +;;; Internal functions: + +(defun gnus-signature-toggle (end) + (save-excursion + (set-buffer gnus-article-buffer) + (let ((buffer-read-only nil) + (inhibit-point-motion-hooks t)) + (if (get-text-property end 'invisible) + (gnus-article-unhide-text end (point-max)) + (gnus-article-hide-text end (point-max) gnus-hidden-properties))))) + +(defun gnus-button-entry () + ;; Return the first entry in `gnus-button-alist' matching this place. + (let ((alist gnus-button-alist) + (entry nil)) + (while alist + (setq entry (pop alist)) + (if (looking-at (car entry)) + (setq alist nil) + (setq entry nil))) + entry)) + +(defun gnus-button-push (marker) + ;; Push button starting at MARKER. + (save-excursion + (set-buffer gnus-article-buffer) + (goto-char marker) + (let* ((entry (gnus-button-entry)) + (inhibit-point-motion-hooks t) + (fun (nth 3 entry)) + (args (mapcar (lambda (group) + (let ((string (match-string group))) + (gnus-set-text-properties + 0 (length string) nil string) + string)) + (nthcdr 4 entry)))) + (cond + ((fboundp fun) + (apply fun args)) + ((and (boundp fun) + (fboundp (symbol-value fun))) + (apply (symbol-value fun) args)) + (t + (gnus-message 1 "You must define `%S' to use this button" + (cons fun args))))))) + +(defun gnus-button-message-id (message-id) + "Fetch MESSAGE-ID." + (save-excursion + (set-buffer gnus-summary-buffer) + (gnus-summary-refer-article message-id))) + +(defun gnus-button-fetch-group (address) + "Fetch GROUP specified by ADDRESS." + (if (not (string-match "^\\([^:/]+\\)\\(:\\([^/]+\\)\\)?/\\(.*\\)$" address)) + (error "Can't parse %s" address) + (gnus-group-read-ephemeral-group + (match-string 4 address) + `(nntp ,(match-string 1 address) (nntp-address ,(match-string 1 address)) + (nntp-port-number ,(if (match-end 3) + (match-string 3 address) + "nntp")))))) + +(defun gnus-split-string (string pattern) + "Return a list of substrings of STRING which are separated by PATTERN." + (let (parts (start 0)) + (while (string-match pattern string start) + (setq parts (cons (substring string start (match-beginning 0)) parts) + start (match-end 0))) + (nreverse (cons (substring string start) parts)))) + +(defun gnus-url-parse-query-string (query &optional downcase) + (let (retval pairs cur key val) + (setq pairs (gnus-split-string query "&")) + (while pairs + (setq cur (car pairs) + pairs (cdr pairs)) + (if (not (string-match "=" cur)) + nil ; Grace + (setq key (gnus-url-unhex-string (substring cur 0 (match-beginning 0))) + val (gnus-url-unhex-string (substring cur (match-end 0) nil))) + (if downcase + (setq key (downcase key))) + (setq cur (assoc key retval)) + (if cur + (setcdr cur (cons val (cdr cur))) + (setq retval (cons (list key val) retval))))) + retval)) + +(defun gnus-url-unhex (x) + (if (> x ?9) + (if (>= x ?a) + (+ 10 (- x ?a)) + (+ 10 (- x ?A))) + (- x ?0))) + +(defun gnus-url-unhex-string (str &optional allow-newlines) + "Remove %XXX embedded spaces, etc in a url. +If optional second argument ALLOW-NEWLINES is non-nil, then allow the +decoding of carriage returns and line feeds in the string, which is normally +forbidden in URL encoding." + (setq str (or str "")) + (let ((tmp "") + (case-fold-search t)) + (while (string-match "%[0-9a-f][0-9a-f]" str) + (let* ((start (match-beginning 0)) + (ch1 (gnus-url-unhex (elt str (+ start 1)))) + (code (+ (* 16 ch1) + (gnus-url-unhex (elt str (+ start 2)))))) + (setq tmp (concat + tmp (substring str 0 start) + (cond + (allow-newlines + (char-to-string code)) + ((or (= code ?\n) (= code ?\r)) + " ") + (t (char-to-string code)))) + str (substring str (match-end 0))))) + (setq tmp (concat tmp str)) + tmp)) + +(defun gnus-url-mailto (url) + ;; Send mail to someone + (when (string-match "mailto:/*\\(.*\\)" url) + (setq url (substring url (match-beginning 1) nil))) + (let (to args source-url subject func) + (if (string-match (regexp-quote "?") url) + (setq to (gnus-url-unhex-string (substring url 0 (match-beginning 0))) + args (gnus-url-parse-query-string + (substring url (match-end 0) nil) t)) + (setq to (gnus-url-unhex-string url))) + (setq args (cons (list "to" to) args) + subject (cdr-safe (assoc "subject" args))) + (message-mail) + (while args + (setq func (intern-soft (concat "message-goto-" (downcase (caar args))))) + (if (fboundp func) + (funcall func) + (message-position-on-field (caar args))) + (insert (mapconcat 'identity (cdar args) ", ")) + (setq args (cdr args))) + (if subject + (message-goto-body) + (message-goto-subject)))) + +(defun gnus-button-mailto (address) + ;; Mail to ADDRESS. + (set-buffer (gnus-copy-article-buffer)) + (message-reply address)) + +(defun gnus-button-reply (address) + ;; Reply to ADDRESS. + (message-reply address)) + +(defun gnus-button-url (address) + "Browse ADDRESS." + (funcall browse-url-browser-function address)) + +(defun gnus-button-embedded-url (address) + "Browse ADDRESS." + (funcall browse-url-browser-function (gnus-strip-whitespace address))) + +;;; Next/prev buttons in the article buffer. + +(defvar gnus-next-page-line-format "%{%(Next page...%)%}\n") +(defvar gnus-prev-page-line-format "%{%(Previous page...%)%}\n") + +(defvar gnus-prev-page-map nil) +(unless gnus-prev-page-map + (setq gnus-prev-page-map (make-sparse-keymap)) + (define-key gnus-prev-page-map gnus-mouse-2 'gnus-button-prev-page) + (define-key gnus-prev-page-map "\r" 'gnus-button-prev-page)) + +(defun gnus-insert-prev-page-button () + (let ((buffer-read-only nil)) + (gnus-eval-format + gnus-prev-page-line-format nil + `(gnus-prev t local-map ,gnus-prev-page-map + gnus-callback gnus-article-button-prev-page)))) + +(defvar gnus-next-page-map nil) +(unless gnus-next-page-map + (setq gnus-next-page-map (make-keymap)) + (suppress-keymap gnus-prev-page-map) + (define-key gnus-next-page-map gnus-mouse-2 'gnus-button-next-page) + (define-key gnus-next-page-map "\r" 'gnus-button-next-page)) + +(defun gnus-button-next-page () + "Go to the next page." + (interactive) + (let ((win (selected-window))) + (select-window (get-buffer-window gnus-article-buffer t)) + (gnus-article-next-page) + (select-window win))) + +(defun gnus-button-prev-page () + "Go to the prev page." + (interactive) + (let ((win (selected-window))) + (select-window (get-buffer-window gnus-article-buffer t)) + (gnus-article-prev-page) + (select-window win))) + +(defun gnus-insert-next-page-button () + (let ((buffer-read-only nil)) + (gnus-eval-format gnus-next-page-line-format nil + `(gnus-next t local-map ,gnus-next-page-map + gnus-callback + gnus-article-button-next-page)))) + +(defun gnus-article-button-next-page (arg) + "Go to the next page." + (interactive "P") + (let ((win (selected-window))) + (select-window (get-buffer-window gnus-article-buffer t)) + (gnus-article-next-page) + (select-window win))) + +(defun gnus-article-button-prev-page (arg) + "Go to the prev page." + (interactive "P") + (let ((win (selected-window))) + (select-window (get-buffer-window gnus-article-buffer t)) + (gnus-article-prev-page) + (select-window win))) + +(gnus-ems-redefine) + +(provide 'gnus-art) + +(run-hooks 'gnus-art-load-hook) + +;;; gnus-art.el ends here diff -r ad457d5f7d04 -r 0293115a14e9 lisp/gnus/gnus-async.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus/gnus-async.el Mon Aug 13 08:49:20 2007 +0200 @@ -0,0 +1,315 @@ +;;; gnus-async.el --- asynchronous support for Gnus +;; Copyright (C) 1996,97 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen +;; Keywords: news + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;;; Code: + +(require 'gnus) +(require 'gnus-sum) +(require 'nntp) + +(defgroup gnus-asynchronous nil + "Support for asynchronous operations." + :group 'gnus) + +(defcustom gnus-asynchronous t + "*If nil, inhibit all Gnus asynchronicity. +If non-nil, let the other asynch variables be heeded." + :group 'gnus-asynchronous + :type 'boolean) + +(defcustom gnus-use-article-prefetch 30 + "*If non-nil, prefetch articles in groups that allow this. +If a number, prefetch only that many articles forward; +if t, prefetch as many articles as possible." + :group 'gnus-asynchronous + :type '(choice (const :tag "off" nil) + (const :tag "all" t) + (integer :tag "some" 0))) + +(defcustom gnus-prefetched-article-deletion-strategy '(read exit) + "List of symbols that say when to remove articles from the prefetch buffer. +Possible values in this list are `read', which means that +articles are removed as they are read, and `exit', which means +that all articles belonging to a group are removed on exit +from that group." + :group 'gnus-asynchronous + :type '(set (const read) (const exit))) + +(defcustom gnus-use-header-prefetch nil + "*If non-nil, prefetch the headers to the next group." + :group 'gnus-asynchronous + :type 'boolean) + +(defcustom gnus-async-prefetch-article-p 'gnus-async-unread-p + "Function called to say whether an article should be prefetched or not. +The function is called with one parameter -- the article data. +It should return non-nil if the article is to be prefetched." + :group 'gnus-asynchronous + :type 'function) + +;;; Internal variables. + +(defvar gnus-async-prefetch-article-buffer " *Async Prefetch Article*") +(defvar gnus-async-article-alist nil) +(defvar gnus-async-article-semaphore '(nil)) +(defvar gnus-async-fetch-list nil) + +(defvar gnus-async-prefetch-headers-buffer " *Async Prefetch Headers*") +(defvar gnus-async-header-prefetched nil) + +;;; Utility functions. + +(defun gnus-group-asynchronous-p (group) + "Say whether GROUP is fetched from a server that supports asynchronicity." + (gnus-asynchronous-p (gnus-find-method-for-group group))) + +;;; Somewhat bogus semaphores. + +(defun gnus-async-get-semaphore (semaphore) + "Wait until SEMAPHORE is released." + (while (/= (length (nconc (symbol-value semaphore) (list nil))) 2) + (sleep-for 1))) + +(defun gnus-async-release-semaphore (semaphore) + "Release SEMAPHORE." + (setcdr (symbol-value semaphore) nil)) + +(defmacro gnus-async-with-semaphore (&rest forms) + `(unwind-protect + (progn + (gnus-async-get-semaphore 'gnus-async-article-semaphore) + ,@forms) + (gnus-async-release-semaphore 'gnus-async-article-semaphore))) + +(put 'gnus-asynch-with-semaphore 'lisp-indent-function 0) +(put 'gnus-asynch-with-semaphore 'edebug-form-spec '(body)) + +;;; +;;; Article prefetch +;;; + +(gnus-add-shutdown 'gnus-async-close 'gnus) +(defun gnus-async-close () + (gnus-kill-buffer gnus-async-prefetch-article-buffer) + (gnus-kill-buffer gnus-async-prefetch-headers-buffer) + (setq gnus-async-article-alist nil + gnus-async-header-prefetched nil)) + +(defun gnus-async-set-buffer () + (nnheader-set-temp-buffer gnus-async-prefetch-article-buffer t)) + +(defun gnus-async-halt-prefetch () + "Stop prefetching." + (setq gnus-async-fetch-list nil)) + +(defun gnus-async-prefetch-next (group article summary) + "Possibly prefetch several articles starting with the article after ARTICLE." + (when (and (gnus-buffer-live-p summary) + gnus-asynchronous + (gnus-group-asynchronous-p group)) + (save-excursion + (set-buffer gnus-summary-buffer) + (let ((next (caadr (gnus-data-find-list article)))) + (when next + (if (not (fboundp 'run-with-idle-timer)) + ;; This is either an older Emacs or XEmacs, so we + ;; do this, which leads to slightly slower article + ;; buffer display. + (gnus-async-prefetch-article group next summary) + (run-with-idle-timer + 0.1 nil 'gnus-async-prefetch-article group next summary))))))) + +(defun gnus-async-prefetch-article (group article summary &optional next) + "Possibly prefetch several articles starting with ARTICLE." + (if (not (gnus-buffer-live-p summary)) + (gnus-async-with-semaphore + (setq gnus-async-fetch-list nil)) + (when (and gnus-asynchronous + (gnus-alive-p)) + (when next + (gnus-async-with-semaphore + (pop gnus-async-fetch-list))) + (let ((do-fetch next) + (do-message t)) ;(eq major-mode 'gnus-summary-mode))) + (when (and (gnus-group-asynchronous-p group) + (gnus-buffer-live-p summary) + (or (not next) + gnus-async-fetch-list)) + (gnus-async-with-semaphore + (unless next + (setq do-fetch (not gnus-async-fetch-list)) + ;; Nix out any outstanding requests. + (setq gnus-async-fetch-list nil) + ;; Fill in the new list. + (let ((n gnus-use-article-prefetch) + (data (gnus-data-find-list article)) + d) + (while (and (setq d (pop data)) + (if (numberp n) + (natnump (decf n)) + n)) + (unless (or (gnus-async-prefetched-article-entry + group (setq article (gnus-data-number d))) + (not (natnump article)) + (not (funcall gnus-async-prefetch-article-p d))) + ;; Not already fetched -- so we add it to the list. + (push article gnus-async-fetch-list))) + (setq gnus-async-fetch-list + (nreverse gnus-async-fetch-list)))) + + (when do-fetch + (setq article (car gnus-async-fetch-list)))) + + (when (and do-fetch article) + ;; We want to fetch some more articles. + (save-excursion + (set-buffer summary) + (let (mark) + (gnus-async-set-buffer) + (goto-char (point-max)) + (setq mark (point-marker)) + (let ((nnheader-callback-function + (gnus-make-async-article-function + group article mark summary next)) + (nntp-server-buffer + (get-buffer gnus-async-prefetch-article-buffer))) + (when do-message + (gnus-message 7 "Prefetching article %d in group %s" + article group)) + (gnus-request-article article group)))))))))) + +(defun gnus-make-async-article-function (group article mark summary next) + "Return a callback function." + `(lambda (arg) + (save-excursion + (when arg + (gnus-async-set-buffer) + (gnus-async-with-semaphore + (push (list ',(intern (format "%s-%d" group article)) + ,mark (set-marker (make-marker) (point-max)) + ,group ,article) + gnus-async-article-alist))) + (if (not (gnus-buffer-live-p ,summary)) + (gnus-async-with-semaphore + (setq gnus-async-fetch-list nil)) + (gnus-async-prefetch-article ,group ,next ,summary t))))) + +(defun gnus-async-unread-p (data) + "Return non-nil if DATA represents an unread article." + (gnus-data-unread-p data)) + +(defun gnus-async-request-fetched-article (group article buffer) + "See whether we have ARTICLE from GROUP and put it in BUFFER." + (when (numberp article) + (let ((entry (gnus-async-prefetched-article-entry group article))) + (when entry + (save-excursion + (gnus-async-set-buffer) + (copy-to-buffer buffer (cadr entry) (caddr entry)) + ;; Remove the read article from the prefetch buffer. + (when (memq 'read gnus-prefetched-article-deletion-strategy) + (gnus-async-delete-prefected-entry entry)) + t))))) + +(defun gnus-async-delete-prefected-entry (entry) + "Delete ENTRY from buffer and alist." + (ignore-errors + (delete-region (cadr entry) (caddr entry)) + (set-marker (cadr entry) nil) + (set-marker (caddr entry) nil)) + (gnus-async-with-semaphore + (setq gnus-async-article-alist + (delq entry gnus-async-article-alist)))) + +(defun gnus-async-prefetch-remove-group (group) + "Remove all articles belonging to GROUP from the prefetch buffer." + (when (and (gnus-group-asynchronous-p group) + (memq 'exit gnus-prefetched-article-deletion-strategy)) + (let ((alist gnus-async-article-alist)) + (save-excursion + (gnus-async-set-buffer) + (while alist + (when (equal group (nth 3 (car alist))) + (gnus-async-delete-prefected-entry (car alist))) + (pop alist)))))) + +(defun gnus-async-prefetched-article-entry (group article) + "Return the entry for ARTICLE in GROUP iff it has been prefetched." + (let ((entry (assq (intern (format "%s-%d" group article)) + gnus-async-article-alist))) + ;; Perhaps something has emptied the buffer? + (if (and entry + (= (cadr entry) (caddr entry))) + (progn + (ignore-errors + (set-marker (cadr entry) nil) + (set-marker (caddr entry) nil)) + (setq gnus-async-article-alist + (delq entry gnus-async-article-alist)) + nil) + entry))) + +;;; +;;; Header prefetch +;;; + +(defun gnus-async-prefetch-headers (group) + "Prefetch the headers for group GROUP." + (save-excursion + (let (unread) + (when (and gnus-use-header-prefetch + gnus-asynchronous + (gnus-group-asynchronous-p group) + (listp gnus-async-header-prefetched) + (setq unread (gnus-list-of-unread-articles group))) + ;; Mark that a fetch is in progress. + (setq gnus-async-header-prefetched t) + (nnheader-set-temp-buffer gnus-async-prefetch-headers-buffer t) + (erase-buffer) + (let ((nntp-server-buffer (current-buffer)) + (nnheader-callback-function + `(lambda (arg) + (setq gnus-async-header-prefetched + ,(cons group unread))))) + (gnus-retrieve-headers unread group gnus-fetch-old-headers)))))) + +(defun gnus-async-retrieve-fetched-headers (articles group) + "See whether we have prefetched headers." + (when (and gnus-use-header-prefetch + (gnus-group-asynchronous-p group) + (listp gnus-async-header-prefetched) + (equal group (car gnus-async-header-prefetched)) + (equal articles (cdr gnus-async-header-prefetched))) + (save-excursion + (nnheader-set-temp-buffer gnus-async-prefetch-headers-buffer t) + (nntp-decode-text) + (copy-to-buffer nntp-server-buffer (point-min) (point-max)) + (erase-buffer) + (setq gnus-async-header-prefetched nil) + t))) + +(provide 'gnus-async) + +;;; gnus-async.el ends here diff -r ad457d5f7d04 -r 0293115a14e9 lisp/gnus/gnus-audio.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus/gnus-audio.el Mon Aug 13 08:49:20 2007 +0200 @@ -0,0 +1,132 @@ +;;; gnus-audio.el --- Sound effects for Gnus +;; Copyright (C) 1996 Free Software Foundation + +;; Author: Steven L. Baur +;; Keywords: news + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: +;; This file provides access to sound effects in Gnus. +;; Prerelease: This file is partially stripped to support earcons.el +;; You can safely ignore most of it until Red Gnus. **Evil Laugh** +;;; Code: + +(when (null (boundp 'running-xemacs)) + (defvar running-xemacs (string-match "XEmacs\\|Lucid" emacs-version))) + +(require 'nnheader) +(eval-when-compile (require 'cl)) + +(defvar gnus-audio-inline-sound + (and (fboundp 'device-sound-enabled-p) + (device-sound-enabled-p)) + "When t, we will not spawn a subprocess to play sounds.") + +(defvar gnus-audio-directory (nnheader-find-etc-directory "sounds") + "The directory containing the Sound Files.") + +(defvar gnus-audio-au-player "/usr/bin/showaudio" + "Executable program for playing sun AU format sound files") +(defvar gnus-audio-wav-player "/usr/local/bin/play" + "Executable program for playing WAV files") + + +;;; The following isn't implemented yet. Wait for Red Gnus. +;(defvar gnus-audio-effects-enabled t +; "When t, Gnus will use sound effects.") +;(defvar gnus-audio-enable-hooks nil +; "Functions run when enabling sound effects.") +;(defvar gnus-audio-disable-hooks nil +; "Functions run when disabling sound effects.") +;(defvar gnus-audio-theme-song nil +; "Theme song for Gnus.") +;(defvar gnus-audio-enter-group nil +; "Sound effect played when selecting a group.") +;(defvar gnus-audio-exit-group nil +; "Sound effect played when exiting a group.") +;(defvar gnus-audio-score-group nil +; "Sound effect played when scoring a group.") +;(defvar gnus-audio-busy-sound nil +; "Sound effect played when going into a ... sequence.") + + +;;;###autoload + ;(defun gnus-audio-enable-sound () +; "Enable Sound Effects for Gnus." +; (interactive) +; (setq gnus-audio-effects-enabled t) +; (run-hooks gnus-audio-enable-hooks)) + +;;;###autoload + ;(defun gnus-audio-disable-sound () +; "Disable Sound Effects for Gnus." +; (interactive) +; (setq gnus-audio-effects-enabled nil) +; (run-hooks gnus-audio-disable-hooks)) + +;;;###autoload +(defun gnus-audio-play (file) + "Play a sound through the speaker." + (interactive) + (let ((sound-file (if (file-exists-p file) + file + (concat gnus-audio-directory file)))) + (when (file-exists-p sound-file) + (if gnus-audio-inline-sound + (play-sound-file sound-file) + (cond ((string-match "\\.wav$" sound-file) + (call-process gnus-audio-wav-player + sound-file + 0 + nil + sound-file)) + ((string-match "\\.au$" sound-file) + (call-process gnus-audio-au-player + sound-file + 0 + nil + sound-file))))))) + + +;;; The following isn't implemented yet, wait for Red Gnus + ;(defun gnus-audio-startrek-sounds () +; "Enable sounds from Star Trek the original series." +; (interactive) +; (setq gnus-audio-busy-sound "working.au") +; (setq gnus-audio-enter-group "bulkhead_door.au") +; (setq gnus-audio-exit-group "bulkhead_door.au") +; (setq gnus-audio-score-group "ST_laser.au") +; (setq gnus-audio-theme-song "startrek.au") +; (add-hook 'gnus-select-group-hook 'gnus-audio-startrek-select-group) +; (add-hook 'gnus-exit-group-hook 'gnus-audio-startrek-exit-group)) +;;;*** + +(defvar gnus-startup-jingle "Tuxedomoon.Jingle4.au" + "Name of the Gnus startup jingle file.") + +(defun gnus-play-jingle () + "Play the Gnus startup jingle, unless that's inhibited." + (interactive) + (gnus-audio-play gnus-startup-jingle)) + +(provide 'gnus-audio) + +(run-hooks 'gnus-audio-load-hook) + +;;; gnus-audio.el ends here diff -r ad457d5f7d04 -r 0293115a14e9 lisp/gnus/gnus-bcklg.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus/gnus-bcklg.el Mon Aug 13 08:49:20 2007 +0200 @@ -0,0 +1,152 @@ +;;; gnus-bcklg.el --- backlog functions for Gnus +;; Copyright (C) 1996,97 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen +;; Keywords: news + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;;; Code: + +(require 'gnus) + +;;; +;;; Buffering of read articles. +;;; + +(defvar gnus-backlog-buffer " *Gnus Backlog*") +(defvar gnus-backlog-articles nil) +(defvar gnus-backlog-hashtb nil) + +(defun gnus-backlog-buffer () + "Return the backlog buffer." + (or (get-buffer gnus-backlog-buffer) + (save-excursion + (set-buffer (get-buffer-create gnus-backlog-buffer)) + (buffer-disable-undo (current-buffer)) + (setq buffer-read-only t) + (gnus-add-current-to-buffer-list) + (get-buffer gnus-backlog-buffer)))) + +(defun gnus-backlog-setup () + "Initialize backlog variables." + (unless gnus-backlog-hashtb + (setq gnus-backlog-hashtb (gnus-make-hashtable 1024)))) + +(gnus-add-shutdown 'gnus-backlog-shutdown 'gnus) + +(defun gnus-backlog-shutdown () + "Clear all backlog variables and buffers." + (when (get-buffer gnus-backlog-buffer) + (kill-buffer gnus-backlog-buffer)) + (setq gnus-backlog-hashtb nil + gnus-backlog-articles nil)) + +(defun gnus-backlog-enter-article (group number buffer) + (gnus-backlog-setup) + (let ((ident (intern (concat group ":" (int-to-string number)) + gnus-backlog-hashtb)) + b) + (if (memq ident gnus-backlog-articles) + () ; It's already kept. + ;; Remove the oldest article, if necessary. + (and (numberp gnus-keep-backlog) + (>= (length gnus-backlog-articles) gnus-keep-backlog) + (gnus-backlog-remove-oldest-article)) + (push ident gnus-backlog-articles) + ;; Insert the new article. + (save-excursion + (set-buffer (gnus-backlog-buffer)) + (let (buffer-read-only) + (goto-char (point-max)) + (unless (bolp) + (insert "\n")) + (setq b (point)) + (insert-buffer-substring buffer) + ;; Tag the beginning of the article with the ident. + (gnus-put-text-property b (1+ b) 'gnus-backlog ident)))))) + +(defun gnus-backlog-remove-oldest-article () + (save-excursion + (set-buffer (gnus-backlog-buffer)) + (goto-char (point-min)) + (if (zerop (buffer-size)) + () ; The buffer is empty. + (let ((ident (get-text-property (point) 'gnus-backlog)) + buffer-read-only) + ;; Remove the ident from the list of articles. + (when ident + (setq gnus-backlog-articles (delq ident gnus-backlog-articles))) + ;; Delete the article itself. + (delete-region + (point) (next-single-property-change + (1+ (point)) 'gnus-backlog nil (point-max))))))) + +(defun gnus-backlog-remove-article (group number) + "Remove article NUMBER in GROUP from the backlog." + (when (numberp number) + (gnus-backlog-setup) + (let ((ident (intern (concat group ":" (int-to-string number)) + gnus-backlog-hashtb)) + beg end) + (when (memq ident gnus-backlog-articles) + ;; It was in the backlog. + (save-excursion + (set-buffer (gnus-backlog-buffer)) + (let (buffer-read-only) + (when (setq beg (text-property-any + (point-min) (point-max) 'gnus-backlog + ident)) + ;; Find the end (i. e., the beginning of the next article). + (setq end + (next-single-property-change + (1+ beg) 'gnus-backlog (current-buffer) (point-max))) + (delete-region beg end) + ;; Return success. + t))))))) + +(defun gnus-backlog-request-article (group number buffer) + (when (numberp number) + (gnus-backlog-setup) + (let ((ident (intern (concat group ":" (int-to-string number)) + gnus-backlog-hashtb)) + beg end) + (when (memq ident gnus-backlog-articles) + ;; It was in the backlog. + (save-excursion + (set-buffer (gnus-backlog-buffer)) + (if (not (setq beg (text-property-any + (point-min) (point-max) 'gnus-backlog + ident))) + ;; It wasn't in the backlog after all. + (ignore + (setq gnus-backlog-articles (delq ident gnus-backlog-articles))) + ;; Find the end (i. e., the beginning of the next article). + (setq end + (next-single-property-change + (1+ beg) 'gnus-backlog (current-buffer) (point-max))))) + (let ((buffer-read-only nil)) + (erase-buffer) + (insert-buffer-substring gnus-backlog-buffer beg end) + t))))) + +(provide 'gnus-bcklg) + +;;; gnus-bcklg.el ends here diff -r ad457d5f7d04 -r 0293115a14e9 lisp/gnus/gnus-cache.el --- a/lisp/gnus/gnus-cache.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/gnus/gnus-cache.el Mon Aug 13 08:49:20 2007 +0200 @@ -1,5 +1,5 @@ ;;; gnus-cache.el --- cache interface for Gnus -;; Copyright (C) 1995,96 Free Software Foundation, Inc. +;; Copyright (C) 1995,96,97 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; Keywords: news @@ -26,32 +26,52 @@ ;;; Code: (require 'gnus) -(eval-when-compile (require 'cl)) +(require 'gnus-int) +(require 'gnus-range) +(require 'gnus-start) +(eval-when-compile + (require 'gnus-sum)) -(defvar gnus-cache-directory +(defgroup gnus-cache nil + "Cache interface." + :group 'gnus) + +(defcustom gnus-cache-directory (nnheader-concat gnus-directory "cache/") - "*The directory where cached articles will be stored.") + "*The directory where cached articles will be stored." + :group 'gnus-cache + :type 'directory) -(defvar gnus-cache-active-file +(defcustom gnus-cache-active-file (concat (file-name-as-directory gnus-cache-directory) "active") - "*The cache active file.") - -(defvar gnus-cache-enter-articles '(ticked dormant) - "*Classes of articles to enter into the cache.") + "*The cache active file." + :group 'gnus-cache + :type 'file) -(defvar gnus-cache-remove-articles '(read) - "*Classes of articles to remove from the cache.") +(defcustom gnus-cache-enter-articles '(ticked dormant) + "Classes of articles to enter into the cache." + :group 'gnus-cache + :type '(set (const ticked) (const dormant) (const unread) (const read))) -(defvar gnus-uncacheable-groups nil +(defcustom gnus-cache-remove-articles '(read) + "Classes of articles to remove from the cache." + :group 'gnus-cache + :type '(set (const ticked) (const dormant) (const unread) (const read))) + +(defcustom gnus-uncacheable-groups nil "*Groups that match this regexp will not be cached. If you want to avoid caching your nnml groups, you could set this -variable to \"^nnml\".") +variable to \"^nnml\"." + :group 'gnus-cache + :type '(choice (const :tag "off" nil) + regexp)) ;;; Internal variables. +(defvar gnus-cache-removable-articles nil) (defvar gnus-cache-buffer nil) (defvar gnus-cache-active-hashtb nil) (defvar gnus-cache-active-altered nil) @@ -71,10 +91,9 @@ (not (eq gnus-use-cache 'passive)))) (gnus-cache-read-active))) -(condition-case () - (gnus-add-shutdown 'gnus-cache-close 'gnus) - ;; Complexities of byte-compiling makes this kludge necessary. Eeek. - (error nil)) +;; Complexities of byte-compiling make this kludge necessary. Eeek. +(ignore-errors + (gnus-add-shutdown 'gnus-cache-close 'gnus)) (defun gnus-cache-close () "Shut down the cache." @@ -85,32 +104,28 @@ (defun gnus-cache-save-buffers () ;; save the overview buffer if it exists and has been modified ;; delete empty cache subdirectories - (if (null gnus-cache-buffer) - () + (when gnus-cache-buffer (let ((buffer (cdr gnus-cache-buffer)) (overview-file (gnus-cache-file-name (car gnus-cache-buffer) ".overview"))) ;; write the overview only if it was modified - (if (buffer-modified-p buffer) - (save-excursion - (set-buffer buffer) - (if (> (buffer-size) 0) - ;; non-empty overview, write it out - (progn - (gnus-make-directory (file-name-directory overview-file)) - (write-region (point-min) (point-max) - overview-file nil 'quietly)) - ;; empty overview file, remove it - (and (file-exists-p overview-file) - (delete-file overview-file)) - ;; if possible, remove group's cache subdirectory - (condition-case nil - ;; FIXME: we can detect the error type and warn the user - ;; of any inconsistencies (articles w/o nov entries?). - ;; for now, just be conservative...delete only if safe -- sj - (delete-directory (file-name-directory overview-file)) - (error nil))))) - ;; kill the buffer, it's either unmodified or saved + (when (buffer-modified-p buffer) + (save-excursion + (set-buffer buffer) + (if (> (buffer-size) 0) + ;; Non-empty overview, write it to a file. + (gnus-write-buffer overview-file) + ;; Empty overview file, remove it + (when (file-exists-p overview-file) + (delete-file overview-file)) + ;; If possible, remove group's cache subdirectory. + (condition-case nil + ;; FIXME: we can detect the error type and warn the user + ;; of any inconsistencies (articles w/o nov entries?). + ;; for now, just be conservative...delete only if safe -- sj + (delete-directory (file-name-directory overview-file)) + (error nil))))) + ;; Kill the buffer -- it's either unmodified or saved. (gnus-kill-buffer buffer) (setq gnus-cache-buffer nil)))) @@ -119,7 +134,8 @@ (when (and (or force (not (eq gnus-use-cache 'passive))) (numberp article) (> article 0) - (vectorp headers)) ; This might be a dummy article. + (vectorp headers)) + ; This might be a dummy article. ;; If this is a virtual group, we find the real group. (when (gnus-virtual-group-p group) (let ((result (nnvirtual-find-group-art @@ -130,16 +146,16 @@ (let ((number (mail-header-number headers)) file dir) (when (and (> number 0) ; Reffed article. - (or (not gnus-uncacheable-groups) - (not (string-match gnus-uncacheable-groups group))) (or force - (gnus-cache-member-of-class - gnus-cache-enter-articles ticked dormant unread)) + (and (or (not gnus-uncacheable-groups) + (not (string-match + gnus-uncacheable-groups group))) + (gnus-cache-member-of-class + gnus-cache-enter-articles ticked dormant unread))) (not (file-exists-p (setq file (gnus-cache-file-name group number))))) ;; Possibly create the cache directory. - (or (file-exists-p (setq dir (file-name-directory file))) - (gnus-make-directory dir)) + (gnus-make-directory (setq dir (file-name-directory file))) ;; Save the article in the cache. (if (file-exists-p file) t ; The article already is saved. @@ -148,25 +164,25 @@ (let ((gnus-use-cache nil)) (gnus-request-article-this-buffer number group)) (when (> (buffer-size) 0) - (write-region (point-min) (point-max) file nil 'quiet) + (gnus-write-buffer file) (gnus-cache-change-buffer group) (set-buffer (cdr gnus-cache-buffer)) (goto-char (point-max)) (forward-line -1) (while (condition-case () - (and (not (bobp)) - (> (read (current-buffer)) number)) + (when (not (bobp)) + (> (read (current-buffer)) number)) (error ;; The line was malformed, so we just remove it!! (gnus-delete-line) t)) (forward-line -1)) - (if (bobp) + (if (bobp) (if (not (eobp)) (progn (beginning-of-line) - (if (< (read (current-buffer)) number) - (forward-line 1))) + (when (< (read (current-buffer)) number) + (forward-line 1))) (beginning-of-line)) (forward-line 1)) (beginning-of-line) @@ -215,14 +231,14 @@ article) (gnus-cache-change-buffer gnus-newsgroup-name) (while articles - (if (memq (setq article (pop articles)) cache-articles) - ;; The article was in the cache, so we see whether we are - ;; supposed to remove it from the cache. - (gnus-cache-possibly-remove-article - article (memq article gnus-newsgroup-marked) - (memq article gnus-newsgroup-dormant) - (or (memq article gnus-newsgroup-unreads) - (memq article gnus-newsgroup-unselected)))))) + (when (memq (setq article (pop articles)) cache-articles) + ;; The article was in the cache, so we see whether we are + ;; supposed to remove it from the cache. + (gnus-cache-possibly-remove-article + article (memq article gnus-newsgroup-marked) + (memq article gnus-newsgroup-dormant) + (or (memq article gnus-newsgroup-unreads) + (memq article gnus-newsgroup-unselected)))))) ;; The overview file might have been modified, save it ;; safe because we're only called at group exit anyway. (gnus-cache-save-buffers))) @@ -239,6 +255,7 @@ (defun gnus-cache-possibly-alter-active (group active) "Alter the ACTIVE info for GROUP to reflect the articles in the cache." + (when (equal group "no.norsk") (error "hie")) (when gnus-cache-active-hashtb (let ((cache-active (gnus-gethash group gnus-cache-active-hashtb))) (and cache-active @@ -302,12 +319,14 @@ (gnus-set-global-variables) (let ((articles (gnus-summary-work-articles n)) article out) - (while articles - (setq article (pop articles)) - (when (gnus-cache-possibly-enter-article - gnus-newsgroup-name article (gnus-summary-article-header article) - nil nil nil t) - (push article out)) + (while (setq article (pop articles)) + (if (natnump article) + (when (gnus-cache-possibly-enter-article + gnus-newsgroup-name article + (gnus-summary-article-header article) + nil nil nil t) + (push article out)) + (gnus-message 2 "Can't cache article %d" article)) (gnus-summary-remove-process-mark article) (gnus-summary-update-secondary-mark article)) (gnus-summary-next-subject 1) @@ -337,6 +356,16 @@ "Say whether ARTICLE is cached in the current group." (memq article gnus-newsgroup-cached)) +(defun gnus-summary-insert-cached-articles () + "Insert all the articles cached for this group into the current buffer." + (interactive) + (let ((cached gnus-newsgroup-cached) + (gnus-verbose (max 6 gnus-verbose))) + (unless cached + (error "No cached articles for this group")) + (while cached + (gnus-summary-goto-subject (pop cached) t)))) + ;;; Internal functions. (defun gnus-cache-change-buffer (group) @@ -346,21 +375,21 @@ ;; Another overview cache is current, save it. (gnus-cache-save-buffers))) ;; if gnus-cache buffer is nil, create it - (or gnus-cache-buffer - ;; Create cache buffer - (save-excursion - (setq gnus-cache-buffer - (cons group - (set-buffer (get-buffer-create " *gnus-cache-overview*")))) - (buffer-disable-undo (current-buffer)) - ;; Insert the contents of this group's cache overview. - (erase-buffer) - (let ((file (gnus-cache-file-name group ".overview"))) - (and (file-exists-p file) - (insert-file-contents file))) - ;; We have a fresh (empty/just loaded) buffer, - ;; mark it as unmodified to save a redundant write later. - (set-buffer-modified-p nil)))) + (unless gnus-cache-buffer + ;; Create cache buffer + (save-excursion + (setq gnus-cache-buffer + (cons group + (set-buffer (get-buffer-create " *gnus-cache-overview*")))) + (buffer-disable-undo (current-buffer)) + ;; Insert the contents of this group's cache overview. + (erase-buffer) + (let ((file (gnus-cache-file-name group ".overview"))) + (when (file-exists-p file) + (nnheader-insert-file-contents file))) + ;; We have a fresh (empty/just loaded) buffer, + ;; mark it as unmodified to save a redundant write later. + (set-buffer-modified-p nil)))) ;; Return whether an article is a member of a class. (defun gnus-cache-member-of-class (class ticked dormant unread) @@ -372,13 +401,14 @@ (defun gnus-cache-file-name (group article) (concat (file-name-as-directory gnus-cache-directory) (file-name-as-directory - (if (gnus-use-long-file-name 'not-cache) - group - (let ((group (nnheader-replace-chars-in-string group ?/ ?_))) - ;; Translate the first colon into a slash. - (when (string-match ":" group) - (aset group (match-beginning 0) ?/)) - (nnheader-replace-chars-in-string group ?. ?/)))) + (nnheader-translate-file-chars + (if (gnus-use-long-file-name 'not-cache) + group + (let ((group (nnheader-replace-chars-in-string group ?/ ?_))) + ;; Translate the first colon into a slash. + (when (string-match ":" group) + (aset group (match-beginning 0) ?/)) + (nnheader-replace-chars-in-string group ?. ?/))))) (if (stringp article) article (int-to-string article)))) (defun gnus-cache-update-article (group article) @@ -410,11 +440,11 @@ (delete-file file) (set-buffer (cdr gnus-cache-buffer)) (goto-char (point-min)) - (if (or (looking-at (concat (int-to-string number) "\t")) - (search-forward (concat "\n" (int-to-string number) "\t") - (point-max) t)) - (delete-region (progn (beginning-of-line) (point)) - (progn (forward-line 1) (point))))) + (when (or (looking-at (concat (int-to-string number) "\t")) + (search-forward (concat "\n" (int-to-string number) "\t") + (point-max) t)) + (delete-region (progn (beginning-of-line) (point)) + (progn (forward-line 1) (point))))) (setq gnus-newsgroup-cached (delq article gnus-newsgroup-cached)) (gnus-summary-update-secondary-mark article) @@ -422,10 +452,9 @@ (defun gnus-cache-articles-in-group (group) "Return a sorted list of cached articles in GROUP." - (let ((dir (file-name-directory (gnus-cache-file-name group 1))) - articles) + (let ((dir (file-name-directory (gnus-cache-file-name group 1)))) (when (file-exists-p dir) - (sort (mapcar (lambda (name) (string-to-int name)) + (sort (mapcar (lambda (name) (string-to-int name)) (directory-files dir nil "^[0-9]+$" t)) '<)))) @@ -455,8 +484,9 @@ (setq beg (progn (beginning-of-line) (point)) end (progn (end-of-line) (point))) (setq beg nil))) - (if beg (progn (insert-buffer-substring cache-buf beg end) - (insert "\n"))) + (when beg + (insert-buffer-substring cache-buf beg end) + (insert "\n")) (setq cached (cdr cached))) (kill-buffer cache-buf))) @@ -494,7 +524,10 @@ ;;;###autoload (defun gnus-jog-cache () - "Go through all groups and put the articles into the cache." + "Go through all groups and put the articles into the cache. + +Usage: +$ emacs -batch -l ~/.emacs -l gnus -f gnus-jog-cache" (interactive) (let ((gnus-mark-article-hook nil) (gnus-expert-user t) @@ -509,7 +542,8 @@ (gnus-group-universal-argument nil nil (lambda () - (gnus-summary-read-group nil nil t) + (interactive) + (gnus-summary-read-group (gnus-group-group-name) nil t) ;; ... and enter the articles into the cache. (when (eq major-mode 'gnus-summary-mode) (gnus-uu-mark-buffer) @@ -518,8 +552,7 @@ (defun gnus-cache-read-active (&optional force) "Read the cache active file." - (unless (file-exists-p gnus-cache-directory) - (make-directory gnus-cache-directory t)) + (gnus-make-directory gnus-cache-directory) (if (not (and (file-exists-p gnus-cache-active-file) (or force (not gnus-cache-active-hashtb)))) ;; There is no active file, so we generate one. @@ -539,18 +572,14 @@ (when (or force (and gnus-cache-active-hashtb gnus-cache-active-altered)) - (save-excursion - (gnus-set-work-buffer) + (nnheader-temp-write gnus-cache-active-file (mapatoms (lambda (sym) (when (and sym (boundp sym)) (insert (format "%s %d %d y\n" (symbol-name sym) (cdr (symbol-value sym)) (car (symbol-value sym)))))) - gnus-cache-active-hashtb) - (gnus-make-directory (file-name-directory gnus-cache-active-file)) - (write-region - (point-min) (point-max) gnus-cache-active-file nil 'silent)) + gnus-cache-active-hashtb)) ;; Mark the active hashtb as unaltered. (setq gnus-cache-active-altered nil))) @@ -564,9 +593,9 @@ ;; Update the lower or upper bound. (if low (setcar active number) - (setcdr active number)) - ;; Mark the active hashtb as altered. - (setq gnus-cache-active-altered t)))) + (setcdr active number))) + ;; Mark the active hashtb as altered. + (setq gnus-cache-active-altered t))) ;;;###autoload (defun gnus-cache-generate-active (&optional directory) @@ -619,6 +648,11 @@ (let ((nnml-generate-active-function 'identity)) (nnml-generate-nov-databases-1 dir))) +(defun gnus-cache-move-cache (dir) + "Move the cache tree to somewhere else." + (interactive "DMove the cache tree to: ") + (rename-file gnus-cache-directory dir)) + (provide 'gnus-cache) ;;; gnus-cache.el ends here diff -r ad457d5f7d04 -r 0293115a14e9 lisp/gnus/gnus-cite.el --- a/lisp/gnus/gnus-cite.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/gnus/gnus-cite.el Mon Aug 13 08:49:20 2007 +0200 @@ -1,5 +1,5 @@ ;;; gnus-cite.el --- parse citations in articles for Gnus -;; Copyright (C) 1995,96 Free Software Foundation, Inc. +;; Copyright (C) 1995,96,97 Free Software Foundation, Inc. ;; Author: Per Abrahamsen ;; Keywords: news, mail @@ -26,94 +26,231 @@ ;;; Code: (require 'gnus) -(require 'gnus-msg) -(require 'gnus-ems) -(eval-when-compile (require 'cl)) - -(eval-and-compile - (autoload 'gnus-article-add-button "gnus-vis")) +(require 'gnus-art) +(require 'gnus-range) ;;; Customization: -(defvar gnus-cited-text-button-line-format "%(%{[...]%}%)\n" - "Format of cited text buttons.") +(defgroup gnus-cite nil + "Citation." + :prefix "gnus-cite-" + :link '(custom-manual "(gnus)Article Highlighting") + :group 'gnus-article) + +(defcustom gnus-cite-reply-regexp + "^\\(Subject: Re\\|In-Reply-To\\|References\\):" + "If headers match this regexp it is reasonable to believe that +article has citations." + :group 'gnus-cite + :type 'string) -(defvar gnus-cited-lines-visible nil - "The number of lines of hidden cited text to remain visible.") +(defcustom gnus-cite-always-check nil + "Check article always for citations. Set it t to check all articles." + :group 'gnus-cite + :type '(choice (const :tag "no" nil) + (const :tag "yes" t))) -(defvar gnus-cite-parse-max-size 25000 +(defcustom gnus-cited-text-button-line-format "%(%{[...]%}%)\n" + "Format of cited text buttons." + :group 'gnus-cite + :type 'string) + +(defcustom gnus-cited-lines-visible nil + "The number of lines of hidden cited text to remain visible." + :group 'gnus-cite + :type '(choice (const :tag "none" nil) + integer)) + +(defcustom gnus-cite-parse-max-size 25000 "Maximum article size (in bytes) where parsing citations is allowed. -Set it to nil to parse all articles.") +Set it to nil to parse all articles." + :group 'gnus-cite + :type '(choice (const :tag "all" nil) + integer)) -(defvar gnus-cite-prefix-regexp +(defcustom gnus-cite-prefix-regexp "^[]>|:}+ ]*[]>|:}+]\\(.*>\\)?\\|^.*>" - "Regexp matching the longest possible citation prefix on a line.") + "Regexp matching the longest possible citation prefix on a line." + :group 'gnus-cite + :type 'regexp) -(defvar gnus-cite-max-prefix 20 - "Maximum possible length for a citation prefix.") +(defcustom gnus-cite-max-prefix 20 + "Maximum possible length for a citation prefix." + :group 'gnus-cite + :type 'integer) -(defvar gnus-supercite-regexp +(defcustom gnus-supercite-regexp (concat "^\\(" gnus-cite-prefix-regexp "\\)? *" ">>>>> +\"\\([^\"\n]+\\)\" +==") "Regexp matching normal Supercite attribution lines. -The first grouping must match prefixes added by other packages.") +The first grouping must match prefixes added by other packages." + :group 'gnus-cite + :type 'regexp) -(defvar gnus-supercite-secondary-regexp "^.*\"\\([^\"\n]+\\)\" +==" +(defcustom gnus-supercite-secondary-regexp "^.*\"\\([^\"\n]+\\)\" +==" "Regexp matching mangled Supercite attribution lines. -The first regexp group should match the Supercite attribution.") - -(defvar gnus-cite-minimum-match-count 2 - "Minimum number of identical prefixes before we believe it's a citation.") +The first regexp group should match the Supercite attribution." + :group 'gnus-cite + :type 'regexp) -;see gnus-cus.el -;(defvar gnus-cite-face-list -; (if (eq gnus-display-type 'color) -; (if (eq gnus-background-mode 'dark) 'light 'dark) -; '(italic)) -; "Faces used for displaying different citations. -;It is either a list of face names, or one of the following special -;values: +(defcustom gnus-cite-minimum-match-count 2 + "Minimum number of identical prefixes before we believe it's a citation." + :group 'gnus-cite + :type 'integer) -;dark: Create faces from `gnus-face-dark-name-list'. -;light: Create faces from `gnus-face-light-name-list'. +(defcustom gnus-cite-attribution-prefix "in article\\|in <" + "Regexp matching the beginning of an attribution line." + :group 'gnus-cite + :type 'regexp) -;The variable `gnus-make-foreground' determines whether the created -;faces change the foreground or the background colors.") - -(defvar gnus-cite-attribution-prefix "in article\\|in <" - "Regexp matching the beginning of an attribution line.") - -(defvar gnus-cite-attribution-suffix +(defcustom gnus-cite-attribution-suffix "\\(wrote\\|writes\\|said\\|says\\):[ \t]*$" "Regexp matching the end of an attribution line. -The text matching the first grouping will be used as a button.") +The text matching the first grouping will be used as a button." + :group 'gnus-cite + :type 'regexp) + +(defface gnus-cite-attribution-face '((t + (:underline t))) + "Face used for attribution lines.") + +(defcustom gnus-cite-attribution-face 'gnus-cite-attribution-face + "Face used for attribution lines. +It is merged with the face for the cited text belonging to the attribution." + :group 'gnus-cite + :type 'face) + +(defface gnus-cite-face-1 '((((class color) + (background dark)) + (:foreground "light blue")) + (((class color) + (background light)) + (:foreground "MidnightBlue")) + (t + (:italic t))) + "Citation face.") -;see gnus-cus.el -;(defvar gnus-cite-attribution-face 'underline -; "Face used for attribution lines. -;It is merged with the face for the cited text belonging to the attribution.") +(defface gnus-cite-face-2 '((((class color) + (background dark)) + (:foreground "light cyan")) + (((class color) + (background light)) + (:foreground "firebrick")) + (t + (:italic t))) + "Citation face.") + +(defface gnus-cite-face-3 '((((class color) + (background dark)) + (:foreground "light yellow")) + (((class color) + (background light)) + (:foreground "dark green")) + (t + (:italic t))) + "Citation face.") -;see gnus-cus.el -;(defvar gnus-cite-hide-percentage 50 -; "Only hide cited text if it is larger than this percent of the body.") +(defface gnus-cite-face-4 '((((class color) + (background dark)) + (:foreground "light pink")) + (((class color) + (background light)) + (:foreground "OrangeRed")) + (t + (:italic t))) + "Citation face.") + +(defface gnus-cite-face-5 '((((class color) + (background dark)) + (:foreground "pale green")) + (((class color) + (background light)) + (:foreground "dark khaki")) + (t + (:italic t))) + "Citation face.") -;see gnus-cus.el -;(defvar gnus-cite-hide-absolute 10 -; "Only hide cited text if there is at least this number of cited lines.") +(defface gnus-cite-face-6 '((((class color) + (background dark)) + (:foreground "beige")) + (((class color) + (background light)) + (:foreground "dark violet")) + (t + (:italic t))) + "Citation face.") + +(defface gnus-cite-face-7 '((((class color) + (background dark)) + (:foreground "orange")) + (((class color) + (background light)) + (:foreground "SteelBlue4")) + (t + (:italic t))) + "Citation face.") + +(defface gnus-cite-face-8 '((((class color) + (background dark)) + (:foreground "magenta")) + (((class color) + (background light)) + (:foreground "magenta")) + (t + (:italic t))) + "Citation face.") + +(defface gnus-cite-face-9 '((((class color) + (background dark)) + (:foreground "violet")) + (((class color) + (background light)) + (:foreground "violet")) + (t + (:italic t))) + "Citation face.") -;see gnus-cus.el -;(defvar gnus-face-light-name-list -; '("light blue" "light cyan" "light yellow" "light pink" -; "pale green" "beige" "orange" "magenta" "violet" "medium purple" -; "turquoise") -; "Names of light colors.") +(defface gnus-cite-face-10 '((((class color) + (background dark)) + (:foreground "medium purple")) + (((class color) + (background light)) + (:foreground "medium purple")) + (t + (:italic t))) + "Citation face.") + +(defface gnus-cite-face-11 '((((class color) + (background dark)) + (:foreground "turquoise")) + (((class color) + (background light)) + (:foreground "turquoise")) + (t + (:italic t))) + "Citation face.") -;see gnus-cus.el -;(defvar gnus-face-dark-name-list -; '("dark salmon" "firebrick" -; "dark green" "dark orange" "dark khaki" "dark violet" -; "dark turquoise") -; "Names of dark colors.") +(defcustom gnus-cite-face-list + '(gnus-cite-face-1 gnus-cite-face-2 gnus-cite-face-3 gnus-cite-face-4 + gnus-cite-face-5 gnus-cite-face-6 gnus-cite-face-7 gnus-cite-face-8 + gnus-cite-face-9 gnus-cite-face-10 gnus-cite-face-11) + "List of faces used for highlighting citations. + +When there are citations from multiple articles in the same message, +Gnus will try to give each citation from each article its own face. +This should make it easier to see who wrote what." + :group 'gnus-cite + :type '(repeat face)) + +(defcustom gnus-cite-hide-percentage 50 + "Only hide excess citation if above this percentage of the body." + :group 'gnus-cite + :type 'number) + +(defcustom gnus-cite-hide-absolute 10 + "Only hide excess citation if above this number of lines in the body." + :group 'gnus-cite + :type 'integer) ;;; Internal Variables: @@ -141,8 +278,8 @@ ;; TAG: Is a Supercite tag, if any. (defvar gnus-cited-text-button-line-format-alist - `((?b beg ?d) - (?e end ?d) + `((?b (marker-position beg) ?d) + (?e (marker-position end) ?d) (?l (- end beg) ?d))) (defvar gnus-cited-text-button-line-format-spec nil) @@ -161,13 +298,6 @@ Lines matching `gnus-cite-attribution-suffix' and perhaps `gnus-cite-attribution-prefix' are considered attribution lines." (interactive (list 'force)) - ;; Create dark or light faces if necessary. - (cond ((eq gnus-cite-face-list 'light) - (setq gnus-cite-face-list - (mapcar 'gnus-make-face gnus-face-light-name-list))) - ((eq gnus-cite-face-list 'dark) - (setq gnus-cite-face-list - (mapcar 'gnus-make-face gnus-face-dark-name-list)))) (save-excursion (set-buffer gnus-article-buffer) (gnus-cite-parse-maybe force) @@ -202,11 +332,11 @@ face (cdr (assoc prefix face-alist))) ;; Add attribution button. (goto-line number) - (if (re-search-forward gnus-cite-attribution-suffix - (save-excursion (end-of-line 1) (point)) - t) - (gnus-article-add-button (match-beginning 1) (match-end 1) - 'gnus-cite-toggle prefix)) + (when (re-search-forward gnus-cite-attribution-suffix + (save-excursion (end-of-line 1) (point)) + t) + (gnus-article-add-button (match-beginning 1) (match-end 1) + 'gnus-cite-toggle prefix)) ;; Highlight attribution line. (gnus-cite-add-face number skip face) (gnus-cite-add-face number skip gnus-cite-attribution-face)) @@ -241,14 +371,17 @@ (goto-char (point-min)) (forward-line (1- number)) (push (cons (point-marker) prefix) marks))) + ;; Skip to the beginning of the body. (goto-char (point-min)) (search-forward "\n\n" nil t) (push (cons (point-marker) "") marks) + ;; Find the end of the body. (goto-char (point-max)) - (re-search-backward gnus-signature-separator nil t) + (gnus-article-search-signature) (push (cons (point-marker) "") marks) + ;; Sort the marks. (setq marks (sort marks (lambda (m1 m2) (< (car m1) (car m2))))) - (let* ((omarks marks)) + (let ((omarks marks)) (setq marks nil) (while (cdr omarks) (if (= (caar omarks) (caadr omarks)) @@ -257,7 +390,10 @@ (push (car omarks) marks)) (unless (equal (cdadr omarks) "") (push (cadr omarks) marks)) - (setq omarks (cdr omarks))) + (unless (and (equal (cdar omarks) "") + (equal (cdadr omarks) "") + (not (cddr omarks))) + (setq omarks (cdr omarks)))) (push (car omarks) marks)) (setq omarks (cdr omarks))) (when (car omarks) @@ -272,17 +408,18 @@ (setcdr m (cdddr m)) (setq m (cdr m)))) marks)))) - -(defun gnus-article-fill-cited-article (&optional force) - "Do word wrapping in the current article." - (interactive (list t)) +(defun gnus-article-fill-cited-article (&optional force width) + "Do word wrapping in the current article. +If WIDTH (the numerical prefix), use that text width when filling." + (interactive (list t current-prefix-arg)) (save-excursion (set-buffer gnus-article-buffer) (let ((buffer-read-only nil) (inhibit-point-motion-hooks t) (marks (gnus-dissect-cited-text)) - (adaptive-fill-mode nil)) + (adaptive-fill-mode nil) + (fill-column (if width (prefix-numeric-value width) fill-column))) (save-restriction (while (cdr marks) (widen) @@ -294,24 +431,35 @@ (set-marker (caar marks) nil) (setq marks (cdr marks))) (when marks - (set-marker (caar marks) nil)))))) + (set-marker (caar marks) nil)) + ;; All this information is now incorrect. + (setq gnus-cite-prefix-alist nil + gnus-cite-attribution-alist nil + gnus-cite-loose-prefix-alist nil + gnus-cite-loose-attribution-alist nil))))) (defun gnus-article-hide-citation (&optional arg force) "Toggle hiding of all cited text except attribution lines. See the documentation for `gnus-article-highlight-citation'. If given a negative prefix, always show; if given a positive prefix, always hide." - (interactive (append (gnus-hidden-arg) (list 'force))) + (interactive (append (gnus-article-hidden-arg) (list 'force))) (setq gnus-cited-text-button-line-format-spec (gnus-parse-format gnus-cited-text-button-line-format gnus-cited-text-button-line-format-alist t)) - (unless (gnus-article-check-hidden-text 'cite arg) - (save-excursion - (set-buffer gnus-article-buffer) + (save-excursion + (set-buffer gnus-article-buffer) + (cond + ((gnus-article-check-hidden-text 'cite arg) + t) + ((gnus-article-text-type-exists-p 'cite) + (let ((buffer-read-only nil)) + (gnus-article-hide-text-of-type 'cite))) + (t (let ((buffer-read-only nil) (marks (gnus-dissect-cited-text)) (inhibit-point-motion-hooks t) - (props (nconc (list 'gnus-type 'cite) + (props (nconc (list 'article-type 'cite) gnus-hidden-properties)) beg end) (while marks @@ -337,11 +485,16 @@ (goto-char beg) (unless (save-excursion (search-backward "\n\n" nil t)) (insert "\n")) - (gnus-article-add-button + (put-text-property (point) - (progn (eval gnus-cited-text-button-line-format-spec) (point)) - `gnus-article-toggle-cited-text (cons beg end)) - (set-marker beg (point)))))))) + (progn + (gnus-article-add-button + (point) + (progn (eval gnus-cited-text-button-line-format-spec) (point)) + `gnus-article-toggle-cited-text (cons beg end)) + (point)) + 'article-type 'annotation) + (set-marker beg (point))))))))) (defun gnus-article-toggle-cited-text (region) "Toggle hiding the text in REGION." @@ -362,7 +515,7 @@ cited text with attributions. When called interactively, these two variables are ignored. See also the documentation for `gnus-article-highlight-citation'." - (interactive (append (gnus-hidden-arg) (list 'force))) + (interactive (append (gnus-article-hidden-arg) (list 'force))) (unless (gnus-article-check-hidden-text 'cite arg) (save-excursion (set-buffer gnus-article-buffer) @@ -376,29 +529,28 @@ (hiden 0) total) (goto-char (point-max)) - (re-search-backward gnus-signature-separator nil t) + (gnus-article-search-signature) (setq total (count-lines start (point))) (while atts (setq hiden (+ hiden (length (cdr (assoc (cdar atts) gnus-cite-prefix-alist)))) atts (cdr atts))) - (if (or force - (and (> (* 100 hiden) (* gnus-cite-hide-percentage total)) - (> hiden gnus-cite-hide-absolute))) - (progn - (setq atts gnus-cite-attribution-alist) - (while atts - (setq total (cdr (assoc (cdar atts) gnus-cite-prefix-alist)) - atts (cdr atts)) - (while total - (setq hiden (car total) - total (cdr total)) - (goto-line hiden) - (or (assq hiden gnus-cite-attribution-alist) - (gnus-add-text-properties - (point) (progn (forward-line 1) (point)) - (nconc (list 'gnus-type 'cite) - gnus-hidden-properties))))))))))) + (when (or force + (and (> (* 100 hiden) (* gnus-cite-hide-percentage total)) + (> hiden gnus-cite-hide-absolute))) + (setq atts gnus-cite-attribution-alist) + (while atts + (setq total (cdr (assoc (cdar atts) gnus-cite-prefix-alist)) + atts (cdr atts)) + (while total + (setq hiden (car total) + total (cdr total)) + (goto-line hiden) + (unless (assq hiden gnus-cite-attribution-alist) + (gnus-add-text-properties + (point) (progn (forward-line 1) (point)) + (nconc (list 'article-type 'cite) + gnus-hidden-properties)))))))))) (defun gnus-article-hide-citation-in-followups () "Hide cited text in non-root articles." @@ -423,26 +575,41 @@ gnus-cite-loose-prefix-alist nil gnus-cite-loose-attribution-alist nil) ;; Parse if not too large. - (if (and (not force) + (if (and (not force) gnus-cite-parse-max-size (> (buffer-size) gnus-cite-parse-max-size)) () (setq gnus-cite-article (cons (car gnus-article-current) (cdr gnus-article-current))) - (gnus-cite-parse)))) + (gnus-cite-parse-wrapper)))) + +(defun gnus-cite-parse-wrapper () + ;; Wrap chopped gnus-cite-parse + (goto-char (point-min)) + (unless (search-forward "\n\n" nil t) + (goto-char (point-max))) + (save-excursion + (gnus-cite-parse-attributions)) + ;; Try to avoid check citation if there is no reason to believe + ;; that article has citations + (if (or gnus-cite-always-check + (save-excursion + (re-search-backward gnus-cite-reply-regexp nil t)) + gnus-cite-loose-attribution-alist) + (progn (save-excursion + (gnus-cite-parse)) + (save-excursion + (gnus-cite-connect-attributions))))) (defun gnus-cite-parse () ;; Parse and connect citation prefixes and attribution lines. ;; Parse current buffer searching for citation prefixes. - (goto-char (point-min)) - (or (search-forward "\n\n" nil t) - (goto-char (point-max))) (let ((line (1+ (count-lines (point-min) (point)))) (case-fold-search t) (max (save-excursion (goto-char (point-max)) - (re-search-backward gnus-signature-separator nil t) + (gnus-article-search-signature) (point))) alist entry start begin end numbers prefix) ;; Get all potential prefixes in `alist'. @@ -453,13 +620,13 @@ start end) (goto-char begin) ;; Ignore standard Supercite attribution prefix. - (if (looking-at gnus-supercite-regexp) - (if (match-end 1) - (setq end (1+ (match-end 1))) - (setq end (1+ begin)))) + (when (looking-at gnus-supercite-regexp) + (if (match-end 1) + (setq end (1+ (match-end 1))) + (setq end (1+ begin)))) ;; Ignore very long prefixes. - (if (> end (+ (point) gnus-cite-max-prefix)) - (setq end (+ (point) gnus-cite-max-prefix))) + (when (> end (+ (point) gnus-cite-max-prefix)) + (setq end (+ (point) gnus-cite-max-prefix))) (while (re-search-forward gnus-cite-prefix-regexp (1- end) t) ;; Each prefix. (setq end (match-end 0) @@ -468,14 +635,14 @@ (setq entry (assoc prefix alist)) (if entry (setcdr entry (cons line (cdr entry))) - (setq alist (cons (list prefix line) alist))) + (push (list prefix line) alist)) (goto-char begin)) (goto-char start) (setq line (1+ line))) ;; We got all the potential prefixes. Now create ;; `gnus-cite-prefix-alist' containing the oldest prefix for each ;; line that appears at least gnus-cite-minimum-match-count - ;; times. First sort them by length. Longer is older. + ;; times. First sort them by length. Longer is older. (setq alist (sort alist (lambda (a b) (> (length (car a)) (length (car b)))))) (while alist @@ -492,11 +659,10 @@ ;; longer in case it is an exact match for an attribution ;; line, but we don't remove the line from other ;; prefixes. - (setq gnus-cite-prefix-alist - (cons entry gnus-cite-prefix-alist))) + (push entry gnus-cite-prefix-alist)) (t - (setq gnus-cite-prefix-alist (cons entry - gnus-cite-prefix-alist)) + (push entry + gnus-cite-prefix-alist) ;; Remove articles from other prefixes. (let ((loop alist) current) @@ -504,59 +670,73 @@ (setq current (car loop) loop (cdr loop)) (setcdr current - (gnus-set-difference (cdr current) numbers)))))))) + (gnus-set-difference (cdr current) numbers))))))))) + +(defun gnus-cite-parse-attributions () + (let (al-alist) + ;; Parse attributions + (while (re-search-forward gnus-cite-attribution-suffix (point-max) t) + (let* ((start (match-beginning 0)) + (end (match-end 0)) + (wrote (count-lines (point-min) end)) + (prefix (gnus-cite-find-prefix wrote)) + ;; Check previous line for an attribution leader. + (tag (progn + (beginning-of-line 1) + (when (looking-at gnus-supercite-secondary-regexp) + (buffer-substring (match-beginning 1) + (match-end 1))))) + (in (progn + (goto-char start) + (and (re-search-backward gnus-cite-attribution-prefix + (save-excursion + (beginning-of-line 0) + (point)) + t) + (not (re-search-forward gnus-cite-attribution-suffix + start t)) + (count-lines (point-min) (1+ (point))))))) + (when (eq wrote in) + (setq in nil)) + (goto-char end) + ;; don't add duplicates + (let ((al (buffer-substring (save-excursion (beginning-of-line 0) + (1+ (point))) + end))) + (if (not (assoc al al-alist)) + (progn + (push (list wrote in prefix tag) + gnus-cite-loose-attribution-alist) + (push (cons al t) al-alist)))))))) + +(defun gnus-cite-connect-attributions () + ;; Connect attributions to citations + ;; No citations have been connected to attribution lines yet. (setq gnus-cite-loose-prefix-alist (append gnus-cite-prefix-alist nil)) ;; Parse current buffer searching for attribution lines. - (goto-char (point-min)) - (search-forward "\n\n" nil t) - (while (re-search-forward gnus-cite-attribution-suffix (point-max) t) - (let* ((start (match-beginning 0)) - (end (match-end 0)) - (wrote (count-lines (point-min) end)) - (prefix (gnus-cite-find-prefix wrote)) - ;; Check previous line for an attribution leader. - (tag (progn - (beginning-of-line 1) - (and (looking-at gnus-supercite-secondary-regexp) - (buffer-substring (match-beginning 1) - (match-end 1))))) - (in (progn - (goto-char start) - (and (re-search-backward gnus-cite-attribution-prefix - (save-excursion - (beginning-of-line 0) - (point)) - t) - (not (re-search-forward gnus-cite-attribution-suffix - start t)) - (count-lines (point-min) (1+ (point))))))) - (if (eq wrote in) - (setq in nil)) - (goto-char end) - (setq gnus-cite-loose-attribution-alist - (cons (list wrote in prefix tag) - gnus-cite-loose-attribution-alist)))) ;; Find exact supercite citations. (gnus-cite-match-attributions 'small nil (lambda (prefix tag) - (if tag - (concat "\\`" - (regexp-quote prefix) "[ \t]*" - (regexp-quote tag) ">")))) + (when tag + (concat "\\`" + (regexp-quote prefix) "[ \t]*" + (regexp-quote tag) ">")))) ;; Find loose supercite citations after attributions. (gnus-cite-match-attributions 'small t (lambda (prefix tag) - (if tag (concat "\\<" - (regexp-quote tag) - "\\>")))) + (when tag + (concat "\\<" + (regexp-quote tag) + "\\>")))) ;; Find loose supercite citations anywhere. (gnus-cite-match-attributions 'small nil (lambda (prefix tag) - (if tag (concat "\\<" - (regexp-quote tag) - "\\>")))) + (when tag + (concat "\\<" + (regexp-quote tag) + "\\>")))) ;; Find nested citations after attributions. (gnus-cite-match-attributions 'small-if-unique t (lambda (prefix tag) @@ -571,11 +751,11 @@ (while alist (setq entry (car alist) alist (cdr alist)) - (if (< (length (cdr entry)) gnus-cite-minimum-match-count) - (setq gnus-cite-prefix-alist - (delq entry gnus-cite-prefix-alist) - gnus-cite-loose-prefix-alist - (delq entry gnus-cite-loose-prefix-alist))))) + (when (< (length (cdr entry)) gnus-cite-minimum-match-count) + (setq gnus-cite-prefix-alist + (delq entry gnus-cite-prefix-alist) + gnus-cite-loose-prefix-alist + (delq entry gnus-cite-loose-prefix-alist))))) ;; Find flat attributions. (gnus-cite-match-attributions 'first t nil) ;; Find any attributions (are we getting desperate yet?). @@ -637,27 +817,25 @@ () (setq gnus-cite-loose-attribution-alist (delq att gnus-cite-loose-attribution-alist)) - (setq gnus-cite-attribution-alist - (cons (cons wrote (car best)) gnus-cite-attribution-alist)) - (if in - (setq gnus-cite-attribution-alist - (cons (cons in (car best)) gnus-cite-attribution-alist))) - (if (memq best gnus-cite-loose-prefix-alist) - (let ((loop gnus-cite-prefix-alist) - (numbers (cdr best)) - current) - (setq gnus-cite-loose-prefix-alist - (delq best gnus-cite-loose-prefix-alist)) - (while loop - (setq current (car loop) - loop (cdr loop)) - (if (eq current best) - () - (setcdr current (gnus-set-difference (cdr current) numbers)) - (if (null (cdr current)) - (setq gnus-cite-loose-prefix-alist - (delq current gnus-cite-loose-prefix-alist) - atts (delq current atts))))))))))) + (push (cons wrote (car best)) gnus-cite-attribution-alist) + (when in + (push (cons in (car best)) gnus-cite-attribution-alist)) + (when (memq best gnus-cite-loose-prefix-alist) + (let ((loop gnus-cite-prefix-alist) + (numbers (cdr best)) + current) + (setq gnus-cite-loose-prefix-alist + (delq best gnus-cite-loose-prefix-alist)) + (while loop + (setq current (car loop) + loop (cdr loop)) + (if (eq current best) + () + (setcdr current (gnus-set-difference (cdr current) numbers)) + (when (null (cdr current)) + (setq gnus-cite-loose-prefix-alist + (delq current gnus-cite-loose-prefix-alist) + atts (delq current atts))))))))))) (defun gnus-cite-find-loose (prefix) ;; Return a list of loose attribution lines prefixed by PREFIX. @@ -667,8 +845,8 @@ (setq att (car atts) line (car att) atts (cdr atts)) - (if (string-equal (gnus-cite-find-prefix line) prefix) - (setq lines (cons line lines)))) + (when (string-equal (gnus-cite-find-prefix line) prefix) + (push line lines))) lines)) (defun gnus-cite-add-face (number prefix face) @@ -677,7 +855,7 @@ (let ((inhibit-point-motion-hooks t) from to) (goto-line number) - (unless (eobp) ;; Sometimes things become confused. + (unless (eobp);; Sometimes things become confused. (forward-char (length prefix)) (skip-chars-forward " \t") (setq from (point)) @@ -705,8 +883,8 @@ (t (gnus-add-text-properties (point) (progn (forward-line 1) (point)) - (nconc (list 'gnus-type 'cite) - gnus-hidden-properties)))))))) + (nconc (list 'article-type 'cite) + gnus-hidden-properties)))))))) (defun gnus-cite-find-prefix (line) ;; Return citation prefix for LINE. @@ -716,8 +894,8 @@ (while alist (setq entry (car alist) alist (cdr alist)) - (if (memq line (cdr entry)) - (setq prefix (car entry)))) + (when (memq line (cdr entry)) + (setq prefix (car entry)))) prefix)) (gnus-add-shutdown 'gnus-cache-close 'gnus) diff -r ad457d5f7d04 -r 0293115a14e9 lisp/gnus/gnus-cus.el --- a/lisp/gnus/gnus-cus.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/gnus/gnus-cus.el Mon Aug 13 08:49:20 2007 +0200 @@ -1,9 +1,9 @@ -;;; gnus-cus.el --- User friendly customization of Gnus -;; Copyright (C) 1995,96 Free Software Foundation, Inc. +;;; gnus-cus.el --- customization commands for Gnus ;; -;; Author: Per Abrahamsen -;; Keywords: help, news -;; Version: 0.1 +;; Copyright (C) 1996 Free Software Foundation, Inc. + +;; Author: Per Abrahamsen +;; Keywords: news ;; This file is part of GNU Emacs. @@ -14,7 +14,7 @@ ;; 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 +;; 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 @@ -26,647 +26,625 @@ ;;; Code: -(require 'custom) -(require 'gnus-ems) -(require 'browse-url) -(eval-when-compile (require 'cl)) +(require 'widget-edit) +(require 'gnus-score) + +;;; Widgets: -;; The following is just helper functions and data, not meant to be set -;; by the user. -(defun gnus-make-face (color) - ;; Create entry for face with COLOR. - (custom-face-lookup color nil nil nil nil nil)) +;; There should be special validation for this. +(define-widget 'gnus-email-address 'string + "An email address") + +(defun gnus-custom-mode () + "Major mode for editing Gnus customization buffers. + +The following commands are available: -(defvar gnus-face-light-name-list - '("light blue" "light cyan" "light yellow" "light pink" - "pale green" "beige" "orange" "magenta" "violet" "medium purple" - "turquoise")) +\\[widget-forward] Move to next button or editable field. +\\[widget-backward] Move to previous button or editable field. +\\[widget-button-click] Activate button under the mouse pointer. +\\[widget-button-press] Activate button under point. -(defvar gnus-face-dark-name-list - '("dark blue" "firebrick" "dark green" "OrangeRed" - "dark khaki" "dark violet" "SteelBlue4")) -; CornflowerBlue SeaGreen OrangeRed SteelBlue4 DeepPink3 -; DarkOlviveGreen4 +Entry to this mode calls the value of `gnus-custom-mode-hook' +if that value is non-nil." + (kill-all-local-variables) + (setq major-mode 'gnus-custom-mode + mode-name "Gnus Customize") + (use-local-map widget-keymap) + (run-hooks 'gnus-custom-mode-hook)) + +;;; Group Customization: + +(defconst gnus-group-parameters + '((to-address (gnus-email-address :tag "To Address") "\ +This will be used when doing followups and posts. -(custom-declare '() - '((tag . "Gnus") - (doc . "\ -The coffee-brewing, all singing, all dancing, kitchen sink newsreader.") - (type . group) - (data - ((tag . "Visual") - (doc . "\ -Gnus can be made colorful and fun or grey and dull as you wish.") - (type . group) - (data - ((tag . "Visual") - (doc . "Enable visual features. -If `visual' is disabled, there will be no menus and few faces. Most of -the visual customization options below will be ignored. Gnus will use -less space and be faster as a result.") - (default . - (summary-highlight group-highlight - article-highlight - mouse-face - summary-menu group-menu article-menu - tree-highlight menu highlight - browse-menu server-menu - page-marker tree-menu binary-menu pick-menu - grouplens-menu)) - (name . gnus-visual) - (type . sexp)) - ((tag . "WWW Browser") - (doc . "\ -WWW Browser to call when clicking on an URL button in the article buffer. +This is primarily useful in mail groups that represent closed +mailing lists--mailing lists where it's expected that everybody that +writes to the mailing list is subscribed to it. Since using this +parameter ensures that the mail only goes to the mailing list itself, +it means that members won't receive two copies of your followups. + +Using `to-address' will actually work whether the group is foreign or +not. Let's say there's a group on the server that is called +`fa.4ad-l'. This is a real newsgroup, but the server has gotten the +articles from a mail-to-news gateway. Posting directly to this group +is therefore impossible--you have to send mail to the mailing list +address instead.") + + (to-list (gnus-email-address :tag "To List") "\ +This address will be used when doing a `a' in the group. + +It is totally ignored when doing a followup--except that if it is +present in a news group, you'll get mail group semantics when doing +`f'.") + + (broken-reply-to (const :tag "Broken Reply To" t) "\ +Ignore `Reply-To' headers in this group. + +That can be useful if you're reading a mailing list group where the +listserv has inserted `Reply-To' headers that point back to the +listserv itself. This is broken behavior. So there!") + + (to-group (string :tag "To Group") "\ +All posts will be send to the specified group.") + + (gcc-self (choice :tag "GCC" + :value t + (const t) + (const none) + (string :format "%v" :hide-front-space t)) "\ +Specify default value for GCC header. -You can choose between one of the predefined browsers, or `Other'.") - (name . browse-url-browser-function) - (calculate . (cond ((boundp 'browse-url-browser-function) - browse-url-browser-function) - ((fboundp 'w3-fetch) - 'w3-fetch) - ((eq window-system 'x) - 'gnus-netscape-open-url))) - (type . choice) - (data - ((tag . "W3") - (type . const) - (default . w3-fetch)) - ((tag . "Netscape") - (type . const) - (default . browse-url-netscape)) - ((prompt . "Other") - (doc . "\ -You must specify the name of a Lisp function here. The lisp function -should open a WWW browser when called with an URL (a string). -") - (default . __uninitialized__) - (type . symbol)))) - ((tag . "Mouse Face") - (doc . "\ -Face used for group or summary buffer mouse highlighting. -The line beneath the mouse pointer will be highlighted with this -face.") - (name . gnus-mouse-face) - (calculate . (condition-case () - (if (gnus-visual-p 'mouse-face 'highlight) - (if (boundp 'gnus-mouse-face) - gnus-mouse-face - 'highlight) - 'default) - (error nil))) - (type . face)) - ((tag . "Article Display") - (doc . "Controls how the article buffer will look. +If this symbol is present in the group parameter list and set to `t', +new composed messages will be `Gcc''d to the current group. If it is +present and set to `none', no `Gcc:' header will be generated, if it +is present and a string, this string will be inserted literally as a +`gcc' header (this symbol takes precedence over any default `Gcc' +rules as described later).") + + (auto-expire (const :tag "Automatic Expire" t) "\ +All articles that are read will be marked as expirable.") + + (total-expire (const :tag "Total Expire" t) "\ +All read articles will be put through the expiry process + +This happens even if they are not marked as expirable. +Use with caution.") + + (expiry-wait (choice :tag "Expire Wait" + :value never + (const never) + (const immediate) + (number :hide-front-space t + :format "%v")) "\ +When to expire. + +Overrides any `nnmail-expiry-wait' and `nnmail-expiry-wait-function' +when expiring expirable messages. The value can either be a number of +days (not necessarily an integer) or the symbols `never' or +`immediate'.") -If you leave the list empty, the article will appear exactly as it is -stored on the disk. The list entries will hide or highlight various -parts of the article, making it easier to find the information you -want.") - (name . gnus-article-display-hook) - (type . list) - (calculate - . (if (and (string-match "xemacs" emacs-version) - (featurep 'xface)) - '(gnus-article-hide-headers-if-wanted - gnus-article-hide-boring-headers - gnus-article-treat-overstrike - gnus-article-maybe-highlight - gnus-article-display-x-face) - '(gnus-article-hide-headers-if-wanted - gnus-article-hide-boring-headers - gnus-article-treat-overstrike - gnus-article-maybe-highlight))) - (data - ((type . repeat) - (header . nil) - (data - (tag . "Filter") - (type . choice) - (data - ((tag . "Treat Overstrike") - (doc . "\ -Convert use of overstrike into bold and underline. + (score-file (file :tag "Score File") "\ +Make the specified file into the current score file. +This means that all score commands you issue will end up in this file.") + + (adapt-file (file :tag "Adapt File") "\ +Make the specified file into the current adaptive file. +All adaptive score entries will be put into this file.") + + (admin-address (gnus-email-address :tag "Admin Address") "\ +Administration address for a mailing list. + +When unsubscribing to a mailing list you should never send the +unsubscription notice to the mailing list itself. Instead, you'd +send messages to the administrative address. This parameter allows +you to put the admin address somewhere convenient.") -Two identical letters separated by a backspace are displayed as a -single bold letter, while a letter followed by a backspace and an -underscore will be displayed as a single underlined letter. This -technique was developed for old line printers (think about it), and is -still in use on some newsgroups, in particular the ClariNet -hierarchy. -") - (type . const) - (default . - gnus-article-treat-overstrike)) - ((tag . "Word Wrap") - (doc . "\ -Format too long lines. -") - (type . const) - (default . gnus-article-word-wrap)) - ((tag . "Remove CR") - (doc . "\ -Remove carriage returns from an article. -") - (type . const) - (default . gnus-article-remove-cr)) - ((tag . "Display X-Face") - (doc . "\ -Look for an X-Face header and display it if present. + (display (choice :tag "Display" + :value default + (const all) + (const default)) "\ +Which articles to display on entering the group. + +`all' + Display all articles, both read and unread. -See also `X Face Command' for a definition of the external command -used for decoding and displaying the face. -") - (type . const) - (default . gnus-article-display-x-face)) - ((tag . "Unquote Printable") - (doc . "\ -Transform MIME quoted printable into 8-bit characters. +`default' + Display the default visible articles, which normally includes + unread and ticked articles.") + + (comment (string :tag "Comment") "\ +An arbitrary comment on the group.")) + "Alist of valid group parameters. + +Each entry has the form (NAME TYPE DOC), where NAME is the parameter +itself (a symbol), TYPE is the parameters type (a sexp widget), and +DOC is a documentation string for the parameter.") + +(defvar gnus-custom-params) +(defvar gnus-custom-method) +(defvar gnus-custom-group) -Quoted printable is often seen by strings like `=EF' where you would -expect a non-English letter. -") - (type . const) - (default . - gnus-article-de-quoted-unreadable)) - ((tag . "Universal Time") - (doc . "\ -Convert date header to universal time. -") - (type . const) - (default . gnus-article-date-ut)) - ((tag . "Local Time") - (doc . "\ -Convert date header to local timezone. -") - (type . const) - (default . gnus-article-date-local)) - ((tag . "Lapsed Time") - (doc . "\ -Replace date header with a header showing the articles age. -") - (type . const) - (default . gnus-article-date-lapsed)) - ((tag . "Highlight") - (doc . "\ -Highlight headers, citations, signature, and buttons. -") - (type . const) - (default . gnus-article-highlight)) - ((tag . "Maybe Highlight") - (doc . "\ -Highlight headers, signature, and buttons if `Visual' is turned on. -") - (type . const) - (default . - gnus-article-maybe-highlight)) - ((tag . "Highlight Some") - (doc . "\ -Highlight headers, signature, and buttons. -") - (type . const) - (default . gnus-article-highlight-some)) - ((tag . "Highlight Headers") - (doc . "\ -Highlight headers as specified by `Article Header Highlighting'. -") - (type . const) - (default . - gnus-article-highlight-headers)) - ((tag . "Highlight Signature") - (doc . "\ -Highlight the signature as specified by `Article Signature Face'. -") - (type . const) - (default . - gnus-article-highlight-signature)) - ((tag . "Citation") - (doc . "\ -Highlight the citations as specified by `Citation Faces'. -") - (type . const) - (default . - gnus-article-highlight-citation)) - ((tag . "Hide") - (doc . "\ -Hide unwanted headers, excess citation, and the signature. -") - (type . const) - (default . gnus-article-hide)) - ((tag . "Hide Headers If Wanted") - (doc . "\ -Hide headers, but allow user to display them with `t' or `v'. -") - (type . const) - (default . - gnus-article-hide-headers-if-wanted)) - ((tag . "Hide Headers") - (doc . "\ -Hide unwanted headers and possibly sort them as well. -Most likely you want to use `Hide Headers If Wanted' instead. -") - (type . const) - (default . gnus-article-hide-headers)) - ((tag . "Hide Signature") - (doc . "\ -Hide the signature. -") - (type . const) - (default . gnus-article-hide-signature)) - ((tag . "Hide Excess Citations") - (doc . "\ -Hide excess citation. +(defun gnus-group-customize (group &optional part) + "Edit the group on the current line." + (interactive (list (gnus-group-group-name))) + (let ((part (or part 'info)) + info + (types (mapcar (lambda (entry) + `(cons :format "%v%h\n" + :doc ,(nth 2 entry) + (const :format "" ,(nth 0 entry)) + ,(nth 1 entry))) + gnus-group-parameters))) + (unless group + (error "No group on current line")) + (unless (setq info (gnus-get-info group)) + (error "Killed group; can't be edited")) + ;; Ready. + (kill-buffer (get-buffer-create "*Gnus Customize*")) + (switch-to-buffer (get-buffer-create "*Gnus Customize*")) + (gnus-custom-mode) + (make-local-variable 'gnus-custom-group) + (setq gnus-custom-group group) + (widget-insert "Customize the ") + (widget-create 'info-link + :help-echo "Push me to learn more." + :tag "group parameters" + "(gnus)Group Parameters") + (widget-insert " for <") + (widget-insert group) + (widget-insert "> and press ") + (widget-create 'push-button + :tag "done" + :help-echo "Push me when done customizing." + :action 'gnus-group-customize-done) + (widget-insert ".\n\n") + (make-local-variable 'gnus-custom-params) + (setq gnus-custom-params + (widget-create 'group + :value (gnus-info-params info) + `(set :inline t + :greedy t + :tag "Parameters" + :format "%t:\n%h%v" + :doc "\ +These special paramerters are recognized by Gnus. +Check the [ ] for the parameters you want to apply to this group, then +edit the value to suit your taste." + ,@types) + '(repeat :inline t + :tag "Variables" + :format "%t:\n%h%v%i\n\n" + :doc "\ +Set variables local to the group you are entering. + +If you want to turn threading off in `news.answers', you could put +`(gnus-show-threads nil)' in the group parameters of that group. +`gnus-show-threads' will be made into a local variable in the summary +buffer you enter, and the form `nil' will be `eval'ed there. -Excess is defined by `Citation Hide Percentage' and `Citation Hide Absolute'. -") - (type . const) - (default . - gnus-article-hide-citation-maybe)) - ((tag . "Hide Citations") - (doc . "\ -Hide all cited text. -") - (type . const) - (default . gnus-article-hide-citation)) - ((tag . "Add Buttons") - (doc . "\ -Make URL's into clickable buttons. -") - (type . const) - (default . gnus-article-add-buttons)) - ((prompt . "Other") - (doc . "\ -Name of Lisp function to call. +This can also be used as a group-specific hook function, if you'd +like. If you want to hear a beep when you enter a group, you could +put something like `(dummy-variable (ding))' in the parameters of that +group. `dummy-variable' will be set to the result of the `(ding)' +form, but who cares?" + (group :value (nil nil) + (symbol :tag "Variable") + (sexp :tag + "Value"))) + + '(repeat :inline t + :tag "Unknown entries" + sexp))) + (widget-insert "\n\nYou can also edit the ") + (widget-create 'info-link + :tag "select method" + :help-echo "Push me to learn more about select methods." + "(gnus)Select Methods") + (widget-insert " for the group.\n") + (setq gnus-custom-method + (widget-create 'sexp + :tag "Method" + :value (gnus-info-method info))) + (use-local-map widget-keymap) + (widget-setup))) -Push the `Filter' button to select one of the predefined filters. -") - (type . symbol))))))) - ((tag . "Article Button Face") - (doc . "\ -Face used for highlighting buttons in the article buffer. +(defun gnus-group-customize-done (&rest ignore) + "Apply changes and bury the buffer." + (interactive) + (gnus-group-edit-group-done 'params gnus-custom-group + (widget-value gnus-custom-params)) + (gnus-group-edit-group-done 'method gnus-custom-group + (widget-value gnus-custom-method)) + (bury-buffer)) + +;;; Score Customization: + +(defconst gnus-score-parameters + '((mark (number :tag "Mark") "\ +The value of this entry should be a number. +Any articles with a score lower than this number will be marked as read.") + + (expunge (number :tag "Expunge") "\ +The value of this entry should be a number. +Any articles with a score lower than this number will be removed from +the summary buffer.") -An article button is a piece of text that you can activate by pressing -`RET' or `mouse-2' above it.") - (name . gnus-article-button-face) - (default . bold) - (type . face)) - ((tag . "Article Mouse Face") - (doc . "\ -Face used for mouse highlighting in the article buffer. + (mark-and-expunge (number :tag "Mark-and-expunge") "\ +The value of this entry should be a number. +Any articles with a score lower than this number will be marked as +read and removed from the summary buffer.") + + (thread-mark-and-expunge (number :tag "Thread-mark-and-expunge") "\ +The value of this entry should be a number. +All articles that belong to a thread that has a total score below this +number will be marked as read and removed from the summary buffer. +`gnus-thread-score-function' says how to compute the total score +for a thread.") + + (files (repeat :tag "Files" file) "\ +The value of this entry should be any number of file names. +These files are assumed to be score files as well, and will be loaded +the same way this one was.") + + (exclude-files (repeat :tag "Exclude-files" file) "\ +The clue of this entry should be any number of files. +These files will not be loaded, even though they would normally be so, +for some reason or other.") + + (eval (sexp :tag "Eval" :value nil) "\ +The value of this entry will be `eval'el. +This element will be ignored when handling global score files.") -Article buttons will be displayed in this face when the cursor is -above them.") - (name . gnus-article-mouse-face) - (default . highlight) - (type . face)) - ((tag . "Article Signature Face") - (doc . "\ -Face used for highlighting a signature in the article buffer.") - (name . gnus-signature-face) - (default . italic) - (type . face)) - ((tag . "Article Header Highlighting") - (doc . "\ -Controls highlighting of article header. + (read-only (boolean :tag "Read-only" :value t) "\ +Read-only score files will not be updated or saved. +Global score files should feature this atom.") + + (orphan (number :tag "Orphan") "\ +The value of this entry should be a number. +Articles that do not have parents will get this number added to their +scores. Imagine you follow some high-volume newsgroup, like +`comp.lang.c'. Most likely you will only follow a few of the threads, +also want to see any new threads. + +You can do this with the following two score file entries: -Below is a list of article header names, and the faces used for -displaying the name and content of the header. The `Header' field -should contain the name of the header. The field actually contains a -regular expression that should match the beginning of the header line, -but if you don't know what a regular expression is, just write the -name of the header. The second field is the `Name' field, which -determines how the header name (i.e. the part of the header left -of the `:') is displayed. The third field is the `Content' field, -which determines how the content (i.e. the part of the header right of -the `:') is displayed. + (orphan -500) + (mark-and-expunge -100) -If you leave the last `Header' field in the list empty, the `Name' and -`Content' fields will determine how headers not listed above are -displayed. +When you enter the group the first time, you will only see the new +threads. You then raise the score of the threads that you find +interesting (with `I T' or `I S'), and ignore (`C y') the rest. +Next time you enter the group, you will see new articles in the +interesting threads, plus any new threads. + +I.e.---the orphan score atom is for high-volume groups where there +exist a few interesting threads which can't be found automatically +by ordinary scoring rules.") -If you only want to change the display of the name part for a specific -header, specify `None' in the `Content' field. Similarly, specify -`None' in the `Name' field if you only want to leave the name part -alone.") - (name . gnus-header-face-alist) - (type . list) - (calculate - . (cond - ((not (eq gnus-display-type 'color)) - '(("" bold italic))) - ((eq gnus-background-mode 'dark) - (list - (list "From" nil - (custom-face-lookup "light blue" nil nil t t nil)) - (list "Subject" nil - (custom-face-lookup "pink" nil nil t t nil)) - (list "Newsgroups:.*," nil - (custom-face-lookup "yellow" nil nil t t nil)) - (list - "" - (custom-face-lookup "cyan" nil nil t nil nil) - (custom-face-lookup "forestgreen" nil nil nil t - nil)))) - (t - (list - (list "From" nil - (custom-face-lookup "MidnightBlue" nil nil t t nil)) - (list "Subject" nil - (custom-face-lookup "firebrick" nil nil t t nil)) - (list "Newsgroups:.*," nil - (custom-face-lookup "indianred" nil nil t t nil)) - (list "" - (custom-face-lookup - "DarkGreen" nil nil t nil nil) - (custom-face-lookup "DarkGreen" nil nil - nil t nil)))))) - (data - ((type . repeat) - (header . nil) - (data - (type . list) - (compact . t) - (data - ((type . string) - (prompt . "Header") - (tag . "Header ")) - "\n " - ((type . face) - (prompt . "Name") - (tag . "Name ")) - "\n " - ((type . face) - (tag . "Content")) - "\n"))))) - ((tag . "Attribution Face") - (doc . "\ -Face used for attribution lines. -It is merged with the face for the cited text belonging to the attribution.") - (name . gnus-cite-attribution-face) - (default . underline) - (type . face)) - ((tag . "Citation Faces") - (doc . "\ -List of faces used for highlighting citations. + (adapt (choice :tag "Adapt" + (const t) + (const ignore) + (sexp :format "%v" + :hide-front-space t)) "\ +This entry controls the adaptive scoring. +If it is `t', the default adaptive scoring rules will be used. If it +is `ignore', no adaptive scoring will be performed on this group. If +it is a list, this list will be used as the adaptive scoring rules. +If it isn't present, or is something other than `t' or `ignore', the +default adaptive scoring rules will be used. If you want to use +adaptive scoring on most groups, you'd set `gnus-use-adaptive-scoring' +to `t', and insert an `(adapt ignore)' in the groups where you do not +want adaptive scoring. If you only want adaptive scoring in a few +groups, you'd set `gnus-use-adaptive-scoring' to `nil', and insert +`(adapt t)' in the score files of the groups where you want it.") + + (adapt-file (file :tag "Adapt-file") "\ +All adaptive score entries will go to the file named by this entry. +It will also be applied when entering the group. This atom might +be handy if you want to adapt on several groups at once, using the +same adaptive file for a number of groups.") + + (local (repeat :tag "Local" + (group :value (nil nil) + (symbol :tag "Variable") + (sexp :tag "Value"))) "\ +The value of this entry should be a list of `(VAR VALUE)' pairs. +Each VAR will be made buffer-local to the current summary buffer, +and set to the value specified. This is a convenient, if somewhat +strange, way of setting variables in some groups if you don't like +hooks much.") + (touched (sexp :format "Touched\n") "Internal variable.")) + "Alist of valid symbolic score parameters. + +Each entry has the form (NAME TYPE DOC), where NAME is the parameter +itself (a symbol), TYPE is the parameters type (a sexp widget), and DOC is a +documentation string for the parameter.") + +(define-widget 'gnus-score-string 'group + "Edit score entries for string-valued headers." + :convert-widget 'gnus-score-string-convert) -When there are citations from multiple articles in the same message, -Gnus will try to give each citation from each article its own face. -This should make it easier to see who wrote what.") - (name . gnus-cite-face-list) - (import . gnus-custom-import-cite-face-list) - (type . list) - (calculate . (cond ((not (eq gnus-display-type 'color)) - '(italic)) - ((eq gnus-background-mode 'dark) - (mapcar 'gnus-make-face - gnus-face-light-name-list)) - (t - (mapcar 'gnus-make-face - gnus-face-dark-name-list)))) - (data - ((type . repeat) - (header . nil) - (data (type . face) - (tag . "Face"))))) - ((tag . "Citation Hide Percentage") - (doc . "\ -Only hide excess citation if above this percentage of the body.") - (name . gnus-cite-hide-percentage) - (default . 50) - (type . integer)) - ((tag . "Citation Hide Absolute") - (doc . "\ -Only hide excess citation if above this number of lines in the body.") - (name . gnus-cite-hide-absolute) - (default . 10) - (type . integer)) - ((tag . "Summary Selected Face") - (doc . "\ -Face used for highlighting the current article in the summary buffer.") - (name . gnus-summary-selected-face) - (default . underline) - (type . face)) - ((tag . "Summary Line Highlighting") - (doc . "\ -Controls the highlighting of summary buffer lines. +(defun gnus-score-string-convert (widget) + ;; Set args appropriately. + (let* ((tag (widget-get widget :tag)) + (item `(const :format "" :value ,(downcase tag))) + (match '(string :tag "Match")) + (score '(choice :tag "Score" + (const :tag "default" nil) + (integer :format "%v" + :hide-front-space t))) + (expire '(choice :tag "Expire" + (const :tag "off" nil) + (integer :format "%v" + :hide-front-space t))) + (type '(choice :tag "Type" + :value s + ;; I should really create a forgiving :match + ;; function for each type below, that only + ;; looked at the first letter. + (const :tag "Regexp" r) + (const :tag "Regexp (fixed case)" R) + (const :tag "Substring" s) + (const :tag "Substring (fixed case)" S) + (const :tag "Exact" e) + (const :tag "Exact (fixed case)" E) + (const :tag "Word" w) + (const :tag "Word (fixed case)" W) + (const :tag "default" nil))) + (group `(group ,match ,score ,expire ,type)) + (doc (concat (or (widget-get widget :doc) + (concat "Change score based on the " tag + " header.\n")) + " +You can have an arbitrary number of score entries for this header, +each score entry has four elements: + +1. The \"match element\". This should be the string to look for in the + header. + +2. The \"score element\". This number should be an integer in the + neginf to posinf interval. This number is added to the score + of the article if the match is successful. If this element is + not present, the `gnus-score-interactive-default-score' number + will be used instead. This is 1000 by default. + +3. The \"date element\". This date says when the last time this score + entry matched, which provides a mechanism for expiring the + score entries. It this element is not present, the score + entry is permanent. The date is represented by the number of + days since December 31, 1 ce. + +4. The \"type element\". This element specifies what function should + be used to see whether this score entry matches the article. -Below is a list of `Form'/`Face' pairs. When deciding how a a -particular summary line should be displayed, each form is -evaluated. The content of the face field after the first true form is -used. You can change how those summary lines are displayed, by -editing the face field. + There are the regexp, as well as substring types, and exact match, + and word match types. If this element is not present, Gnus will + assume that substring matching should be used. There is case + sensitive variants of all match types."))) + (widget-put widget :args `(,item + (repeat :inline t + :indent 0 + :tag ,tag + :doc ,doc + :format "%t:\n%h%v%i\n\n" + (choice :format "%v" + :value ("" nil nil s) + ,group + sexp))))) + widget) -It is also possible to change and add form fields, but currently that -requires an understanding of Lisp expressions. Hopefully this will -change in a future release. For now, you can use the following -variables in the Lisp expression: +(define-widget 'gnus-score-integer 'group + "Edit score entries for integer-valued headers." + :convert-widget 'gnus-score-integer-convert) -score: The article's score -default: The default article score. -below: The score below which articles are automatically marked as read. -mark: The article's mark.") - (name . gnus-summary-highlight) - (type . list) - (calculate - . (cond - ((not (eq gnus-display-type 'color)) - '(((> score default) . bold) - ((< score default) . italic))) - ((eq gnus-background-mode 'dark) - (list - (cons - '(= mark gnus-canceled-mark) - (custom-face-lookup "yellow" "black" nil - nil nil nil)) - (cons '(and (> score default) - (or (= mark gnus-dormant-mark) - (= mark gnus-ticked-mark))) - (custom-face-lookup - "pink" nil nil t nil nil)) - (cons '(and (< score default) - (or (= mark gnus-dormant-mark) - (= mark gnus-ticked-mark))) - (custom-face-lookup "pink" nil nil - nil t nil)) - (cons '(or (= mark gnus-dormant-mark) - (= mark gnus-ticked-mark)) - (custom-face-lookup - "pink" nil nil nil nil nil)) +(defun gnus-score-integer-convert (widget) + ;; Set args appropriately. + (let* ((tag (widget-get widget :tag)) + (item `(const :format "" :value ,(downcase tag))) + (match '(integer :tag "Match")) + (score '(choice :tag "Score" + (const :tag "default" nil) + (integer :format "%v" + :hide-front-space t))) + (expire '(choice :tag "Expire" + (const :tag "off" nil) + (integer :format "%v" + :hide-front-space t))) + (type '(choice :tag "Type" + :value < + (const <) + (const >) + (const =) + (const >=) + (const <=))) + (group `(group ,match ,score ,expire ,type)) + (doc (concat (or (widget-get widget :doc) + (concat "Change score based on the " tag + " header."))))) + (widget-put widget :args `(,item + (repeat :inline t + :indent 0 + :tag ,tag + :doc ,doc + :format "%t:\n%h%v%i\n\n" + ,group)))) + widget) + +(define-widget 'gnus-score-date 'group + "Edit score entries for date-valued headers." + :convert-widget 'gnus-score-date-convert) - (cons - '(and (> score default) (= mark gnus-ancient-mark)) - (custom-face-lookup "medium blue" nil nil t - nil nil)) - (cons - '(and (< score default) (= mark gnus-ancient-mark)) - (custom-face-lookup "SkyBlue" nil nil - nil t nil)) - (cons - '(= mark gnus-ancient-mark) - (custom-face-lookup "SkyBlue" nil nil - nil nil nil)) - (cons '(and (> score default) (= mark gnus-unread-mark)) - (custom-face-lookup "white" nil nil t - nil nil)) - (cons '(and (< score default) (= mark gnus-unread-mark)) - (custom-face-lookup "white" nil nil - nil t nil)) - (cons '(= mark gnus-unread-mark) - (custom-face-lookup - "white" nil nil nil nil nil)) +(defun gnus-score-date-convert (widget) + ;; Set args appropriately. + (let* ((tag (widget-get widget :tag)) + (item `(const :format "" :value ,(downcase tag))) + (match '(string :tag "Match")) + (score '(choice :tag "Score" + (const :tag "default" nil) + (integer :format "%v" + :hide-front-space t))) + (expire '(choice :tag "Expire" + (const :tag "off" nil) + (integer :format "%v" + :hide-front-space t))) + (type '(choice :tag "Type" + :value regexp + (const regexp) + (const before) + (const at) + (const after))) + (group `(group ,match ,score ,expire ,type)) + (doc (concat (or (widget-get widget :doc) + (concat "Change score based on the " tag + " header.")) + " +For the Date header we have three kinda silly match types: `before', +`at' and `after'. I can't really imagine this ever being useful, but, +like, it would feel kinda silly not to provide this function. Just in +case. You never know. Better safe than sorry. Once burnt, twice +shy. Don't judge a book by its cover. Never not have sex on a first +date. (I have been told that at least one person, and I quote, +\"found this function indispensable\", however.) - (cons '(> score default) 'bold) - (cons '(< score default) 'italic))) - (t - (list - (cons - '(= mark gnus-canceled-mark) - (custom-face-lookup - "yellow" "black" nil nil nil nil)) - (cons '(and (> score default) - (or (= mark gnus-dormant-mark) - (= mark gnus-ticked-mark))) - (custom-face-lookup "firebrick" nil nil - t nil nil)) - (cons '(and (< score default) - (or (= mark gnus-dormant-mark) - (= mark gnus-ticked-mark))) - (custom-face-lookup "firebrick" nil nil - nil t nil)) - (cons - '(or (= mark gnus-dormant-mark) - (= mark gnus-ticked-mark)) - (custom-face-lookup - "firebrick" nil nil nil nil nil)) +A more useful match type is `regexp'. With it, you can match the date +string using a regular expression. The date is normalized to ISO8601 +compact format first---`YYYYMMDDTHHMMSS'. If you want to match all +articles that have been posted on April 1st in every year, you could +use `....0401.........' as a match string, for instance. (Note that +the date is kept in its original time zone, so this will match +articles that were posted when it was April 1st where the article was +posted from. Time zones are such wholesome fun for the whole family, +eh?"))) + (widget-put widget :args `(,item + (repeat :inline t + :indent 0 + :tag ,tag + :doc ,doc + :format "%t:\n%h%v%i\n\n" + ,group)))) + widget) - (cons '(and (> score default) (= mark gnus-ancient-mark)) - (custom-face-lookup "RoyalBlue" nil nil - t nil nil)) - (cons '(and (< score default) (= mark gnus-ancient-mark)) - (custom-face-lookup "RoyalBlue" nil nil - nil t nil)) - (cons - '(= mark gnus-ancient-mark) - (custom-face-lookup - "RoyalBlue" nil nil nil nil nil)) - - (cons '(and (> score default) (/= mark gnus-unread-mark)) - (custom-face-lookup "DarkGreen" nil nil - t nil nil)) - (cons '(and (< score default) (/= mark gnus-unread-mark)) - (custom-face-lookup "DarkGreen" nil nil - nil t nil)) - (cons - '(/= mark gnus-unread-mark) - (custom-face-lookup "DarkGreen" nil nil - nil nil nil)) - - (cons '(> score default) 'bold) - (cons '(< score default) 'italic))))) - (data - ((type . repeat) - (header . nil) - (data (type . pair) - (compact . t) - (data ((type . sexp) - (width . 60) - (tag . "Form")) - "\n " - ((type . face) - (tag . "Face")) - "\n"))))) - - ((tag . "Group Line Highlighting") - (doc . "\ -Controls the highlighting of group buffer lines. +(defvar gnus-custom-scores) +(defvar gnus-custom-score-alist) -Below is a list of `Form'/`Face' pairs. When deciding how a a -particular group line should be displayed, each form is -evaluated. The content of the face field after the first true form is -used. You can change how those group lines are displayed by -editing the face field. - -It is also possible to change and add form fields, but currently that -requires an understanding of Lisp expressions. Hopefully this will -change in a future release. For now, you can use the following -variables in the Lisp expression: +(defun gnus-score-customize (file) + "Customize score file FILE." + (interactive (list gnus-current-score-file)) + (let ((scores (gnus-score-load file)) + (types (mapcar (lambda (entry) + `(group :format "%v%h\n" + :doc ,(nth 2 entry) + (const :format "" ,(nth 0 entry)) + ,(nth 1 entry))) + gnus-score-parameters))) + ;; Ready. + (kill-buffer (get-buffer-create "*Gnus Customize*")) + (switch-to-buffer (get-buffer-create "*Gnus Customize*")) + (gnus-custom-mode) + (make-local-variable 'gnus-custom-score-alist) + (setq gnus-custom-score-alist scores) + (widget-insert "Customize the ") + (widget-create 'info-link + :help-echo "Push me to learn more." + :tag "score entries" + "(gnus)Score File Format") + (widget-insert " for\n\t") + (widget-insert file) + (widget-insert "\nand press ") + (widget-create 'push-button + :tag "done" + :help-echo "Push me when done customizing." + :action 'gnus-score-customize-done) + (widget-insert ".\n +Check the [ ] for the entries you want to apply to this score file, then +edit the value to suit your taste. Don't forget to mark the checkbox, +if you do all your changes will be lost. ") + (widget-create 'push-button + :action (lambda (&rest ignore) + (require 'gnus-audio) + (gnus-audio-play "Evil_Laugh.au")) + "Bhahahah!") + (widget-insert "\n\n") + (make-local-variable 'gnus-custom-scores) + (setq gnus-custom-scores + (widget-create 'group + :value scores + `(checklist :inline t + :greedy t + (gnus-score-string :tag "From") + (gnus-score-string :tag "Subject") + (gnus-score-string :tag "References") + (gnus-score-string :tag "Xref") + (gnus-score-string :tag "Message-ID") + (gnus-score-integer :tag "Lines") + (gnus-score-integer :tag "Chars") + (gnus-score-date :tag "Date") + (gnus-score-string :tag "Head" + :doc "\ +Match all headers in the article. -group: The name of the group. -unread: The number of unread articles in the group. -method: The select method used. -mailp: Whether it's a mail group or not. -level: The level of the group. -score: The score of the group. -ticked: The number of ticked articles.") - (name . gnus-group-highlight) - (type . list) - (calculate - . (cond - ((not (eq gnus-display-type 'color)) - '((mailp . bold) - ((= unread 0) . italic))) - ((eq gnus-background-mode 'dark) - `(((and (not mailp) (eq level 1)) . - ,(custom-face-lookup "PaleTurquoise" nil nil t)) - ((and (not mailp) (eq level 2)) . - ,(custom-face-lookup "turquoise" nil nil t)) - ((and (not mailp) (eq level 3)) . - ,(custom-face-lookup "MediumTurquoise" nil nil t)) - ((and (not mailp) (>= level 4)) . - ,(custom-face-lookup "DarkTurquoise" nil nil t)) - ((and mailp (eq level 1)) . - ,(custom-face-lookup "aquamarine1" nil nil t)) - ((and mailp (eq level 2)) . - ,(custom-face-lookup "aquamarine2" nil nil t)) - ((and mailp (eq level 3)) . - ,(custom-face-lookup "aquamarine3" nil nil t)) - ((and mailp (>= level 4)) . - ,(custom-face-lookup "aquamarine4" nil nil t)) - )) - (t - `(((and (not mailp) (<= level 3)) . - ,(custom-face-lookup "ForestGreen" nil nil t)) - ((and (not mailp) (eq level 4)) . - ,(custom-face-lookup "DarkGreen" nil nil t)) - ((and (not mailp) (eq level 5)) . - ,(custom-face-lookup "CadetBlue4" nil nil t)) - ((and mailp (eq level 1)) . - ,(custom-face-lookup "DeepPink3" nil nil t)) - ((and mailp (eq level 2)) . - ,(custom-face-lookup "HotPink3" nil nil t)) - ((and mailp (eq level 3)) . - ,(custom-face-lookup "dark magenta" nil nil t)) - ((and mailp (eq level 4)) . - ,(custom-face-lookup "DeepPink4" nil nil t)) - ((and mailp (> level 4)) . - ,(custom-face-lookup "DarkOrchid4" nil nil t)) - )))) - (data - ((type . repeat) - (header . nil) - (data (type . pair) - (compact . t) - (data ((type . sexp) - (width . 60) - (tag . "Form")) - "\n " - ((type . face) - (tag . "Face")) - "\n"))))) +Using one of `Head', `Body', `All' will slow down scoring considerable. +") + (gnus-score-string :tag "Body" + :doc "\ +Match the body sans header of the article. + +Using one of `Head', `Body', `All' will slow down scoring considerable. +") + (gnus-score-string :tag "All" + :doc "\ +Match the entire article, including both headers and body. + +Using one of `Head', `Body', `All' will slow down scoring +considerable. +") + (gnus-score-string :tag + "Followup" + :doc "\ +Score all followups to the specified authors. + +This entry is somewhat special, in that it will match the `From:' +header, and affect the score of not only the matching articles, but +also all followups to the matching articles. This allows you +e.g. increase the score of followups to your own articles, or decrease +the score of followups to the articles of some known trouble-maker. +") + (gnus-score-string :tag "Thread" + :doc "\ +Add a score entry on all articles that are part of a thread. - ;; Do not define `gnus-button-alist' before we have - ;; some `complexity' attribute so we can hide it from - ;; beginners. - ))))) +This match key works along the same lines as the `Followup' match key. +If you say that you want to score on a (sub-)thread that is started by +an article with a `Message-ID' X, then you add a `thread' match. This +will add a new `thread' match for each article that has X in its +`References' header. (These new `thread' matches will use the +`Message-ID's of these matching articles.) This will ensure that you +can raise/lower the score of an entire thread, even though some +articles in the thread may not have complete `References' headers. +Note that using this may lead to undeterministic scores of the +articles in the thread. +") + ,@types) + '(repeat :inline t + :tag "Unknown entries" + sexp))) + (use-local-map widget-keymap) + (widget-setup))) -(defun gnus-custom-import-cite-face-list (custom alist) - ;; Backward compatible grokking of light and dark. - (cond ((eq alist 'light) - (setq alist (mapcar 'gnus-make-face gnus-face-light-name-list))) - ((eq alist 'dark) - (setq alist (mapcar 'gnus-make-face gnus-face-dark-name-list)))) - (funcall (custom-super custom 'import) custom alist)) +(defun gnus-score-customize-done (&rest ignore) + "Reset the score alist with the present value." + (let ((alist gnus-custom-score-alist) + (value (widget-value gnus-custom-scores))) + (setcar alist (car value)) + (setcdr alist (cdr value)) + (gnus-score-set 'touched '(t) alist)) + (bury-buffer)) +;;; The End: + (provide 'gnus-cus) ;;; gnus-cus.el ends here + diff -r ad457d5f7d04 -r 0293115a14e9 lisp/gnus/gnus-demon.el --- a/lisp/gnus/gnus-demon.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/gnus/gnus-demon.el Mon Aug 13 08:49:20 2007 +0200 @@ -1,5 +1,5 @@ ;;; gnus-demon.el --- daemonic Gnus behaviour -;; Copyright (C) 1995,96 Free Software Foundation, Inc. +;; Copyright (C) 1995,96,97 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; Keywords: news @@ -26,10 +26,18 @@ ;;; Code: (require 'gnus) +(require 'gnus-int) +(require 'nnheader) +(eval-and-compile + (if (string-match "XEmacs" (emacs-version)) + (require 'itimer) + (require 'timer))) -(eval-when-compile (require 'cl)) +(defgroup gnus-demon nil + "Demonic behaviour." + :group 'gnus) -(defvar gnus-demon-handlers nil +(defcustom gnus-demon-handlers nil "Alist of daemonic handlers to be run at intervals. Each handler is a list on the form @@ -42,10 +50,22 @@ is a number, only call when Emacs has been idle more than this number of `gnus-demon-timestep's. If IDLE is nil, don't care about idleness. If IDLE is a number and TIME is nil, then call once each -time Emacs has been idle for IDLE `gnus-demon-timestep's.") +time Emacs has been idle for IDLE `gnus-demon-timestep's." + :group 'gnus-demon + :type '(repeat (list function + (choice :tag "Time" + (const :tag "never" nil) + (const :tag "one" t) + (integer :tag "steps" 1)) + (choice :tag "Idle" + (const :tag "don't care" nil) + (const :tag "for a while" t) + (integer :tag "steps" 1))))) -(defvar gnus-demon-timestep 60 - "*Number of seconds in each demon timestep.") +(defcustom gnus-demon-timestep 60 + "*Number of seconds in each demon timestep." + :group 'gnus-demon + :type 'integer) ;;; Internal variables. @@ -53,8 +73,7 @@ (defvar gnus-demon-idle-has-been-called nil) (defvar gnus-demon-idle-time 0) (defvar gnus-demon-handler-state nil) -(defvar gnus-demon-is-idle nil) -(defvar gnus-demon-last-keys nil) +(defvar gnus-demon-last-keys nil) (eval-and-compile (autoload 'timezone-parse-date "timezone") @@ -75,14 +94,15 @@ (setq gnus-demon-handlers (delq (assq function gnus-demon-handlers) gnus-demon-handlers)) - (or no-init (gnus-demon-init))) + (unless no-init + (gnus-demon-init))) (defun gnus-demon-init () "Initialize the Gnus daemon." (interactive) (gnus-demon-cancel) (if (null gnus-demon-handlers) - () ; Nothing to do. + () ; Nothing to do. ;; Set up timer. (setq gnus-demon-timer (nnheader-run-at-time @@ -103,10 +123,13 @@ (defun gnus-demon-cancel () "Cancel any Gnus daemons." (interactive) - (and gnus-demon-timer - (nnheader-cancel-timer gnus-demon-timer)) + (when gnus-demon-timer + (nnheader-cancel-timer gnus-demon-timer)) (setq gnus-demon-timer nil - gnus-use-demon nil)) + gnus-use-demon nil) + (condition-case () + (nnheader-cancel-function-timers 'gnus-demon) + (error t))) (defun gnus-demon-is-idle-p () "Whether Emacs is idle or not." @@ -135,9 +158,11 @@ (nseconds (gnus-time-minus (gnus-encode-date tdate) (gnus-encode-date date)))) (round - (/ (if (< nseconds 0) - (+ nseconds (* 60 60 24)) - nseconds) gnus-demon-timestep))))) + (/ (+ (if (< (car nseconds) 0) + 86400 0) + (* 65536 (car nseconds)) + (nth 1 nseconds)) + gnus-demon-timestep))))) (defun gnus-demon () "The Gnus daemon that takes care of running all Gnus handlers." @@ -146,48 +171,54 @@ (incf gnus-demon-idle-time) (setq gnus-demon-idle-time 0) (setq gnus-demon-idle-has-been-called nil)) - ;; Then we go through all the handler and call those that are - ;; sufficiently ripe. - (let ((handlers gnus-demon-handler-state) - handler time idle) - (while handlers - (setq handler (pop handlers)) - (cond - ((numberp (setq time (nth 1 handler))) - ;; These handlers use a regular timeout mechanism. We decrease - ;; the timer if it hasn't reached zero yet. - (or (zerop time) + ;; Disable all daemonic stuff if we're in the minibuffer + (unless (window-minibuffer-p (selected-window)) + ;; Then we go through all the handler and call those that are + ;; sufficiently ripe. + (let ((handlers gnus-demon-handler-state) + handler time idle) + (while handlers + (setq handler (pop handlers)) + (cond + ((numberp (setq time (nth 1 handler))) + ;; These handlers use a regular timeout mechanism. We decrease + ;; the timer if it hasn't reached zero yet. + (unless (zerop time) (setcar (nthcdr 1 handler) (decf time))) - (and (zerop time) ; If the timer now is zero... - (or (not (setq idle (nth 2 handler))) ; Don't care about idle. - (and (numberp idle) ; Numerical idle... - (< idle gnus-demon-idle-time)) ; Idle timed out. - gnus-demon-is-idle) ; Or just need to be idle. - ;; So we call the handler. - (progn - (funcall (car handler)) - ;; And reset the timer. - (setcar (nthcdr 1 handler) - (gnus-demon-time-to-step - (nth 1 (assq (car handler) gnus-demon-handlers))))))) - ;; These are only supposed to be called when Emacs is idle. - ((null (setq idle (nth 2 handler))) - ;; We do nothing. - ) - ((not (numberp idle)) - ;; We want to call this handler each and every time that - ;; Emacs is idle. - (funcall (car handler))) - (t - ;; We want to call this handler only if Emacs has been idle - ;; for a specified number of timesteps. - (and (not (memq (car handler) gnus-demon-idle-has-been-called)) - (< idle gnus-demon-idle-time) - (progn - (funcall (car handler)) - ;; Make sure the handler won't be called once more in - ;; this idle-cycle. - (push (car handler) gnus-demon-idle-has-been-called)))))))) + (and (zerop time) ; If the timer now is zero... + ;; Test for appropriate idleness + (progn + (setq idle (nth 2 handler)) + (cond + ((null idle) t) ; Don't care about idle. + ((numberp idle) ; Numerical idle... + (< idle gnus-demon-idle-time)) ; Idle timed out. + (t (< 0 gnus-demon-idle-time)))) ; Or just need to be idle. + ;; So we call the handler. + (progn + (funcall (car handler)) + ;; And reset the timer. + (setcar (nthcdr 1 handler) + (gnus-demon-time-to-step + (nth 1 (assq (car handler) gnus-demon-handlers))))))) + ;; These are only supposed to be called when Emacs is idle. + ((null (setq idle (nth 2 handler))) + ;; We do nothing. + ) + ((not (numberp idle)) + ;; We want to call this handler each and every time that + ;; Emacs is idle. + (funcall (car handler))) + (t + ;; We want to call this handler only if Emacs has been idle + ;; for a specified number of timesteps. + (and (not (memq (car handler) gnus-demon-idle-has-been-called)) + (< idle gnus-demon-idle-time) + (progn + (funcall (car handler)) + ;; Make sure the handler won't be called once more in + ;; this idle-cycle. + (push (car handler) gnus-demon-idle-has-been-called))))))))) (defun gnus-demon-add-nocem () "Add daemonic NoCeM handling to Gnus." @@ -195,27 +226,60 @@ (defun gnus-demon-scan-nocem () "Scan NoCeM groups for NoCeM messages." - (gnus-nocem-scan-groups)) + (save-window-excursion + (gnus-nocem-scan-groups))) (defun gnus-demon-add-disconnection () "Add daemonic server disconnection to Gnus." (gnus-demon-add-handler 'gnus-demon-close-connections nil 30)) (defun gnus-demon-close-connections () - (gnus-close-backends)) + (save-window-excursion + (gnus-close-backends))) (defun gnus-demon-add-scanmail () "Add daemonic scanning of mail from the mail backends." (gnus-demon-add-handler 'gnus-demon-scan-mail 120 60)) (defun gnus-demon-scan-mail () - (let ((servers gnus-opened-servers) - server) - (while (setq server (car (pop servers))) - (and (gnus-check-backend-function 'request-scan (car server)) - (or (gnus-server-opened server) - (gnus-open-server server)) - (gnus-request-scan nil server))))) + (save-window-excursion + (let ((servers gnus-opened-servers) + server) + (while (setq server (car (pop servers))) + (and (gnus-check-backend-function 'request-scan (car server)) + (or (gnus-server-opened server) + (gnus-open-server server)) + (gnus-request-scan nil server)))))) + +(defun gnus-demon-add-rescan () + "Add daemonic scanning of new articles from all backends." + (gnus-demon-add-handler 'gnus-demon-scan-news 120 60)) + +(defun gnus-demon-scan-news () + (save-window-excursion + (when (gnus-alive-p) + (save-excursion + (set-buffer gnus-group-buffer) + (gnus-group-get-new-news))))) + +(defun gnus-demon-add-scan-timestamps () + "Add daemonic updating of timestamps in empty newgroups." + (gnus-demon-add-handler 'gnus-demon-scan-timestamps nil 30)) + +(defun gnus-demon-scan-timestamps () + "Set the timestamp on all newsgroups with no unread and no ticked articles." + (when (gnus-alive-p) + (let ((cur-time (current-time)) + (newsrc (cdr gnus-newsrc-alist)) + info group unread has-ticked) + (while (setq info (pop newsrc)) + (setq group (gnus-info-group info) + unread (gnus-group-unread group) + has-ticked (cdr (assq 'tick (gnus-info-marks info)))) + (when (and (numberp unread) + (= unread 0) + (not has-ticked)) + (gnus-group-set-parameter group 'timestamp cur-time)))))) (provide 'gnus-demon) diff -r ad457d5f7d04 -r 0293115a14e9 lisp/gnus/gnus-dup.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus/gnus-dup.el Mon Aug 13 08:49:20 2007 +0200 @@ -0,0 +1,157 @@ +;;; gnus-dup.el --- suppression of duplicate articles in Gnus +;; Copyright (C) 1996,97 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen +;; Keywords: news + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; This package tries to mark articles as read the second time the +;; user reads a copy. This is useful if the server doesn't support +;; Xref properly, or if the user reads the same group from several +;; servers. + +;;; Code: + +(require 'gnus) +(require 'gnus-art) + +(defgroup gnus-duplicate nil + "Suppression of duplicate articles." + :group 'gnus) + +(defcustom gnus-save-duplicate-list nil + "*If non-nil, save the duplicate list when shutting down Gnus. +If nil, duplicate suppression will only work on duplicates +seen in the same session." + :group 'gnus-duplicate + :type 'boolean) + +(defcustom gnus-duplicate-list-length 10000 + "*The number of Message-IDs to keep in the duplicate suppression list." + :group 'gnus-duplicate + :type 'integer) + +(defcustom gnus-duplicate-file (nnheader-concat gnus-directory "suppression") + "*The name of the file to store the duplicate suppression list." + :group 'gnus-duplicate + :type 'file) + +;;; Internal variables + +(defvar gnus-dup-list nil) +(defvar gnus-dup-hashtb nil) + +(defvar gnus-dup-list-dirty nil) + +;;; +;;; Starting and stopping +;;; + +(gnus-add-shutdown 'gnus-dup-close 'gnus) + +(defun gnus-dup-close () + "Possibly save the duplicate suppression list and shut down the subsystem." + (gnus-dup-save) + (setq gnus-dup-list nil + gnus-dup-hashtb nil + gnus-dup-list-dirty nil)) + +(defun gnus-dup-open () + "Possibly read the duplicate suppression list and start the subsystem." + (if gnus-save-duplicate-list + (gnus-dup-read) + (setq gnus-dup-list nil)) + (setq gnus-dup-hashtb (gnus-make-hashtable gnus-duplicate-list-length)) + ;; Enter all Message-IDs into the hash table. + (let ((list gnus-dup-list) + (obarray gnus-dup-hashtb)) + (while list + (intern (pop list))))) + +(defun gnus-dup-read () + "Read the duplicate suppression list." + (setq gnus-dup-list nil) + (when (file-exists-p gnus-duplicate-file) + (load gnus-duplicate-file t t t))) + +(defun gnus-dup-save () + "Save the duplicate suppression list." + (when (and gnus-save-duplicate-list + gnus-dup-list-dirty) + (nnheader-temp-write gnus-duplicate-file + (gnus-prin1 `(setq gnus-dup-list ',gnus-dup-list)))) + (setq gnus-dup-list-dirty nil)) + +;;; +;;; Interface functions +;;; + +(defun gnus-dup-enter-articles () + "Enter articles from the current group for future duplicate suppression." + (unless gnus-dup-list + (gnus-dup-open)) + (setq gnus-dup-list-dirty t) ; mark list for saving + (let ((data gnus-newsgroup-data) + datum msgid) + ;; Enter the Message-IDs of all read articles into the list + ;; and hash table. + (while (setq datum (pop data)) + (when (and (not (gnus-data-pseudo-p datum)) + (> (gnus-data-number datum) 0) + (gnus-data-read-p datum) + (setq msgid (mail-header-id (gnus-data-header datum))) + (not (nnheader-fake-message-id-p msgid)) + (not (intern-soft msgid gnus-dup-hashtb))) + (push msgid gnus-dup-list) + (intern msgid gnus-dup-hashtb)))) + ;; Chop off excess Message-IDs from the list. + (let ((end (nthcdr gnus-duplicate-list-length gnus-dup-list))) + (when end + (setcdr end nil)))) + +(defun gnus-dup-suppress-articles () + "Mark duplicate articles as read." + (unless gnus-dup-list + (gnus-dup-open)) + (gnus-message 6 "Suppressing duplicates...") + (let ((headers gnus-newsgroup-headers) + number header) + (while (setq header (pop headers)) + (when (and (intern-soft (mail-header-id header) gnus-dup-hashtb) + (gnus-summary-article-unread-p (mail-header-number header))) + (setq gnus-newsgroup-unreads + (delq (setq number (mail-header-number header)) + gnus-newsgroup-unreads)) + (push (cons number gnus-duplicate-mark) + gnus-newsgroup-reads)))) + (gnus-message 6 "Suppressing duplicates...done")) + +(defun gnus-dup-unsuppress-article (article) + "Stop suppression of ARTICLE." + (let ((id (mail-header-id (gnus-data-header (gnus-data-find article))))) + (when id + (setq gnus-dup-list-dirty t) + (setq gnus-dup-list (delete id gnus-dup-list)) + (unintern id gnus-dup-hashtb)))) + +(provide 'gnus-dup) + +;;; gnus-dup.el ends here diff -r ad457d5f7d04 -r 0293115a14e9 lisp/gnus/gnus-eform.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus/gnus-eform.el Mon Aug 13 08:49:20 2007 +0200 @@ -0,0 +1,130 @@ +;;; gnus-eform.el --- a mode for editing forms for Gnus +;; Copyright (C) 1996,97 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen +;; Keywords: news + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;;; Code: + +(require 'gnus) +(require 'gnus-win) + +;;; +;;; Editing forms +;;; + +(defgroup gnus-edit-form nil + "A mode for editing forms." + :group 'gnus) + +(defcustom gnus-edit-form-mode-hook nil + "Hook run in `gnus-edit-form-mode' buffers." + :group 'gnus-edit-form + :type 'hook) + +(defcustom gnus-edit-form-menu-hook nil + "Hook run when creating menus in `gnus-edit-form-mode' buffers." + :group 'gnus-edit-form + :type 'hook) + +;;; Internal variables + +(defvar gnus-edit-form-done-function nil) +(defvar gnus-edit-form-buffer "*Gnus edit form*") + +(defvar gnus-edit-form-mode-map nil) +(unless gnus-edit-form-mode-map + (setq gnus-edit-form-mode-map (copy-keymap emacs-lisp-mode-map)) + (gnus-define-keys gnus-edit-form-mode-map + "\C-c\C-c" gnus-edit-form-done + "\C-c\C-k" gnus-edit-form-exit)) + +(defun gnus-edit-form-make-menu-bar () + (unless (boundp 'gnus-edit-form-menu) + (easy-menu-define + gnus-edit-form-menu gnus-edit-form-mode-map "" + '("Edit Form" + ["Exit and save changes" gnus-edit-form-done t] + ["Exit" gnus-edit-form-exit t])) + (run-hooks 'gnus-edit-form-menu-hook))) + +(defun gnus-edit-form-mode () + "Major mode for editing forms. +It is a slightly enhanced emacs-lisp-mode. + +\\{gnus-edit-form-mode-map}" + (interactive) + (when (gnus-visual-p 'group-menu 'menu) + (gnus-edit-form-make-menu-bar)) + (kill-all-local-variables) + (setq major-mode 'gnus-edit-form-mode) + (setq mode-name "Edit Form") + (use-local-map gnus-edit-form-mode-map) + (make-local-variable 'gnus-edit-form-done-function) + (make-local-variable 'gnus-prev-winconf) + (run-hooks 'gnus-edit-form-mode-hook)) + +(defun gnus-edit-form (form documentation exit-func) + "Edit FORM in a new buffer. +Call EXIT-FUNC on exit. Display DOCUMENTATION in the beginning +of the buffer." + (let ((winconf (current-window-configuration))) + (set-buffer (get-buffer-create gnus-edit-form-buffer)) + (gnus-configure-windows 'edit-form) + (gnus-add-current-to-buffer-list) + (gnus-edit-form-mode) + (setq gnus-prev-winconf winconf) + (setq gnus-edit-form-done-function exit-func) + (erase-buffer) + (insert documentation) + (unless (bolp) + (insert "\n")) + (goto-char (point-min)) + (while (not (eobp)) + (insert ";;; ") + (forward-line 1)) + (insert ";; Type `C-c C-c' after you've finished editing.\n") + (insert "\n") + (let ((p (point))) + (pp form (current-buffer)) + (insert "\n") + (goto-char p)))) + +(defun gnus-edit-form-done () + "Update changes and kill the current buffer." + (interactive) + (goto-char (point-min)) + (let ((form (read (current-buffer))) + (func gnus-edit-form-done-function)) + (gnus-edit-form-exit) + (funcall func form))) + +(defun gnus-edit-form-exit () + "Kill the current buffer." + (interactive) + (let ((winconf gnus-prev-winconf)) + (kill-buffer (current-buffer)) + (set-window-configuration winconf))) + +(provide 'gnus-eform) + +;;; gnus-eform.el ends here diff -r ad457d5f7d04 -r 0293115a14e9 lisp/gnus/gnus-ems.el --- a/lisp/gnus/gnus-ems.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/gnus/gnus-ems.el Mon Aug 13 08:49:20 2007 +0200 @@ -1,5 +1,5 @@ ;;; gnus-ems.el --- functions for making Gnus work under different Emacsen -;; Copyright (C) 1995,96 Free Software Foundation, Inc. +;; Copyright (C) 1995,96,97 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; Keywords: news @@ -27,26 +27,13 @@ (eval-when-compile (require 'cl)) -(defvar gnus-mouse-2 [mouse-2]) +;;; Function aliases later to be redefined for XEmacs usage. -(defalias 'gnus-make-overlay 'make-overlay) -(defalias 'gnus-overlay-put 'overlay-put) -(defalias 'gnus-move-overlay 'move-overlay) -(defalias 'gnus-overlay-end 'overlay-end) -(defalias 'gnus-extent-detached-p 'ignore) -(defalias 'gnus-extent-start-open 'ignore) -(defalias 'gnus-set-text-properties 'set-text-properties) -(defalias 'gnus-group-remove-excess-properties 'ignore) -(defalias 'gnus-topic-remove-excess-properties 'ignore) -(defalias 'gnus-appt-select-lowest-window 'appt-select-lowest-window) -(defalias 'gnus-mail-strip-quoted-names 'mail-strip-quoted-names) -(defalias 'gnus-make-local-hook 'make-local-hook) -(defalias 'gnus-add-hook 'add-hook) -(defalias 'gnus-character-to-event 'identity) -(defalias 'gnus-add-text-properties 'add-text-properties) -(defalias 'gnus-put-text-property 'put-text-property) -(defalias 'gnus-mode-line-buffer-identification 'identity) +(defvar gnus-xemacs (string-match "XEmacs\\|Lucid" emacs-version) + "Non-nil if running under XEmacs.") +(defvar gnus-mouse-2 [mouse-2]) +(defvar gnus-down-mouse-2 [down-mouse-2]) (eval-and-compile (autoload 'gnus-xmas-define "gnus-xmas") @@ -60,20 +47,20 @@ (defun gnus-mule-cite-add-face (number prefix face) ;; At line NUMBER, ignore PREFIX and add FACE to the rest of the line. - (if face - (let ((inhibit-point-motion-hooks t) - from to) - (goto-line number) - (if (boundp 'MULE) - (forward-char (chars-in-string prefix)) - (forward-char (length prefix))) - (skip-chars-forward " \t") - (setq from (point)) - (end-of-line 1) - (skip-chars-backward " \t") - (setq to (point)) - (if (< from to) - (gnus-overlay-put (gnus-make-overlay from to) 'face face))))) + (when face + (let ((inhibit-point-motion-hooks t) + from to) + (goto-line number) + (if (boundp 'MULE) + (forward-char (chars-in-string prefix)) + (forward-char (length prefix))) + (skip-chars-forward " \t") + (setq from (point)) + (end-of-line 1) + (skip-chars-backward " \t") + (setq to (point)) + (when (< from to) + (gnus-overlay-put (gnus-make-overlay from to) 'face face))))) (defun gnus-mule-max-width-function (el max-width) (` (let* ((val (eval (, el))) @@ -84,8 +71,8 @@ valstr)))) (eval-and-compile - (if (string-match "XEmacs\\|Lucid" emacs-version) - () + (if gnus-xemacs + nil (defvar gnus-mouse-face-prop 'mouse-face "Property used for highlighting mouse regions.") @@ -94,50 +81,7 @@ "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | xv -quit -" "String or function to be executed to display an X-Face header. If it is a string, the command will be executed in a sub-shell -asynchronously. The compressed face will be piped to this command.") - - ;; Added by Per Abrahamsen . - (defvar gnus-display-type - (condition-case nil - (let ((display-resource (x-get-resource ".displayType" "DisplayType"))) - (cond (display-resource (intern (downcase display-resource))) - ((x-display-color-p) 'color) - ((x-display-grayscale-p) 'grayscale) - (t 'mono))) - (error 'mono)) - "A symbol indicating the display Emacs is running under. -The symbol should be one of `color', `grayscale' or `mono'. If Emacs -guesses this display attribute wrongly, either set this variable in -your `~/.emacs' or set the resource `Emacs.displayType' in your -`~/.Xdefaults'. See also `gnus-background-mode'. - -This is a meta-variable that will affect what default values other -variables get. You would normally not change this variable, but -pounce directly on the real variables themselves.") - - (defvar gnus-background-mode - (condition-case nil - (let ((bg-resource (x-get-resource ".backgroundMode" - "BackgroundMode")) - (params (frame-parameters))) - (cond (bg-resource (intern (downcase bg-resource))) - ((and (cdr (assq 'background-color params)) - (< (apply '+ (x-color-values - (cdr (assq 'background-color params)))) - (* (apply '+ (x-color-values "white")) .6))) - 'dark) - (t 'light))) - (error 'light)) - "A symbol indicating the Emacs background brightness. -The symbol should be one of `light' or `dark'. -If Emacs guesses this frame attribute wrongly, either set this variable in -your `~/.emacs' or set the resource `Emacs.backgroundMode' in your -`~/.Xdefaults'. -See also `gnus-display-type'. - -This is a meta-variable that will affect what default values other -variables get. You would normally not change this variable, but -pounce directly on the real variables themselves.")) +asynchronously. The compressed face will be piped to this command.")) (cond ((string-match "XEmacs\\|Lucid" emacs-version) @@ -146,14 +90,15 @@ ((or (not (boundp 'emacs-minor-version)) (< emacs-minor-version 30)) ;; Remove the `intangible' prop. - (let ((props (and (boundp 'gnus-hidden-properties) + (let ((props (and (boundp 'gnus-hidden-properties) gnus-hidden-properties))) (while (and props (not (eq (car (cdr props)) 'intangible))) (setq props (cdr props))) - (and props (setcdr props (cdr (cdr (cdr props)))))) - (or (fboundp 'buffer-substring-no-properties) - (defun buffer-substring-no-properties (beg end) - (format "%s" (buffer-substring beg end))))) + (when props + (setcdr props (cdr (cdr (cdr props)))))) + (unless (fboundp 'buffer-substring-no-properties) + (defun buffer-substring-no-properties (beg end) + (format "%s" (buffer-substring beg end))))) ((boundp 'MULE) (provide 'gnusutil)))) @@ -165,16 +110,16 @@ (let ((funcs '(mouse-set-point set-face-foreground set-face-background x-popup-menu))) (while funcs - (or (fboundp (car funcs)) - (fset (car funcs) 'gnus-dummy-func)) + (unless (fboundp (car funcs)) + (fset (car funcs) 'gnus-dummy-func)) (setq funcs (cdr funcs)))))) - (or (fboundp 'file-regular-p) - (defun file-regular-p (file) - (and (not (file-directory-p file)) - (not (file-symlink-p file)) - (file-exists-p file)))) - (or (fboundp 'face-list) - (defun face-list (&rest args)))) + (unless (fboundp 'file-regular-p) + (defun file-regular-p (file) + (and (not (file-directory-p file)) + (not (file-symlink-p file)) + (file-exists-p file)))) + (unless (fboundp 'face-list) + (defun face-list (&rest args)))) (eval-and-compile (let ((case-fold-search t)) @@ -200,18 +145,36 @@ ((string-match "XEmacs\\|Lucid" emacs-version) (gnus-xmas-redefine)) - ((boundp 'MULE) - ;; Mule definitions + ((featurep 'mule) + ;; Mule and new Emacs definitions + + ;; [Note] Now there are three kinds of mule implementations, + ;; original MULE, XEmacs/mule and beta version of Emacs including + ;; some mule features. Unfortunately these API are different. In + ;; particular, Emacs (including original MULE) and XEmacs are + ;; quite different. + ;; Predicates to check are following: + ;; (boundp 'MULE) is t only if MULE (original; anything older than + ;; Mule 2.3) is running. + ;; (featurep 'mule) is t when every mule variants are running. + + ;; These implementations may be able to share between original + ;; MULE and beta version of new Emacs. In addition, it is able to + ;; detect XEmacs/mule by (featurep 'mule) and to check variable + ;; `emacs-version'. In this case, implementation for XEmacs/mule + ;; may be able to share between XEmacs and XEmacs/mule. + (defalias 'gnus-truncate-string 'truncate-string) - (fset 'gnus-summary-make-display-table (lambda () nil)) + (defvar gnus-summary-display-table nil + "Display table used in summary mode buffers.") (fset 'gnus-cite-add-face 'gnus-mule-cite-add-face) (fset 'gnus-max-width-function 'gnus-mule-max-width-function) - (if (boundp 'gnus-check-before-posting) - (setq gnus-check-before-posting - (delq 'long-lines - (delq 'control-chars gnus-check-before-posting)))) + (when (boundp 'gnus-check-before-posting) + (setq gnus-check-before-posting + (delq 'long-lines + (delq 'control-chars gnus-check-before-posting)))) (defun gnus-summary-line-format-spec () (insert gnus-tmp-unread gnus-tmp-replied @@ -223,8 +186,8 @@ gnus-tmp-opening-bracket (format "%4d: %-20s" gnus-tmp-lines - (if (> (length gnus-tmp-name) 20) - (truncate-string gnus-tmp-name 20) + (if (> (length gnus-tmp-name) 20) + (truncate-string gnus-tmp-name 20) gnus-tmp-name)) gnus-tmp-closing-bracket) (point)) diff -r ad457d5f7d04 -r 0293115a14e9 lisp/gnus/gnus-gl.el --- a/lisp/gnus/gnus-gl.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/gnus/gnus-gl.el Mon Aug 13 08:49:20 2007 +0200 @@ -1,5 +1,5 @@ ;;; gnus-gl.el --- an interface to GroupLens for Gnus -;; Copyright (C) 1995,96 Free Software Foundation, Inc. +;; Copyright (C) 1995,96,97 Free Software Foundation, Inc. ;; Author: Brad Miller ;; Keywords: news, score @@ -69,7 +69,7 @@ ;; How do I Rate an article?? ;; Before you type n to go to the next article, hit a number from 1-5 ;; Type r in the summary buffer and you will be prompted. -;; Note that when you're in grouplens-minor-mode 'r' maskes the +;; Note that when you're in grouplens-minor-mode 'r' masks the ;; usual reply binding for 'r' ;; ;; What if, Gasp, I find a bug??? @@ -77,7 +77,7 @@ ;; mail buffer with the state of variables and buffers that will help ;; me debug the problem. A short description up front would help too! ;; -;; How do I display the prediction for an aritcle: +;; How do I display the prediction for an article: ;; If you set the gnus-summary-line-format as shown above, the score ;; (prediction) will be shown automatically. ;; @@ -121,6 +121,7 @@ (require 'gnus-score) (require 'cl) +(require 'gnus) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; User variables @@ -131,19 +132,25 @@ "*The line format spec in summary GroupLens mode buffers.") (defvar grouplens-pseudonym "" - "User's pseudonym. This pseudonym is obtained during the registration process") + "User's pseudonym. +This pseudonym is obtained during the registration process") (defvar grouplens-bbb-host "grouplens.cs.umn.edu" "Host where the bbbd is running" ) -(defvar grouplens-bbb-port 9000 +(defvar grouplens-bbb-port 9000 "Port where the bbbd is listening" ) (defvar grouplens-newsgroups - '("comp.lang.c++" "rec.humor" "rec.food.recipes" "comp.groupware" + '("comp.groupware" "comp.human-factors" "comp.lang.c++" + "comp.lang.java" "comp.os.linux.admin" "comp.os.linux.advocacy" + "comp.os.linux.announce" "comp.os.linux.answers" + "comp.os.linux.development" "comp.os.linux.development.apps" + "comp.os.linux.development.system" "comp.os.linux.hardware" + "comp.os.linux.help" "comp.os.linux.m68k" "comp.os.linux.misc" + "comp.os.linux.networking" "comp.os.linux.setup" "comp.os.linux.x" "mn.general" "rec.arts.movies" "rec.arts.movies.current-films" - "comp.lang.java" "comp.os.linux.announce" "comp.os.linux.misc" - "comp.os.linux.development.apps" "comp.os.linux.development.system") + "rec.food.recipes" "rec.humor") "*Groups that are part of the GroupLens experiment.") (defvar grouplens-prediction-display 'prediction-spot @@ -175,7 +182,7 @@ The scale factor is applied after the offset.") (defvar gnus-grouplens-override-scoring 'override - "Tell Grouplens to override the normal Gnus scoring mechanism. + "Tell GroupLens to override the normal Gnus scoring mechanism. GroupLens scores can be combined with gnus scores in one of three ways. 'override -- just use grouplens predictions for grouplens groups 'combine -- combine grouplens scores with gnus scores @@ -185,7 +192,7 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; Program global variables ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defvar grouplens-bbb-token "0" +(defvar grouplens-bbb-token nil "Current session token number") (defvar grouplens-bbb-process nil @@ -197,18 +204,12 @@ (defvar grouplens-rating-alist nil "Current set of message-id rating pairs") -(defvar grouplens-current-hashtable (make-hash-table :test 'equal :size 100)) -;; this seems like a pretty ugly way to get around the problem, but If -;; I don't do this, then the compiler complains when I call gethash -;; -(eval-when-compile (setq grouplens-current-hashtable - (make-hash-table :test 'equal :size 100))) +(defvar grouplens-current-hashtable nil + "A hashtable to hold predictions from the BBB") (defvar grouplens-current-group nil) -(defvar bbb-mid-list nil) - -(defvar bbb-alist nil) +;;(defvar bbb-alist nil) (defvar bbb-timeout-secs 10 "Number of seconds to wait for some response from the BBB. @@ -220,23 +221,38 @@ (defvar bbb-read-point) (defvar bbb-response-point) +(defun bbb-renew-hash-table () + (setq grouplens-current-hashtable (make-vector 100 0))) + +(bbb-renew-hash-table) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; Utility Functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (defun bbb-connect-to-bbbd (host port) - (unless grouplens-bbb-buffer - (setq grouplens-bbb-buffer + (unless grouplens-bbb-buffer + (setq grouplens-bbb-buffer (get-buffer-create (format " *BBBD trace: %s*" host))) (save-excursion (set-buffer grouplens-bbb-buffer) (make-local-variable 'bbb-read-point) + (make-local-variable 'bbb-response-point) (setq bbb-read-point (point-min)))) + + ;; if an old process is still running for some reason, kill it + (when grouplens-bbb-process + (ignore-errors + (when (eq 'open (process-status grouplens-bbb-process)) + (set-process-buffer grouplens-bbb-process nil) + (delete-process grouplens-bbb-process)))) + ;; clear the trace buffer of old output (save-excursion (set-buffer grouplens-bbb-buffer) (erase-buffer)) + ;; open the connection to the server - (setq grouplens-bbb-process nil) (catch 'done (condition-case error (setq grouplens-bbb-process @@ -245,34 +261,30 @@ nil)) (and (null grouplens-bbb-process) (throw 'done nil)) - ;; (set-process-filter grouplens-bbb-process 'bbb-process-filter) (save-excursion (set-buffer grouplens-bbb-buffer) (setq bbb-read-point (point-min)) (or (bbb-read-response grouplens-bbb-process) (throw 'done nil)))) + + ;; return the process grouplens-bbb-process) -;; (defun bbb-process-filter (process output) -;; (save-excursion -;; (set-buffer (bbb-process-buffer process)) -;; (goto-char (point-max)) -;; (insert output))) - (defun bbb-send-command (process command) (goto-char (point-max)) - (insert command) + (insert command) (insert "\r\n") (setq bbb-read-point (point)) (setq bbb-response-point (point)) (set-marker (process-mark process) (point)) ; process output also comes here (process-send-string process command) - (process-send-string process "\r\n")) + (process-send-string process "\r\n") + (process-send-eof process)) -(defun bbb-read-response (process) ; &optional return-response-string) +(defun bbb-read-response (process) "This function eats the initial response of OK or ERROR from the BBB." (let ((case-fold-search nil) - match-end) + match-end) (goto-char bbb-read-point) (while (and (not (search-forward "\r\n" nil t)) (accept-process-output process bbb-timeout-secs)) @@ -290,36 +302,36 @@ (interactive) (setq grouplens-bbb-token nil) (if (not (equal grouplens-pseudonym "")) - (let ((bbb-process + (let ((bbb-process (bbb-connect-to-bbbd grouplens-bbb-host grouplens-bbb-port))) (if bbb-process - (save-excursion + (save-excursion (set-buffer (process-buffer bbb-process)) - (bbb-send-command bbb-process + (bbb-send-command bbb-process (concat "login " grouplens-pseudonym)) (if (bbb-read-response bbb-process) (setq grouplens-bbb-token (bbb-extract-token-number)) - (gnus-message 3 "Error: Grouplens login failed"))))) + (gnus-message 3 "Error: GroupLens login failed"))))) (gnus-message 3 "Error: you must set a pseudonym")) grouplens-bbb-token) (defun bbb-extract-token-number () - (let ((token-pos (search-forward "token=" nil t) )) - (if (looking-at "[0-9]+") - (buffer-substring token-pos (match-end 0))))) + (let ((token-pos (search-forward "token=" nil t))) + (when (looking-at "[0-9]+") + (buffer-substring token-pos (match-end 0))))) (gnus-add-shutdown 'bbb-logout 'gnus) (defun bbb-logout () "logout of bbb session" - (let ((bbb-process - (bbb-connect-to-bbbd grouplens-bbb-host grouplens-bbb-port))) - (if bbb-process - (save-excursion + (when grouplens-bbb-token + (let ((bbb-process + (bbb-connect-to-bbbd grouplens-bbb-host grouplens-bbb-port))) + (when bbb-process + (save-excursion (set-buffer (process-buffer bbb-process)) (bbb-send-command bbb-process (concat "logout " grouplens-bbb-token)) - (bbb-read-response bbb-process)) - nil))) + (bbb-read-response bbb-process)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; Get Predictions @@ -327,126 +339,106 @@ (defun bbb-build-mid-scores-alist (groupname) "this function can be called as part of the function to return the -list of score files to use. See the gnus variable +list of score files to use. See the gnus variable gnus-score-find-score-files-function. -*Note:* If you want to use grouplens scores along with calculated scores, +*Note:* If you want to use grouplens scores along with calculated scores, you should see the offset and scale variables. At this point, I don't recommend using both scores and grouplens predictions together." (setq grouplens-current-group groupname) - (if (member groupname grouplens-newsgroups) - (let* ((mid-list (bbb-get-all-mids)) - (predict-list (bbb-get-predictions mid-list groupname))) - (setq grouplens-previous-article nil) - ;; scores-alist should be a list of lists: - ;; ((("message-id" ("" score1 nil s) (" score2 nil s)))) - ;;`((("message-id" . ,predict-list))) ; Yes, this is the return value - (list (list (list (append (list "message-id") predict-list))))) - nil)) + (when (member groupname grouplens-newsgroups) + (setq grouplens-previous-article nil) + ;; scores-alist should be a list of lists: + ;; ((("message-id" ("" score1 nil s) (" score2 nil s)))) + ;;`((("message-id" . ,predict-list))) ; Yes, this is the return value + (list + (list + (list (append (list "message-id") + (bbb-get-predictions (bbb-get-all-mids) groupname))))))) (defun bbb-get-predictions (midlist groupname) "Ask the bbb for predictions, and build up the score alist." - (if (or (null grouplens-bbb-token) - (equal grouplens-bbb-token "0")) - (progn - (gnus-message 3 "Error: You are not logged in to a BBB") - nil) - (gnus-message 5 "Fetching Predictions...") - (let (predict-list - (predict-command (bbb-build-predict-command midlist groupname - grouplens-bbb-token)) - (bbb-process (bbb-connect-to-bbbd grouplens-bbb-host - grouplens-bbb-port))) - (if bbb-process - (save-excursion + (gnus-message 5 "Fetching Predictions...") + (if grouplens-bbb-token + (let ((bbb-process (bbb-connect-to-bbbd grouplens-bbb-host + grouplens-bbb-port))) + (when bbb-process + (save-excursion (set-buffer (process-buffer bbb-process)) - (bbb-send-command bbb-process predict-command) + (bbb-send-command bbb-process + (bbb-build-predict-command midlist groupname + grouplens-bbb-token)) (if (bbb-read-response bbb-process) - (setq predict-list (bbb-get-prediction-response bbb-process)) + (bbb-get-prediction-response bbb-process) (gnus-message 1 "Invalid Token, login and try again") - (ding)))) - (setq bbb-alist predict-list)))) + (ding))))) + (gnus-message 3 "Error: You are not logged in to a BBB") + (ding))) (defun bbb-get-all-mids () - (let ((index (nth 1 (assoc "message-id" gnus-header-index))) - (articles gnus-newsgroup-headers) - art this) - (setq bbb-mid-list nil) - (while articles - (progn (setq art (car articles) - this (aref art index) - articles (cdr articles)) - (setq bbb-mid-list (cons this bbb-mid-list)))) - bbb-mid-list)) + (mapcar (function (lambda (x) (mail-header-id x))) gnus-newsgroup-headers)) (defun bbb-build-predict-command (mlist grpname token) - (let ((cmd (concat "getpredictions " token " " grpname "\r\n")) - art) - (while mlist - (setq art (car mlist) - cmd (concat cmd art "\r\n") - mlist (cdr mlist))) - (setq cmd (concat cmd ".\r\n")) - cmd)) + (concat "getpredictions " token " " grpname "\r\n" + (mapconcat 'identity mlist "\r\n") "\r\n.\r\n")) (defun bbb-get-prediction-response (process) - (let ((case-fold-search nil) - match-end) + (let ((case-fold-search nil)) (goto-char bbb-read-point) (while (and (not (search-forward ".\r\n" nil t)) (accept-process-output process bbb-timeout-secs)) (goto-char bbb-read-point)) - (setq match-end (point)) - (goto-char (+ bbb-response-point 4)) ;; we ought to be right before OK + (goto-char (+ bbb-response-point 4));; we ought to be right before OK (bbb-build-response-alist))) ;; build-response-alist assumes that the cursor has been positioned at -;; the first line of the list of mid/rating pairs. For now we will -;; use a prediction of 99 to signify no prediction. Ultimately, we -;; should just ignore messages with no predictions. +;; the first line of the list of mid/rating pairs. (defun bbb-build-response-alist () - (let ((resp nil) - (match-end (point))) - (setq grouplens-current-hashtable (make-hash-table :test 'equal :size 100)) + (let (resp mid pred) (while - (cond ((looking-at "\\(<.*>\\) :nopred=") - (push `(,(bbb-get-mid) ,gnus-summary-default-score nil s) resp) - (forward-line 1) - t) - ((looking-at "\\(<.*>\\) :pred=\\([0-9]\.[0-9][0-9]\\) :conflow=\\([0-9]\.[0-9][0-9]\\) :confhigh=\\([0-9]\.[0-9][0-9]\\)") - (push `(,(bbb-get-mid) ,(bbb-get-pred) nil s) resp) - (cl-puthash (bbb-get-mid) - (list (bbb-get-pred) (bbb-get-confl) (bbb-get-confh)) - grouplens-current-hashtable) - (forward-line 1) - t) - ((looking-at "\\(<.*>\\) :pred=\\([0-9]\.[0-9][0-9]\\)") - (push `(,(bbb-get-mid) ,(bbb-get-pred) nil s) resp) - (cl-puthash (bbb-get-mid) - (list (bbb-get-pred) 0 0) - grouplens-current-hashtable) - (forward-line 1) - t) - (t nil))) + (cond + ((looking-at "\\(<.*>\\) :nopred=") + ;;(push `(,(bbb-get-mid) ,gnus-summary-default-score nil s) resp) + (forward-line 1) + t) + ((looking-at "\\(<.*>\\) :pred=\\([0-9]\.[0-9][0-9]\\) :conflow=\\([0-9]\.[0-9][0-9]\\) :confhigh=\\([0-9]\.[0-9][0-9]\\)") + (setq mid (bbb-get-mid) + pred (bbb-get-pred)) + (push `(,mid ,pred nil s) resp) + (gnus-sethash mid (list pred (bbb-get-confl) (bbb-get-confh)) + grouplens-current-hashtable) + (forward-line 1) + t) + ((looking-at "\\(<.*>\\) :pred=\\([0-9]\.[0-9][0-9]\\)") + (setq mid (bbb-get-mid) + pred (bbb-get-pred)) + (push `(,mid ,pred nil s) resp) + (gnus-sethash mid (list pred 0 0) grouplens-current-hashtable) + (forward-line 1) + t) + (t nil))) resp)) -;; these two functions assume that there is an active match lying +;; these "get" functions assume that there is an active match lying ;; around. Where the first parenthesized expression is the -;; message-id, and the second is the prediction. Since gnus assumes -;; that scores are integer values?? we round the prediction. +;; message-id, and the second is the prediction, the third and fourth +;; are the confidence interval +;; +;; Since gnus assumes that scores are integer values?? we round the +;; prediction. (defun bbb-get-mid () (buffer-substring (match-beginning 1) (match-end 1))) (defun bbb-get-pred () - (let ((tpred (string-to-number (buffer-substring - (match-beginning 2) - (match-end 2))))) + (let ((tpred (string-to-number (buffer-substring (match-beginning 2) + (match-end 2))))) (if (> tpred 0) - (round (* grouplens-score-scale-factor (+ grouplens-score-offset tpred))) + (round (* grouplens-score-scale-factor + (+ grouplens-score-offset tpred))) 1))) (defun bbb-get-confl () - (string-to-number (buffer-substring (match-beginning 3) (match-end 3)))) + (string-to-number (buffer-substring (match-beginning 4) (match-end 4)))) (defun bbb-get-confh () (string-to-number (buffer-substring (match-beginning 4) (match-end 4)))) @@ -463,13 +455,13 @@ (defun bbb-grouplens-score (header) (if (eq gnus-grouplens-override-scoring 'separate) (bbb-grouplens-other-score header) - (let* ((rate-string (make-string 12 ? )) - (mid (aref header (nth 1 (assoc "message-id" gnus-header-index)))) - (hashent (gethash mid grouplens-current-hashtable)) + (let* ((rate-string (make-string 12 ?\ )) + (mid (mail-header-id header)) + (hashent (gnus-gethash mid grouplens-current-hashtable)) (iscore gnus-tmp-score) (low (car (cdr hashent))) (high (car (cdr (cdr hashent))))) - (aset rate-string 0 ?|) + (aset rate-string 0 ?|) (aset rate-string 11 ?|) (unless (member grouplens-current-group grouplens-newsgroups) (unless (equal grouplens-prediction-display 'prediction-num) @@ -477,9 +469,9 @@ (setq iscore 1)) ((> iscore 5) (setq iscore 5)))) - (setq low 0) + (setq low 0) (setq high 0)) - (if (and (bbb-valid-score iscore) + (if (and (bbb-valid-score iscore) (not (null mid))) (cond ;; prediction-spot @@ -508,7 +500,6 @@ (aset rate-string 5 ?N) (aset rate-string 6 ?A)) rate-string))) -;; ;; Gnus user format function that doesn't depend on ;; bbb-build-mid-scores-alist being used as the score function, but is ;; instead called from gnus-select-group-hook. -- LAB @@ -516,14 +507,14 @@ (if (not (member grouplens-current-group grouplens-newsgroups)) ;; Return an empty string "" - (let* ((rate-string (make-string 12 ? )) - (mid (aref header (nth 1 (assoc "message-id" gnus-header-index)))) - (hashent (gethash mid grouplens-current-hashtable)) + (let* ((rate-string (make-string 12 ?\ )) + (mid (mail-header-id header)) + (hashent (gnus-gethash mid grouplens-current-hashtable)) (pred (or (nth 0 hashent) 0)) (low (nth 1 hashent)) (high (nth 2 hashent))) ;; Init rate-string - (aset rate-string 0 ?|) + (aset rate-string 0 ?|) (aset rate-string 11 ?|) (unless (equal grouplens-prediction-display 'prediction-num) (cond ((< pred 0) @@ -532,8 +523,8 @@ (setq pred 5)))) ;; If no entry in BBB hash mark rate string as NA and return (cond - ((null hashent) - (aset rate-string 5 ?N) + ((null hashent) + (aset rate-string 5 ?N) (aset rate-string 6 ?A) rate-string) @@ -560,7 +551,7 @@ (t (gnus-message 3 "Invalid prediction display type") - (aset rate-string 0 ?|) + (aset rate-string 0 ?|) (aset rate-string 11 ?|) rate-string))))) @@ -596,14 +587,14 @@ (bbb-fmt-prediction-num score))) (defun bbb-fmt-prediction-bar (rate-string score) - (let* ((i 1) + (let* ((i 1) (step (/ grplens-rating-range (- grplens-predstringsize 4))) (half-step (/ step 2)) (loc (- grplens-minrating half-step))) (while (< i (- grplens-predstringsize 2)) (if (> score loc) (aset rate-string i ?#) - (aset rate-string i ? )) + (aset rate-string i ?\ )) (setq i (+ i 1)) (setq loc (+ loc step))) ) @@ -616,14 +607,12 @@ ;;;; Put Ratings ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; The message-id for the current article can be found in -;; (aref gnus-current-headers (nth 1 (assoc "message-id" gnus-header-index))) - (defun bbb-put-ratings () - (if (and grouplens-rating-alist + (if (and grouplens-bbb-token + grouplens-rating-alist (member gnus-newsgroup-name grouplens-newsgroups)) (let ((bbb-process (bbb-connect-to-bbbd grouplens-bbb-host - grouplens-bbb-port)) + grouplens-bbb-port)) (rate-command (bbb-build-rate-command grouplens-rating-alist))) (if bbb-process (save-excursion @@ -640,15 +629,13 @@ (setq grouplens-rating-alist nil))) (defun bbb-build-rate-command (rate-alist) - (let (this - (cmd (concat "putratings " grouplens-bbb-token - " " grouplens-current-group " \r\n"))) - (while rate-alist - (setq this (car rate-alist) - cmd (concat cmd (car this) " :rating=" (cadr this) ".00" - " :time=" (cddr this) "\r\n") - rate-alist (cdr rate-alist))) - (concat cmd ".\r\n"))) + (concat "putratings " grouplens-bbb-token " " grouplens-current-group " \r\n" + (mapconcat '(lambda (this) ; form (mid . (score . time)) + (concat (car this) + " :rating=" (cadr this) ".00" + " :time=" (cddr this))) + rate-alist "\r\n") + "\r\n.\r\n")) ;; Interactive rating functions. (defun bbb-summary-rate-article (rating &optional midin) @@ -656,53 +643,54 @@ (when (member gnus-newsgroup-name grouplens-newsgroups) (let ((mid (or midin (bbb-get-current-id)))) (if (and rating - (>= rating grplens-minrating) + (>= rating grplens-minrating) (<= rating grplens-maxrating) mid) (let ((oldrating (assoc mid grouplens-rating-alist))) (if oldrating (setcdr oldrating (cons rating 0)) (push `(,mid . (,rating . 0)) grouplens-rating-alist)) - (gnus-summary-mark-article nil (int-to-string rating))) + (gnus-summary-mark-article nil (int-to-string rating))) (gnus-message 3 "Invalid rating"))))) (defun grouplens-next-unread-article (rating) "Select unread article after current one." (interactive "P") - (if rating (bbb-summary-rate-article rating)) + (when rating + (bbb-summary-rate-article rating)) (gnus-summary-next-unread-article)) (defun grouplens-best-unread-article (rating) "Select unread article after current one." (interactive "P") - (if rating (bbb-summary-rate-article rating)) + (when rating + (bbb-summary-rate-article rating)) (gnus-summary-best-unread-article)) (defun grouplens-summary-catchup-and-exit (rating) - "Mark all articles not marked as unread in this newsgroup as read, + "Mark all articles not marked as unread in this newsgroup as read, then exit. If prefix argument ALL is non-nil, all articles are marked as read." - (interactive "P") - (if rating - (bbb-summary-rate-article rating)) - (if (numberp rating) - (gnus-summary-catchup-and-exit) - (gnus-summary-catchup-and-exit rating))) + (interactive "P") + (when rating + (bbb-summary-rate-article rating)) + (if (numberp rating) + (gnus-summary-catchup-and-exit) + (gnus-summary-catchup-and-exit rating))) (defun grouplens-score-thread (score) "Raise the score of the articles in the current thread with SCORE." (interactive "nRating: ") (let (e) (save-excursion - (let ((articles (gnus-summary-articles-in-thread))) - (while articles - (gnus-summary-goto-subject (car articles)) + (let ((articles (gnus-summary-articles-in-thread)) + article) + (while (setq article (pop articles)) + (gnus-summary-goto-subject article) (gnus-set-global-variables) (bbb-summary-rate-article score (mail-header-id - (gnus-summary-article-header - (car articles)))) - (setq articles (cdr articles)))) + (gnus-summary-article-header article))))) (setq e (point))) (let ((gnus-summary-check-current t)) (or (zerop (gnus-summary-next-subject 1 t)) @@ -711,11 +699,13 @@ (gnus-summary-position-point) (gnus-set-mode-line 'summary)) +(defun bbb-exit-group () + (bbb-put-ratings) + (bbb-renew-hash-table)) (defun bbb-get-current-id () (if gnus-current-headers - (aref gnus-current-headers - (nth 1 (assoc "message-id" gnus-header-index))) + (mail-header-id gnus-current-headers) (gnus-message 3 "You must select an article before you rate it"))) (defun bbb-grouplens-group-p (group) @@ -735,8 +725,8 @@ (- et (bbb-time-float grouplens-current-starting-time)))) (defun bbb-time-float (timeval) - (+ (* (car timeval) 65536) - (cadr timeval))) + (+ (* (car timeval) 65536) + (cadr timeval))) (defun grouplens-do-time () (when (member gnus-newsgroup-name grouplens-newsgroups) @@ -755,7 +745,7 @@ ;; BUG REPORTING ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defconst gnus-gl-version "gnus-gl.el 2.12") +(defconst gnus-gl-version "gnus-gl.el 2.50") (defconst gnus-gl-maintainer-address "grouplens-bug@cs.umn.edu") (defun gnus-gl-submit-bug-report () "Submit via mail a bug report on gnus-gl" @@ -770,22 +760,19 @@ 'grouplens-bbb-token 'grouplens-bbb-process 'grouplens-current-group - 'grouplens-previous-article - 'grouplens-mid-list - 'bbb-alist) + 'grouplens-previous-article) nil 'gnus-gl-get-trace)) (defun gnus-gl-get-trace () "Insert the contents of the BBBD trace buffer" - (if grouplens-bbb-buffer (insert-buffer grouplens-bbb-buffer))) + (when grouplens-bbb-buffer + (insert-buffer grouplens-bbb-buffer))) -;;; -;;; Additions to make gnus-grouplens-mode Warning Warning!! -;;; This version of the gnus-grouplens-mode does -;;; not work with gnus-5.x. The "old" way of -;;; setting up GroupLens still works however. -;;; +;; +;; GroupLens minor mode +;; + (defvar gnus-grouplens-mode nil "Minor mode for providing a GroupLens interface in Gnus summary buffers.") @@ -823,38 +810,41 @@ (if (null arg) (not gnus-grouplens-mode) (> (prefix-numeric-value arg) 0))) (when gnus-grouplens-mode - (if (not (fboundp 'make-local-hook)) - (add-hook 'gnus-select-article-hook 'grouplens-do-time) - (make-local-hook 'gnus-select-article-hook) - (add-hook 'gnus-select-article-hook 'grouplens-do-time nil 'local)) - (if (not (fboundp 'make-local-hook)) - (add-hook 'gnus-exit-group-hook 'bbb-put-ratings) - (make-local-hook 'gnus-exit-group-hook) - (add-hook 'gnus-exit-group-hook 'bbb-put-ratings nil 'local)) + (gnus-make-local-hook 'gnus-select-article-hook) + (gnus-add-hook 'gnus-select-article-hook 'grouplens-do-time nil 'local) + (gnus-make-local-hook 'gnus-exit-group-hook) + (gnus-add-hook 'gnus-exit-group-hook 'bbb-exit-group nil 'local) (make-local-variable 'gnus-score-find-score-files-function) - (cond ((eq gnus-grouplens-override-scoring 'combine) - ;; either add bbb-buld-mid-scores-alist to a list - ;; or make a list - (if (listp gnus-score-find-score-files-function) - (setq gnus-score-find-score-files-function - (append 'bbb-build-mid-scores-alist - gnus-score-find-score-files-function )) - (setq gnus-score-find-score-files-function - (list gnus-score-find-score-files-function - 'bbb-build-mid-scores-alist)))) - ;; leave the gnus-score-find-score-files variable alone - ((eq gnus-grouplens-override-scoring 'separate) - (add-hook 'gnus-select-group-hook - '(lambda() - (bbb-build-mid-scores-alist gnus-newsgroup-name)))) - ;; default is to override - (t (setq gnus-score-find-score-files-function - 'bbb-build-mid-scores-alist))) + + (cond + ((eq gnus-grouplens-override-scoring 'combine) + ;; either add bbb-buld-mid-scores-alist to a list + ;; or make a list + (if (listp gnus-score-find-score-files-function) + (setq gnus-score-find-score-files-function + (append 'bbb-build-mid-scores-alist + gnus-score-find-score-files-function)) + (setq gnus-score-find-score-files-function + (list gnus-score-find-score-files-function + 'bbb-build-mid-scores-alist)))) + ;; leave the gnus-score-find-score-files variable alone + ((eq gnus-grouplens-override-scoring 'separate) + (add-hook 'gnus-select-group-hook + (lambda () + (bbb-get-predictions (bbb-get-all-mids) + gnus-newsgroup-name)))) + ;; default is to override + (t + (setq gnus-score-find-score-files-function + 'bbb-build-mid-scores-alist))) + + ;; Change how summary lines look (make-local-variable 'gnus-summary-line-format) - (setq gnus-summary-line-format - gnus-summary-grouplens-line-format) (make-local-variable 'gnus-summary-line-format-spec) + (setq gnus-summary-line-format gnus-summary-grouplens-line-format) (setq gnus-summary-line-format-spec nil) + (gnus-update-format-specifications nil 'summary) + (gnus-update-summary-mark-positions) ;; Set up the menu. (when (and menu-bar-mode diff -r ad457d5f7d04 -r 0293115a14e9 lisp/gnus/gnus-group.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus/gnus-group.el Mon Aug 13 08:49:20 2007 +0200 @@ -0,0 +1,3308 @@ +;;; gnus-group.el --- group mode commands for Gnus +;; Copyright (C) 1996,97 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen +;; Keywords: news + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;;; Code: + +(require 'gnus) +(require 'gnus-start) +(require 'nnmail) +(require 'gnus-spec) +(require 'gnus-int) +(require 'gnus-range) +(require 'gnus-win) +(require 'gnus-undo) + +(defcustom gnus-group-archive-directory + "/ftp@ftp.hpc.uh.edu:/pub/emacs/ding-list/" + "*The address of the (ding) archives." + :group 'gnus-group-foreign + :type 'directory) + +(defcustom gnus-group-recent-archive-directory + "/ftp@ftp.hpc.uh.edu:/pub/emacs/ding-list-recent/" + "*The address of the most recent (ding) articles." + :group 'gnus-group-foreign + :type 'directory) + +(defcustom gnus-no-groups-message "No news is no news" + "*Message displayed by Gnus when no groups are available." + :group 'gnus-start + :type 'string) + +(defcustom gnus-keep-same-level nil + "*Non-nil means that the next newsgroup after the current will be on the same level. +When you type, for instance, `n' after reading the last article in the +current newsgroup, you will go to the next newsgroup. If this variable +is nil, the next newsgroup will be the next from the group +buffer. +If this variable is non-nil, Gnus will either put you in the +next newsgroup with the same level, or, if no such newsgroup is +available, the next newsgroup with the lowest possible level higher +than the current level. +If this variable is `best', Gnus will make the next newsgroup the one +with the best level." + :group 'gnus-group-levels + :type '(choice (const nil) + (const best) + (sexp :tag "other" t))) + +(defcustom gnus-group-goto-unread t + "*If non-nil, movement commands will go to the next unread and subscribed group." + :link '(custom-manual "(gnus)Group Maneuvering") + :group 'gnus-group-various + :type 'boolean) + +(defcustom gnus-goto-next-group-when-activating t + "*If non-nil, the \\\\[gnus-group-get-new-news-this-group] command will advance point to the next group." + :link '(custom-manual "(gnus)Scanning New Messages") + :group 'gnus-group-various + :type 'boolean) + +(defcustom gnus-permanently-visible-groups nil + "*Regexp to match groups that should always be listed in the group buffer. +This means that they will still be listed when there are no unread +articles in the groups." + :group 'gnus-group-listing + :type 'regexp) + +(defcustom gnus-list-groups-with-ticked-articles t + "*If non-nil, list groups that have only ticked articles. +If nil, only list groups that have unread articles." + :group 'gnus-group-listing + :type 'boolean) + +(defcustom gnus-group-default-list-level gnus-level-subscribed + "*Default listing level. +Ignored if `gnus-group-use-permanent-levels' is non-nil." + :group 'gnus-group-listing + :type 'integer) + +(defcustom gnus-group-list-inactive-groups t + "*If non-nil, inactive groups will be listed." + :group 'gnus-group-listing + :group 'gnus-group-levels + :type 'boolean) + +(defcustom gnus-group-sort-function 'gnus-group-sort-by-alphabet + "*Function used for sorting the group buffer. +This function will be called with group info entries as the arguments +for the groups to be sorted. Pre-made functions include +`gnus-group-sort-by-alphabet', `gnus-group-sort-by-real-name', +`gnus-group-sort-by-unread', `gnus-group-sort-by-level', +`gnus-group-sort-by-score', `gnus-group-sort-by-method', and +`gnus-group-sort-by-rank'. + +This variable can also be a list of sorting functions. In that case, +the most significant sort function should be the last function in the +list." + :group 'gnus-group-listing + :link '(custom-manual "(gnus)Sorting Groups") + :type '(radio (function-item gnus-group-sort-by-alphabet) + (function-item gnus-group-sort-by-real-name) + (function-item gnus-group-sort-by-unread) + (function-item gnus-group-sort-by-level) + (function-item gnus-group-sort-by-score) + (function-item gnus-group-sort-by-method) + (function-item gnus-group-sort-by-rank) + (function :tag "other" nil))) + +(defcustom gnus-group-line-format "%M\%S\%p\%P\%5y: %(%g%)%l\n" + "*Format of group lines. +It works along the same lines as a normal formatting string, +with some simple extensions. + +%M Only marked articles (character, \"*\" or \" \") +%S Whether the group is subscribed (character, \"U\", \"K\", \"Z\" or \" \") +%L Level of subscribedness (integer) +%N Number of unread articles (integer) +%I Number of dormant articles (integer) +%i Number of ticked and dormant (integer) +%T Number of ticked articles (integer) +%R Number of read articles (integer) +%t Estimated total number of articles (integer) +%y Number of unread, unticked articles (integer) +%G Group name (string) +%g Qualified group name (string) +%D Group description (string) +%s Select method (string) +%o Moderated group (char, \"m\") +%p Process mark (char) +%O Moderated group (string, \"(m)\" or \"\") +%P Topic indentation (string) +%m Whether there is new(ish) mail in the group (char, \"%\") +%l Whether there are GroupLens predictions for this group (string) +%n Select from where (string) +%z A string that look like `<%s:%n>' if a foreign select method is used +?d The date the group was last entered. +%u User defined specifier. The next character in the format string should + be a letter. Gnus will call the function gnus-user-format-function-X, + where X is the letter following %u. The function will be passed the + current header as argument. The function should return a string, which + will be inserted into the buffer just like information from any other + group specifier. + +Text between %( and %) will be highlighted with `gnus-mouse-face' when +the mouse point move inside the area. There can only be one such area. + +Note that this format specification is not always respected. For +reasons of efficiency, when listing killed groups, this specification +is ignored altogether. If the spec is changed considerably, your +output may end up looking strange when listing both alive and killed +groups. + +If you use %o or %O, reading the active file will be slower and quite +a bit of extra memory will be used. %D will also worsen performance. +Also note that if you change the format specification to include any +of these specs, you must probably re-start Gnus to see them go into +effect." + :group 'gnus-group-visual + :type 'string) + +(defcustom gnus-group-mode-line-format "Gnus: %%b {%M\%:%S}" + "*The format specification for the group mode line. +It works along the same lines as a normal formatting string, +with some simple extensions: + +%S The native news server. +%M The native select method. +%: \":\" if %S isn't \"\"." + :group 'gnus-group-visual + :type 'string) + +(defcustom gnus-group-mode-hook nil + "Hook for Gnus group mode." + :group 'gnus-group-various + :options '(gnus-topic-mode) + :type 'hook) + +(defcustom gnus-group-menu-hook nil + "Hook run after the creation of the group mode menu." + :group 'gnus-group-various + :type 'hook) + +(defcustom gnus-group-catchup-group-hook nil + "Hook run when catching up a group from the group buffer." + :group 'gnus-group-various + :link '(custom-manual "(gnus)Group Data") + :type 'hook) + +(defcustom gnus-group-update-group-hook nil + "Hook called when updating group lines." + :group 'gnus-group-visual + :type 'hook) + +(defcustom gnus-group-prepare-function 'gnus-group-prepare-flat + "*A function that is called to generate the group buffer. +The function is called with three arguments: The first is a number; +all group with a level less or equal to that number should be listed, +if the second is non-nil, empty groups should also be displayed. If +the third is non-nil, it is a number. No groups with a level lower +than this number should be displayed. + +The only current function implemented is `gnus-group-prepare-flat'." + :group 'gnus-group-listing + :type 'function) + +(defcustom gnus-group-prepare-hook nil + "Hook called after the group buffer has been generated. +If you want to modify the group buffer, you can use this hook." + :group 'gnus-group-listing + :type 'hook) + +(defcustom gnus-suspend-gnus-hook nil + "Hook called when suspending (not exiting) Gnus." + :group 'gnus-exit + :type 'hook) + +(defcustom gnus-exit-gnus-hook nil + "Hook called when exiting Gnus." + :group 'gnus-exit + :type 'hook) + +(defcustom gnus-after-exiting-gnus-hook nil + "Hook called after exiting Gnus." + :group 'gnus-exit + :type 'hook) + +(defcustom gnus-group-update-hook '(gnus-group-highlight-line) + "Hook called when a group line is changed. +The hook will not be called if `gnus-visual' is nil. + +The default function `gnus-group-highlight-line' will +highlight the line according to the `gnus-group-highlight' +variable." + :group 'gnus-group-visual + :type 'hook) + +(defcustom gnus-useful-groups + `(("(ding) mailing list mirrored at sunsite.auc.dk" + "emacs.ding" + (nntp "sunsite.auc.dk" + (nntp-address "sunsite.auc.dk"))) + ("Gnus help group" + "gnus-help" + (nndoc "gnus-help" + (nndoc-article-type mbox) + (eval `(nndoc-address + ,(let ((file (nnheader-find-etc-directory + "gnus-tut.txt" t))) + (unless file + (error "Couldn't find doc group")) + file)))))) + "Alist of useful group-server pairs." + :group 'gnus-group-listing + :type '(repeat (list (string :tag "Description") + (string :tag "Name") + (sexp :tag "Method")))) + +(defcustom gnus-group-highlight + '(;; News. + ((and (= unread 0) (not mailp) (eq level 1)) . + gnus-group-news-1-empty-face) + ((and (not mailp) (eq level 1)) . + gnus-group-news-1-face) + ((and (= unread 0) (not mailp) (eq level 2)) . + gnus-group-news-2-empty-face) + ((and (not mailp) (eq level 2)) . + gnus-group-news-2-face) + ((and (= unread 0) (not mailp) (eq level 3)) . + gnus-group-news-3-empty-face) + ((and (not mailp) (eq level 3)) . + gnus-group-news-3-face) + ((and (= unread 0) (not mailp)) . + gnus-group-news-low-empty-face) + ((and (not mailp)) . + gnus-group-news-low-face) + ;; Mail. + ((and (= unread 0) (eq level 1)) . + gnus-group-mail-1-empty-face) + ((eq level 1) . + gnus-group-mail-1-face) + ((and (= unread 0) (eq level 2)) . + gnus-group-mail-2-empty-face) + ((eq level 2) . + gnus-group-mail-2-face) + ((and (= unread 0) (eq level 3)) . + gnus-group-mail-3-empty-face) + ((eq level 3) . + gnus-group-mail-3-face) + ((= unread 0) . + gnus-group-mail-low-empty-face) + (t . + gnus-group-mail-low-face)) + "Controls the highlighting of group buffer lines. + +Below is a list of `Form'/`Face' pairs. When deciding how a a +particular group line should be displayed, each form is +evaluated. The content of the face field after the first true form is +used. You can change how those group lines are displayed by +editing the face field. + +It is also possible to change and add form fields, but currently that +requires an understanding of Lisp expressions. Hopefully this will +change in a future release. For now, you can use the following +variables in the Lisp expression: + +group: The name of the group. +unread: The number of unread articles in the group. +method: The select method used. +mailp: Whether it's a mail group or not. +level: The level of the group. +score: The score of the group. +ticked: The number of ticked articles." + :group 'gnus-group-visual + :type '(repeat (cons (sexp :tag "Form") face))) + +(defcustom gnus-new-mail-mark ?% + "Mark used for groups with new mail." + :group 'gnus-group-visual + :type 'character) + +;;; Internal variables + +(defvar gnus-group-sort-alist-function 'gnus-group-sort-flat + "Function for sorting the group buffer.") + +(defvar gnus-group-sort-selected-function 'gnus-group-sort-selected-flat + "Function for sorting the selected groups in the group buffer.") + +(defvar gnus-group-indentation-function nil) +(defvar gnus-goto-missing-group-function nil) +(defvar gnus-group-update-group-function nil) +(defvar gnus-group-goto-next-group-function nil + "Function to override finding the next group after listing groups.") + +(defvar gnus-group-edit-buffer nil) + +(defvar gnus-group-line-format-alist + `((?M gnus-tmp-marked-mark ?c) + (?S gnus-tmp-subscribed ?c) + (?L gnus-tmp-level ?d) + (?N (cond ((eq number t) "*" ) + ((numberp number) + (int-to-string + (+ number + (gnus-range-length (cdr (assq 'dormant gnus-tmp-marked))) + (gnus-range-length (cdr (assq 'tick gnus-tmp-marked)))))) + (t number)) ?s) + (?R gnus-tmp-number-of-read ?s) + (?t gnus-tmp-number-total ?d) + (?y gnus-tmp-number-of-unread ?s) + (?I (gnus-range-length (cdr (assq 'dormant gnus-tmp-marked))) ?d) + (?T (gnus-range-length (cdr (assq 'tick gnus-tmp-marked))) ?d) + (?i (+ (gnus-range-length (cdr (assq 'dormant gnus-tmp-marked))) + (gnus-range-length (cdr (assq 'tick gnus-tmp-marked)))) ?d) + (?g gnus-tmp-group ?s) + (?G gnus-tmp-qualified-group ?s) + (?c (gnus-short-group-name gnus-tmp-group) ?s) + (?D gnus-tmp-newsgroup-description ?s) + (?o gnus-tmp-moderated ?c) + (?O gnus-tmp-moderated-string ?s) + (?p gnus-tmp-process-marked ?c) + (?s gnus-tmp-news-server ?s) + (?n gnus-tmp-news-method ?s) + (?P gnus-group-indentation ?s) + (?l gnus-tmp-grouplens ?s) + (?z gnus-tmp-news-method-string ?s) + (?m (gnus-group-new-mail gnus-tmp-group) ?c) + (?d (gnus-group-timestamp-string gnus-tmp-group) ?s) + (?u gnus-tmp-user-defined ?s))) + +(defvar gnus-group-mode-line-format-alist + `((?S gnus-tmp-news-server ?s) + (?M gnus-tmp-news-method ?s) + (?u gnus-tmp-user-defined ?s) + (?: gnus-tmp-colon ?s))) + +(defvar gnus-topic-topology nil + "The complete topic hierarchy.") + +(defvar gnus-topic-alist nil + "The complete topic-group alist.") + +(defvar gnus-group-marked nil) + +(defvar gnus-group-list-mode nil) + +;;; +;;; Gnus group mode +;;; + +(put 'gnus-group-mode 'mode-class 'special) + +(when t + (gnus-define-keys gnus-group-mode-map + " " gnus-group-read-group + "=" gnus-group-select-group + "\r" gnus-group-select-group + "\M-\r" gnus-group-quick-select-group + [(meta control return)] gnus-group-select-group-ephemerally + "j" gnus-group-jump-to-group + "n" gnus-group-next-unread-group + "p" gnus-group-prev-unread-group + "\177" gnus-group-prev-unread-group + [delete] gnus-group-prev-unread-group + "N" gnus-group-next-group + "P" gnus-group-prev-group + "\M-n" gnus-group-next-unread-group-same-level + "\M-p" gnus-group-prev-unread-group-same-level + "," gnus-group-best-unread-group + "." gnus-group-first-unread-group + "u" gnus-group-unsubscribe-current-group + "U" gnus-group-unsubscribe-group + "c" gnus-group-catchup-current + "C" gnus-group-catchup-current-all + "\M-c" gnus-group-clear-data + "l" gnus-group-list-groups + "L" gnus-group-list-all-groups + "m" gnus-group-mail + "g" gnus-group-get-new-news + "\M-g" gnus-group-get-new-news-this-group + "R" gnus-group-restart + "r" gnus-group-read-init-file + "B" gnus-group-browse-foreign-server + "b" gnus-group-check-bogus-groups + "F" gnus-find-new-newsgroups + "\C-c\C-d" gnus-group-describe-group + "\M-d" gnus-group-describe-all-groups + "\C-c\C-a" gnus-group-apropos + "\C-c\M-\C-a" gnus-group-description-apropos + "a" gnus-group-post-news + "\ek" gnus-group-edit-local-kill + "\eK" gnus-group-edit-global-kill + "\C-k" gnus-group-kill-group + "\C-y" gnus-group-yank-group + "\C-w" gnus-group-kill-region + "\C-x\C-t" gnus-group-transpose-groups + "\C-c\C-l" gnus-group-list-killed + "\C-c\C-x" gnus-group-expire-articles + "\C-c\M-\C-x" gnus-group-expire-all-groups + "V" gnus-version + "s" gnus-group-save-newsrc + "z" gnus-group-suspend + "q" gnus-group-exit + "Q" gnus-group-quit + "?" gnus-group-describe-briefly + "\C-c\C-i" gnus-info-find-node + "\M-e" gnus-group-edit-group-method + "^" gnus-group-enter-server-mode + gnus-mouse-2 gnus-mouse-pick-group + "<" beginning-of-buffer + ">" end-of-buffer + "\C-c\C-b" gnus-bug + "\C-c\C-s" gnus-group-sort-groups + "t" gnus-topic-mode + "\C-c\M-g" gnus-activate-all-groups + "\M-&" gnus-group-universal-argument + "#" gnus-group-mark-group + "\M-#" gnus-group-unmark-group) + + (gnus-define-keys (gnus-group-mark-map "M" gnus-group-mode-map) + "m" gnus-group-mark-group + "u" gnus-group-unmark-group + "w" gnus-group-mark-region + "m" gnus-group-mark-buffer + "r" gnus-group-mark-regexp + "U" gnus-group-unmark-all-groups) + + (gnus-define-keys (gnus-group-group-map "G" gnus-group-mode-map) + "d" gnus-group-make-directory-group + "h" gnus-group-make-help-group + "u" gnus-group-make-useful-group + "a" gnus-group-make-archive-group + "k" gnus-group-make-kiboze-group + "m" gnus-group-make-group + "E" gnus-group-edit-group + "e" gnus-group-edit-group-method + "p" gnus-group-edit-group-parameters + "v" gnus-group-add-to-virtual + "V" gnus-group-make-empty-virtual + "D" gnus-group-enter-directory + "f" gnus-group-make-doc-group + "w" gnus-group-make-web-group + "r" gnus-group-rename-group + "c" gnus-group-customize + "\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 + "u" gnus-group-sort-groups-by-unread + "l" gnus-group-sort-groups-by-level + "v" gnus-group-sort-groups-by-score + "r" gnus-group-sort-groups-by-rank + "m" gnus-group-sort-groups-by-method) + + (gnus-define-keys (gnus-group-sort-map "P" gnus-group-group-map) + "s" gnus-group-sort-selected-groups + "a" gnus-group-sort-selected-groups-by-alphabet + "u" gnus-group-sort-selected-groups-by-unread + "l" gnus-group-sort-selected-groups-by-level + "v" gnus-group-sort-selected-groups-by-score + "r" gnus-group-sort-selected-groups-by-rank + "m" gnus-group-sort-selected-groups-by-method) + + (gnus-define-keys (gnus-group-list-map "A" gnus-group-mode-map) + "k" gnus-group-list-killed + "z" gnus-group-list-zombies + "s" gnus-group-list-groups + "u" gnus-group-list-all-groups + "A" gnus-group-list-active + "a" gnus-group-apropos + "d" gnus-group-description-apropos + "m" gnus-group-list-matching + "M" gnus-group-list-all-matching + "l" gnus-group-list-level) + + (gnus-define-keys (gnus-group-score-map "W" gnus-group-mode-map) + "f" gnus-score-flush-cache) + + (gnus-define-keys (gnus-group-help-map "H" gnus-group-mode-map) + "d" gnus-group-describe-group + "f" gnus-group-fetch-faq) + + (gnus-define-keys (gnus-group-sub-map "S" gnus-group-mode-map) + "l" gnus-group-set-current-level + "t" gnus-group-unsubscribe-current-group + "s" gnus-group-unsubscribe-group + "k" gnus-group-kill-group + "y" gnus-group-yank-group + "w" gnus-group-kill-region + "\C-k" gnus-group-kill-level + "z" gnus-group-kill-all-zombies)) + +(defun gnus-group-make-menu-bar () + (gnus-turn-off-edit-menu 'group) + (unless (boundp 'gnus-group-reading-menu) + + (easy-menu-define + gnus-group-reading-menu gnus-group-mode-map "" + '("Group" + ["Read" gnus-group-read-group (gnus-group-group-name)] + ["Select" gnus-group-select-group (gnus-group-group-name)] + ["See old articles" (gnus-group-select-group 'all) + :keys "C-u SPC" :active (gnus-group-group-name)] + ["Catch up" gnus-group-catchup-current (gnus-group-group-name)] + ["Catch up all articles" gnus-group-catchup-current-all + (gnus-group-group-name)] + ["Check for new articles" gnus-group-get-new-news-this-group + (gnus-group-group-name)] + ["Toggle subscription" gnus-group-unsubscribe-current-group + (gnus-group-group-name)] + ["Kill" gnus-group-kill-group (gnus-group-group-name)] + ["Yank" gnus-group-yank-group gnus-list-of-killed-groups] + ["Describe" gnus-group-describe-group (gnus-group-group-name)] + ["Fetch FAQ" gnus-group-fetch-faq (gnus-group-group-name)] + ;; Actually one should check, if any of the marked groups gives t for + ;; (gnus-check-backend-function 'request-expire-articles ...) + ["Expire articles" gnus-group-expire-articles + (or (and (gnus-group-group-name) + (gnus-check-backend-function + 'request-expire-articles + (gnus-group-group-name))) gnus-group-marked)] + ["Set group level" gnus-group-set-current-level + (gnus-group-group-name)] + ["Select quick" gnus-group-quick-select-group (gnus-group-group-name)] + ["Customize" gnus-group-customize (gnus-group-group-name)] + ("Edit" + ["Parameters" gnus-group-edit-group-parameters + (gnus-group-group-name)] + ["Select method" gnus-group-edit-group-method + (gnus-group-group-name)] + ["Info" gnus-group-edit-group (gnus-group-group-name)] + ["Local kill file" gnus-group-edit-local-kill (gnus-group-group-name)] + ["Global kill file" gnus-group-edit-global-kill t]) + )) + + (easy-menu-define + gnus-group-group-menu gnus-group-mode-map "" + '("Groups" + ("Listing" + ["List unread subscribed groups" gnus-group-list-groups t] + ["List (un)subscribed groups" gnus-group-list-all-groups t] + ["List killed groups" gnus-group-list-killed gnus-killed-list] + ["List zombie groups" gnus-group-list-zombies gnus-zombie-list] + ["List level..." gnus-group-list-level t] + ["Describe all groups" gnus-group-describe-all-groups t] + ["Group apropos..." gnus-group-apropos t] + ["Group and description apropos..." gnus-group-description-apropos t] + ["List groups matching..." gnus-group-list-matching t] + ["List all groups matching..." gnus-group-list-all-matching t] + ["List active file" gnus-group-list-active t]) + ("Sort" + ["Default sort" gnus-group-sort-groups t] + ["Sort by method" gnus-group-sort-groups-by-method t] + ["Sort by rank" gnus-group-sort-groups-by-rank t] + ["Sort by score" gnus-group-sort-groups-by-score t] + ["Sort by level" gnus-group-sort-groups-by-level t] + ["Sort by unread" gnus-group-sort-groups-by-unread t] + ["Sort by name" gnus-group-sort-groups-by-alphabet t]) + ("Sort process/prefixed" + ["Default sort" gnus-group-sort-selected-groups + (or (not (boundp 'gnus-topic-mode)) (not gnus-topic-mode))] + ["Sort by method" gnus-group-sort-selected-groups-by-method + (or (not (boundp 'gnus-topic-mode)) (not gnus-topic-mode))] + ["Sort by rank" gnus-group-sort-selected-groups-by-rank + (or (not (boundp 'gnus-topic-mode)) (not gnus-topic-mode))] + ["Sort by score" gnus-group-sort-selected-groups-by-score + (or (not (boundp 'gnus-topic-mode)) (not gnus-topic-mode))] + ["Sort by level" gnus-group-sort-selected-groups-by-level + (or (not (boundp 'gnus-topic-mode)) (not gnus-topic-mode))] + ["Sort by unread" gnus-group-sort-selected-groups-by-unread + (or (not (boundp 'gnus-topic-mode)) (not gnus-topic-mode))] + ["Sort by name" gnus-group-sort-selected-groups-by-alphabet + (or (not (boundp 'gnus-topic-mode)) (not gnus-topic-mode))]) + ("Mark" + ["Mark group" gnus-group-mark-group + (and (gnus-group-group-name) + (not (memq (gnus-group-group-name) gnus-group-marked)))] + ["Unmark group" gnus-group-unmark-group + (and (gnus-group-group-name) + (memq (gnus-group-group-name) gnus-group-marked))] + ["Unmark all" gnus-group-unmark-all-groups gnus-group-marked] + ["Mark regexp..." gnus-group-mark-regexp t] + ["Mark region" gnus-group-mark-region t] + ["Mark buffer" gnus-group-mark-buffer t] + ["Execute command" gnus-group-universal-argument + (or gnus-group-marked (gnus-group-group-name))]) + ("Subscribe" + ["Subscribe to a group" gnus-group-unsubscribe-group t] + ["Kill all newsgroups in region" gnus-group-kill-region t] + ["Kill all zombie groups" gnus-group-kill-all-zombies + gnus-zombie-list] + ["Kill all groups on level..." gnus-group-kill-level t]) + ("Foreign groups" + ["Make a foreign group" gnus-group-make-group t] + ["Add a directory group" gnus-group-make-directory-group t] + ["Add the help group" gnus-group-make-help-group t] + ["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] + ["Rename group" gnus-group-rename-group + (gnus-check-backend-function + 'request-rename-group (gnus-group-group-name))] + ["Delete group" gnus-group-delete-group + (gnus-check-backend-function + 'request-delete-group (gnus-group-group-name))]) + ("Move" + ["Next" gnus-group-next-group t] + ["Previous" gnus-group-prev-group t] + ["Next unread" gnus-group-next-unread-group t] + ["Previous unread" gnus-group-prev-unread-group t] + ["Next unread same level" gnus-group-next-unread-group-same-level t] + ["Previous unread same level" + gnus-group-prev-unread-group-same-level t] + ["Jump to group" gnus-group-jump-to-group t] + ["First unread group" gnus-group-first-unread-group t] + ["Best unread group" gnus-group-best-unread-group t]) + ["Delete bogus groups" gnus-group-check-bogus-groups t] + ["Find new newsgroups" gnus-find-new-newsgroups t] + ["Transpose" gnus-group-transpose-groups + (gnus-group-group-name)] + ["Read a directory as a group..." gnus-group-enter-directory t] + )) + + (easy-menu-define + gnus-group-misc-menu gnus-group-mode-map "" + '("Misc" + ("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-soup-brew-soup (fboundp 'gnus-soup-pack-packet)]) + ["Send a bug report" gnus-bug t] + ["Send a mail" gnus-group-mail t] + ["Post an article..." gnus-group-post-news t] + ["Check for new news" gnus-group-get-new-news t] + ["Activate all groups" gnus-activate-all-groups t] + ["Restart Gnus" gnus-group-restart t] + ["Read init file" gnus-group-read-init-file t] + ["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] + ["Clear dribble buffer" gnus-group-clear-dribble t] + ["Read manual" gnus-info-find-node t] + ["Flush score cache" gnus-score-flush-cache t] + ["Toggle topics" gnus-topic-mode t] + ["Exit from Gnus" gnus-group-exit t] + ["Exit without saving" gnus-group-quit t] + )) + + (run-hooks 'gnus-group-menu-hook))) + +(defun gnus-group-mode () + "Major mode for reading news. + +All normal editing commands are switched off. +\\ +The group buffer lists (some of) the groups available. For instance, +`\\[gnus-group-list-groups]' will list all subscribed groups with unread articles, while `\\[gnus-group-list-zombies]' +lists all zombie groups. + +Groups that are displayed can be entered with `\\[gnus-group-read-group]'. To subscribe +to a group not displayed, type `\\[gnus-group-unsubscribe-group]'. + +For more in-depth information on this mode, read the manual (`\\[gnus-info-find-node]'). + +The following commands are available: + +\\{gnus-group-mode-map}" + (interactive) + (when (gnus-visual-p 'group-menu 'menu) + (gnus-group-make-menu-bar)) + (kill-all-local-variables) + (gnus-simplify-mode-line) + (setq major-mode 'gnus-group-mode) + (setq mode-name "Group") + (gnus-group-set-mode-line) + (setq mode-line-process nil) + (use-local-map gnus-group-mode-map) + (buffer-disable-undo (current-buffer)) + (setq truncate-lines t) + (setq buffer-read-only t) + (gnus-set-default-directory) + (gnus-update-format-specifications nil 'group 'group-mode) + (gnus-update-group-mark-positions) + (gnus-make-local-hook 'post-command-hook) + (gnus-add-hook 'post-command-hook 'gnus-clear-inboxes-moved nil t) + (when gnus-use-undo + (gnus-undo-mode 1)) + (run-hooks 'gnus-group-mode-hook)) + +(defun gnus-update-group-mark-positions () + (save-excursion + (let ((gnus-process-mark 128) + (gnus-group-marked '("dummy.group")) + (gnus-active-hashtb (make-vector 10 0))) + (gnus-set-active "dummy.group" '(0 . 0)) + (gnus-set-work-buffer) + (gnus-group-insert-group-line "dummy.group" 0 nil 0 nil) + (goto-char (point-min)) + (setq gnus-group-mark-positions + (list (cons 'process (and (search-forward "\200" nil t) + (- (point) 2)))))))) + +(defun gnus-clear-inboxes-moved () + (setq nnmail-moved-inboxes nil)) + +(defun gnus-mouse-pick-group (e) + "Enter the group under the mouse pointer." + (interactive "e") + (mouse-set-point e) + (gnus-group-read-group nil)) + +;; Look at LEVEL and find out what the level is really supposed to be. +;; If LEVEL is non-nil, LEVEL will be returned, if not, what happens +;; will depend on whether `gnus-group-use-permanent-levels' is used. +(defun gnus-group-default-level (&optional level number-or-nil) + (cond + (gnus-group-use-permanent-levels + (or (setq gnus-group-use-permanent-levels + (or level (if (numberp gnus-group-use-permanent-levels) + gnus-group-use-permanent-levels + (or gnus-group-default-list-level + gnus-level-subscribed)))) + gnus-group-default-list-level gnus-level-subscribed)) + (number-or-nil + level) + (t + (or level gnus-group-default-list-level gnus-level-subscribed)))) + +(defun gnus-group-setup-buffer () + (switch-to-buffer gnus-group-buffer) + (unless (eq major-mode 'gnus-group-mode) + (gnus-add-current-to-buffer-list) + (gnus-group-mode) + (when gnus-carpal + (gnus-carpal-setup-buffer 'group)))) + +(defun gnus-group-list-groups (&optional level unread lowest) + "List newsgroups with level LEVEL or lower that have unread articles. +Default is all subscribed groups. +If argument UNREAD is non-nil, groups with no unread articles are also +listed." + (interactive + (list (if current-prefix-arg + (prefix-numeric-value current-prefix-arg) + (or + (gnus-group-default-level nil t) + gnus-group-default-list-level + gnus-level-subscribed)))) + ;; Just do this here, for no particular good reason. + (gnus-clear-inboxes-moved) + (unless level + (setq level (car gnus-group-list-mode) + unread (cdr gnus-group-list-mode))) + (setq level (gnus-group-default-level level)) + (gnus-group-setup-buffer) + (gnus-update-format-specifications nil 'group 'group-mode) + (let ((case-fold-search nil) + (props (text-properties-at (point-at-bol))) + (empty (= (point-min) (point-max))) + (group (gnus-group-group-name)) + number) + (set-buffer gnus-group-buffer) + (setq number (funcall gnus-group-prepare-function level unread lowest)) + (when (or (and (numberp number) + (zerop number)) + (zerop (buffer-size))) + ;; No groups in the buffer. + (gnus-message 5 gnus-no-groups-message)) + ;; We have some groups displayed. + (goto-char (point-max)) + (when (or (not gnus-group-goto-next-group-function) + (not (funcall gnus-group-goto-next-group-function + group props))) + (cond + (empty + (goto-char (point-min))) + ((not group) + ;; Go to the first group with unread articles. + (gnus-group-search-forward t)) + (t + ;; Find the right group to put point on. If the current group + ;; has disappeared in the new listing, try to find the next + ;; one. If no next one can be found, just leave point at the + ;; first newsgroup in the buffer. + (when (not (gnus-goto-char + (text-property-any + (point-min) (point-max) + 'gnus-group (gnus-intern-safe + group gnus-active-hashtb)))) + (let ((newsrc (cdddr (gnus-gethash group gnus-newsrc-hashtb)))) + (while (and newsrc + (not (gnus-goto-char + (text-property-any + (point-min) (point-max) 'gnus-group + (gnus-intern-safe + (caar newsrc) gnus-active-hashtb))))) + (setq newsrc (cdr newsrc))) + (unless newsrc + (goto-char (point-max)) + (forward-line -1))))))) + ;; Adjust cursor point. + (gnus-group-position-point))) + +(defun gnus-group-list-level (level &optional all) + "List groups on LEVEL. +If ALL (the prefix), also list groups that have no unread articles." + (interactive "nList groups on level: \nP") + (gnus-group-list-groups level all level)) + +(defun gnus-group-prepare-flat (level &optional all lowest regexp) + "List all newsgroups with unread articles of level LEVEL or lower. +If ALL is non-nil, list groups that have no unread articles. +If LOWEST is non-nil, list all newsgroups of level LOWEST or higher. +If REGEXP, only list groups matching REGEXP." + (set-buffer gnus-group-buffer) + (let ((buffer-read-only nil) + (newsrc (cdr gnus-newsrc-alist)) + (lowest (or lowest 1)) + info clevel unread group params) + (erase-buffer) + (when (< lowest gnus-level-zombie) + ;; List living groups. + (while newsrc + (setq info (car newsrc) + group (gnus-info-group info) + params (gnus-info-params info) + newsrc (cdr newsrc) + unread (car (gnus-gethash group gnus-newsrc-hashtb))) + (and unread ; This group might be bogus + (or (not regexp) + (string-match regexp group)) + (<= (setq clevel (gnus-info-level info)) level) + (>= clevel lowest) + (or all ; We list all groups? + (if (eq unread t) ; Unactivated? + gnus-group-list-inactive-groups ; We list unactivated + (> unread 0)) ; We list groups with unread articles + (and gnus-list-groups-with-ticked-articles + (cdr (assq 'tick (gnus-info-marks info)))) + ; And groups with tickeds + ;; Check for permanent visibility. + (and gnus-permanently-visible-groups + (string-match gnus-permanently-visible-groups + group)) + (memq 'visible params) + (cdr (assq 'visible params))) + (gnus-group-insert-group-line + group (gnus-info-level info) + (gnus-info-marks info) unread (gnus-info-method info))))) + + ;; List dead groups. + (and (>= level gnus-level-zombie) (<= lowest gnus-level-zombie) + (gnus-group-prepare-flat-list-dead + (setq gnus-zombie-list (sort gnus-zombie-list 'string<)) + gnus-level-zombie ?Z + regexp)) + (and (>= level gnus-level-killed) (<= lowest gnus-level-killed) + (gnus-group-prepare-flat-list-dead + (setq gnus-killed-list (sort gnus-killed-list 'string<)) + gnus-level-killed ?K regexp)) + + (gnus-group-set-mode-line) + (setq gnus-group-list-mode (cons level all)) + (run-hooks 'gnus-group-prepare-hook) + t)) + +(defun gnus-group-prepare-flat-list-dead (groups level mark regexp) + ;; List zombies and killed lists somewhat faster, which was + ;; suggested by Jack Vinson . It does + ;; this by ignoring the group format specification altogether. + (let (group) + (if regexp + ;; This loop is used when listing groups that match some + ;; regexp. + (while groups + (setq group (pop groups)) + (when (string-match regexp group) + (gnus-add-text-properties + (point) (prog1 (1+ (point)) + (insert " " mark " *: " group "\n")) + (list 'gnus-group (gnus-intern-safe group gnus-active-hashtb) + 'gnus-unread t + 'gnus-level level)))) + ;; This loop is used when listing all groups. + (while groups + (gnus-add-text-properties + (point) (prog1 (1+ (point)) + (insert " " mark " *: " + (setq group (pop groups)) "\n")) + (list 'gnus-group (gnus-intern-safe group gnus-active-hashtb) + 'gnus-unread t + 'gnus-level level)))))) + +(defun gnus-group-update-group-line () + "Update the current line in the group buffer." + (let* ((buffer-read-only nil) + (group (gnus-group-group-name)) + (entry (and group (gnus-gethash group gnus-newsrc-hashtb))) + gnus-group-indentation) + (when group + (and entry + (not (gnus-ephemeral-group-p group)) + (gnus-dribble-enter + (concat "(gnus-group-set-info '" + (gnus-prin1-to-string (nth 2 entry)) + ")"))) + (setq gnus-group-indentation (gnus-group-group-indentation)) + (gnus-delete-line) + (gnus-group-insert-group-line-info group) + (forward-line -1) + (gnus-group-position-point)))) + +(defun gnus-group-insert-group-line-info (group) + "Insert GROUP on the current line." + (let ((entry (gnus-gethash group gnus-newsrc-hashtb)) + (gnus-group-indentation (gnus-group-group-indentation)) + active info) + (if entry + (progn + ;; (Un)subscribed group. + (setq info (nth 2 entry)) + (gnus-group-insert-group-line + group (gnus-info-level info) (gnus-info-marks info) + (or (car entry) t) (gnus-info-method info))) + ;; This group is dead. + (gnus-group-insert-group-line + group + (if (member group gnus-zombie-list) gnus-level-zombie gnus-level-killed) + nil + (if (setq active (gnus-active group)) + (if (zerop (cdr active)) + 0 + (- (1+ (cdr active)) (car active))) + nil) + nil)))) + +(defun gnus-group-insert-group-line (gnus-tmp-group gnus-tmp-level + gnus-tmp-marked number + gnus-tmp-method) + "Insert a group line in the group buffer." + (let* ((gnus-tmp-active (gnus-active gnus-tmp-group)) + (gnus-tmp-number-total + (if gnus-tmp-active + (1+ (- (cdr gnus-tmp-active) (car gnus-tmp-active))) + 0)) + (gnus-tmp-number-of-unread + (if (numberp number) (int-to-string (max 0 number)) + "*")) + (gnus-tmp-number-of-read + (if (numberp number) + (int-to-string (max 0 (- gnus-tmp-number-total number))) + "*")) + (gnus-tmp-subscribed + (cond ((<= gnus-tmp-level gnus-level-subscribed) ? ) + ((<= gnus-tmp-level gnus-level-unsubscribed) ?U) + ((= gnus-tmp-level gnus-level-zombie) ?Z) + (t ?K))) + (gnus-tmp-qualified-group (gnus-group-real-name gnus-tmp-group)) + (gnus-tmp-newsgroup-description + (if gnus-description-hashtb + (or (gnus-gethash gnus-tmp-group gnus-description-hashtb) "") + "")) + (gnus-tmp-moderated + (if (and gnus-moderated-hashtb + (gnus-gethash gnus-tmp-group gnus-moderated-hashtb)) + ?m ? )) + (gnus-tmp-moderated-string + (if (eq gnus-tmp-moderated ?m) "(m)" "")) + (gnus-tmp-method + (gnus-server-get-method gnus-tmp-group gnus-tmp-method)) + (gnus-tmp-news-server (or (cadr gnus-tmp-method) "")) + (gnus-tmp-news-method (or (car gnus-tmp-method) "")) + (gnus-tmp-news-method-string + (if gnus-tmp-method + (format "(%s:%s)" (car gnus-tmp-method) + (cadr gnus-tmp-method)) "")) + (gnus-tmp-marked-mark + (if (and (numberp number) + (zerop number) + (cdr (assq 'tick gnus-tmp-marked))) + ?* ? )) + (gnus-tmp-process-marked + (if (member gnus-tmp-group gnus-group-marked) + gnus-process-mark ? )) + (gnus-tmp-grouplens + (or (and gnus-use-grouplens + (bbb-grouplens-group-p gnus-tmp-group)) + "")) + (buffer-read-only nil) + header gnus-tmp-header) ; passed as parameter to user-funcs. + (beginning-of-line) + (gnus-add-text-properties + (point) + (prog1 (1+ (point)) + ;; Insert the text. + (eval gnus-group-line-format-spec)) + `(gnus-group ,(gnus-intern-safe gnus-tmp-group gnus-active-hashtb) + gnus-unread ,(if (numberp number) + (string-to-int gnus-tmp-number-of-unread) + t) + gnus-marked ,gnus-tmp-marked-mark + gnus-indentation ,gnus-group-indentation + gnus-level ,gnus-tmp-level)) + (when (inline (gnus-visual-p 'group-highlight 'highlight)) + (forward-line -1) + (run-hooks 'gnus-group-update-hook) + (forward-line)) + ;; Allow XEmacs to remove front-sticky text properties. + (gnus-group-remove-excess-properties))) + +(defun gnus-group-highlight-line () + "Highlight the current line according to `gnus-group-highlight'." + (let* ((list gnus-group-highlight) + (p (point)) + (end (progn (end-of-line) (point))) + ;; now find out where the line starts and leave point there. + (beg (progn (beginning-of-line) (point))) + (group (gnus-group-group-name)) + (entry (gnus-group-entry group)) + (unread (if (numberp (car entry)) (car entry) 0)) + (active (gnus-active group)) + (total (if active (1+ (- (cdr active) (car active))) 0)) + (info (nth 2 entry)) + (method (gnus-server-get-method group (gnus-info-method info))) + (marked (gnus-info-marks info)) + (mailp (memq 'mail (assoc (symbol-name + (car (or method gnus-select-method))) + gnus-valid-select-methods))) + (level (or (gnus-info-level info) 9)) + (score (or (gnus-info-score info) 0)) + (ticked (gnus-range-length (cdr (assq 'tick marked)))) + (group-age (gnus-group-timestamp-delta group)) + (inhibit-read-only t)) + ;; Eval the cars of the lists until we find a match. + (while (and list + (not (eval (caar list)))) + (setq list (cdr list))) + (let ((face (cdar list))) + (unless (eq face (get-text-property beg 'face)) + (gnus-put-text-property + beg end 'face + (setq face (if (boundp face) (symbol-value face) face))) + (gnus-extent-start-open beg))) + (goto-char p))) + +(defun gnus-group-update-group (group &optional visible-only) + "Update all lines where GROUP appear. +If VISIBLE-ONLY is non-nil, the group won't be displayed if it isn't +already." + (save-excursion + (set-buffer gnus-group-buffer) + ;; 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-gethash group gnus-newsrc-hashtb))) + (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) + (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-gethash group gnus-newsrc-hashtb)))) + (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) + (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) + (let* ((gformat (or gnus-group-mode-line-format-spec + (setq gnus-group-mode-line-format-spec + (gnus-parse-format + gnus-group-mode-line-format + gnus-group-mode-line-format-alist)))) + (gnus-tmp-news-server (cadr gnus-select-method)) + (gnus-tmp-news-method (car gnus-select-method)) + (gnus-tmp-colon (if (equal gnus-tmp-news-server "") "" ":")) + (max-len 60) + gnus-tmp-header ;Dummy binding for user-defined formats + ;; Get the resulting string. + (modified + (and gnus-dribble-buffer + (buffer-name gnus-dribble-buffer) + (buffer-modified-p gnus-dribble-buffer) + (save-excursion + (set-buffer gnus-dribble-buffer) + (not (zerop (buffer-size)))))) + (mode-string (eval gformat))) + ;; Say whether the dribble buffer has been modified. + (setq mode-line-modified + (if modified "---*- " "----- ")) + ;; If the line is too long, we chop it off. + (when (> (length mode-string) max-len) + (setq mode-string (substring mode-string 0 (- max-len 4)))) + (prog1 + (setq mode-line-buffer-identification + (gnus-mode-line-buffer-identification + (list mode-string))) + (set-buffer-modified-p modified)))))) + +(defun gnus-group-group-name () + "Get the name of the newsgroup on the current line." + (let ((group (get-text-property (point-at-bol) 'gnus-group))) + (and group (symbol-name group)))) + +(defun gnus-group-group-level () + "Get the level of the newsgroup on the current line." + (get-text-property (point-at-bol) 'gnus-level)) + +(defun gnus-group-group-indentation () + "Get the indentation of the newsgroup on the current line." + (or (get-text-property (point-at-bol) 'gnus-indentation) + (and gnus-group-indentation-function + (funcall gnus-group-indentation-function)) + "")) + +(defun gnus-group-group-unread () + "Get the number of unread articles of the newsgroup on the current line." + (get-text-property (point-at-bol) 'gnus-unread)) + +(defun gnus-group-new-mail (group) + (if (nnmail-new-mail-p (gnus-group-real-name group)) + gnus-new-mail-mark + ? )) + +(defun gnus-group-level (group) + "Return the estimated level of GROUP." + (or (gnus-info-level (gnus-get-info group)) + (and (member group gnus-zombie-list) 8) + 9)) + +(defun gnus-group-search-forward (&optional backward all level first-too) + "Find the next newsgroup with unread articles. +If BACKWARD is non-nil, find the previous newsgroup instead. +If ALL is non-nil, just find any newsgroup. +If LEVEL is non-nil, find group with level LEVEL, or higher if no such +group exists. +If FIRST-TOO, the current line is also eligible as a target." + (let ((way (if backward -1 1)) + (low gnus-level-killed) + (beg (point)) + pos found lev) + (if (and backward (progn (beginning-of-line)) (bobp)) + nil + (unless first-too + (forward-line way)) + (while (and + (not (eobp)) + (not (setq + found + (and (or all + (and + (let ((unread + (get-text-property (point) 'gnus-unread))) + (and (numberp unread) (> unread 0))) + (setq lev (get-text-property (point) + 'gnus-level)) + (<= lev gnus-level-subscribed))) + (or (not level) + (and (setq lev (get-text-property (point) + 'gnus-level)) + (or (= lev level) + (and (< lev low) + (< level lev) + (progn + (setq low lev) + (setq pos (point)) + nil)))))))) + (zerop (forward-line way))))) + (if found + (progn (gnus-group-position-point) t) + (goto-char (or pos beg)) + (and pos t)))) + +;;; Gnus group mode commands + +;; Group marking. + +(defun gnus-group-mark-group (n &optional unmark no-advance) + "Mark the current group." + (interactive "p") + (let ((buffer-read-only nil) + group) + (while (and (> n 0) + (not (eobp))) + (when (setq group (gnus-group-group-name)) + ;; Go to the mark position. + (beginning-of-line) + (forward-char (or (cdr (assq 'process gnus-group-mark-positions)) 2)) + (subst-char-in-region + (point) (1+ (point)) (following-char) + (if unmark + (progn + (setq gnus-group-marked (delete group gnus-group-marked)) + ? ) + (setq gnus-group-marked + (cons group (delete group gnus-group-marked))) + gnus-process-mark))) + (unless no-advance + (gnus-group-next-group 1)) + (decf n)) + (gnus-summary-position-point) + n)) + +(defun gnus-group-unmark-group (n) + "Remove the mark from the current group." + (interactive "p") + (gnus-group-mark-group n 'unmark) + (gnus-group-position-point)) + +(defun gnus-group-unmark-all-groups () + "Unmark all groups." + (interactive) + (let ((groups gnus-group-marked)) + (save-excursion + (while groups + (gnus-group-remove-mark (pop groups))))) + (gnus-group-position-point)) + +(defun gnus-group-mark-region (unmark beg end) + "Mark all groups between point and mark. +If UNMARK, remove the mark instead." + (interactive "P\nr") + (let ((num (count-lines beg end))) + (save-excursion + (goto-char beg) + (- num (gnus-group-mark-group num unmark))))) + +(defun gnus-group-mark-buffer (&optional unmark) + "Mark all groups in the buffer. +If UNMARK, remove the mark instead." + (interactive "P") + (gnus-group-mark-region unmark (point-min) (point-max))) + +(defun gnus-group-mark-regexp (regexp) + "Mark all groups that match some regexp." + (interactive "sMark (regexp): ") + (let ((alist (cdr gnus-newsrc-alist)) + group) + (while alist + (when (string-match regexp (setq group (gnus-info-group (pop alist)))) + (gnus-group-set-mark group)))) + (gnus-group-position-point)) + +(defun gnus-group-remove-mark (group) + "Remove the process mark from GROUP and move point there. +Return nil if the group isn't displayed." + (if (gnus-group-goto-group group) + (save-excursion + (gnus-group-mark-group 1 'unmark t) + t) + (setq gnus-group-marked + (delete group gnus-group-marked)) + nil)) + +(defun gnus-group-set-mark (group) + "Set the process mark on GROUP." + (if (gnus-group-goto-group group) + (save-excursion + (gnus-group-mark-group 1 nil t)) + (setq gnus-group-marked (cons group (delete group gnus-group-marked))))) + +(defun gnus-group-universal-argument (arg &optional groups func) + "Perform any command on all groups according to the process/prefix convention." + (interactive "P") + (if (eq (setq func (or func + (key-binding + (read-key-sequence + (substitute-command-keys + "\\\\[gnus-group-universal-argument]"))))) + 'undefined) + (gnus-error 1 "Undefined key") + (gnus-group-iterate arg + (lambda (group) + (command-execute func)))) + (gnus-group-position-point)) + +(defun gnus-group-process-prefix (n) + "Return a list of groups to work on. +Take into consideration N (the prefix) and the list of marked groups." + (cond + (n + (setq n (prefix-numeric-value n)) + ;; There is a prefix, so we return a list of the N next + ;; groups. + (let ((way (if (< n 0) -1 1)) + (n (abs n)) + group groups) + (save-excursion + (while (and (> n 0) + (setq group (gnus-group-group-name))) + (push group groups) + (setq n (1- n)) + (gnus-group-next-group way))) + (nreverse groups))) + ((and (boundp 'transient-mark-mode) + transient-mark-mode + (boundp 'mark-active) + mark-active) + ;; Work on the region between point and mark. + (let ((max (max (point) (mark))) + groups) + (save-excursion + (goto-char (min (point) (mark))) + (while + (and + (push (gnus-group-group-name) groups) + (zerop (gnus-group-next-group 1)) + (< (point) max))) + (nreverse groups)))) + (gnus-group-marked + ;; No prefix, but a list of marked articles. + (reverse gnus-group-marked)) + (t + ;; Neither marked articles or a prefix, so we return the + ;; current group. + (let ((group (gnus-group-group-name))) + (and group (list group)))))) + +(defun gnus-group-iterate (arg function) + "Iterate FUNCTION over all process/prefixed groups. +FUNCTION will be called with the group name as the paremeter +and with point over the group in question." + (let ((groups (gnus-group-process-prefix arg)) + group) + (while (setq group (pop groups)) + (gnus-group-remove-mark group) + (funcall function group)))) + +(put 'gnus-group-iterate 'lisp-indent-function 1) + +;; Selecting groups. + +(defun gnus-group-read-group (&optional all no-article group) + "Read news in this newsgroup. +If the prefix argument ALL is non-nil, already read articles become +readable. IF ALL is a number, fetch this number of articles. If the +optional argument NO-ARTICLE is non-nil, no article will be +auto-selected upon group entry. If GROUP is non-nil, fetch that +group." + (interactive "P") + (let ((no-display (eq all 0)) + (group (or group (gnus-group-group-name))) + number active marked entry) + (when (eq all 0) + (setq all nil)) + (unless group + (error "No group on current line")) + (setq marked (gnus-info-marks + (nth 2 (setq entry (gnus-gethash + group gnus-newsrc-hashtb))))) + ;; This group might be a dead group. In that case we have to get + ;; the number of unread articles from `gnus-active-hashtb'. + (setq number + (cond ((numberp all) all) + (entry (car entry)) + ((setq active (gnus-active group)) + (- (1+ (cdr active)) (car active))))) + (gnus-summary-read-group + group (or all (and (numberp number) + (zerop (+ number (gnus-range-length + (cdr (assq 'tick marked))) + (gnus-range-length + (cdr (assq 'dormant marked))))))) + no-article nil no-display))) + +(defun gnus-group-select-group (&optional all) + "Select this newsgroup. +No article is selected automatically. +If ALL is non-nil, already read articles become readable. +If ALL is a number, fetch this number of articles." + (interactive "P") + (gnus-group-read-group all t)) + +(defun gnus-group-quick-select-group (&optional all) + "Select the current group \"quickly\". +This means that no highlighting or scoring will be performed. +If ALL (the prefix argument) is 0, don't even generate the summary +buffer." + (interactive "P") + (require 'gnus-score) + (let (gnus-visual + gnus-score-find-score-files-function + gnus-apply-kill-hook + gnus-summary-expunge-below) + (gnus-group-read-group all t))) + +(defun gnus-group-visible-select-group (&optional all) + "Select the current group without hiding any articles." + (interactive "P") + (let ((gnus-inhibit-limiting t)) + (gnus-group-read-group all t))) + +(defun gnus-group-select-group-ephemerally () + "Select the current group without doing any processing whatsoever. +You will actually be entered into a group that's a copy of +the current group; no changes you make while in this group will +be permanent." + (interactive) + (require 'gnus-score) + (let* (gnus-visual + gnus-score-find-score-files-function gnus-apply-kill-hook + gnus-summary-expunge-below gnus-show-threads gnus-suppress-duplicates + gnus-summary-mode-hook gnus-select-group-hook + (group (gnus-group-group-name)) + (method (gnus-find-method-for-group group))) + (setq method + `(,(car method) ,(concat (cadr method) "-ephemeral") + (,(intern (format "%s-address" (car method))) ,(cadr method)) + ,@(cddr method))) + (gnus-group-read-ephemeral-group + (gnus-group-prefixed-name group method) method))) + +;;;###autoload +(defun gnus-fetch-group (group) + "Start Gnus if necessary and enter GROUP. +Returns whether the fetching was successful or not." + (interactive "sGroup name: ") + (unless (get-buffer gnus-group-buffer) + (gnus)) + (gnus-group-read-group nil nil group)) + +;; Enter a group that is not in the group buffer. Non-nil is returned +;; if selection was successful. +(defun gnus-group-read-ephemeral-group (group method &optional activate + quit-config request-only) + "Read GROUP from METHOD as an ephemeral group. +If ACTIVATE, request the group first. +If QUIT-CONFIG, use that window configuration when exiting from the +ephemeral group. +If REQUEST-ONLY, don't actually read the group; just request it. + +Return the name of the group is selection was successful." + (let ((group (if (gnus-group-foreign-p group) group + (gnus-group-prefixed-name group method)))) + (gnus-sethash + group + `(-1 nil (,group + ,gnus-level-default-subscribed nil nil ,method + ((quit-config . + ,(if quit-config quit-config + (cons gnus-summary-buffer + gnus-current-window-configuration)))))) + gnus-newsrc-hashtb) + (set-buffer gnus-group-buffer) + (unless (gnus-check-server method) + (error "Unable to contact server: %s" (gnus-status-message method))) + (when activate + (gnus-activate-group group 'scan) + (unless (gnus-request-group group) + (error "Couldn't request group: %s" + (nnheader-get-report (car method))))) + (if request-only + group + (condition-case () + (when (gnus-group-read-group t t group) + group) + ;;(error nil) + (quit nil))))) + +(defun gnus-group-jump-to-group (group) + "Jump to newsgroup GROUP." + (interactive + (list (completing-read + "Group: " gnus-active-hashtb nil + (gnus-read-active-file-p) + nil + 'gnus-group-history))) + + (when (equal group "") + (error "Empty group name")) + + (unless (gnus-ephemeral-group-p group) + ;; Either go to the line in the group buffer... + (unless (gnus-group-goto-group group) + ;; ... or insert the line. + (gnus-group-update-group group) + (gnus-group-goto-group group))) + ;; Adjust cursor point. + (gnus-group-position-point)) + +(defun gnus-group-goto-group (group &optional far) + "Goto to newsgroup GROUP. +If FAR, it is likely that the group is not on the current line." + (when group + (if far + (gnus-goto-char + (text-property-any + (point-min) (point-max) + 'gnus-group (gnus-intern-safe group gnus-active-hashtb))) + (beginning-of-line) + (cond + ;; It's quite likely that we are on the right line, so + ;; we check the current line first. + ((eq (get-text-property (point) 'gnus-group) + (gnus-intern-safe group gnus-active-hashtb)) + (point)) + ;; Previous and next line are also likely, so we check them as well. + ((save-excursion + (forward-line -1) + (eq (get-text-property (point) 'gnus-group) + (gnus-intern-safe group gnus-active-hashtb))) + (forward-line -1) + (point)) + ((save-excursion + (forward-line 1) + (eq (get-text-property (point) 'gnus-group) + (gnus-intern-safe group gnus-active-hashtb))) + (forward-line 1) + (point)) + (t + ;; Search through the entire buffer. + (gnus-goto-char + (text-property-any + (point-min) (point-max) + 'gnus-group (gnus-intern-safe group gnus-active-hashtb)))))))) + +(defun gnus-group-next-group (n &optional silent) + "Go to next N'th newsgroup. +If N is negative, search backward instead. +Returns the difference between N and the number of skips actually +done." + (interactive "p") + (gnus-group-next-unread-group n t nil silent)) + +(defun gnus-group-next-unread-group (n &optional all level silent) + "Go to next N'th unread newsgroup. +If N is negative, search backward instead. +If ALL is non-nil, choose any newsgroup, unread or not. +If LEVEL is non-nil, choose the next group with level LEVEL, or, if no +such group can be found, the next group with a level higher than +LEVEL. +Returns the difference between N and the number of skips actually +made." + (interactive "p") + (let ((backward (< n 0)) + (n (abs n))) + (while (and (> n 0) + (gnus-group-search-forward + backward (or (not gnus-group-goto-unread) all) level)) + (setq n (1- n))) + (when (and (/= 0 n) + (not silent)) + (gnus-message 7 "No more%s newsgroups%s" (if all "" " unread") + (if level " on this level or higher" ""))) + n)) + +(defun gnus-group-prev-group (n) + "Go to previous N'th newsgroup. +Returns the difference between N and the number of skips actually +done." + (interactive "p") + (gnus-group-next-unread-group (- n) t)) + +(defun gnus-group-prev-unread-group (n) + "Go to previous N'th unread newsgroup. +Returns the difference between N and the number of skips actually +done." + (interactive "p") + (gnus-group-next-unread-group (- n))) + +(defun gnus-group-next-unread-group-same-level (n) + "Go to next N'th unread newsgroup on the same level. +If N is negative, search backward instead. +Returns the difference between N and the number of skips actually +done." + (interactive "p") + (gnus-group-next-unread-group n t (gnus-group-group-level)) + (gnus-group-position-point)) + +(defun gnus-group-prev-unread-group-same-level (n) + "Go to next N'th unread newsgroup on the same level. +Returns the difference between N and the number of skips actually +done." + (interactive "p") + (gnus-group-next-unread-group (- n) t (gnus-group-group-level)) + (gnus-group-position-point)) + +(defun gnus-group-best-unread-group (&optional exclude-group) + "Go to the group with the highest level. +If EXCLUDE-GROUP, do not go to that group." + (interactive) + (goto-char (point-min)) + (let ((best 100000) + unread best-point) + (while (not (eobp)) + (setq unread (get-text-property (point) 'gnus-unread)) + (when (and (numberp unread) (> unread 0)) + (when (and (get-text-property (point) 'gnus-level) + (< (get-text-property (point) 'gnus-level) best) + (or (not exclude-group) + (not (equal exclude-group (gnus-group-group-name))))) + (setq best (get-text-property (point) 'gnus-level)) + (setq best-point (point)))) + (forward-line 1)) + (when best-point + (goto-char best-point)) + (gnus-summary-position-point) + (and best-point (gnus-group-group-name)))) + +(defun gnus-group-first-unread-group () + "Go to the first group with unread articles." + (interactive) + (prog1 + (let ((opoint (point)) + unread) + (goto-char (point-min)) + (if (or (eq (setq unread (gnus-group-group-unread)) t) ; Not active. + (and (numberp unread) ; Not a topic. + (not (zerop unread))) ; Has unread articles. + (zerop (gnus-group-next-unread-group 1))) ; Next unread group. + (point) ; Success. + (goto-char opoint) + nil)) ; Not success. + (gnus-group-position-point))) + +(defun gnus-group-enter-server-mode () + "Jump to the server buffer." + (interactive) + (gnus-enter-server-buffer)) + +(defun gnus-group-make-group (name &optional method address args) + "Add a new newsgroup. +The user will be prompted for a NAME, for a select METHOD, and an +ADDRESS." + (interactive + (list + (gnus-read-group "Group name: ") + (gnus-read-method "From method: "))) + + (let* ((meth (when (and method + (not (gnus-server-equal method gnus-select-method))) + (if address (list (intern method) address) + method))) + (nname (if method (gnus-group-prefixed-name name meth) name)) + backend info) + (when (gnus-gethash nname gnus-newsrc-hashtb) + (error "Group %s already exists" nname)) + ;; Subscribe to the new group. + (gnus-group-change-level + (setq info (list t nname gnus-level-default-subscribed nil nil meth)) + gnus-level-default-subscribed gnus-level-killed + (and (gnus-group-group-name) + (gnus-gethash (gnus-group-group-name) + gnus-newsrc-hashtb)) + t) + ;; Make it active. + (gnus-set-active nname (cons 1 0)) + (unless (gnus-ephemeral-group-p name) + (gnus-dribble-enter + (concat "(gnus-group-set-info '" + (gnus-prin1-to-string (cdr info)) ")"))) + ;; Insert the line. + (gnus-group-insert-group-line-info nname) + (forward-line -1) + (gnus-group-position-point) + + ;; Load the backend and try to make the backend create + ;; the group as well. + (when (assoc (symbol-name (setq backend (car (gnus-server-get-method + nil meth)))) + gnus-valid-select-methods) + (require backend)) + (gnus-check-server meth) + (when (gnus-check-backend-function 'request-create-group nname) + (gnus-request-create-group nname nil args)) + t)) + +(defun gnus-group-delete-group (group &optional force) + "Delete the current group. Only meaningful with mail groups. +If FORCE (the prefix) is non-nil, all the articles in the group will +be deleted. This is \"deleted\" as in \"removed forever from the face +of the Earth\". There is no undo. The user will be prompted before +doing the deletion." + (interactive + (list (gnus-group-group-name) + current-prefix-arg)) + (unless group + (error "No group to rename")) + (unless (gnus-check-backend-function 'request-delete-group group) + (error "This backend does not support group deletion")) + (prog1 + (if (not (gnus-yes-or-no-p + (format + "Do you really want to delete %s%s? " + group (if force " and all its contents" "")))) + () ; Whew! + (gnus-message 6 "Deleting group %s..." group) + (if (not (gnus-request-delete-group group force)) + (gnus-error 3 "Couldn't delete group %s" group) + (gnus-message 6 "Deleting group %s...done" group) + (gnus-group-goto-group group) + (gnus-group-kill-group 1 t) + (gnus-sethash group nil gnus-active-hashtb) + t)) + (gnus-group-position-point))) + +(defun gnus-group-rename-group (group new-name) + "Rename group from GROUP to NEW-NAME. +When used interactively, GROUP is the group under point +and NEW-NAME will be prompted for." + (interactive + (list + (gnus-group-group-name) + (progn + (unless (gnus-check-backend-function + 'request-rename-group (gnus-group-group-name)) + (error "This backend does not support renaming groups")) + (gnus-read-group "Rename group to: " + (gnus-group-real-name (gnus-group-group-name)))))) + + (unless (gnus-check-backend-function 'request-rename-group group) + (error "This backend does not support renaming groups")) + (unless group + (error "No group to rename")) + (when (equal (gnus-group-real-name group) new-name) + (error "Can't rename to the same name")) + + ;; We find the proper prefixed name. + (setq new-name + (if (equal (gnus-group-real-name new-name) new-name) + ;; Native group. + new-name + ;; Foreign group. + (gnus-group-prefixed-name + (gnus-group-real-name new-name) + (gnus-info-method (gnus-get-info group))))) + + (gnus-message 6 "Renaming group %s to %s..." group new-name) + (prog1 + (if (not (gnus-request-rename-group group new-name)) + (gnus-error 3 "Couldn't rename group %s to %s" group new-name) + ;; We rename the group internally by killing it... + (gnus-group-goto-group group) + (gnus-group-kill-group) + ;; ... changing its name ... + (setcar (cdar gnus-list-of-killed-groups) new-name) + ;; ... and then yanking it. Magic! + (gnus-group-yank-group) + (gnus-set-active new-name (gnus-active group)) + (gnus-message 6 "Renaming group %s to %s...done" group new-name) + new-name) + (gnus-group-position-point))) + +(defun gnus-group-edit-group (group &optional part) + "Edit the group on the current line." + (interactive (list (gnus-group-group-name))) + (let ((part (or part 'info)) + info) + (unless group + (error "No group on current line")) + (unless (setq info (gnus-get-info group)) + (error "Killed group; can't be edited")) + (gnus-close-group group) + (gnus-edit-form + ;; Find the proper form to edit. + (cond ((eq part 'method) + (or (gnus-info-method info) "native")) + ((eq part 'params) + (gnus-info-params info)) + (t info)) + ;; The proper documentation. + (format + "Editing the %s." + (cond + ((eq part 'method) "select method") + ((eq part 'params) "group parameters") + (t "group info"))) + `(lambda (form) + (gnus-group-edit-group-done ',part ,group form))))) + +(defun gnus-group-edit-group-method (group) + "Edit the select method of GROUP." + (interactive (list (gnus-group-group-name))) + (gnus-group-edit-group group 'method)) + +(defun gnus-group-edit-group-parameters (group) + "Edit the group parameters of GROUP." + (interactive (list (gnus-group-group-name))) + (gnus-group-edit-group group 'params)) + +(defun gnus-group-edit-group-done (part group form) + "Update variables." + (let* ((method (cond ((eq part 'info) (nth 4 form)) + ((eq part 'method) form) + (t nil))) + (info (cond ((eq part 'info) form) + ((eq part 'method) (gnus-get-info group)) + (t nil))) + (new-group (if info + (if (or (not method) + (gnus-server-equal + gnus-select-method method)) + (gnus-group-real-name (car info)) + (gnus-group-prefixed-name + (gnus-group-real-name (car info)) method)) + nil))) + (when (and new-group + (not (equal new-group group))) + (when (gnus-group-goto-group group) + (gnus-group-kill-group 1)) + (gnus-activate-group new-group)) + ;; Set the info. + (if (not (and info new-group)) + (gnus-group-set-info form (or new-group group) part) + (setq info (gnus-copy-sequence info)) + (setcar info new-group) + (unless (gnus-server-equal method "native") + (unless (nthcdr 3 info) + (nconc info (list nil nil))) + (unless (nthcdr 4 info) + (nconc info (list nil))) + (gnus-info-set-method info method)) + (gnus-group-set-info info)) + (gnus-group-update-group (or new-group group)) + (gnus-group-position-point))) + +(defun gnus-group-make-useful-group (group method) + (interactive + (let ((entry (assoc (completing-read "Create group: " gnus-useful-groups + nil t) + gnus-useful-groups))) + (list (cadr entry) (caddr entry)))) + (setq method (gnus-copy-sequence method)) + (let (entry) + (while (setq entry (memq (assq 'eval method) method)) + (setcar entry (eval (cadar entry))))) + (gnus-group-make-group group method)) + +(defun gnus-group-make-help-group () + "Create the Gnus documentation group." + (interactive) + (let ((name (gnus-group-prefixed-name "gnus-help" '(nndoc "gnus-help"))) + (file (nnheader-find-etc-directory "gnus-tut.txt" t)) + dir) + (when (gnus-gethash name gnus-newsrc-hashtb) + (error "Documentation group already exists")) + (if (not file) + (gnus-message 1 "Couldn't find doc group") + (gnus-group-make-group + (gnus-group-real-name name) + (list 'nndoc "gnus-help" + (list 'nndoc-address file) + (list 'nndoc-article-type 'mbox))))) + (gnus-group-position-point)) + +(defun gnus-group-make-doc-group (file type) + "Create a group that uses a single file as the source." + (interactive + (list (read-file-name "File name: ") + (and current-prefix-arg 'ask))) + (when (eq type 'ask) + (let ((err "") + char found) + (while (not found) + (message + "%sFile type (mbox, babyl, digest, forward, mmdf, guess) [mbdfag]: " + err) + (setq found (cond ((= (setq char (read-char)) ?m) 'mbox) + ((= char ?b) 'babyl) + ((= char ?d) 'digest) + ((= char ?f) 'forward) + ((= char ?a) 'mmfd) + (t (setq err (format "%c unknown. " char)) + nil)))) + (setq type found))) + (let* ((file (expand-file-name file)) + (name (gnus-generate-new-group-name + (gnus-group-prefixed-name + (file-name-nondirectory file) '(nndoc ""))))) + (gnus-group-make-group + (gnus-group-real-name name) + (list 'nndoc file + (list 'nndoc-address file) + (list 'nndoc-article-type (or type 'guess)))))) + +(defvar nnweb-type-definition) +(defvar gnus-group-web-type-history nil) +(defvar gnus-group-web-search-history nil) +(defun gnus-group-make-web-group (&optional solid) + "Create an ephemeral nnweb group. +If SOLID (the prefix), create a solid group." + (interactive "P") + (require 'nnweb) + (let* ((group + (if solid (gnus-read-group "Group name: ") + (message-unique-id))) + (type + (completing-read + "Search engine type: " + (mapcar (lambda (elem) (list (symbol-name (car elem)))) + nnweb-type-definition) + nil t (cons (or (car gnus-group-web-type-history) + (symbol-name (caar nnweb-type-definition))) + 0) + 'gnus-group-web-type-history)) + (search + (read-string + "Search string: " + (cons (or (car gnus-group-web-search-history) "") 0) + 'gnus-group-web-search-history)) + (method + `(nnweb ,group (nnweb-search ,search) + (nnweb-type ,(intern type)) + (nnweb-ephemeral-p t)))) + (if solid + (gnus-group-make-group group "nnweb" "" `(,(intern type) ,search)) + (gnus-group-read-ephemeral-group + group method t + (cons (current-buffer) + (if (eq major-mode 'gnus-summary-mode) 'summary 'group)))))) + +(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." + (interactive "P") + (let ((group (gnus-group-prefixed-name + (if all "ding.archives" "ding.recent") '(nndir "")))) + (when (gnus-gethash group gnus-newsrc-hashtb) + (error "Archive group already exists")) + (gnus-group-make-group + (gnus-group-real-name group) + (list 'nndir (if all "hpc" "edu") + (list 'nndir-directory + (if all gnus-group-archive-directory + gnus-group-recent-archive-directory)))) + (gnus-group-add-parameter group (cons 'to-address "ding@ifi.uio.no")))) + +(defun gnus-group-make-directory-group (dir) + "Create an nndir group. +The user will be prompted for a directory. The contents of this +directory will be used as a newsgroup. The directory should contain +mail messages or news articles in files that have numeric names." + (interactive + (list (read-file-name "Create group from directory: "))) + (unless (file-exists-p dir) + (error "No such directory")) + (unless (file-directory-p dir) + (error "Not a directory")) + (let ((ext "") + (i 0) + group) + (while (or (not group) (gnus-gethash group gnus-newsrc-hashtb)) + (setq group + (gnus-group-prefixed-name + (concat (file-name-as-directory (directory-file-name dir)) + ext) + '(nndir ""))) + (setq ext (format "<%d>" (setq i (1+ i))))) + (gnus-group-make-group + (gnus-group-real-name group) + (list 'nndir (gnus-group-real-name group) (list 'nndir-directory dir))))) + +(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 (lambda (group) (list group)) + '("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 (string): " + header))))) + (push (list regexp nil nil 'r) regexps)) + (push (cons header regexps) scores)) + scores))) + (gnus-group-make-group group "nnkiboze" address) + (nnheader-temp-write (gnus-score-file-name (concat "nnkiboze:" group)) + (let (emacs-lisp-mode-hook) + (pp scores (current-buffer))))) + +(defun gnus-group-add-to-virtual (n vgroup) + "Add the current group to a virtual group." + (interactive + (list current-prefix-arg + (completing-read "Add to virtual group: " gnus-newsrc-hashtb nil t + "nnvirtual:"))) + (unless (eq (car (gnus-find-method-for-group vgroup)) 'nnvirtual) + (error "%s is not an nnvirtual group" vgroup)) + (gnus-close-group vgroup) + (let* ((groups (gnus-group-process-prefix n)) + (method (gnus-info-method (gnus-get-info vgroup)))) + (setcar (cdr method) + (concat + (nth 1 method) "\\|" + (mapconcat + (lambda (s) + (gnus-group-remove-mark s) + (concat "\\(^" (regexp-quote s) "$\\)")) + groups "\\|")))) + (gnus-group-position-point)) + +(defun gnus-group-make-empty-virtual (group) + "Create a new, fresh, empty virtual group." + (interactive "sCreate new, empty virtual group: ") + (let* ((method (list 'nnvirtual "^$")) + (pgroup (gnus-group-prefixed-name group method))) + ;; Check whether it exists already. + (when (gnus-gethash pgroup gnus-newsrc-hashtb) + (error "Group %s already exists." pgroup)) + ;; Subscribe the new group after the group on the current line. + (gnus-subscribe-group pgroup (gnus-group-group-name) method) + (gnus-group-update-group pgroup) + (forward-line -1) + (gnus-group-position-point))) + +(defun gnus-group-enter-directory (dir) + "Enter an ephemeral nneething group." + (interactive "DDirectory to read: ") + (let* ((method (list 'nneething dir '(nneething-read-only t))) + (leaf (gnus-group-prefixed-name + (file-name-nondirectory (directory-file-name dir)) + method)) + (name (gnus-generate-new-group-name leaf))) + (unless (gnus-group-read-ephemeral-group + name method t + (cons (current-buffer) + (if (eq major-mode 'gnus-summary-mode) + 'summary 'group))) + (error "Couldn't enter %s" dir)))) + +;; Group sorting commands +;; Suggested by Joe Hildebrand . + +(defun gnus-group-sort-groups (func &optional reverse) + "Sort the group buffer according to FUNC. +If REVERSE, reverse the sorting order." + (interactive (list gnus-group-sort-function current-prefix-arg)) + (funcall gnus-group-sort-alist-function + (gnus-make-sort-function func) reverse) + (gnus-group-list-groups)) + +(defun gnus-group-sort-flat (func reverse) + ;; We peel off the dummy group from the alist. + (when func + (when (equal (car (gnus-info-group gnus-newsrc-alist)) "dummy.group") + (pop gnus-newsrc-alist)) + ;; Do the sorting. + (setq gnus-newsrc-alist + (sort gnus-newsrc-alist func)) + (when reverse + (setq gnus-newsrc-alist (nreverse gnus-newsrc-alist))) + ;; Regenerate the hash table. + (gnus-make-hashtable-from-newsrc-alist))) + +(defun gnus-group-sort-groups-by-alphabet (&optional reverse) + "Sort the group buffer alphabetically by group name. +If REVERSE, sort in reverse order." + (interactive "P") + (gnus-group-sort-groups 'gnus-group-sort-by-alphabet reverse)) + +(defun gnus-group-sort-groups-by-unread (&optional reverse) + "Sort the group buffer by number of unread articles. +If REVERSE, sort in reverse order." + (interactive "P") + (gnus-group-sort-groups 'gnus-group-sort-by-unread reverse)) + +(defun gnus-group-sort-groups-by-level (&optional reverse) + "Sort the group buffer by group level. +If REVERSE, sort in reverse order." + (interactive "P") + (gnus-group-sort-groups 'gnus-group-sort-by-level reverse)) + +(defun gnus-group-sort-groups-by-score (&optional reverse) + "Sort the group buffer by group score. +If REVERSE, sort in reverse order." + (interactive "P") + (gnus-group-sort-groups 'gnus-group-sort-by-score reverse)) + +(defun gnus-group-sort-groups-by-rank (&optional reverse) + "Sort the group buffer by group rank. +If REVERSE, sort in reverse order." + (interactive "P") + (gnus-group-sort-groups 'gnus-group-sort-by-rank reverse)) + +(defun gnus-group-sort-groups-by-method (&optional reverse) + "Sort the group buffer alphabetically by backend name. +If REVERSE, sort in reverse order." + (interactive "P") + (gnus-group-sort-groups 'gnus-group-sort-by-method reverse)) + +;;; Selected group sorting. + +(defun gnus-group-sort-selected-groups (n func &optional reverse) + "Sort the process/prefixed groups." + (interactive (list current-prefix-arg gnus-group-sort-function)) + (let ((groups (gnus-group-process-prefix n))) + (funcall gnus-group-sort-selected-function + groups (gnus-make-sort-function func) reverse) + (gnus-group-list-groups))) + +(defun gnus-group-sort-selected-flat (groups func reverse) + (let (entries infos) + ;; First find all the group entries for these groups. + (while groups + (push (nthcdr 2 (gnus-gethash (pop groups) gnus-newsrc-hashtb)) + entries)) + ;; Then sort the infos. + (setq infos + (sort + (mapcar + (lambda (entry) (car entry)) + (setq entries (nreverse entries))) + func)) + (when reverse + (setq infos (nreverse infos))) + ;; Go through all the infos and replace the old entries + ;; with the new infos. + (while infos + (setcar entries (pop infos)) + (pop entries)) + ;; Update the hashtable. + (gnus-make-hashtable-from-newsrc-alist))) + +(defun gnus-group-sort-selected-groups-by-alphabet (&optional reverse) + "Sort the group buffer alphabetically by group name. +If REVERSE, sort in reverse order." + (interactive "P") + (gnus-group-sort-selected-groups 'gnus-group-sort-by-alphabet reverse)) + +(defun gnus-group-sort-selected-groups-by-unread (&optional reverse) + "Sort the group buffer by number of unread articles. +If REVERSE, sort in reverse order." + (interactive "P") + (gnus-group-sort-selected-groups 'gnus-group-sort-by-unread reverse)) + +(defun gnus-group-sort-selected-groups-by-level (&optional reverse) + "Sort the group buffer by group level. +If REVERSE, sort in reverse order." + (interactive "P") + (gnus-group-sort-selected-groups 'gnus-group-sort-by-level reverse)) + +(defun gnus-group-sort-selected-groups-by-score (&optional reverse) + "Sort the group buffer by group score. +If REVERSE, sort in reverse order." + (interactive "P") + (gnus-group-sort-selected-groups 'gnus-group-sort-by-score reverse)) + +(defun gnus-group-sort-selected-groups-by-rank (&optional reverse) + "Sort the group buffer by group rank. +If REVERSE, sort in reverse order." + (interactive "P") + (gnus-group-sort-selected-groups 'gnus-group-sort-by-rank reverse)) + +(defun gnus-group-sort-selected-groups-by-method (&optional reverse) + "Sort the group buffer alphabetically by backend name. +If REVERSE, sort in reverse order." + (interactive "P") + (gnus-group-sort-selected-groups 'gnus-group-sort-by-method reverse)) + +;;; Sorting predicates. + +(defun gnus-group-sort-by-alphabet (info1 info2) + "Sort alphabetically." + (string< (gnus-info-group info1) (gnus-info-group info2))) + +(defun gnus-group-sort-by-real-name (info1 info2) + "Sort alphabetically on real (unprefixed) names." + (string< (gnus-group-real-name (gnus-info-group info1)) + (gnus-group-real-name (gnus-info-group info2)))) + +(defun gnus-group-sort-by-unread (info1 info2) + "Sort by number of unread articles." + (let ((n1 (car (gnus-gethash (gnus-info-group info1) gnus-newsrc-hashtb))) + (n2 (car (gnus-gethash (gnus-info-group info2) gnus-newsrc-hashtb)))) + (< (or (and (numberp n1) n1) 0) + (or (and (numberp n2) n2) 0)))) + +(defun gnus-group-sort-by-level (info1 info2) + "Sort by level." + (< (gnus-info-level info1) (gnus-info-level info2))) + +(defun gnus-group-sort-by-method (info1 info2) + "Sort alphabetically by backend name." + (string< (symbol-name (car (gnus-find-method-for-group + (gnus-info-group info1) info1))) + (symbol-name (car (gnus-find-method-for-group + (gnus-info-group info2) info2))))) + +(defun gnus-group-sort-by-score (info1 info2) + "Sort by group score." + (< (gnus-info-score info1) (gnus-info-score info2))) + +(defun gnus-group-sort-by-rank (info1 info2) + "Sort by level and score." + (let ((level1 (gnus-info-level info1)) + (level2 (gnus-info-level info2))) + (or (< level1 level2) + (and (= level1 level2) + (> (gnus-info-score info1) (gnus-info-score info2)))))) + +;;; Clearing data + +(defun gnus-group-clear-data (&optional arg) + "Clear all marks and read ranges from the current group." + (interactive "P") + (gnus-group-iterate arg + (lambda (group) + (let (info) + (gnus-info-clear-data (setq info (gnus-get-info group))) + (gnus-get-unread-articles-in-group info (gnus-active group) t) + (when (gnus-group-goto-group group) + (gnus-group-update-group-line)))))) + +(defun gnus-group-clear-data-on-native-groups () + "Clear all marks and read ranges from all native groups." + (interactive) + (when (gnus-yes-or-no-p "Really clear all data from almost all groups? ") + (let ((alist (cdr gnus-newsrc-alist)) + info) + (while (setq info (pop alist)) + (when (gnus-group-native-p (gnus-info-group info)) + (gnus-info-clear-data info))) + (gnus-get-unread-articles) + (gnus-dribble-enter "") + (when (gnus-y-or-n-p + "Move the cache away to avoid problems in the future? ") + (call-interactively 'gnus-cache-move-cache))))) + +(defun gnus-info-clear-data (info) + "Clear all marks and read ranges from INFO." + (let ((group (gnus-info-group info))) + (gnus-undo-register + `(progn + (gnus-info-set-marks ',info ',(gnus-info-marks info) t) + (gnus-info-set-read ',info ',(gnus-info-read info)) + (when (gnus-group-goto-group ,group) + (gnus-group-update-group-line)))) + (gnus-info-set-read info nil) + (when (gnus-info-marks info) + (gnus-info-set-marks info nil)))) + +;; Group catching up. + +(defun gnus-group-catchup-current (&optional n all) + "Mark all articles not marked as unread in current newsgroup as read. +If prefix argument N is numeric, the ARG next newsgroups will be +caught up. If ALL is non-nil, marked articles will also be marked as +read. Cross references (Xref: header) of articles are ignored. +The difference between N and actual number of newsgroups that were +caught up is returned." + (interactive "P") + (unless (gnus-group-group-name) + (error "No group on the current line")) + (let ((groups (gnus-group-process-prefix n)) + (ret 0)) + (if (not + (or (not gnus-interactive-catchup) ;Without confirmation? + gnus-expert-user + (gnus-y-or-n-p + (format + (if all + "Do you really want to mark all articles in %s as read? " + "Mark all unread articles in %s as read? ") + (if (= (length groups) 1) + (car groups) + (format "these %d groups" (length groups))))))) + n + (while groups + ;; Virtual groups have to be given special treatment. + (let ((method (gnus-find-method-for-group (car groups)))) + (when (eq 'nnvirtual (car method)) + (nnvirtual-catchup-group + (gnus-group-real-name (car groups)) (nth 1 method) all))) + (gnus-group-remove-mark (car groups)) + (if (>= (gnus-group-group-level) gnus-level-zombie) + (gnus-message 2 "Dead groups can't be caught up") + (if (prog1 + (gnus-group-goto-group (car groups)) + (gnus-group-catchup (car groups) all)) + (gnus-group-update-group-line) + (setq ret (1+ ret)))) + (setq groups (cdr groups))) + (gnus-group-next-unread-group 1) + ret))) + +(defun gnus-group-catchup-current-all (&optional n) + "Mark all articles in current newsgroup as read. +Cross references (Xref: header) of articles are ignored." + (interactive "P") + (gnus-group-catchup-current n 'all)) + +(defun gnus-group-catchup (group &optional all) + "Mark all articles in GROUP as read. +If ALL is non-nil, all articles are marked as read. +The return value is the number of articles that were marked as read, +or nil if no action could be taken." + (let* ((entry (gnus-gethash group gnus-newsrc-hashtb)) + (num (car entry))) + ;; Do the updating only if the newsgroup isn't killed. + (if (not (numberp (car entry))) + (gnus-message 1 "Can't catch up %s; non-active group" group) + ;; Do auto-expirable marks if that's required. + (when (gnus-group-auto-expirable-p group) + (gnus-add-marked-articles + group 'expire (gnus-list-of-unread-articles group)) + (when all + (let ((marks (nth 3 (nth 2 entry)))) + (gnus-add-marked-articles + group 'expire (gnus-uncompress-range (cdr (assq 'tick marks)))) + (gnus-add-marked-articles + group 'expire (gnus-uncompress-range (cdr (assq 'tick marks))))))) + (when entry + (gnus-update-read-articles group nil) + ;; Also nix out the lists of marks and dormants. + (when all + (gnus-add-marked-articles group 'tick nil nil 'force) + (gnus-add-marked-articles group 'dormant nil nil 'force)) + (let ((gnus-newsgroup-name group)) + (run-hooks 'gnus-group-catchup-group-hook)) + num)))) + +(defun gnus-group-expire-articles (&optional n) + "Expire all expirable articles in the current newsgroup." + (interactive "P") + (let ((groups (gnus-group-process-prefix n)) + group) + (unless groups + (error "No groups to expire")) + (while (setq group (pop groups)) + (gnus-group-remove-mark group) + (when (gnus-check-backend-function 'request-expire-articles group) + (gnus-message 6 "Expiring articles in %s..." group) + (let* ((info (gnus-get-info group)) + (expirable (if (gnus-group-total-expirable-p group) + (cons nil (gnus-list-of-read-articles group)) + (assq 'expire (gnus-info-marks info)))) + (expiry-wait (gnus-group-find-parameter group 'expiry-wait))) + (when expirable + (setcdr + expirable + (gnus-compress-sequence + (if expiry-wait + ;; We set the expiry variables to the group + ;; parameter. + (let ((nnmail-expiry-wait-function nil) + (nnmail-expiry-wait expiry-wait)) + (gnus-request-expire-articles + (gnus-uncompress-sequence (cdr expirable)) group)) + ;; Just expire using the normal expiry values. + (gnus-request-expire-articles + (gnus-uncompress-sequence (cdr expirable)) group)))) + (gnus-close-group group)) + (gnus-message 6 "Expiring articles in %s...done" group))) + (gnus-group-position-point)))) + +(defun gnus-group-expire-all-groups () + "Expire all expirable articles in all newsgroups." + (interactive) + (save-excursion + (gnus-message 5 "Expiring...") + (let ((gnus-group-marked (mapcar (lambda (info) (gnus-info-group info)) + (cdr gnus-newsrc-alist)))) + (gnus-group-expire-articles nil))) + (gnus-group-position-point) + (gnus-message 5 "Expiring...done")) + +(defun gnus-group-set-current-level (n level) + "Set the level of the next N groups to LEVEL." + (interactive + (list + current-prefix-arg + (string-to-int + (let ((s (read-string + (format "Level (default %s): " + (or (gnus-group-group-level) + gnus-level-default-subscribed))))) + (if (string-match "^\\s-*$" s) + (int-to-string (or (gnus-group-group-level) + gnus-level-default-subscribed)) + s))))) + (unless (and (>= level 1) (<= level gnus-level-killed)) + (error "Illegal level: %d" level)) + (let ((groups (gnus-group-process-prefix n)) + group) + (while (setq group (pop groups)) + (gnus-group-remove-mark group) + (gnus-message 6 "Changed level of %s from %d to %d" + group (or (gnus-group-group-level) gnus-level-killed) + level) + (gnus-group-change-level + group level (or (gnus-group-group-level) gnus-level-killed)) + (gnus-group-update-group-line))) + (gnus-group-position-point)) + +(defun gnus-group-unsubscribe (&optional n) + "Unsubscribe the current group." + (interactive "P") + (gnus-group-unsubscribe-current-group n 'unsubscribe)) + +(defun gnus-group-subscribe (&optional n) + "Unsubscribe the current group." + (interactive "P") + (gnus-group-unsubscribe-current-group n 'subscribe)) + +(defun gnus-group-unsubscribe-current-group (&optional n do-sub) + "Toggle subscription of the current group. +If given numerical prefix, toggle the N next groups." + (interactive "P") + (let ((groups (gnus-group-process-prefix n)) + group) + (while groups + (setq group (car groups) + groups (cdr groups)) + (gnus-group-remove-mark group) + (gnus-group-unsubscribe-group + group + (cond + ((eq do-sub 'unsubscribe) + gnus-level-default-unsubscribed) + ((eq do-sub 'subscribe) + gnus-level-default-subscribed) + ((<= (gnus-group-group-level) gnus-level-subscribed) + gnus-level-default-unsubscribed) + (t + gnus-level-default-subscribed)) + t) + (gnus-group-update-group-line)) + (gnus-group-next-group 1))) + +(defun gnus-group-unsubscribe-group (group &optional level silent) + "Toggle subscription to GROUP. +Killed newsgroups are subscribed. If SILENT, don't try to update the +group line." + (interactive + (list (completing-read + "Group: " gnus-active-hashtb nil + (gnus-read-active-file-p) + nil + 'gnus-group-history))) + (let ((newsrc (gnus-gethash group gnus-newsrc-hashtb))) + (cond + ((string-match "^[ \t]$" group) + (error "Empty group name")) + (newsrc + ;; Toggle subscription flag. + (gnus-group-change-level + newsrc (if level level (if (<= (nth 1 (nth 2 newsrc)) + gnus-level-subscribed) + (1+ gnus-level-subscribed) + gnus-level-default-subscribed))) + (unless silent + (gnus-group-update-group group))) + ((and (stringp group) + (or (not (gnus-read-active-file-p)) + (gnus-active group))) + ;; Add new newsgroup. + (gnus-group-change-level + group + (if level level gnus-level-default-subscribed) + (or (and (member group gnus-zombie-list) + gnus-level-zombie) + gnus-level-killed) + (when (gnus-group-group-name) + (gnus-gethash (gnus-group-group-name) gnus-newsrc-hashtb))) + (unless silent + (gnus-group-update-group group))) + (t (error "No such newsgroup: %s" group))) + (gnus-group-position-point))) + +(defun gnus-group-transpose-groups (n) + "Move the current newsgroup up N places. +If given a negative prefix, move down instead. The difference between +N and the number of steps taken is returned." + (interactive "p") + (unless (gnus-group-group-name) + (error "No group on current line")) + (gnus-group-kill-group 1) + (prog1 + (forward-line (- n)) + (gnus-group-yank-group) + (gnus-group-position-point))) + +(defun gnus-group-kill-all-zombies () + "Kill all zombie newsgroups." + (interactive) + (setq gnus-killed-list (nconc gnus-zombie-list gnus-killed-list)) + (setq gnus-zombie-list nil) + (gnus-group-list-groups)) + +(defun gnus-group-kill-region (begin end) + "Kill newsgroups in current region (excluding current point). +The killed newsgroups can be yanked by using \\[gnus-group-yank-group]." + (interactive "r") + (let ((lines + ;; Count lines. + (save-excursion + (count-lines + (progn + (goto-char begin) + (beginning-of-line) + (point)) + (progn + (goto-char end) + (beginning-of-line) + (point)))))) + (goto-char begin) + (beginning-of-line) ;Important when LINES < 1 + (gnus-group-kill-group lines))) + +(defun gnus-group-kill-group (&optional n discard) + "Kill the next N groups. +The killed newsgroups can be yanked by using \\[gnus-group-yank-group]. +However, only groups that were alive can be yanked; already killed +groups or zombie groups can't be yanked. +The return value is the name of the group that was killed, or a list +of groups killed." + (interactive "P") + (let ((buffer-read-only nil) + (groups (gnus-group-process-prefix n)) + group entry level out) + (if (< (length groups) 10) + ;; This is faster when there are few groups. + (while groups + (push (setq group (pop groups)) out) + (gnus-group-remove-mark group) + (setq level (gnus-group-group-level)) + (gnus-delete-line) + (when (and (not discard) + (setq entry (gnus-gethash group gnus-newsrc-hashtb))) + (gnus-undo-register + `(progn + (gnus-group-goto-group ,(gnus-group-group-name)) + (gnus-group-yank-group))) + (push (cons (car entry) (nth 2 entry)) + gnus-list-of-killed-groups)) + (gnus-group-change-level + (if entry entry group) gnus-level-killed (if entry nil level))) + ;; If there are lots and lots of groups to be killed, we use + ;; this thing instead. + (let (entry) + (setq groups (nreverse groups)) + (while groups + (gnus-group-remove-mark (setq group (pop groups))) + (gnus-delete-line) + (push group gnus-killed-list) + (setq gnus-newsrc-alist + (delq (assoc group gnus-newsrc-alist) + gnus-newsrc-alist)) + (when gnus-group-change-level-function + (funcall gnus-group-change-level-function group 9 3)) + (cond + ((setq entry (gnus-gethash group gnus-newsrc-hashtb)) + (push (cons (car entry) (nth 2 entry)) + gnus-list-of-killed-groups) + (setcdr (cdr entry) (cdddr entry))) + ((member group gnus-zombie-list) + (setq gnus-zombie-list (delete group gnus-zombie-list))))) + (gnus-make-hashtable-from-newsrc-alist))) + + (gnus-group-position-point) + (if (< (length out) 2) (car out) (nreverse out)))) + +(defun gnus-group-yank-group (&optional arg) + "Yank the last newsgroups killed with \\[gnus-group-kill-group], +inserting it before the current newsgroup. The numeric ARG specifies +how many newsgroups are to be yanked. The name of the newsgroup yanked +is returned, or (if several groups are yanked) a list of yanked groups +is returned." + (interactive "p") + (setq arg (or arg 1)) + (let (info group prev out) + (while (>= (decf arg) 0) + (when (not (setq info (pop gnus-list-of-killed-groups))) + (error "No more newsgroups to yank")) + (push (setq group (nth 1 info)) out) + ;; Find which newsgroup to insert this one before - search + ;; backward until something suitable is found. If there are no + ;; other newsgroups in this buffer, just make this newsgroup the + ;; first newsgroup. + (setq prev (gnus-group-group-name)) + (gnus-group-change-level + info (gnus-info-level (cdr info)) gnus-level-killed + (and prev (gnus-gethash prev gnus-newsrc-hashtb)) + t) + (gnus-group-insert-group-line-info group) + (gnus-undo-register + `(when (gnus-group-goto-group ,group) + (gnus-group-kill-group 1)))) + (forward-line -1) + (gnus-group-position-point) + (if (< (length out) 2) (car out) (nreverse out)))) + +(defun gnus-group-kill-level (level) + "Kill all groups that is on a certain LEVEL." + (interactive "nKill all groups on level: ") + (cond + ((= level gnus-level-zombie) + (setq gnus-killed-list + (nconc gnus-zombie-list gnus-killed-list)) + (setq gnus-zombie-list nil)) + ((and (< level gnus-level-zombie) + (> level 0) + (or gnus-expert-user + (gnus-yes-or-no-p + (format + "Do you really want to kill all groups on level %d? " + level)))) + (let* ((prev gnus-newsrc-alist) + (alist (cdr prev))) + (while alist + (if (= (gnus-info-level (car alist)) level) + (progn + (push (gnus-info-group (car alist)) gnus-killed-list) + (setcdr prev (cdr alist))) + (setq prev alist)) + (setq alist (cdr alist))) + (gnus-make-hashtable-from-newsrc-alist) + (gnus-group-list-groups))) + (t + (error "Can't kill; illegal level: %d" level)))) + +(defun gnus-group-list-all-groups (&optional arg) + "List all newsgroups with level ARG or lower. +Default is gnus-level-unsubscribed, which lists all subscribed and most +unsubscribed groups." + (interactive "P") + (gnus-group-list-groups (or arg gnus-level-unsubscribed) t)) + +;; Redefine this to list ALL killed groups if prefix arg used. +;; Rewritten by engstrom@src.honeywell.com (Eric Engstrom). +(defun gnus-group-list-killed (&optional arg) + "List all killed newsgroups in the group buffer. +If ARG is non-nil, list ALL killed groups known to Gnus. This may +entail asking the server for the groups." + (interactive "P") + ;; Find all possible killed newsgroups if arg. + (when arg + (gnus-get-killed-groups)) + (if (not gnus-killed-list) + (gnus-message 6 "No killed groups") + (let (gnus-group-list-mode) + (funcall gnus-group-prepare-function + gnus-level-killed t gnus-level-killed)) + (goto-char (point-min))) + (gnus-group-position-point)) + +(defun gnus-group-list-zombies () + "List all zombie newsgroups in the group buffer." + (interactive) + (if (not gnus-zombie-list) + (gnus-message 6 "No zombie groups") + (let (gnus-group-list-mode) + (funcall gnus-group-prepare-function + gnus-level-zombie t gnus-level-zombie)) + (goto-char (point-min))) + (gnus-group-position-point)) + +(defun gnus-group-list-active () + "List all groups that are available from the server(s)." + (interactive) + ;; First we make sure that we have really read the active file. + (unless (gnus-read-active-file-p) + (let ((gnus-read-active-file t)) + (gnus-read-active-file))) + ;; Find all groups and sort them. + (let ((groups + (sort + (let (list) + (mapatoms + (lambda (sym) + (and (boundp sym) + (symbol-value sym) + (push (symbol-name sym) list))) + gnus-active-hashtb) + list) + 'string<)) + (buffer-read-only nil) + group) + (erase-buffer) + (while groups + (gnus-add-text-properties + (point) (prog1 (1+ (point)) + (insert " *: " + (setq group (pop groups)) "\n")) + (list 'gnus-group (gnus-intern-safe group gnus-active-hashtb) + 'gnus-unread t + 'gnus-level (inline (gnus-group-level group))))) + (goto-char (point-min)))) + +(defun gnus-activate-all-groups (level) + "Activate absolutely all groups." + (interactive (list 7)) + (let ((gnus-activate-level level) + (gnus-activate-foreign-newsgroups level)) + (gnus-group-get-new-news))) + +(defun gnus-group-get-new-news (&optional arg) + "Get newly arrived articles. +If ARG is a number, it specifies which levels you are interested in +re-scanning. If ARG is non-nil and not a number, this will force +\"hard\" re-reading of the active files from all servers." + (interactive "P") + (run-hooks 'gnus-get-new-news-hook) + + ;; Read any slave files. + (unless gnus-slave + (gnus-master-read-slave-newsrc)) + + ;; We might read in new NoCeM messages here. + (when (and gnus-use-nocem + (null 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))) + (run-hooks 'gnus-after-getting-new-news-hook) + (gnus-group-list-groups)) + +(defun gnus-group-get-new-news-this-group (&optional n) + "Check for newly arrived news in the current group (and the N-1 next groups). +The difference between N and the number of newsgroup checked is returned. +If N is negative, this group and the N-1 previous groups will be checked." + (interactive "P") + (let* ((groups (gnus-group-process-prefix n)) + (ret (if (numberp n) (- n (length groups)) 0)) + (beg (unless n + (point))) + group) + (while (setq group (pop groups)) + (gnus-group-remove-mark group) + ;; Bypass any previous denials from the server. + (gnus-remove-denial (gnus-find-method-for-group group)) + (if (gnus-activate-group group 'scan) + (progn + (gnus-get-unread-articles-in-group + (gnus-get-info group) (gnus-active group) t) + (unless (gnus-virtual-group-p group) + (gnus-close-group group)) + (gnus-group-update-group group)) + (if (eq (gnus-server-status (gnus-find-method-for-group group)) + 'denied) + (gnus-error 3 "Server denied access") + (gnus-error 3 "%s error: %s" group (gnus-status-message group))))) + (when beg + (goto-char beg)) + (when gnus-goto-next-group-when-activating + (gnus-group-next-unread-group 1 t)) + (gnus-summary-position-point) + ret)) + +(defun gnus-group-fetch-faq (group &optional faq-dir) + "Fetch the FAQ for the current group. +If given a prefix argument, prompt for the FAQ dir +to use." + (interactive + (list + (gnus-group-group-name) + (cond (current-prefix-arg + (completing-read + "Faq dir: " (and (listp gnus-group-faq-directory) + (mapcar (lambda (file) (list file)) + gnus-group-faq-directory))))))) + (unless group + (error "No group name given")) + (let ((dirs (or faq-dir gnus-group-faq-directory)) + dir found file) + (unless (listp dirs) + (setq dirs (list dirs))) + (while (and (not found) + (setq dir (pop dirs))) + (setq file (concat (file-name-as-directory dir) + (gnus-group-real-name group))) + (if (not (file-exists-p file)) + (gnus-message 1 "No such file: %s" file) + (let ((enable-local-variables nil)) + (find-file file) + (setq found t)))))) + +(defun gnus-group-describe-group (force &optional group) + "Display a description of the current newsgroup." + (interactive (list current-prefix-arg (gnus-group-group-name))) + (let* ((method (gnus-find-method-for-group group)) + (mname (gnus-group-prefixed-name "" method)) + desc) + (when (and force + gnus-description-hashtb) + (gnus-sethash mname nil gnus-description-hashtb)) + (unless group + (error "No group name given")) + (when (or (and gnus-description-hashtb + ;; We check whether this group's method has been + ;; queried for a description file. + (gnus-gethash mname gnus-description-hashtb)) + (setq desc (gnus-group-get-description group)) + (gnus-read-descriptions-file method)) + (gnus-message 1 + (or desc (gnus-gethash group gnus-description-hashtb) + "No description available"))))) + +;; Suggested by Per Abrahamsen . +(defun gnus-group-describe-all-groups (&optional force) + "Pop up a buffer with descriptions of all newsgroups." + (interactive "P") + (when force + (setq gnus-description-hashtb nil)) + (when (not (or gnus-description-hashtb + (gnus-read-all-descriptions-files))) + (error "Couldn't request descriptions file")) + (let ((buffer-read-only nil) + b) + (erase-buffer) + (mapatoms + (lambda (group) + (setq b (point)) + (insert (format " *: %-20s %s\n" (symbol-name group) + (symbol-value group))) + (gnus-add-text-properties + b (1+ b) (list 'gnus-group group + 'gnus-unread t 'gnus-marked nil + 'gnus-level (1+ gnus-level-subscribed)))) + gnus-description-hashtb) + (goto-char (point-min)) + (gnus-group-position-point))) + +;; Suggested by Daniel Quinlan . +(defun gnus-group-apropos (regexp &optional search-description) + "List all newsgroups that have names that match a regexp." + (interactive "sGnus apropos (regexp): ") + (let ((prev "") + (obuf (current-buffer)) + groups des) + ;; Go through all newsgroups that are known to Gnus. + (mapatoms + (lambda (group) + (and (symbol-name group) + (string-match regexp (symbol-name group)) + (push (symbol-name group) groups))) + gnus-active-hashtb) + ;; Also go through all descriptions that are known to Gnus. + (when search-description + (mapatoms + (lambda (group) + (and (string-match regexp (symbol-value group)) + (gnus-active (symbol-name group)) + (push (symbol-name group) groups))) + gnus-description-hashtb)) + (if (not groups) + (gnus-message 3 "No groups matched \"%s\"." regexp) + ;; Print out all the groups. + (save-excursion + (pop-to-buffer "*Gnus Help*") + (buffer-disable-undo (current-buffer)) + (erase-buffer) + (setq groups (sort groups 'string<)) + (while groups + ;; Groups may be entered twice into the list of groups. + (when (not (string= (car groups) prev)) + (insert (setq prev (car groups)) "\n") + (when (and gnus-description-hashtb + (setq des (gnus-gethash (car groups) + gnus-description-hashtb))) + (insert " " des "\n"))) + (setq groups (cdr groups))) + (goto-char (point-min)))) + (pop-to-buffer obuf))) + +(defun gnus-group-description-apropos (regexp) + "List all newsgroups that have names or descriptions that match a regexp." + (interactive "sGnus description apropos (regexp): ") + (when (not (or gnus-description-hashtb + (gnus-read-all-descriptions-files))) + (error "Couldn't request descriptions file")) + (gnus-group-apropos regexp t)) + +;; Suggested by Per Abrahamsen . +(defun gnus-group-list-matching (level regexp &optional all lowest) + "List all groups with unread articles that match REGEXP. +If the prefix LEVEL is non-nil, it should be a number that says which +level to cut off listing groups. +If ALL, also list groups with no unread articles. +If LOWEST, don't list groups with level lower than LOWEST. + +This command may read the active file." + (interactive "P\nsList newsgroups matching: ") + ;; First make sure active file has been read. + (when (and level + (> (prefix-numeric-value level) gnus-level-killed)) + (gnus-get-killed-groups)) + (gnus-group-prepare-flat + (or level gnus-level-subscribed) all (or lowest 1) regexp) + (goto-char (point-min)) + (gnus-group-position-point)) + +(defun gnus-group-list-all-matching (level regexp &optional lowest) + "List all groups that match REGEXP. +If the prefix LEVEL is non-nil, it should be a number that says which +level to cut off listing groups. +If LOWEST, don't list groups with level lower than LOWEST." + (interactive "P\nsList newsgroups matching: ") + (when level + (setq level (prefix-numeric-value level))) + (gnus-group-list-matching (or level gnus-level-killed) regexp t lowest)) + +;; Suggested by Jack Vinson . +(defun gnus-group-save-newsrc (&optional force) + "Save the Gnus startup files. +If FORCE, force saving whether it is necessary or not." + (interactive "P") + (gnus-save-newsrc-file force)) + +(defun gnus-group-restart (&optional arg) + "Force Gnus to read the .newsrc file." + (interactive "P") + (when (gnus-yes-or-no-p + (format "Are you sure you want to restart Gnus? ")) + (gnus-save-newsrc-file) + (gnus-clear-system) + (gnus))) + +(defun gnus-group-read-init-file () + "Read the Gnus elisp init file." + (interactive) + (gnus-read-init-file)) + +(defun gnus-group-check-bogus-groups (&optional silent) + "Check bogus newsgroups. +If given a prefix, don't ask for confirmation before removing a bogus +group." + (interactive "P") + (gnus-check-bogus-newsgroups (and (not silent) (not gnus-expert-user))) + (gnus-group-list-groups)) + +(defun gnus-group-edit-global-kill (&optional article group) + "Edit the global kill file. +If GROUP, edit that local kill file instead." + (interactive "P") + (setq gnus-current-kill-article article) + (gnus-kill-file-edit-file group) + (gnus-message + 6 + (substitute-command-keys + (format "Editing a %s kill file (Type \\[gnus-kill-file-exit] to exit)" + (if group "local" "global"))))) + +(defun gnus-group-edit-local-kill (article group) + "Edit a local kill file." + (interactive (list nil (gnus-group-group-name))) + (gnus-group-edit-global-kill article group)) + +(defun gnus-group-force-update () + "Update `.newsrc' file." + (interactive) + (gnus-save-newsrc-file)) + +(defun gnus-group-suspend () + "Suspend the current Gnus session. +In fact, cleanup buffers except for group mode buffer. +The hook gnus-suspend-gnus-hook is called before actually suspending." + (interactive) + (run-hooks 'gnus-suspend-gnus-hook) + ;; Kill Gnus buffers except for group mode buffer. + (let* ((group-buf (get-buffer gnus-group-buffer)) + ;; Do this on a separate list in case the user does a ^G before we finish + (gnus-buffer-list + (delete group-buf (delete gnus-dribble-buffer + (append gnus-buffer-list nil))))) + (while gnus-buffer-list + (gnus-kill-buffer (pop gnus-buffer-list))) + (gnus-kill-gnus-frames) + (when group-buf + (setq gnus-buffer-list (list group-buf)) + (bury-buffer group-buf) + (delete-windows-on group-buf t)))) + +(defun gnus-group-clear-dribble () + "Clear all information from the dribble buffer." + (interactive) + (gnus-dribble-clear) + (gnus-message 7 "Cleared dribble buffer")) + +(defun gnus-group-exit () + "Quit reading news after updating .newsrc.eld and .newsrc. +The hook `gnus-exit-gnus-hook' is called before actually exiting." + (interactive) + (when + (or noninteractive ;For gnus-batch-kill + (not gnus-interactive-exit) ;Without confirmation + gnus-expert-user + (gnus-y-or-n-p "Are you sure you want to quit reading news? ")) + (run-hooks 'gnus-exit-gnus-hook) + ;; Offer to save data from non-quitted summary buffers. + (gnus-offer-save-summaries) + ;; Save the newsrc file(s). + (gnus-save-newsrc-file) + ;; Kill-em-all. + (gnus-close-backends) + ;; Reset everything. + (gnus-clear-system) + ;; Allow the user to do things after cleaning up. + (run-hooks 'gnus-after-exiting-gnus-hook))) + +(defun gnus-group-quit () + "Quit reading news without updating .newsrc.eld or .newsrc. +The hook `gnus-exit-gnus-hook' is called before actually exiting." + (interactive) + (when (or noninteractive ;For gnus-batch-kill + (zerop (buffer-size)) + (not (gnus-server-opened gnus-select-method)) + gnus-expert-user + (not gnus-current-startup-file) + (gnus-yes-or-no-p + (format "Quit reading news without saving %s? " + (file-name-nondirectory gnus-current-startup-file)))) + (run-hooks 'gnus-exit-gnus-hook) + (gnus-configure-windows 'group t) + (gnus-dribble-save) + (gnus-close-backends) + (gnus-clear-system) + (gnus-kill-buffer gnus-group-buffer) + ;; Allow the user to do things after cleaning up. + (run-hooks 'gnus-after-exiting-gnus-hook))) + +(defun gnus-group-describe-briefly () + "Give a one line description of the group mode commands." + (interactive) + (gnus-message 7 (substitute-command-keys "\\\\[gnus-group-read-group]:Select \\[gnus-group-next-unread-group]:Forward \\[gnus-group-prev-unread-group]:Backward \\[gnus-group-exit]:Exit \\[gnus-info-find-node]:Run Info \\[gnus-group-describe-briefly]:This help"))) + +(defun gnus-group-browse-foreign-server (method) + "Browse a foreign news server. +If called interactively, this function will ask for a select method + (nntp, nnspool, etc.) and a server address (eg. nntp.some.where). +If not, METHOD should be a list where the first element is the method +and the second element is the address." + (interactive + (list (let ((how (completing-read + "Which backend: " + (append gnus-valid-select-methods gnus-server-alist) + nil t (cons "nntp" 0) 'gnus-method-history))) + ;; We either got a backend name or a virtual server name. + ;; If the first, we also need an address. + (if (assoc how gnus-valid-select-methods) + (list (intern how) + ;; Suggested by mapjph@bath.ac.uk. + (completing-read + "Address: " + (mapcar (lambda (server) (list server)) + gnus-secondary-servers))) + ;; We got a server name, so we find the method. + (gnus-server-to-method how))))) + (gnus-browse-foreign-server method)) + +(defun gnus-group-set-info (info &optional method-only-group part) + (let* ((entry (gnus-gethash + (or method-only-group (gnus-info-group info)) + gnus-newsrc-hashtb)) + (part-info info) + (info (if method-only-group (nth 2 entry) info)) + method) + (when method-only-group + (unless entry + (error "Trying to change non-existent group %s" method-only-group)) + ;; We have received parts of the actual group info - either the + ;; select method or the group parameters. We first check + ;; whether we have to extend the info, and if so, do that. + (let ((len (length info)) + (total (if (eq part 'method) 5 6))) + (when (< len total) + (setcdr (nthcdr (1- len) info) + (make-list (- total len) nil))) + ;; Then we enter the new info. + (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) + (setq method (gnus-info-method info)) + (when (gnus-server-equal method "native") + (setq method nil)) + (save-excursion + (set-buffer gnus-group-buffer) + (if method + ;; It's a foreign group... + (gnus-group-make-group + (gnus-group-real-name (gnus-info-group info)) + (if (stringp method) method + (prin1-to-string (car method))) + (and (consp method) + (nth 1 (gnus-info-method info)))) + ;; It's a native group. + (gnus-group-make-group (gnus-info-group info)))) + (gnus-message 6 "Note: New group created") + (setq entry + (gnus-gethash (gnus-group-prefixed-name + (gnus-group-real-name (gnus-info-group info)) + (or (gnus-info-method info) gnus-select-method)) + gnus-newsrc-hashtb)))) + ;; Whether it was a new group or not, we now have the entry, so we + ;; can do the update. + (if entry + (progn + (setcar (nthcdr 2 entry) info) + (when (and (not (eq (car entry) t)) + (gnus-active (gnus-info-group info))) + (setcar entry (length (gnus-list-of-unread-articles (car info)))))) + (error "No such group: %s" (gnus-info-group info))))) + +(defun gnus-group-set-method-info (group select-method) + (gnus-group-set-info select-method group 'method)) + +(defun gnus-group-set-params-info (group params) + (gnus-group-set-info params group 'params)) + +(defun gnus-add-marked-articles (group type articles &optional info force) + ;; Add ARTICLES of TYPE to the info of GROUP. + ;; If INFO is non-nil, use that info. If FORCE is non-nil, don't + ;; add, but replace marked articles of TYPE with ARTICLES. + (let ((info (or info (gnus-get-info group))) + (uncompressed '(score bookmark killed)) + marked m) + (or (not info) + (and (not (setq marked (nthcdr 3 info))) + (or (null articles) + (setcdr (nthcdr 2 info) + (list (list (cons type (gnus-compress-sequence + articles t))))))) + (and (not (setq m (assq type (car marked)))) + (or (null articles) + (setcar marked + (cons (cons type (gnus-compress-sequence articles t) ) + (car marked))))) + (if force + (if (null articles) + (setcar (nthcdr 3 info) + (delq (assq type (car marked)) (car marked))) + (setcdr m (gnus-compress-sequence articles t))) + (setcdr m (gnus-compress-sequence + (sort (nconc (gnus-uncompress-range (cdr m)) + (copy-sequence articles)) '<) t)))))) + +;;; +;;; Group timestamps +;;; + +(defun gnus-group-set-timestamp () + "Change the timestamp of the current group to the current time. +This function can be used in hooks like `gnus-select-group-hook' +or `gnus-group-catchup-group-hook'." + (when gnus-newsgroup-name + (let ((time (current-time))) + (setcdr (cdr time) nil) + (gnus-group-set-parameter gnus-newsgroup-name 'timestamp time)))) + +(defsubst gnus-group-timestamp (group) + "Return the timestamp for GROUP." + (gnus-group-get-parameter group 'timestamp)) + +(defun gnus-group-timestamp-delta (group) + "Return the offset in seconds from the timestamp for GROUP to the current time, as a floating point number." + (let* ((time (or (gnus-group-timestamp group) + (list 0 0))) + (delta (gnus-time-minus (current-time) time))) + (+ (* (nth 0 delta) 65536.0) + (nth 1 delta)))) + +(defun gnus-group-timestamp-string (group) + "Return a string of the timestamp for GROUP." + (let ((time (gnus-group-timestamp group))) + (if (not time) + "" + (gnus-time-iso8601 time)))) + +(provide 'gnus-group) + +;;; gnus-group.el ends here diff -r ad457d5f7d04 -r 0293115a14e9 lisp/gnus/gnus-int.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus/gnus-int.el Mon Aug 13 08:49:20 2007 +0200 @@ -0,0 +1,436 @@ +;;; gnus-int.el --- backend interface functions for Gnus +;; Copyright (C) 1996,97 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen +;; Keywords: news + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;;; Code: + +(require 'gnus) + +(defcustom gnus-open-server-hook nil + "Hook called just before opening connection to the news server." + :group 'gnus-start + :type 'hook) + +;;; +;;; Server Communication +;;; + +(defun gnus-start-news-server (&optional confirm) + "Open a method for getting news. +If CONFIRM is non-nil, the user will be asked for an NNTP server." + (let (how) + (if gnus-current-select-method + ;; Stream is already opened. + nil + ;; Open NNTP server. + (unless gnus-nntp-service + (setq gnus-nntp-server nil)) + (when confirm + ;; Read server name with completion. + (setq gnus-nntp-server + (completing-read "NNTP server: " + (mapcar (lambda (server) (list server)) + (cons (list gnus-nntp-server) + gnus-secondary-servers)) + nil nil gnus-nntp-server))) + + (when (and gnus-nntp-server + (stringp gnus-nntp-server) + (not (string= gnus-nntp-server ""))) + (setq gnus-select-method + (cond ((or (string= gnus-nntp-server "") + (string= gnus-nntp-server "::")) + (list 'nnspool (system-name))) + ((string-match "^:" gnus-nntp-server) + (list 'nnmh gnus-nntp-server + (list 'nnmh-directory + (file-name-as-directory + (expand-file-name + (concat "~/" (substring + gnus-nntp-server 1))))) + (list 'nnmh-get-new-mail nil))) + (t + (list 'nntp gnus-nntp-server))))) + + (setq how (car gnus-select-method)) + (cond + ((eq how 'nnspool) + (require 'nnspool) + (gnus-message 5 "Looking up local news spool...")) + ((eq how 'nnmh) + (require 'nnmh) + (gnus-message 5 "Looking up mh spool...")) + (t + (require 'nntp))) + (setq gnus-current-select-method gnus-select-method) + (run-hooks 'gnus-open-server-hook) + (or + ;; gnus-open-server-hook might have opened it + (gnus-server-opened gnus-select-method) + (gnus-open-server gnus-select-method) + (gnus-y-or-n-p + (format + "%s (%s) open error: '%s'. Continue? " + (car gnus-select-method) (cadr gnus-select-method) + (gnus-status-message gnus-select-method))) + (gnus-error 1 "Couldn't open server on %s" + (nth 1 gnus-select-method)))))) + +(defun gnus-check-group (group) + "Try to make sure that the server where GROUP exists is alive." + (let ((method (gnus-find-method-for-group group))) + (or (gnus-server-opened method) + (gnus-open-server method)))) + +(defun gnus-check-server (&optional method silent) + "Check whether the connection to METHOD is down. +If METHOD is nil, use `gnus-select-method'. +If it is down, start it up (again)." + (let ((method (or method gnus-select-method))) + ;; Transform virtual server names into select methods. + (when (stringp method) + (setq method (gnus-server-to-method method))) + (if (gnus-server-opened method) + ;; The stream is already opened. + t + ;; Open the server. + (unless silent + (gnus-message 5 "Opening %s server%s..." (car method) + (if (equal (nth 1 method) "") "" + (format " on %s" (nth 1 method))))) + (run-hooks 'gnus-open-server-hook) + (prog1 + (gnus-open-server method) + (unless silent + (message "")))))) + +(defun gnus-get-function (method function &optional noerror) + "Return a function symbol based on METHOD and FUNCTION." + ;; Translate server names into methods. + (unless method + (error "Attempted use of a nil select method")) + (when (stringp method) + (setq method (gnus-server-to-method method))) + (let ((func (intern (format "%s-%s" (car method) function)))) + ;; If the functions isn't bound, we require the backend in + ;; question. + (unless (fboundp func) + (require (car method)) + (when (and (not (fboundp func)) + (not noerror)) + ;; This backend doesn't implement this function. + (error "No such function: %s" func))) + func)) + + +;;; +;;; Interface functions to the backends. +;;; + +(defun gnus-open-server (method) + "Open a connection to METHOD." + (when (stringp method) + (setq method (gnus-server-to-method method))) + (let ((elem (assoc method gnus-opened-servers))) + ;; If this method was previously denied, we just return nil. + (if (eq (nth 1 elem) 'denied) + (progn + (gnus-message 1 "Denied server") + nil) + ;; Open the server. + (let ((result + (funcall (gnus-get-function method 'open-server) + (nth 1 method) (nthcdr 2 method)))) + ;; If this hasn't been opened before, we add it to the list. + (unless elem + (setq elem (list method nil) + gnus-opened-servers (cons elem gnus-opened-servers))) + ;; Set the status of this server. + (setcar (cdr elem) (if result 'ok 'denied)) + ;; Return the result from the "open" call. + result)))) + +(defun gnus-close-server (method) + "Close the connection to METHOD." + (when (stringp method) + (setq method (gnus-server-to-method method))) + (funcall (gnus-get-function method 'close-server) (nth 1 method))) + +(defun gnus-request-list (method) + "Request the active file from METHOD." + (when (stringp method) + (setq method (gnus-server-to-method method))) + (funcall (gnus-get-function method 'request-list) (nth 1 method))) + +(defun gnus-request-list-newsgroups (method) + "Request the newsgroups file from METHOD." + (when (stringp method) + (setq method (gnus-server-to-method method))) + (funcall (gnus-get-function method 'request-list-newsgroups) (nth 1 method))) + +(defun gnus-request-newgroups (date method) + "Request all new groups since DATE from METHOD." + (when (stringp method) + (setq method (gnus-server-to-method method))) + (let ((func (gnus-get-function method 'request-newgroups t))) + (when func + (funcall func date (nth 1 method))))) + +(defun gnus-server-opened (method) + "Check whether a connection to METHOD has been opened." + (when (stringp method) + (setq method (gnus-server-to-method method))) + (funcall (gnus-get-function method 'server-opened) (nth 1 method))) + +(defun gnus-status-message (method) + "Return the status message from METHOD. +If METHOD is a string, it is interpreted as a group name. The method +this group uses will be queried." + (let ((method (if (stringp method) (gnus-find-method-for-group method) + method))) + (funcall (gnus-get-function method 'status-message) (nth 1 method)))) + +(defun gnus-request-regenerate (method) + "Request a data generation from METHOD." + (when (stringp method) + (setq method (gnus-server-to-method method))) + (funcall (gnus-get-function method 'request-regenerate) (nth 1 method))) + +(defun gnus-request-group (group &optional dont-check method) + "Request GROUP. If DONT-CHECK, no information is required." + (let ((method (or method (gnus-find-method-for-group group)))) + (when (stringp method) + (setq method (gnus-server-to-method method))) + (funcall (gnus-get-function method 'request-group) + (gnus-group-real-name group) (nth 1 method) dont-check))) + +(defun gnus-list-active-group (group) + "Request active information on GROUP." + (let ((method (gnus-find-method-for-group group)) + (func 'list-active-group)) + (when (gnus-check-backend-function func group) + (funcall (gnus-get-function method func) + (gnus-group-real-name group) (nth 1 method))))) + +(defun gnus-request-group-description (group) + "Request a description of GROUP." + (let ((method (gnus-find-method-for-group group)) + (func 'request-group-description)) + (when (gnus-check-backend-function func group) + (funcall (gnus-get-function method func) + (gnus-group-real-name group) (nth 1 method))))) + +(defun gnus-close-group (group) + "Request the GROUP be closed." + (let ((method (gnus-find-method-for-group group))) + (funcall (gnus-get-function method 'close-group) + (gnus-group-real-name group) (nth 1 method)))) + +(defun gnus-retrieve-headers (articles group &optional fetch-old) + "Request headers for ARTICLES in GROUP. +If FETCH-OLD, retrieve all headers (or some subset thereof) in the group." + (let ((method (gnus-find-method-for-group group))) + (if (and gnus-use-cache (numberp (car articles))) + (gnus-cache-retrieve-headers articles group fetch-old) + (funcall (gnus-get-function method 'retrieve-headers) + articles (gnus-group-real-name group) (nth 1 method) + fetch-old)))) + +(defun gnus-retrieve-groups (groups method) + "Request active information on GROUPS from METHOD." + (when (stringp method) + (setq method (gnus-server-to-method method))) + (funcall (gnus-get-function method 'retrieve-groups) groups (nth 1 method))) + +(defun gnus-request-type (group &optional article) + "Return the type (`post' or `mail') of GROUP (and ARTICLE)." + (let ((method (gnus-find-method-for-group group))) + (if (not (gnus-check-backend-function 'request-type (car method))) + 'unknown + (funcall (gnus-get-function method 'request-type) + (gnus-group-real-name group) article)))) + +(defun gnus-request-update-mark (group article mark) + "Return the type (`post' or `mail') of GROUP (and ARTICLE)." + (let ((method (gnus-find-method-for-group group))) + (if (not (gnus-check-backend-function 'request-update-mark (car method))) + mark + (funcall (gnus-get-function method 'request-update-mark) + (gnus-group-real-name group) article mark)))) + +(defun gnus-request-article (article group &optional buffer) + "Request the ARTICLE in GROUP. +ARTICLE can either be an article number or an article Message-ID. +If BUFFER, insert the article in that group." + (let ((method (gnus-find-method-for-group group))) + (funcall (gnus-get-function method 'request-article) + article (gnus-group-real-name group) (nth 1 method) buffer))) + +(defun gnus-request-head (article group) + "Request the head of ARTICLE in GROUP." + (let* ((method (gnus-find-method-for-group group)) + (head (gnus-get-function method 'request-head t)) + res clean-up) + (cond + ;; Check the cache. + ((and gnus-use-cache + (numberp article) + (gnus-cache-request-article article group)) + (setq res (cons group article) + clean-up t)) + ;; Use `head' function. + ((fboundp head) + (setq res (funcall head article (gnus-group-real-name group) + (nth 1 method)))) + ;; Use `article' function. + (t + (setq res (gnus-request-article article group) + clean-up t))) + (when clean-up + (save-excursion + (set-buffer nntp-server-buffer) + (goto-char (point-min)) + (when (search-forward "\n\n" nil t) + (delete-region (1- (point)) (point-max))) + (nnheader-fold-continuation-lines))) + res)) + +(defun gnus-request-body (article group) + "Request the body of ARTICLE in GROUP." + (let ((method (gnus-find-method-for-group group))) + (funcall (gnus-get-function method 'request-body) + article (gnus-group-real-name group) (nth 1 method)))) + +(defun gnus-request-post (method) + "Post the current buffer using METHOD." + (when (stringp method) + (setq method (gnus-server-to-method method))) + (funcall (gnus-get-function method 'request-post) (nth 1 method))) + +(defun gnus-request-scan (group method) + "Request a SCAN being performed in GROUP from METHOD. +If GROUP is nil, all groups on METHOD are scanned." + (let ((method (if group (gnus-find-method-for-group group) method))) + (funcall (gnus-get-function method 'request-scan) + (and group (gnus-group-real-name group)) (nth 1 method)))) + +(defsubst gnus-request-update-info (info method) + "Request that METHOD update INFO." + (when (stringp method) + (setq method (gnus-server-to-method method))) + (when (gnus-check-backend-function 'request-update-info (car method)) + (funcall (gnus-get-function method 'request-update-info) + (gnus-group-real-name (gnus-info-group info)) + info (nth 1 method)))) + +(defun gnus-request-expire-articles (articles group &optional force) + (let ((method (gnus-find-method-for-group group))) + (funcall (gnus-get-function method 'request-expire-articles) + articles (gnus-group-real-name group) (nth 1 method) + force))) + +(defun gnus-request-move-article + (article group server accept-function &optional last) + (let ((method (gnus-find-method-for-group group))) + (funcall (gnus-get-function method 'request-move-article) + article (gnus-group-real-name group) + (nth 1 method) accept-function last))) + +(defun gnus-request-accept-article (group method &optional last) + ;; Make sure there's a newline at the end of the article. + (when (stringp method) + (setq method (gnus-server-to-method method))) + (when (and (not method) + (stringp group)) + (setq method (gnus-group-name-to-method group))) + (goto-char (point-max)) + (unless (bolp) + (insert "\n")) + (let ((func (car (or method (gnus-find-method-for-group group))))) + (funcall (intern (format "%s-request-accept-article" func)) + (if (stringp group) (gnus-group-real-name group) group) + (cadr method) + last))) + +(defun gnus-request-replace-article (article group buffer) + (let ((func (car (gnus-find-method-for-group group)))) + (funcall (intern (format "%s-request-replace-article" func)) + article (gnus-group-real-name group) buffer))) + +(defun gnus-request-associate-buffer (group) + (let ((method (gnus-find-method-for-group group))) + (funcall (gnus-get-function method 'request-associate-buffer) + (gnus-group-real-name group)))) + +(defun gnus-request-restore-buffer (article group) + "Request a new buffer restored to the state of ARTICLE." + (let ((method (gnus-find-method-for-group group))) + (funcall (gnus-get-function method 'request-restore-buffer) + article (gnus-group-real-name group) (nth 1 method)))) + +(defun gnus-request-create-group (group &optional method args) + (when (stringp method) + (setq method (gnus-server-to-method method))) + (let ((method (or method (gnus-find-method-for-group group)))) + (funcall (gnus-get-function method 'request-create-group) + (gnus-group-real-name group) (nth 1 method) args))) + +(defun gnus-request-delete-group (group &optional force) + (let ((method (gnus-find-method-for-group group))) + (funcall (gnus-get-function method 'request-delete-group) + (gnus-group-real-name group) force (nth 1 method)))) + +(defun gnus-request-rename-group (group new-name) + (let ((method (gnus-find-method-for-group group))) + (funcall (gnus-get-function method 'request-rename-group) + (gnus-group-real-name group) + (gnus-group-real-name new-name) (nth 1 method)))) + +(defun gnus-close-backends () + ;; Send a close request to all backends that support such a request. + (let ((methods gnus-valid-select-methods) + func method) + (while (setq method (pop methods)) + (when (fboundp (setq func (intern + (concat (car method) "-request-close")))) + (funcall func))))) + +(defun gnus-asynchronous-p (method) + (let ((func (gnus-get-function method 'asynchronous-p t))) + (when (fboundp func) + (funcall func)))) + +(defun gnus-remove-denial (method) + (when (stringp method) + (setq method (gnus-server-to-method method))) + (let* ((elem (assoc method gnus-opened-servers)) + (status (cadr elem))) + ;; If this hasn't been opened before, we add it to the list. + (when (eq status 'denied) + ;; Set the status of this server. + (setcar (cdr elem) 'closed)))) + +(provide 'gnus-int) + +;;; gnus-int.el ends here diff -r ad457d5f7d04 -r 0293115a14e9 lisp/gnus/gnus-kill.el --- a/lisp/gnus/gnus-kill.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/gnus/gnus-kill.el Mon Aug 13 08:49:20 2007 +0200 @@ -1,5 +1,5 @@ ;;; gnus-kill.el --- kill commands for Gnus -;; Copyright (C) 1995,96 Free Software Foundation, Inc. +;; Copyright (C) 1995,96,97 Free Software Foundation, Inc. ;; Author: Masanobu UMEDA ;; Lars Magne Ingebrigtsen @@ -27,18 +27,36 @@ ;;; Code: (require 'gnus) -(eval-when-compile (require 'cl)) +(require 'gnus-art) +(require 'gnus-range) -(defvar gnus-kill-file-mode-hook nil - "*A hook for Gnus kill file mode.") +(defcustom gnus-kill-file-mode-hook nil + "Hook for Gnus kill file mode." + :group 'gnus-score + :type 'hook) + +(defcustom gnus-kill-expiry-days 7 + "*Number of days before expiring unused kill file entries." + :group 'gnus-score + :type 'integer) -(defvar gnus-kill-expiry-days 7 - "*Number of days before expiring unused kill file entries.") +(defcustom gnus-kill-save-kill-file nil + "*If non-nil, will save kill files after processing them." + :group 'gnus-score + :type 'boolean) -(defvar gnus-kill-save-kill-file nil - "*If non-nil, will save kill files after processing them.") +(defcustom gnus-winconf-kill-file nil + "What does this do, Lars?" + :group 'gnus-score + :type 'sexp) -(defvar gnus-winconf-kill-file nil) +(defcustom gnus-kill-killed t + "*If non-nil, Gnus will apply kill files to already killed articles. +If it is nil, Gnus will never apply kill files to articles that have +already been through the scoring process, which might very well save lots +of time." + :group 'gnus-score + :type 'boolean) @@ -57,15 +75,15 @@ (defvar gnus-kill-file-mode-map nil) (unless gnus-kill-file-mode-map - (gnus-define-keymap - (setq gnus-kill-file-mode-map (copy-keymap emacs-lisp-mode-map)) - "\C-c\C-k\C-s" gnus-kill-file-kill-by-subject - "\C-c\C-k\C-a" gnus-kill-file-kill-by-author - "\C-c\C-k\C-t" gnus-kill-file-kill-by-thread - "\C-c\C-k\C-x" gnus-kill-file-kill-by-xref - "\C-c\C-a" gnus-kill-file-apply-buffer - "\C-c\C-e" gnus-kill-file-apply-last-sexp - "\C-c\C-c" gnus-kill-file-exit)) + (gnus-define-keymap (setq gnus-kill-file-mode-map + (copy-keymap emacs-lisp-mode-map)) + "\C-c\C-k\C-s" gnus-kill-file-kill-by-subject + "\C-c\C-k\C-a" gnus-kill-file-kill-by-author + "\C-c\C-k\C-t" gnus-kill-file-kill-by-thread + "\C-c\C-k\C-x" gnus-kill-file-kill-by-xref + "\C-c\C-a" gnus-kill-file-apply-buffer + "\C-c\C-e" gnus-kill-file-apply-last-sexp + "\C-c\C-c" gnus-kill-file-exit)) (defun gnus-kill-file-mode () "Major mode for editing kill files. @@ -93,12 +111,12 @@ does this easily for non-Lisp programmers. The `gnus-kill' function executes commands available in Summary Mode -by their key sequences. `gnus-kill' should be called with FIELD, +by their key sequences. `gnus-kill' should be called with FIELD, REGEXP and optional COMMAND and ALL. FIELD is a string representing the header field or an empty string. If FIELD is an empty string, the entire article body is searched for. REGEXP is a string which is -compared with FIELD value. COMMAND is a string representing a valid -key sequence in Summary mode or Lisp expression. COMMAND defaults to +compared with FIELD value. COMMAND is a string representing a valid +key sequence in Summary mode or Lisp expression. COMMAND defaults to '(gnus-summary-mark-as-read nil \"X\"). Make sure that COMMAND is executed in the Summary buffer. If the second optional argument ALL is non-nil, the COMMAND is applied to articles which are already @@ -180,8 +198,8 @@ ;; REGEXP: The string to kill. (save-excursion (let (string) - (or (eq major-mode 'gnus-kill-file-mode) - (gnus-kill-set-kill-buffer)) + (unless (eq major-mode 'gnus-kill-file-mode) + (gnus-kill-set-kill-buffer)) (unless dont-move (goto-char (point-max))) (insert (setq string (format "(gnus-kill %S %S)\n" field regexp))) @@ -195,7 +213,8 @@ (if (vectorp gnus-current-headers) (regexp-quote (gnus-simplify-subject (mail-header-subject gnus-current-headers))) - "") t)) + "") + t)) (defun gnus-kill-file-kill-by-author () "Kill by author." @@ -218,19 +237,19 @@ (defun gnus-kill-file-kill-by-xref () "Kill by Xref." (interactive) - (let ((xref (and (vectorp gnus-current-headers) + (let ((xref (and (vectorp gnus-current-headers) (mail-header-xref gnus-current-headers))) (start 0) group) (if xref (while (string-match " \\([^ \t]+\\):" xref start) (setq start (match-end 0)) - (if (not (string= - (setq group - (substring xref (match-beginning 1) (match-end 1))) - gnus-newsgroup-name)) - (gnus-kill-file-enter-kill - "Xref" (concat " " (regexp-quote group) ":") t))) + (when (not (string= + (setq group + (substring xref (match-beginning 1) (match-end 1))) + gnus-newsgroup-name)) + (gnus-kill-file-enter-kill + "Xref" (concat " " (regexp-quote group) ":") t))) (gnus-kill-file-enter-kill "Xref" "" t)))) (defun gnus-kill-file-raise-followups-to-author (level) @@ -293,13 +312,13 @@ (save-buffer) (let ((killbuf (current-buffer))) ;; We don't want to return to article buffer. - (and (get-buffer gnus-article-buffer) - (bury-buffer gnus-article-buffer)) + (when (get-buffer gnus-article-buffer) + (bury-buffer gnus-article-buffer)) ;; Delete the KILL file windows. (delete-windows-on killbuf) ;; Restore last window configuration if available. - (and gnus-winconf-kill-file - (set-window-configuration gnus-winconf-kill-file)) + (when gnus-winconf-kill-file + (set-window-configuration gnus-winconf-kill-file)) (setq gnus-winconf-kill-file nil) ;; Kill the KILL file buffer. Suggested by tale@pawl.rpi.edu. (kill-buffer killbuf))) @@ -334,9 +353,9 @@ "Apply .KILL file, unless a .SCORE file for the same newsgroup exists." (cond ((file-exists-p (gnus-score-file-name gnus-newsgroup-name)) ;; Ignores global KILL. - (if (file-exists-p (gnus-newsgroup-kill-file gnus-newsgroup-name)) - (gnus-message 3 "Note: Ignoring %s.KILL; preferring .SCORE" - gnus-newsgroup-name)) + (when (file-exists-p (gnus-newsgroup-kill-file gnus-newsgroup-name)) + (gnus-message 3 "Note: Ignoring %s.KILL; preferring .SCORE" + gnus-newsgroup-name)) 0) ((or (file-exists-p (gnus-newsgroup-kill-file nil)) (file-exists-p (gnus-newsgroup-kill-file gnus-newsgroup-name))) @@ -355,7 +374,7 @@ (setq gnus-newsgroup-kill-headers nil) ;; If there are any previously scored articles, we remove these ;; from the `gnus-newsgroup-headers' list that the score functions - ;; will see. This is probably pretty wasteful when it comes to + ;; will see. This is probably pretty wasteful when it comes to ;; conses, but is, I think, faster than having to assq in every ;; single score function. (let ((files kill-files)) @@ -367,12 +386,11 @@ (mapcar (lambda (header) (mail-header-number header)) headers)) (while headers - (or (gnus-member-of-range - (mail-header-number (car headers)) - gnus-newsgroup-killed) - (setq gnus-newsgroup-kill-headers - (cons (mail-header-number (car headers)) - gnus-newsgroup-kill-headers))) + (unless (gnus-member-of-range + (mail-header-number (car headers)) + gnus-newsgroup-killed) + (push (mail-header-number (car headers)) + gnus-newsgroup-kill-headers)) (setq headers (cdr headers)))) (setq files nil)) (setq files (cdr files))))) @@ -388,8 +406,7 @@ (gnus-add-current-to-buffer-list) (goto-char (point-min)) - (if (consp (condition-case nil (read (current-buffer)) - (error nil))) + (if (consp (ignore-errors (read (current-buffer)))) (gnus-kill-parse-gnus-kill-file) (gnus-kill-parse-rn-kill-file)) @@ -423,10 +440,9 @@ (let (beg form) (while (progn (setq beg (point)) - (setq form (condition-case () (read (current-buffer)) - (error nil)))) - (or (listp form) - (error "Illegal kill entry (possibly rn kill file?): %s" form)) + (setq form (ignore-errors (read (current-buffer))))) + (unless (listp form) + (error "Illegal kill entry (possibly rn kill file?): %s" form)) (if (or (eq (car form) 'gnus-kill) (eq (car form) 'gnus-raise) (eq (car form) 'gnus-lower)) @@ -435,8 +451,8 @@ (insert (or (eval form) ""))) (save-excursion (set-buffer gnus-summary-buffer) - (condition-case () (eval form) (error nil))))) - (and (buffer-modified-p) + (ignore-errors (eval form))))) + (and (buffer-modified-p) gnus-kill-save-kill-file (save-buffer)) (set-buffer-modified-p nil))) @@ -465,17 +481,16 @@ ;; The "f:+" command marks everything *but* the matches as read, ;; so we simply first match everything as read, and then unmark ;; PATTERN later. - (and (string-match "\\+" commands) - (progn - (gnus-kill "from" ".") - (setq commands "m"))) + (when (string-match "\\+" commands) + (gnus-kill "from" ".") + (setq commands "m")) (gnus-kill (or (cdr (assq modifier mod-to-header)) "subject") pattern - (if (string-match "m" commands) + (if (string-match "m" commands) '(gnus-summary-mark-as-unread nil " ") - '(gnus-summary-mark-as-read nil "X")) + '(gnus-summary-mark-as-read nil "X")) nil t)) (forward-line 1)))) @@ -493,7 +508,7 @@ (save-excursion (save-window-excursion ;; Selected window must be summary buffer to execute keyboard - ;; macros correctly. See command_loop_1. + ;; macros correctly. See command_loop_1. (switch-to-buffer gnus-summary-buffer 'norecord) (goto-char (point-min)) ;From the beginning. (let ((kill-list regexp) @@ -505,11 +520,11 @@ ;; It is a list. (if (not (consp (cdr kill-list))) ;; It's on the form (regexp . date). - (if (zerop (gnus-execute field (car kill-list) + (if (zerop (gnus-execute field (car kill-list) command nil (not all))) - (if (> (gnus-days-between date (cdr kill-list)) - gnus-kill-expiry-days) - (setq regexp nil)) + (when (> (gnus-days-between date (cdr kill-list)) + gnus-kill-expiry-days) + (setq regexp nil)) (setcdr kill-list date)) (while (setq kill (car kill-list)) (if (consp kill) @@ -518,14 +533,14 @@ (setq kdate (cdr kill)) (if (zerop (gnus-execute field (car kill) command nil (not all))) - (if (> (gnus-days-between date kdate) - gnus-kill-expiry-days) - ;; Time limit has been exceeded, so we - ;; remove the match. - (if prev - (setcdr prev (cdr kill-list)) - (setq regexp (cdr regexp)))) - ;; Successful kill. Set the date to today. + (when (> (gnus-days-between date kdate) + gnus-kill-expiry-days) + ;; Time limit has been exceeded, so we + ;; remove the match. + (if prev + (setcdr prev (cdr kill-list)) + (setq regexp (cdr regexp)))) + ;; Successful kill. Set the date to today. (setcdr kill date))) ;; It's a permanent kill. (gnus-execute field kill command nil (not all))) @@ -533,19 +548,20 @@ (setq kill-list (cdr kill-list)))) (gnus-execute field kill-list command nil (not all)))))) (switch-to-buffer old-buffer) - (if (and (eq major-mode 'gnus-kill-file-mode) regexp (not silent)) - (gnus-pp-gnus-kill - (nconc (list 'gnus-kill field - (if (consp regexp) (list 'quote regexp) regexp)) - (if (or exe-command all) (list (list 'quote exe-command))) - (if all (list t) nil)))))) + (when (and (eq major-mode 'gnus-kill-file-mode) regexp (not silent)) + (gnus-pp-gnus-kill + (nconc (list 'gnus-kill field + (if (consp regexp) (list 'quote regexp) regexp)) + (when (or exe-command all) + (list (list 'quote exe-command))) + (if all (list t) nil)))))) (defun gnus-pp-gnus-kill (object) (if (or (not (consp (nth 2 object))) (not (consp (cdr (nth 2 object)))) (and (eq 'quote (car (nth 2 object))) (not (consp (cdadr (nth 2 object)))))) - (concat "\n" (prin1-to-string object)) + (concat "\n" (gnus-prin1-to-string object)) (save-excursion (set-buffer (get-buffer-create "*Gnus PP*")) (buffer-disable-undo (current-buffer)) @@ -555,17 +571,17 @@ (first t)) (while klist (insert (if first (progn (setq first nil) "") "\n ") - (prin1-to-string (car klist))) + (gnus-prin1-to-string (car klist))) (setq klist (cdr klist)))) (insert ")") (and (nth 3 object) (insert "\n " (if (and (consp (nth 3 object)) - (not (eq 'quote (car (nth 3 object))))) + (not (eq 'quote (car (nth 3 object))))) "'" "") - (prin1-to-string (nth 3 object)))) - (and (nth 4 object) - (insert "\n t")) + (gnus-prin1-to-string (nth 3 object)))) + (when (nth 4 object) + (insert "\n t")) (insert ")") (prog1 (buffer-substring (point-min) (point-max)) @@ -583,10 +599,10 @@ (progn (setq value (funcall function header)) ;; Number (Lines:) or symbol must be converted to string. - (or (stringp value) - (setq value (prin1-to-string value))) + (unless (stringp value) + (setq value (gnus-prin1-to-string value))) (setq did-kill (string-match regexp value))) - (cond ((stringp form) ;Keyboard macro. + (cond ((stringp form) ;Keyboard macro. (execute-kbd-macro form)) ((gnus-functionp form) (funcall form)) @@ -601,27 +617,30 @@ 6 "Searching for article: %d..." (mail-header-number header)) (gnus-article-setup-buffer) (gnus-article-prepare (mail-header-number header) t) - (if (save-excursion - (set-buffer gnus-article-buffer) - (goto-char (point-min)) - (setq did-kill (re-search-forward regexp nil t))) - (if (stringp form) ;Keyboard macro. - (execute-kbd-macro form) - (eval form)))))) + (when (save-excursion + (set-buffer gnus-article-buffer) + (goto-char (point-min)) + (setq did-kill (re-search-forward regexp nil t))) + (cond ((stringp form) ;Keyboard macro. + (execute-kbd-macro form)) + ((gnus-functionp form) + (funcall form)) + (t + (eval form))))))) did-kill))) -(defun gnus-execute (field regexp form &optional backward ignore-marked) +(defun gnus-execute (field regexp form &optional backward unread) "If FIELD of article header matches REGEXP, execute lisp FORM (or a string). If FIELD is an empty string (or nil), entire article body is searched for. If optional 1st argument BACKWARD is non-nil, do backward instead. -If optional 2nd argument IGNORE-MARKED is non-nil, articles which are +If optional 2nd argument UNREAD is non-nil, articles which are marked as read or ticked are ignored." (save-excursion (let ((killed-no 0) function article header) (cond ;; Search body. - ((or (null field) + ((or (null field) (string-equal field "")) (setq function nil)) ;; Get access function of header field. @@ -640,8 +659,7 @@ (setq article (gnus-summary-article-number))) ;; Find later articles. (setq article - (gnus-summary-search-forward - (not ignore-marked) nil backward))) + (gnus-summary-search-forward unread nil backward))) (and (or (null gnus-newsgroup-kill-headers) (memq article gnus-newsgroup-kill-headers)) (vectorp (setq header (gnus-summary-article-header article))) @@ -650,6 +668,49 @@ ;; Return the number of killed articles. killed-no))) +;;;###autoload +(defalias 'gnus-batch-kill 'gnus-batch-score) +;;;###autoload +(defun gnus-batch-score () + "Run batched scoring. +Usage: emacs -batch -l gnus -f gnus-batch-score ... +Newsgroups is a list of strings in Bnews format. If you want to score +the comp hierarchy, you'd say \"comp.all\". If you would not like to +score the alt hierarchy, you'd say \"!alt.all\"." + (interactive) + (let* ((gnus-newsrc-options-n + (gnus-newsrc-parse-options + (concat "options -n " + (mapconcat 'identity command-line-args-left " ")))) + (gnus-expert-user t) + (nnmail-spool-file nil) + (gnus-use-dribble-file nil) + (gnus-batch-mode t) + group newsrc entry + ;; Disable verbose message. + gnus-novice-user gnus-large-newsgroup + gnus-options-subscribe gnus-auto-subscribed-groups + gnus-options-not-subscribe) + ;; Eat all arguments. + (setq command-line-args-left nil) + (gnus-slave) + ;; Apply kills to specified newsgroups in command line arguments. + (setq newsrc (cdr gnus-newsrc-alist)) + (while (setq group (car (pop newsrc))) + (setq entry (gnus-gethash group gnus-newsrc-hashtb)) + (when (and (<= (gnus-info-level (car newsrc)) gnus-level-subscribed) + (and (car entry) + (or (eq (car entry) t) + (not (zerop (car entry))))) + ;;(eq (gnus-matches-options-n group) 'subscribe) + ) + (gnus-summary-read-group group nil t nil t) + (when (eq (current-buffer) (get-buffer gnus-summary-buffer)) + (gnus-summary-exit)))) + ;; Exit Emacs. + (switch-to-buffer gnus-group-buffer) + (gnus-group-save-newsrc))) + (provide 'gnus-kill) ;;; gnus-kill.el ends here diff -r ad457d5f7d04 -r 0293115a14e9 lisp/gnus/gnus-load.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus/gnus-load.el Mon Aug 13 08:49:20 2007 +0200 @@ -0,0 +1,60 @@ +;;; gnus-load.el --- automatically extracted custom dependencies +;; +;;; Code: + +(put 'gnus-visual 'custom-loads '("smiley" "gnus-sum" "gnus-picon" "earcon")) +(put 'gnus-summary-maneuvering 'custom-loads '("gnus-sum")) +(put 'gnus-start 'custom-loads '("gnus" "gnus-util" "gnus-start" "gnus-int")) +(put 'gnus-extract-view 'custom-loads '("gnus-sum")) +(put 'article-hiding-headers 'custom-loads '("gnus-sum")) +(put 'gnus-various 'custom-loads '("gnus-sum")) +(put 'gnus-meta 'custom-loads '("gnus")) +(put 'message-news 'custom-loads '("message")) +(put 'gnus-thread 'custom-loads '("gnus-sum")) +(put 'gnus-treading 'custom-loads '("gnus-sum")) +(put 'message-various 'custom-loads '("message")) +(put 'gnus-summary-exit 'custom-loads '("gnus-sum")) +(put 'gnus 'custom-loads '("nnmail" "gnus" "gnus-win" "gnus-uu" "gnus-sum" "gnus-group" "gnus-eform" "gnus-dup" "gnus-demon" "gnus-cache" "gnus-async" "gnus-art")) +(put 'gnus-summary-visual 'custom-loads '("gnus-sum")) +(put 'gnus-score 'custom-loads '("gnus-sum" "gnus-score" "gnus-nocem" "gnus-kill")) +(put 'gnus-group-select 'custom-loads '("gnus-sum")) +(put 'message-buffers 'custom-loads '("message")) +(put 'gnus-threading 'custom-loads '("gnus-sum")) +(put 'article 'custom-loads '("gnus-sum" "gnus-cite" "gnus-art")) +(put 'gnus-nocem 'custom-loads '("gnus-nocem")) +(put 'gnus-cite 'custom-loads '("gnus-cite")) +(put 'gnus-demon 'custom-loads '("gnus-demon")) +(put 'gnus-mail 'custom-loads '("nnmail")) +(put 'message-interface 'custom-loads '("message")) +(put 'gnus-edit-form 'custom-loads '("gnus-eform")) +(put 'emacs 'custom-loads '("custom" "widget-edit" "message" "gnus" "custom-opt")) +(put 'gnus-summary-mail 'custom-loads '("gnus-sum")) +(put 'gnus-topic 'custom-loads '("gnus-topic")) +(put 'gnus-summary-choose 'custom-loads '("gnus-sum")) +(put 'message-headers 'custom-loads '("message")) +(put 'message-forwarding 'custom-loads '("message")) +(put 'gnus-duplicate 'custom-loads '("gnus-dup")) +(put 'widgets 'custom-loads '("widget-edit")) +(put 'earcon 'custom-loads '("earcon")) +(put 'gnus-summary-format 'custom-loads '("gnus-sum")) +(put 'gnus-windows 'custom-loads '("gnus-win")) +(put 'gnus-summary 'custom-loads '("gnus-sum")) +(put 'gnus-group 'custom-loads '("gnus-topic" "gnus-sum" "gnus-group")) +(put 'gnus-summary-marks 'custom-loads '("gnus-sum")) +(put 'message-mail 'custom-loads '("message")) +(put 'gnus-summary-various 'custom-loads '("gnus-sum")) +(put 'message 'custom-loads '("message")) +(put 'message-sending 'custom-loads '("message")) +(put 'message-insertion 'custom-loads '("message")) +(put 'gnus-summary-sort 'custom-loads '("gnus-sum")) +(put 'customize 'custom-loads '("custom" "custom-edit")) +(put 'gnus-asynchronous 'custom-loads '("gnus-async")) +(put 'article-mime 'custom-loads '("gnus-sum")) +(put 'gnus-extract 'custom-loads '("gnus-uu" "gnus-sum")) +(put 'article-various 'custom-loads '("gnus-sum")) +(put 'mesage-sending 'custom-loads '("message")) +(put 'picons 'custom-loads '("gnus-picon")) + +(provide 'gnus-load) + +;;; gnus-load.el ends here diff -r ad457d5f7d04 -r 0293115a14e9 lisp/gnus/gnus-logic.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus/gnus-logic.el Mon Aug 13 08:49:20 2007 +0200 @@ -0,0 +1,227 @@ +;;; gnus-logic.el --- advanced scoring code for Gnus +;; Copyright (C) 1996,97 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen +;; Keywords: news + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;;; Code: + +(require 'gnus) +(require 'gnus-score) +(require 'gnus-util) + +;;; Internal variables. + +(defvar gnus-advanced-headers nil) + +;; To avoid having 8-bit characters in the source file. +(defvar gnus-advanced-not (intern (format "%c" 172))) + +(defconst gnus-advanced-index + ;; Name to index alist. + '(("number" 0 gnus-advanced-integer) + ("subject" 1 gnus-advanced-string) + ("from" 2 gnus-advanced-string) + ("date" 3 gnus-advanced-date) + ("message-id" 4 gnus-advanced-string) + ("references" 5 gnus-advanced-string) + ("chars" 6 gnus-advanced-integer) + ("lines" 7 gnus-advanced-integer) + ("xref" 8 gnus-advanced-string) + ("head" nil gnus-advanced-body) + ("body" nil gnus-advanced-body) + ("all" nil gnus-advanced-body))) + +(eval-and-compile + (autoload 'parse-time-string "parse-time")) + +(defun gnus-score-advanced (rule &optional trace) + "Apply advanced scoring RULE to all the articles in the current group." + (let ((headers gnus-newsgroup-headers) + gnus-advanced-headers score) + (while (setq gnus-advanced-headers (pop headers)) + (when (gnus-advanced-score-rule (car rule)) + ;; This rule was successful, so we add the score to + ;; this article. + (if (setq score (assq (mail-header-number gnus-advanced-headers) + gnus-newsgroup-scored)) + (setcdr score + (+ (cdr score) + (or (nth 1 rule) + gnus-score-interactive-default-score))) + (push (cons (mail-header-number gnus-advanced-headers) + (or (nth 1 rule) + gnus-score-interactive-default-score)) + gnus-newsgroup-scored) + (when trace + (push (cons "A file" rule) + gnus-score-trace))))))) + +(defun gnus-advanced-score-rule (rule) + "Apply RULE to `gnus-advanced-headers'." + (let ((type (car rule))) + (cond + ;; "And" rule. + ((or (eq type '&) (eq type 'and)) + (pop rule) + (if (not rule) + t ; Empty rule is true. + (while (and rule + (gnus-advanced-score-rule (car rule))) + (pop rule)) + ;; If all the rules were true, then `rule' should be nil. + (not rule))) + ;; "Or" rule. + ((or (eq type '|) (eq type 'or)) + (pop rule) + (if (not rule) + nil + (while (and rule + (not (gnus-advanced-score-rule (car rule)))) + (pop rule)) + ;; If one of the rules returned true, then `rule' should be non-nil. + rule)) + ;; "Not" rule. + ((or (eq type '!) (eq type 'not) (eq type gnus-advanced-not)) + (not (gnus-advanced-score-rule (nth 1 rule)))) + ;; This is a `1-'-type redirection rule. + ((and (symbolp type) + (string-match "^[0-9]+-$\\|^\\^+$" (symbol-name type))) + (let ((gnus-advanced-headers + (gnus-parent-headers + gnus-advanced-headers + (if (string-match "^\\([0-9]+\\)-$" (symbol-name type)) + ;; 1- type redirection. + (string-to-number + (substring (symbol-name type) + (match-beginning 0) (match-end 0))) + ;; ^^^ type redirection. + (length (symbol-name type)))))) + (when gnus-advanced-headers + (gnus-advanced-score-rule (nth 1 rule))))) + ;; Plain scoring rule. + ((stringp type) + (gnus-advanced-score-article rule)) + ;; Bug-out time! + (t + (error "Unknown advanced score type: %s" rule))))) + +(defun gnus-advanced-score-article (rule) + ;; `rule' is a semi-normal score rule, so we find out + ;; what function that's supposed to do the actual + ;; processing. + (let* ((header (car rule)) + (func (assoc (downcase header) gnus-advanced-index))) + (if (not func) + (error "No such header: %s" rule) + ;; Call the score function. + (funcall (caddr func) (or (cadr func) header) + (cadr rule) (caddr rule))))) + +(defun gnus-advanced-string (index match type) + "See whether string MATCH of TYPE matches `gnus-advanced-headers' in INDEX." + (let* ((type (or type 's)) + (case-fold-search (not (eq (downcase (symbol-name type)) + (symbol-name type)))) + (header (aref gnus-advanced-headers index))) + (cond + ((memq type '(r R regexp Regexp)) + (string-match match header)) + ((memq type '(s S string String)) + (string-match (regexp-quote match) header)) + ((memq type '(e E exact Exact)) + (string= match header)) + ((memq type '(f F fuzzy Fuzzy)) + (string-match (regexp-quote (gnus-simplify-subject-fuzzy match)) + header)) + (t + (error "No such string match type: %s" type))))) + +(defun gnus-advanced-integer (index match type) + (if (not (memq type '(< > <= >= =))) + (error "No such integer score type: %s" type) + (funcall type match (or (aref gnus-advanced-headers index) 0)))) + +(defun gnus-advanced-date (index match type) + (let ((date (encode-time (parse-time-string + (aref gnus-advanced-headers index)))) + (match (encode-time (parse-time-string match)))) + (cond + ((eq type 'at) + (equal date match)) + ((eq type 'before) + (gnus-time-less match date)) + ((eq type 'after) + (gnus-time-less date match)) + (t + (error "No such date score type: %s" type))))) + +(defun gnus-advanced-body (header match type) + (when (string= header "all") + (setq header "article")) + (save-excursion + (set-buffer nntp-server-buffer) + (let* ((request-func (cond ((string= "head" header) + 'gnus-request-head) + ((string= "body" header) + 'gnus-request-body) + (t 'gnus-request-article))) + ofunc article) + ;; Not all backends support partial fetching. In that case, + ;; we just fetch the entire article. + (unless (gnus-check-backend-function + (intern (concat "request-" header)) + gnus-newsgroup-name) + (setq ofunc request-func) + (setq request-func 'gnus-request-article)) + (setq article (mail-header-number gnus-advanced-headers)) + (gnus-message 7 "Scoring article %s..." article) + (when (funcall request-func article gnus-newsgroup-name) + (goto-char (point-min)) + ;; If just parts of the article is to be searched and the + ;; backend didn't support partial fetching, we just narrow + ;; to the relevant parts. + (when ofunc + (if (eq ofunc 'gnus-request-head) + (narrow-to-region + (point) + (or (search-forward "\n\n" nil t) (point-max))) + (narrow-to-region + (or (search-forward "\n\n" nil t) (point)) + (point-max)))) + (let* ((case-fold-search (not (eq (downcase (symbol-name type)) + (symbol-name type)))) + (search-func + (cond ((memq type '(r R regexp Regexp)) + 're-search-forward) + ((memq type '(s S string String)) + 'search-forward) + (t + (error "Illegal match type: %s" type))))) + (goto-char (point-min)) + (prog1 + (funcall search-func match nil t) + (widen))))))) + +(provide 'gnus-logic) + +;;; gnus-logic.el ends here. diff -r ad457d5f7d04 -r 0293115a14e9 lisp/gnus/gnus-mh.el --- a/lisp/gnus/gnus-mh.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/gnus/gnus-mh.el Mon Aug 13 08:49:20 2007 +0200 @@ -1,5 +1,5 @@ ;;; gnus-mh.el --- mh-e interface for Gnus -;; Copyright (C) 1994,95,96 Free Software Foundation, Inc. +;; Copyright (C) 1994,95,96,97 Free Software Foundation, Inc. ;; Author: Masanobu UMEDA ;; Lars Magne Ingebrigtsen @@ -33,11 +33,11 @@ ;;; Code: +(require 'gnus) (require 'mh-e) (require 'mh-comp) -(require 'gnus) (require 'gnus-msg) -(eval-when-compile (require 'cl)) +(require 'gnus-sum) (defun gnus-summary-save-article-folder (&optional arg) "Append the current article to an mh folder. diff -r ad457d5f7d04 -r 0293115a14e9 lisp/gnus/gnus-move.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus/gnus-move.el Mon Aug 13 08:49:20 2007 +0200 @@ -0,0 +1,172 @@ +;;; gnus-move.el --- commands for moving Gnus from one server to another +;; Copyright (C) 1996,97 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen +;; Keywords: news + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;;; Code: + +(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) + (nnmail-spool-file nil)) + (gnus)) + + (save-excursion + ;; Go through all groups and translate. + (let ((newsrc gnus-newsrc-alist) + (nntp-nov-gap nil) + info) + (while (setq info (pop newsrc)) + (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) + (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)) + ;; Fetch the headers from the `to-server'. + (when (and to-active + (setq type (gnus-retrieve-headers + (gnus-uncompress-range to-active) + 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) + (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") + (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 (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. + (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 (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-gethash group gnus-newsrc-hashtb) + gnus-newsrc-hashtb) + (gnus-sethash group nil gnus-newsrc-hashtb)))) + +(provide 'gnus-move) + +;;; gnus-move.el ends here diff -r ad457d5f7d04 -r 0293115a14e9 lisp/gnus/gnus-msg.el --- a/lisp/gnus/gnus-msg.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/gnus/gnus-msg.el Mon Aug 13 08:49:20 2007 +0200 @@ -1,5 +1,5 @@ ;;; gnus-msg.el --- mail and post interface for Gnus -;; Copyright (C) 1995,96 Free Software Foundation, Inc. +;; Copyright (C) 1995,96,97 Free Software Foundation, Inc. ;; Author: Masanobu UMEDA ;; Lars Magne Ingebrigtsen @@ -29,7 +29,7 @@ (require 'gnus) (require 'gnus-ems) (require 'message) -(eval-when-compile (require 'cl)) +(require 'gnus-art) ;; Added by Sudish Joseph . (defvar gnus-post-method nil @@ -47,7 +47,7 @@ (defvar gnus-outgoing-message-group nil "*All outgoing messages will be put in this group. If you want to store all your outgoing mail and articles in the group -\"nnml:archive\", you set this variable to that value. This variable +\"nnml:archive\", you set this variable to that value. This variable can also be a list of group names. If you want to have greater control over what group to put each @@ -68,12 +68,53 @@ (defvar gnus-sent-message-ids-length 1000 "The number of sent Message-IDs to save.") +(defvar gnus-crosspost-complaint + "Hi, + +You posted the article below with the following Newsgroups header: + +Newsgroups: %s + +The %s group, at least, was an inappropriate recipient +of this message. Please trim your Newsgroups header to exclude this +group before posting in the future. + +Thank you. + +" + "Format string to be inserted when complaining about crossposts. +The first %s will be replaced by the Newsgroups header; +the second with the current group name.") + +(defvar gnus-message-setup-hook nil + "Hook run after setting up a message buffer.") + ;;; Internal variables. (defvar gnus-message-buffer "*Mail Gnus*") (defvar gnus-article-copy nil) (defvar gnus-last-posting-server nil) +(defconst gnus-bug-message + "Sending a bug report to the Gnus Towers. +======================================== + +The buffer below is a mail buffer. When you press `C-c C-c', it will +be sent to the Gnus Bug Exterminators. + +At the bottom of the buffer you'll see lots of variable settings. +Please do not delete those. They will tell the Bug People what your +environment is, so that it will be easier to locate the bugs. + +If you have found a bug that makes Emacs go \"beep\", set +debug-on-error to t (`M-x set-variable RET debug-on-error RET t RET') +and include the backtrace in your bug report. + +Please describe the bug in annoying, painstaking detail. + +Thank you for your help in stamping out bugs. +") + (eval-and-compile (autoload 'gnus-uu-post-news "gnus-uu" nil t) (autoload 'news-setup "rnewspost") @@ -86,27 +127,30 @@ ;;; Gnus Posting Functions ;;; -(gnus-define-keys - (gnus-summary-send-map "S" gnus-summary-mode-map) - "p" gnus-summary-post-news - "f" gnus-summary-followup - "F" gnus-summary-followup-with-original - "c" gnus-summary-cancel-article - "s" gnus-summary-supersede-article - "r" gnus-summary-reply - "R" gnus-summary-reply-with-original - "m" gnus-summary-mail-other-window - "u" gnus-uu-post-news - "om" gnus-summary-mail-forward - "op" gnus-summary-post-forward - "Om" gnus-uu-digest-mail-forward - "Op" gnus-uu-digest-post-forward) +(gnus-define-keys (gnus-summary-send-map "S" gnus-summary-mode-map) + "p" gnus-summary-post-news + "f" gnus-summary-followup + "F" gnus-summary-followup-with-original + "c" gnus-summary-cancel-article + "s" gnus-summary-supersede-article + "r" gnus-summary-reply + "R" gnus-summary-reply-with-original + "w" gnus-summary-wide-reply + "W" gnus-summary-wide-reply-with-original + "n" gnus-summary-followup-to-mail + "N" gnus-summary-followup-to-mail-with-original + "m" gnus-summary-mail-other-window + "u" gnus-uu-post-news + "\M-c" gnus-summary-mail-crosspost-complaint + "om" gnus-summary-mail-forward + "op" gnus-summary-post-forward + "Om" gnus-uu-digest-mail-forward + "Op" gnus-uu-digest-post-forward) -(gnus-define-keys - (gnus-send-bounce-map "D" gnus-summary-send-map) - "b" gnus-summary-resend-bounced-mail -; "c" gnus-summary-send-draft - "r" gnus-summary-resend-message) +(gnus-define-keys (gnus-send-bounce-map "D" gnus-summary-send-map) + "b" gnus-summary-resend-bounced-mail + ;; "c" gnus-summary-send-draft + "r" gnus-summary-resend-message) ;;; Internal functions. @@ -116,15 +160,18 @@ (buffer (make-symbol "buffer")) (article (make-symbol "article"))) `(let ((,winconf (current-window-configuration)) - (,buffer (current-buffer)) + (,buffer (buffer-name (current-buffer))) (,article (and gnus-article-reply (gnus-summary-article-number))) (message-header-setup-hook (copy-sequence message-header-setup-hook))) (add-hook 'message-header-setup-hook 'gnus-inews-insert-gcc) (add-hook 'message-header-setup-hook 'gnus-inews-insert-archive-gcc) - ,@forms - (gnus-inews-add-send-actions ,winconf ,buffer ,article) - (setq gnus-message-buffer (current-buffer)) + (unwind-protect + ,@forms + (gnus-inews-add-send-actions ,winconf ,buffer ,article) + (setq gnus-message-buffer (current-buffer)) + (make-local-variable 'gnus-newsgroup-name) + (run-hooks 'gnus-message-setup-hook)) (gnus-configure-windows ,config t)))) (defun gnus-inews-add-send-actions (winconf buffer article) @@ -137,15 +184,14 @@ (message-add-action `(set-window-configuration ,winconf) 'exit 'postpone 'kill) (message-add-action - `(when (buffer-name ,buffer) + `(when (buffer-name (get-buffer ,buffer)) (save-excursion - (set-buffer ,buffer) + (set-buffer (get-buffer ,buffer)) ,(when article `(gnus-summary-mark-article-as-replied ,article)))) 'send)) (put 'gnus-setup-message 'lisp-indent-function 1) -(put 'gnus-setup-message 'lisp-indent-hook 1) (put 'gnus-setup-message 'edebug-form-spec '(form body)) ;;; Post news commands of Gnus group mode and summary mode @@ -201,8 +247,21 @@ (interactive "P") (gnus-summary-followup (gnus-summary-work-articles n) force-news)) +(defun gnus-summary-followup-to-mail (&optional arg) + "Followup to the current mail message via news." + (interactive + (list (and current-prefix-arg + (gnus-summary-work-articles 1)))) + (gnus-summary-followup arg t)) + +(defun gnus-summary-followup-to-mail-with-original (&optional arg) + "Followup to the current mail message via news." + (interactive "P") + (gnus-summary-followup (gnus-summary-work-articles arg) t)) + (defun gnus-inews-yank-articles (articles) (let (beg article) + (message-goto-body) (while (setq article (pop articles)) (save-window-excursion (set-buffer gnus-summary-buffer) @@ -213,8 +272,8 @@ (message-reply-headers gnus-current-headers)) (message-yank-original) (setq beg (or beg (mark t)))) - (when articles (insert "\n"))) - + (when articles + (insert "\n"))) (push-mark) (goto-char beg))) @@ -229,8 +288,8 @@ article) (while (setq article (pop articles)) (when (gnus-summary-select-article t nil nil article) - (when (gnus-eval-in-buffer-window - gnus-original-article-buffer (message-cancel-news)) + (when (gnus-eval-in-buffer-window gnus-original-article-buffer + (message-cancel-news)) (gnus-summary-mark-as-read article gnus-canceled-mark) (gnus-cache-remove-article 1)) (gnus-article-hide-headers-if-wanted)) @@ -250,6 +309,13 @@ (push `((lambda () (gnus-cache-possibly-remove-article ,article nil nil nil t))) + message-send-actions) + (push + `((lambda () + (when (buffer-name (get-buffer ,gnus-summary-buffer)) + (save-excursion + (set-buffer (get-buffer ,gnus-summary-buffer)) + (gnus-summary-mark-as-read ,article gnus-canceled-mark))))) message-send-actions)))) @@ -262,28 +328,41 @@ (setq gnus-article-copy (get-buffer-create " *gnus article copy*")) (buffer-disable-undo gnus-article-copy) (or (memq gnus-article-copy gnus-buffer-list) - (setq gnus-buffer-list (cons gnus-article-copy gnus-buffer-list))) + (push gnus-article-copy gnus-buffer-list)) (let ((article-buffer (or article-buffer gnus-article-buffer)) end beg contents) - (when (and (get-buffer article-buffer) - (buffer-name (get-buffer article-buffer))) + (if (not (and (get-buffer article-buffer) + (buffer-name (get-buffer article-buffer)))) + (error "Can't find any article buffer") (save-excursion (set-buffer article-buffer) (save-restriction + ;; Copy over the (displayed) article buffer, delete + ;; hidden text and remove text properties. (widen) - (setq contents (format "%s" (buffer-string))) + (copy-to-buffer gnus-article-copy (point-min) (point-max)) + (set-buffer gnus-article-copy) + (gnus-article-delete-text-of-type 'annotation) + (gnus-remove-text-with-property 'gnus-prev) + (gnus-remove-text-with-property 'gnus-next) + (insert + (prog1 + (format "%s" (buffer-string)) + (erase-buffer))) + ;; Find the original headers. (set-buffer gnus-original-article-buffer) (goto-char (point-min)) (while (looking-at message-unix-mail-delimiter) (forward-line 1)) (setq beg (point)) (setq end (or (search-forward "\n\n" nil t) (point))) + ;; Delete the headers from the displayed articles. (set-buffer gnus-article-copy) - (erase-buffer) - (insert contents) (delete-region (goto-char (point-min)) (or (search-forward "\n\n" nil t) (point))) - (insert-buffer-substring gnus-original-article-buffer beg end))) + ;; Insert the original article headers. + (insert-buffer-substring gnus-original-article-buffer beg end) + (gnus-article-decode-rfc1522))) gnus-article-copy))) (defun gnus-post-news (post &optional group header article-buffer yank subject @@ -296,16 +375,19 @@ (t 'message)) (let* ((group (or group gnus-newsgroup-name)) (pgroup group) - to-address to-group mailing-list to-list) + to-address to-group mailing-list to-list + newsgroup-p) (when group - (setq to-address (gnus-group-get-parameter group 'to-address) - to-group (gnus-group-get-parameter group 'to-group) - to-list (gnus-group-get-parameter group 'to-list) + (setq to-address (gnus-group-find-parameter group 'to-address) + to-group (gnus-group-find-parameter group 'to-group) + to-list (gnus-group-find-parameter group 'to-list) + newsgroup-p (gnus-group-find-parameter group 'newsgroup) mailing-list (when gnus-mailing-list-groups (string-match gnus-mailing-list-groups group)) group (gnus-group-real-name group))) (if (or (and to-group (gnus-news-group-p to-group)) + newsgroup-p force-news (and (gnus-news-group-p (or pgroup gnus-newsgroup-name) @@ -318,7 +400,7 @@ (if post (message-news (or to-group group)) (set-buffer gnus-article-copy) - (message-followup)) + (message-followup (if (or newsgroup-p force-news) nil to-group))) ;; The is mail. (if post (progn @@ -339,7 +421,7 @@ (cond ;; If the group-method is nil (which shouldn't happen) we use ;; the default method. - ((null arg) + ((null group-method) (or gnus-post-method gnus-select-method message-post-method)) ;; We want this group's method. ((and arg (not (eq arg 0))) @@ -384,14 +466,8 @@ (cons (or gnus-last-posting-server "") 0)))) method-alist)))) ;; Override normal method. - ((and gnus-post-method - (or (gnus-method-option-p group-method 'post) - (gnus-method-option-p group-method 'post-mail))) + (gnus-post-method gnus-post-method) - ;; Perhaps this is a mail group? - ((and (not (gnus-member-of-valid 'post group)) - (not (gnus-method-option-p group-method 'post-mail))) - group-method) ;; Use the normal select method. (t gnus-select-method)))) @@ -419,9 +495,8 @@ end) (when message-id (unless gnus-inews-sent-ids - (condition-case () - (load t t t) - (error nil))) + (ignore-errors + (load t t t))) (if (member message-id gnus-inews-sent-ids) ;; Reject this message. (not (gnus-yes-or-no-p @@ -433,8 +508,7 @@ gnus-inews-sent-ids)) (setcdr end nil)) (nnheader-temp-write gnus-sent-message-ids-file - (prin1 `(setq gnus-inews-sent-ids ',gnus-inews-sent-ids) - (current-buffer))) + (gnus-prin1 `(setq gnus-inews-sent-ids ',gnus-inews-sent-ids))) nil))))) @@ -463,7 +537,7 @@ (format " %d.%d" emacs-major-version emacs-minor-version))) (t emacs-version)))) -;; Written by "Mr. Per Persson" . +;; Written by "Mr. Per Persson" . (defun gnus-inews-insert-mime-headers () (goto-char (point-min)) (let ((mail-header-separator @@ -496,13 +570,13 @@ ;;; Mail reply commands of Gnus summary mode -(defun gnus-summary-reply (&optional yank) - "Reply mail to news author. -If prefix argument YANK is non-nil, original article is yanked automatically." +(defun gnus-summary-reply (&optional yank wide) + "Start composing a reply mail to the current message. +If prefix argument YANK is non-nil, the original article is yanked +automatically." (interactive (list (and current-prefix-arg (gnus-summary-work-articles 1)))) - ;; Bug fix by jbw@bigbird.bu.edu (Joe Wells) ;; Stripping headers should be specified with mail-yank-ignored-headers. (gnus-set-global-variables) (when yank @@ -511,54 +585,111 @@ (gnus-setup-message (if yank 'reply-yank 'reply) (gnus-summary-select-article) (set-buffer (gnus-copy-article-buffer)) - (message-reply nil nil (gnus-group-get-parameter - gnus-newsgroup-name 'broken-reply-to)) + (message-reply nil wide (gnus-group-find-parameter + gnus-newsgroup-name 'broken-reply-to)) (when yank (gnus-inews-yank-articles yank))))) -(defun gnus-summary-reply-with-original (n) - "Reply mail to news author with original article." +(defun gnus-summary-reply-with-original (n &optional wide) + "Start composing a reply mail to the current message. +The original article will be yanked." (interactive "P") (gnus-summary-reply (gnus-summary-work-articles n))) -(defun gnus-summary-mail-forward (&optional post) - "Forward the current message to another user." +(defun gnus-summary-wide-reply (&optional yank) + "Start composing a wide reply mail to the current message. +If prefix argument YANK is non-nil, the original article is yanked +automatically." + (interactive + (list (and current-prefix-arg + (gnus-summary-work-articles 1)))) + (gnus-summary-reply yank t)) + +(defun gnus-summary-wide-reply-with-original (n) + "Start composing a wide reply mail to the current message. +The original article will be yanked." + (interactive "P") + (gnus-summary-reply-with-original n t)) + +(defun gnus-summary-mail-forward (&optional full-headers post) + "Forward the current message to another user. +If FULL-HEADERS (the prefix), include full headers when forwarding." (interactive "P") (gnus-set-global-variables) (gnus-setup-message 'forward (gnus-summary-select-article) (set-buffer gnus-original-article-buffer) - (message-forward post))) + (let ((message-included-forward-headers + (if full-headers "" message-included-forward-headers))) + (message-forward post)))) -(defun gnus-summary-resend-message (address) +(defun gnus-summary-resend-message (address n) "Resend the current article to ADDRESS." - (interactive "sResend message to: ") - (gnus-summary-select-article) - (save-excursion - (set-buffer gnus-original-article-buffer) - (message-resend address))) + (interactive "sResend message(s) to: \nP") + (let ((articles (gnus-summary-work-articles n)) + article) + (while (setq article (pop articles)) + (gnus-summary-select-article nil nil nil article) + (save-excursion + (set-buffer gnus-original-article-buffer) + (message-resend address))))) -(defun gnus-summary-post-forward () - "Forward the current article to a newsgroup." - (interactive) - (gnus-summary-mail-forward t)) +(defun gnus-summary-post-forward (&optional full-headers) + "Forward the current article to a newsgroup. +If FULL-HEADERS (the prefix), include full headers when forwarding." + (interactive "P") + (gnus-summary-mail-forward full-headers t)) (defvar gnus-nastygram-message - "The following article was inappropriately posted to %s.\n" + "The following article was inappropriately posted to %s.\n\n" "Format string to insert in nastygrams. The current group name will be inserted at \"%s\".") (defun gnus-summary-mail-nastygram (n) "Send a nastygram to the author of the current article." (interactive "P") - (if (or gnus-expert-user - (gnus-y-or-n-p - "Really send a nastygram to the author of the current article? ")) - (let ((group gnus-newsgroup-name)) - (gnus-summary-reply-with-original n) - (set-buffer gnus-message-buffer) - (insert (format gnus-nastygram-message group)) - (message-send-and-exit)))) + (when (or gnus-expert-user + (gnus-y-or-n-p + "Really send a nastygram to the author of the current article? ")) + (let ((group gnus-newsgroup-name)) + (gnus-summary-reply-with-original n) + (set-buffer gnus-message-buffer) + (message-goto-body) + (insert (format gnus-nastygram-message group)) + (message-send-and-exit)))) + +(defun gnus-summary-mail-crosspost-complaint (n) + "Send a complaint about crossposting to the current article(s)." + (interactive "P") + (let ((articles (gnus-summary-work-articles n)) + article) + (while (setq article (pop articles)) + (set-buffer gnus-summary-buffer) + (gnus-summary-goto-subject article) + (let ((group (gnus-group-real-name gnus-newsgroup-name)) + newsgroups followup-to) + (gnus-summary-select-article) + (set-buffer gnus-original-article-buffer) + (if (and (<= (length (message-tokenize-header + (setq newsgroups (mail-fetch-field "newsgroups")) + ", ")) + 1) + (or (not (setq followup-to (mail-fetch-field "followup-to"))) + (not (member group (message-tokenize-header + followup-to ", "))))) + (if followup-to + (gnus-message 1 "Followup-to restricted") + (gnus-message 1 "Not a crossposted article")) + (set-buffer gnus-summary-buffer) + (gnus-summary-reply-with-original 1) + (set-buffer gnus-message-buffer) + (message-goto-body) + (insert (format gnus-crosspost-complaint newsgroups group)) + (message-goto-subject) + (re-search-forward " *$") + (replace-match " (crosspost notification)" t t) + (when (gnus-y-or-n-p "Send this complaint? ") + (message-send-and-exit))))))) (defun gnus-summary-mail-other-window () "Compose mail in other window." @@ -582,24 +713,17 @@ (logand (progn (while (search-forward "\"" nil t) (incf i)) - (if (zerop i) 2 i)) 2))))) + (if (zerop i) 2 i)) + 2))))) (skip-chars-forward ",") (skip-chars-forward "^,")) (skip-chars-backward " ") - (setq accumulated - (cons (buffer-substring beg (point)) - accumulated)) + (push (buffer-substring beg (point)) + accumulated) (skip-chars-forward "^,") (skip-chars-forward ", ")) accumulated)) -(defun gnus-mail-yank-original () - (interactive) - (save-excursion - (mail-yank-original nil)) - (or mail-yank-hooks mail-citation-hook - (run-hooks 'news-reply-header-hook))) - (defun gnus-inews-add-to-address (group) (let ((to-address (mail-fetch-field "to"))) (when (and to-address @@ -618,8 +742,8 @@ (or (and group (not (gnus-group-read-only-p group))) (setq group (read-string "Put in group: " nil (gnus-writable-groups)))) - (and (gnus-gethash group gnus-newsrc-hashtb) - (error "No such group: %s" group)) + (when (gnus-gethash group gnus-newsrc-hashtb) + (error "No such group: %s" group)) (save-excursion (save-restriction @@ -635,15 +759,14 @@ (gnus-inews-do-gcc) - (if (get-buffer gnus-group-buffer) - (progn - (if (gnus-buffer-exists-p (car-safe reply)) - (progn - (set-buffer (car reply)) - (and (cdr reply) - (gnus-summary-mark-article-as-replied - (cdr reply))))) - (and winconf (set-window-configuration winconf)))))) + (when (get-buffer gnus-group-buffer) + (when (gnus-buffer-exists-p (car-safe reply)) + (set-buffer (car reply)) + (and (cdr reply) + (gnus-summary-mark-article-as-replied + (cdr reply)))) + (when winconf + (set-window-configuration winconf))))) (defun gnus-article-mail (yank) "Send a reply to the address near point. @@ -658,9 +781,12 @@ (when yank (gnus-inews-yank-articles (list (cdr gnus-article-current))))))) +(defvar nntp-server-type) (defun gnus-bug () "Send a bug report to the Gnus maintainers." (interactive) + (unless (gnus-alive-p) + (error "Gnus has been shut down")) (gnus-setup-message 'bug (delete-other-windows) (switch-to-buffer "*Gnus Help Bug*") @@ -674,7 +800,10 @@ (re-search-forward (concat "^" (regexp-quote mail-header-separator) "$")) (forward-line 1) (insert (gnus-version) "\n") - (insert (emacs-version)) + (insert (emacs-version) "\n") + (when (and (boundp 'nntp-server-type) + (stringp nntp-server-type)) + (insert nntp-server-type)) (insert "\n\n\n\n\n") (gnus-debug) (goto-char (point-min)) @@ -682,49 +811,43 @@ (message ""))) (defun gnus-bug-kill-buffer () - (and (get-buffer "*Gnus Help Bug*") - (kill-buffer "*Gnus Help Bug*"))) + (when (get-buffer "*Gnus Help Bug*") + (kill-buffer "*Gnus Help Bug*"))) (defun gnus-debug () - "Attemps to go through the Gnus source file and report what variables have been changed. + "Attempts to go through the Gnus source file and report what variables have been changed. The source file has to be in the Emacs load path." (interactive) - (let ((files '("gnus.el" "gnus-msg.el" "gnus-score.el" "nnmail.el" - "message.el")) - file dirs expr olist sym) + (let ((files '("gnus.el" "gnus-sum.el" "gnus-group.el" + "gnus-art.el" "gnus-start.el" "gnus-async.el" + "gnus-msg.el" "gnus-score.el" "gnus-win.el" + "nnmail.el" "message.el")) + file expr olist sym) (gnus-message 4 "Please wait while we snoop your variables...") (sit-for 0) + ;; Go through all the files looking for non-default values for variables. (save-excursion (set-buffer (get-buffer-create " *gnus bug info*")) (buffer-disable-undo (current-buffer)) (while files (erase-buffer) - (setq dirs load-path) - (while dirs - (if (or (not (car dirs)) - (not (stringp (car dirs))) - (not (file-exists-p - (setq file (concat (file-name-as-directory - (car dirs)) (car files)))))) - (setq dirs (cdr dirs)) - (setq dirs nil) - (insert-file-contents file) + (when (and (setq file (locate-library (pop files))) + (file-exists-p file)) + (insert-file-contents file) + (goto-char (point-min)) + (if (not (re-search-forward "^;;* *Internal variables" nil t)) + (gnus-message 4 "Malformed sources in file %s" file) + (narrow-to-region (point-min) (point)) (goto-char (point-min)) - (if (not (re-search-forward "^;;* *Internal variables" nil t)) - (gnus-message 4 "Malformed sources in file %s" file) - (narrow-to-region (point-min) (point)) - (goto-char (point-min)) - (while (setq expr (condition-case () - (read (current-buffer)) (error nil))) - (condition-case () - (and (eq (car expr) 'defvar) - (stringp (nth 3 expr)) - (or (not (boundp (nth 1 expr))) - (not (equal (eval (nth 2 expr)) - (symbol-value (nth 1 expr))))) - (setq olist (cons (nth 1 expr) olist))) - (error nil)))))) - (setq files (cdr files))) + (while (setq expr (ignore-errors (read (current-buffer)))) + (ignore-errors + (and (or (eq (car expr) 'defvar) + (eq (car expr) 'defcustom)) + (stringp (nth 3 expr)) + (or (not (boundp (nth 1 expr))) + (not (equal (eval (nth 2 expr)) + (symbol-value (nth 1 expr))))) + (push (nth 1 expr) olist))))))) (kill-buffer (current-buffer))) (when (setq olist (nreverse olist)) (insert "------------------ Environment follows ------------------\n\n")) @@ -745,7 +868,7 @@ (setq olist (cdr olist))) (insert "\n\n") ;; Remove any null chars - they seem to cause trouble for some - ;; mailers. (Byte-compiled output from the stuff above.) + ;; mailers. (Byte-compiled output from the stuff above.) (goto-char (point-min)) (while (re-search-forward "[\000\200]" nil t) (replace-match "" t t)))) @@ -843,6 +966,7 @@ (let* ((var gnus-message-archive-group) (group (or group gnus-newsgroup-name "")) result + gcc-self-val (groups (cond ((null gnus-message-archive-method) @@ -886,13 +1010,28 @@ (gnus-inews-narrow-to-headers) (goto-char (point-max)) (insert "Gcc: ") - (while (setq name (pop groups)) - (insert (if (string-match ":" name) - name - (gnus-group-prefixed-name - name gnus-message-archive-method))) - (if groups (insert " "))) - (insert "\n")))))) + (if (and gnus-newsgroup-name + (setq gcc-self-val + (gnus-group-find-parameter + gnus-newsgroup-name 'gcc-self))) + (progn + (insert + (if (stringp gcc-self-val) + gcc-self-val + group)) + (if (not (eq gcc-self-val 'none)) + (insert "\n") + (progn + (beginning-of-line) + (kill-line)))) + (while (setq name (pop groups)) + (insert (if (string-match ":" name) + name + (gnus-group-prefixed-name + name gnus-message-archive-method))) + (when groups + (insert " "))) + (insert "\n"))))))) (defun gnus-summary-send-draft () "Enter a mail/post buffer to edit and send the draft." diff -r ad457d5f7d04 -r 0293115a14e9 lisp/gnus/gnus-nocem.el --- a/lisp/gnus/gnus-nocem.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/gnus/gnus-nocem.el Mon Aug 13 08:49:20 2007 +0200 @@ -1,5 +1,5 @@ ;;; gnus-nocem.el --- NoCeM pseudo-cancellation treatment -;; Copyright (C) 1995,96 Free Software Foundation, Inc. +;; Copyright (C) 1995,96,97 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; Keywords: news @@ -27,31 +27,58 @@ (require 'gnus) (require 'nnmail) -(eval-when-compile (require 'cl)) +(require 'gnus-art) +(require 'gnus-sum) +(require 'gnus-range) -(defvar gnus-nocem-groups - '("alt.nocem.misc" "news.admin.net-abuse.announce") - "*List of groups that will be searched for NoCeM messages.") +(defgroup gnus-nocem nil + "NoCeM pseudo-cancellation treatment" + :group 'gnus-score) + +(defcustom gnus-nocem-groups + '("news.lists.filters" "news.admin.net-abuse.bulletins" + "alt.nocem.misc" "news.admin.net-abuse.announce") + "List of groups that will be searched for NoCeM messages." + :group 'gnus-nocem + :type '(repeat (string :tag "Group"))) -(defvar gnus-nocem-issuers - '("Automoose-1" ; The CancelMoose[tm] on autopilot. - "clewis@ferret.ocunix.on.ca;" ; Chris Lewis -- Canadian angel & despammer. - "jem@xpat.com;" ; John Milburn -- despammer in Korea. - "red@redpoll.mrfs.oh.us (Richard E. Depew)" ; Spew/bincancel guy. - ) - "*List of NoCeM issuers to pay attention to.") +(defcustom gnus-nocem-issuers + '("AutoMoose-1" "Automoose-1" ; CancelMoose[tm] + "rbraver@ohww.norman.ok.us" ; Robert Braver + "clewis@ferret.ocunix.on.ca;" ; Chris Lewis + "jem@xpat.com;" ; Despammer from Korea + "snowhare@xmission.com" ; Benjamin "Snowhare" Franz + "red@redpoll.mrfs.oh.us (Richard E. Depew)" + ) + "List of NoCeM issuers to pay attention to." + :group 'gnus-nocem + :type '(repeat string)) -(defvar gnus-nocem-directory - (concat (file-name-as-directory gnus-article-save-directory) "NoCeM/") - "*Directory where NoCeM files will be stored.") +(defcustom gnus-nocem-directory + (nnheader-concat gnus-article-save-directory "NoCeM/") + "*Directory where NoCeM files will be stored." + :group 'gnus-nocem + :type 'directory) -(defvar gnus-nocem-expiry-wait 15 - "*Number of days to keep NoCeM headers in the cache.") +(defcustom gnus-nocem-expiry-wait 15 + "*Number of days to keep NoCeM headers in the cache." + :group 'gnus-nocem + :type 'integer) -(defvar gnus-nocem-verifyer nil +(defcustom gnus-nocem-verifyer 'mc-verify "*Function called to verify that the NoCeM message is valid. One likely value is `mc-verify'. If the function in this variable -isn't bound, the message will be used unconditionally.") +isn't bound, the message will be used unconditionally." + :group 'gnus-nocem + :type '(radio (function-item mc-verify) + (function :tag "other"))) + +(defcustom gnus-nocem-liberal-fetch nil + "*If t try to fetch all messages which have @@NCM in the subject. +Otherwise don't fetch messages which have references or whose messsage-id +matches an previously scanned and verified nocem message." + :group 'gnus-nocem + :type 'boolean) ;;; Internal variables @@ -59,6 +86,7 @@ (defvar gnus-nocem-alist nil) (defvar gnus-nocem-touched-alist nil) (defvar gnus-nocem-hashtb nil) +(defvar gnus-nocem-seen-message-ids nil) ;;; Functions @@ -73,21 +101,19 @@ (interactive) (let ((groups gnus-nocem-groups) group active gactive articles) - (or (file-exists-p gnus-nocem-directory) - (make-directory gnus-nocem-directory t)) + (gnus-make-directory gnus-nocem-directory) ;; Load any previous NoCeM headers. (gnus-nocem-load-cache) ;; Read the active file if it hasn't been read yet. (and (file-exists-p (gnus-nocem-active-file)) (not gnus-nocem-active) - (condition-case () - (load (gnus-nocem-active-file) t t t) - (error nil))) + (ignore-errors + (load (gnus-nocem-active-file) t t t))) ;; Go through all groups and see whether new articles have ;; arrived. (while (setq group (pop groups)) (if (not (setq gactive (gnus-activate-group group))) - () ; This group doesn't exist. + () ; This group doesn't exist. (setq active (nth 1 (assoc group gnus-nocem-active))) (when (and (not (< (cdr gactive) (car gactive))) ; Empty group. (or (not active) @@ -96,31 +122,35 @@ ;; headers. (save-excursion (let ((dependencies (make-vector 10 nil)) - (buffer (nnheader-set-temp-buffer " *Gnus NoCeM*")) - headers) - (setq headers - (if (eq 'nov - (gnus-retrieve-headers - (setq articles - (gnus-uncompress-range - (cons - (if active (1+ (cdr active)) - (car gactive)) - (cdr gactive)))) - group)) - (gnus-get-newsgroup-headers-xover - articles nil dependencies) - (gnus-get-newsgroup-headers dependencies))) - (while headers - ;; We take a closer look on all articles that have - ;; "@@NCM" in the subject. - (when (string-match "@@NCM" - (mail-header-subject (car headers))) - (gnus-nocem-check-article group (car headers))) - (setq headers (cdr headers))) - (kill-buffer (current-buffer))))) + headers header) + (nnheader-temp-write nil + (setq headers + (if (eq 'nov + (gnus-retrieve-headers + (setq articles + (gnus-uncompress-range + (cons + (if active (1+ (cdr active)) + (car gactive)) + (cdr gactive)))) + group)) + (gnus-get-newsgroup-headers-xover + articles nil dependencies) + (gnus-get-newsgroup-headers dependencies))) + (while (setq header (pop headers)) + ;; We take a closer look on all articles that have + ;; "@@NCM" in the subject. Unless we already read + ;; this cross posted message. Nocem messages + ;; are not allowed to have references, so we can + ;; ignore scanning followups. + (and (string-match "@@NCM" (mail-header-subject header)) + (or gnus-nocem-liberal-fetch + (and (string= "" (mail-header-references header)) + (not (member (mail-header-message-id header) + gnus-nocem-seen-message-ids)))) + (gnus-nocem-check-article group header))))))) (setq gnus-nocem-active - (cons (list group gactive) + (cons (list group gactive) (delq (assoc group gnus-nocem-active) gnus-nocem-active))))) ;; Save the results, if any. @@ -140,22 +170,29 @@ (nnmail-days-to-time gnus-nocem-expiry-wait))) (gnus-request-article-this-buffer (mail-header-number header) group) (goto-char (point-min)) + (when (re-search-forward "-----BEGIN PGP MESSAGE-----" nil t) + (delete-region (point-min) (match-beginning 0))) + (when (re-search-forward "-----END PGP MESSAGE-----\n?" nil t) + (delete-region (match-end 0) (point-max))) + (goto-char (point-min)) ;; The article has to have proper NoCeM headers. (when (and (setq b (search-forward "\n@@BEGIN NCM HEADERS\n" nil t)) (setq e (search-forward "\n@@BEGIN NCM BODY\n" nil t))) ;; We get the name of the issuer. (narrow-to-region b e) (setq issuer (mail-fetch-field "issuer")) - (and (member issuer gnus-nocem-issuers) ; We like her... - (gnus-nocem-verify-issuer issuer) ; She is who she says she is.. - (gnus-nocem-enter-article)))))) ; We gobble the message. - + (widen) + (and (member issuer gnus-nocem-issuers) ; We like her.... + (gnus-nocem-verify-issuer issuer) ; She is who she says she is... + (gnus-nocem-enter-article) ; We gobble the message.. + (push (mail-header-message-id header) ; But don't come back for + gnus-nocem-seen-message-ids)))))) ; second helpings. + (defun gnus-nocem-verify-issuer (person) "Verify using PGP that the canceler is who she says she is." - (widen) (if (fboundp gnus-nocem-verifyer) (funcall gnus-nocem-verifyer) - ;; If we don't have MailCrypt, then we use the message anyway. + ;; If we don't have Mailcrypt, then we use the message anyway. t)) (defun gnus-nocem-enter-article () @@ -164,31 +201,46 @@ (let ((b (search-forward "\n@@BEGIN NCM BODY\n" nil t)) (e (search-forward "\n@@END NCM BODY\n" nil t)) (buf (current-buffer)) - ncm id) + ncm id group) (when (and b e) (narrow-to-region b (1+ (match-beginning 0))) (goto-char (point-min)) (while (search-forward "\t" nil t) - (when (condition-case nil - (boundp (let ((obarray gnus-active-hashtb)) (read buf))) - (error nil)) - (beginning-of-line) - (while (= (following-char) ?\t) - (forward-line -1)) - (setq id (buffer-substring (point) (1- (search-forward "\t")))) - (push id ncm) - (gnus-sethash id t gnus-nocem-hashtb) - (forward-line 1) - (while (= (following-char) ?\t) - (forward-line 1)))) + (cond + ((not (ignore-errors + (setq group (let ((obarray gnus-active-hashtb)) (read buf))))) + ;; An error. + ) + ((not (symbolp group)) + ;; Ignore invalid entries. + ) + ((not (boundp group)) + ;; Make sure all entries in the hashtb are bound. + (set group nil)) + (t + (when (gnus-gethash (symbol-name group) gnus-newsrc-hashtb) + ;; Valid group. + (beginning-of-line) + (while (= (following-char) ?\t) + (forward-line -1)) + (setq id (buffer-substring (point) (1- (search-forward "\t")))) + (unless (gnus-gethash id gnus-nocem-hashtb) + ;; only store if not already present + (gnus-sethash id t gnus-nocem-hashtb) + (push id ncm)) + (forward-line 1) + (while (= (following-char) ?\t) + (forward-line 1)))))) (when ncm (setq gnus-nocem-touched-alist t) (push (cons (let ((time (current-time))) (setcdr (cdr time) nil) time) - ncm) - gnus-nocem-alist))))) + ncm) + gnus-nocem-alist)) + t))) (defun gnus-nocem-load-cache () "Load the NoCeM cache." + (interactive) (unless gnus-nocem-alist ;; The buffer doesn't exist, so we create it and load the NoCeM ;; cache. @@ -201,13 +253,13 @@ (when (and gnus-nocem-alist gnus-nocem-touched-alist) (nnheader-temp-write (gnus-nocem-cache-file) - (prin1 `(setq gnus-nocem-alist ',gnus-nocem-alist) (current-buffer))) + (gnus-prin1 `(setq gnus-nocem-alist ',gnus-nocem-alist))) (setq gnus-nocem-touched-alist nil))) (defun gnus-nocem-save-active () "Save the NoCeM active file." (nnheader-temp-write (gnus-nocem-active-file) - (prin1 `(setq gnus-nocem-active ',gnus-nocem-active) (current-buffer)))) + (gnus-prin1 `(setq gnus-nocem-active ',gnus-nocem-active)))) (defun gnus-nocem-alist-to-hashtb () "Create a hashtable from the Message-IDs we have." @@ -236,7 +288,8 @@ (setq gnus-nocem-alist nil gnus-nocem-hashtb nil gnus-nocem-active nil - gnus-nocem-touched-alist nil)) + gnus-nocem-touched-alist nil + gnus-nocem-seen-message-ids nil)) (defun gnus-nocem-unwanted-article-p (id) "Say whether article ID in the current group is wanted." diff -r ad457d5f7d04 -r 0293115a14e9 lisp/gnus/gnus-picon.el --- a/lisp/gnus/gnus-picon.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/gnus/gnus-picon.el Mon Aug 13 08:49:20 2007 +0200 @@ -1,5 +1,5 @@ ;;; gnus-picon.el --- displaying pretty icons in Gnus -;; Copyright (C) 1996 Free Software Foundation, Inc. +;; Copyright (C) 1996,97 Free Software Foundation, Inc. ;; Author: Wes Hardaker ;; Keywords: news xpm annotation glyph faces @@ -23,94 +23,76 @@ ;;; Commentary: -;; Usage: -;; - You must have XEmacs (19.12 or above I think) to use this. -;; - Read the variable descriptions below. -;; -;; - chose a setup: -;; -;; 1) display the icons in its own buffer: -;; -;; (add-hook 'gnus-article-display-hook 'gnus-article-display-picons t) -;; (add-hook 'gnus-summary-prepare-hook 'gnus-group-display-picons t) -;; (setq gnus-picons-display-where 'picons) -;; -;; Then add the picons buffer to your display configuration: -;; The picons buffer needs to be at least 48 pixels high, -;; which for me is 5 lines: -;; -;; (gnus-add-configuration -;; '(article (vertical 1.0 -;; (group 6) -;; (picons 5) -;; (summary .25 point) -;; (article 1.0)))) -;; -;; (gnus-add-configuration -;; '(summary (vertical 1.0 (group 6) -;; (picons 5) -;; (summary 1.0 point)))) -;; -;; 2) display the icons in the summary buffer -;; -;; (add-hook 'gnus-article-display-hook 'gnus-article-display-picons t) -;; (add-hook 'gnus-summary-prepare-hook 'gnus-group-display-picons t) -;; (setq gnus-picons-display-where 'summary) -;; -;; 3) display the icons in the article buffer -;; -;; (add-hook 'gnus-article-display-hook 'gnus-article-display-picons t) -;; (add-hook 'gnus-article-prepare-hook 'gnus-group-display-picons t) -;; (setq gnus-picons-display-where 'article) -;; -;; -;; Warnings: -;; - I'm not even close to being a lisp expert. -;; - The 't' (append) flag MUST be in the add-hook line -;; -;; TODO: -;; - Remove the TODO section in the headers. -;; - ;;; Code: +(require 'gnus) (require 'xpm) (require 'annotations) -(eval-when-compile (require 'cl)) +(require 'custom) -(defvar gnus-picons-buffer "*Icon Buffer*" - "Buffer name to display the icons in if gnus-picons-display-where is 'picons.") +(defgroup picons nil + "Show pictures of people, domains, and newsgroups (XEmacs). +For this to work, you must add gnus-group-display-picons to the +gnus-summary-display-hook or to the gnus-article-display-hook +depending on what gnus-picons-display-where is set to. You must +also add gnus-article-display-picons to gnus-article-display-hook." + :group 'gnus-visual) -(defvar gnus-picons-display-where 'picons - "Where to display the group and article icons.") +(defcustom gnus-picons-buffer "*Icon Buffer*" + "Buffer name to display the icons in if gnus-picons-display-where is 'picons." + :type 'string + :group 'picons) -(defvar gnus-picons-database "/usr/local/faces" +(defcustom gnus-picons-display-where 'picons + "Where to display the group and article icons." + :type '(choice symbol string) + :group 'picons) + +(defcustom gnus-picons-database "/usr/local/faces" "Defines the location of the faces database. For information on obtaining this database of pretty pictures, please -see http://www.cs.indiana.edu/picons/ftp/index.html" ) - -(defvar gnus-picons-news-directory "news" - "Sub-directory of the faces database containing the icons for newsgroups." -) +see http://www.cs.indiana.edu/picons/ftp/index.html" + :type 'directory + :group 'picons) -(defvar gnus-picons-user-directories '("local" "users" "usenix" "misc/MISC") +(defcustom gnus-picons-news-directory "news" + "Sub-directory of the faces database containing the icons for newsgroups." + :type 'string + :group 'picons) + +(defcustom gnus-picons-user-directories '("local" "users" "usenix" "misc/MISC") "List of directories to search for user faces." -) + :type '(repeat string) + :group 'picons) -(defvar gnus-picons-domain-directories '("domains") +(defcustom gnus-picons-domain-directories '("domains") "List of directories to search for domain faces. Some people may want to add \"unknown\" to this list." -) + :type '(repeat string) + :group 'picons) -(defvar gnus-picons-x-face-file-name - (format "/tmp/picon-xface.%s.xbm" (user-login-name)) - "The name of the file in which to store the converted X-face header.") +(defcustom gnus-picons-refresh-before-display nil + "If non-nil, display the article buffer before computing the picons." + :type 'boolean + :group 'picons) -(defvar gnus-picons-convert-x-face (format "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | pbmtoxbm > %s" gnus-picons-x-face-file-name) +(defcustom gnus-picons-x-face-file-name + (format "/tmp/picon-xface.%s.xbm" (user-login-name)) + "The name of the file in which to store the converted X-face header." + :type 'string + :group 'picons) + +(defcustom gnus-picons-convert-x-face (format "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | pbmtoxbm > %s" gnus-picons-x-face-file-name) "Command to convert the x-face header into a xbm file." -) + :type 'string + :group 'picons) -(defvar gnus-picons-file-suffixes +(defcustom gnus-picons-display-as-address t + "*If t display textual email addresses along with pictures." + :type 'boolean + :group 'picons) + +(defcustom gnus-picons-file-suffixes (when (featurep 'x) (let ((types (list "xbm"))) (when (featurep 'gif) @@ -118,11 +100,20 @@ (when (featurep 'xpm) (push "xpm" types)) types)) - "List of suffixes on picon file names to try.") + "List of suffixes on picon file names to try." + :type '(repeat string) + :group 'picons) -(defvar gnus-picons-display-article-move-p t +(defcustom gnus-picons-display-article-move-p t "*Whether to move point to first empty line when displaying picons. -This has only an effect if `gnus-picons-display-where' hs value article.") +This has only an effect if `gnus-picons-display-where' hs value article." + :type 'boolean + :group 'picons) + +(defvar gnus-picons-map (make-sparse-keymap "gnus-picons-keys") + "keymap to hide/show picon glyphs") + +(define-key gnus-picons-map [(button2)] 'gnus-picons-toggle-extent) ;;; Internal variables. @@ -133,10 +124,9 @@ (defun gnus-picons-remove (plist) (let ((listitem (car plist))) (while (setq listitem (car plist)) - (if (annotationp listitem) - (delete-annotation listitem)) - (setq plist (cdr plist)))) - ) + (when (annotationp listitem) + (delete-annotation listitem)) + (setq plist (cdr plist))))) (defun gnus-picons-remove-all () "Removes all picons from the Gnus display(s)." @@ -147,9 +137,8 @@ (setq gnus-article-annotations nil gnus-group-annotations nil gnus-x-face-annotations nil) - (if (bufferp gnus-picons-buffer) - (kill-buffer gnus-picons-buffer)) - ) + (when (bufferp gnus-picons-buffer) + (kill-buffer gnus-picons-buffer))) (defun gnus-get-buffer-name (variable) "Returns the buffer name associated with the contents of a variable." @@ -207,19 +196,28 @@ (defun gnus-article-display-picons () "Display faces for an author and his/her domain in gnus-picons-display-where." (interactive) - (let (from at-idx databases) - (when (and (featurep 'xpm) + ;; let drawing catch up + (when gnus-picons-refresh-before-display + (sit-for 0)) + (let ((first t) + from at-idx databases) + (when (and (featurep 'xpm) (or (not (fboundp 'device-type)) (equal (device-type) 'x)) (setq from (mail-fetch-field "from")) - (setq from (downcase (or (cadr (mail-extract-address-components - from)) - "")) - at-idx (string-match "@" from))) + (setq from (downcase + (or (cadr (mail-extract-address-components from)) + ""))) + (or (setq at-idx (string-match "@" from)) + (setq at-idx (length from)))) (save-excursion (let ((username (substring from 0 at-idx)) - (addrs (nreverse - (message-tokenize-header (substring from (1+ at-idx)) - ".")))) + (addrs (if (eq at-idx (length from)) + (if gnus-local-domain + (nreverse (message-tokenize-header + gnus-local-domain ".")) + '("")) + (nreverse (message-tokenize-header + (substring from (1+ at-idx)) "."))))) (set-buffer (get-buffer-create (gnus-get-buffer-name gnus-picons-display-where))) (gnus-add-current-to-buffer-list) @@ -235,26 +233,54 @@ (gnus-picons-remove gnus-article-annotations) (setq gnus-article-annotations nil) - (setq databases (append gnus-picons-user-directories - gnus-picons-domain-directories)) + ;; look for domain paths. + (setq databases gnus-picons-domain-directories) (while databases (setq gnus-article-annotations (nconc (gnus-picons-insert-face-if-exists (car databases) addrs - "unknown") - (gnus-picons-insert-face-if-exists - (car databases) - addrs - (downcase username) t) + "unknown" (or gnus-picons-display-as-address + gnus-article-annotations) t t) gnus-article-annotations)) (setq databases (cdr databases))) + + ;; add an '@' if displaying as address + (when gnus-picons-display-as-address + (setq gnus-article-annotations + (nconc gnus-article-annotations + (list + (make-annotation "@" (point) 'text nil nil nil t))))) + + ;; then do user directories, + (let (found) + (setq databases gnus-picons-user-directories) + (setq username (downcase username)) + (while databases + (setq found + (nconc (gnus-picons-insert-face-if-exists + (car databases) addrs username + (or gnus-picons-display-as-address + gnus-article-annotations) nil t) + found)) + (setq databases (cdr databases))) + ;; add their name if no face exists + (when (and gnus-picons-display-as-address (not found)) + (setq found + (list + (make-annotation username (point) 'text nil nil nil t)))) + (setq gnus-article-annotations + (nconc found gnus-article-annotations))) + (add-hook 'gnus-summary-exit-hook 'gnus-picons-remove-all)))))) (defun gnus-group-display-picons () "Display icons for the group in the gnus-picons-display-where buffer." (interactive) - (when (and (featurep 'xpm) + ;; let display catch up so far + (when gnus-picons-refresh-before-display + (sit-for 0)) + (when (and (featurep 'xpm) (or (not (fboundp 'device-type)) (equal (device-type) 'x))) (save-excursion (set-buffer (get-buffer-create @@ -263,14 +289,16 @@ (goto-char (point-min)) (if (and (eq gnus-picons-display-where 'article) gnus-picons-display-article-move-p) - (if (search-forward "\n\n" nil t) - (forward-line -1)) + (when (search-forward "\n\n" nil t) + (forward-line -1)) (unless (eolp) (push (make-annotation "\n" (point) 'text) gnus-group-annotations))) - (cond + (cond ((listp gnus-group-annotations) - (mapcar 'delete-annotation gnus-group-annotations) + (mapc #'(lambda (ext) (when (extent-live-p ext) + (delete-annotation ext))) + gnus-group-annotations) (setq gnus-group-annotations nil)) ((annotationp gnus-group-annotations) (delete-annotation gnus-group-annotations) @@ -280,7 +308,7 @@ (gnus-picons-insert-face-if-exists gnus-picons-news-directory (message-tokenize-header gnus-newsgroup-name ".") - "unknown")) + "unknown" nil t)) (add-hook 'gnus-summary-exit-hook 'gnus-picons-remove-all)))) (defsubst gnus-picons-try-suffixes (file) @@ -292,10 +320,10 @@ f)) (defun gnus-picons-insert-face-if-exists (database addrs filename &optional - nobar-p) + nobar-p dots rightp) "Inserts a face at point if I can find one" ;; '(gnus-picons-insert-face-if-exists - ; "Database" '("edu" "indiana" "cs") "Name") + ;; "Database" '("edu" "indiana" "cs") "Name") ;; looks for: ;; 1. edu/indiana/cs/Name ;; 2. edu/indiana/Name @@ -307,34 +335,62 @@ ;; The special treatment of MISC doesn't conform with the conventions for ;; picon databases, but otherwise we would always see the MISC/unknown face. (let ((bar (and (not nobar-p) - (annotations-in-region - (point) (min (point-max) (1+ (point))) - (current-buffer)))) + (or gnus-picons-display-as-address + (annotations-in-region + (point) (min (point-max) (1+ (point))) + (current-buffer))))) (path (concat (file-name-as-directory gnus-picons-database) database "/")) - picons found bar-ann) - (if (string-match "/MISC" database) - (setq addrs '(""))) + (domainp (and gnus-picons-display-as-address dots)) + picons found bar-ann cur first) + (when (string-match "/MISC" database) + (setq addrs '(""))) (while (and addrs (file-accessible-directory-p path)) - (setq path (concat path (pop addrs) "/")) - (when (setq found - (gnus-picons-try-suffixes - (concat path filename "/face."))) - (when bar - (setq bar-ann (gnus-picons-try-to-find-face - (concat gnus-xmas-glyph-directory "bar.xbm"))) - (when bar-ann - (setq picons (nconc picons bar-ann)) - (setq bar nil))) - (setq picons (nconc (gnus-picons-try-to-find-face found) - picons)))) - (nreverse picons))) + (setq cur (pop addrs) + path (concat path cur "/")) + (if (setq found + (gnus-picons-try-suffixes (concat path filename "/face."))) + (progn + (setq picons (nconc (when (and domainp first rightp) + (list (make-annotation + "." (point) 'text + nil nil nil rightp) + picons)) + (gnus-picons-try-to-find-face + found nil (if domainp cur filename) rightp) + (when (and domainp first (not rightp)) + (list (make-annotation + "." (point) 'text + nil nil nil rightp) + picons)) + picons))) + (when domainp + (setq picons + (nconc (list (make-annotation + (if first (concat (if (not rightp) ".") cur + (if rightp ".")) cur) + (point) 'text nil nil nil rightp)) + picons)))) + (when (and bar (or domainp found)) + (setq bar-ann (gnus-picons-try-to-find-face + (concat gnus-xmas-glyph-directory "bar.xbm") + nil nil t)) + (when bar-ann + (setq picons (nconc picons bar-ann)) + (setq bar nil))) + (setq first t)) + (when (and addrs domainp) + (let ((it (mapconcat 'downcase (nreverse addrs) "."))) + (make-annotation + (if first (concat (if (not rightp) ".") it (if rightp ".")) it) + (point) 'text nil nil nil rightp))) + picons)) (defvar gnus-picons-glyph-alist nil) -(defun gnus-picons-try-to-find-face (path &optional xface-p) - "If PATH exists, display it as a bitmap. Returns t if succedded." +(defun gnus-picons-try-to-find-face (path &optional xface-p part rightp) + "If PATH exists, display it as a bitmap. Returns t if succeeded." (let ((glyph (and (not xface-p) (cdr (assoc path gnus-picons-glyph-alist))))) (when (or glyph (file-exists-p path)) @@ -343,15 +399,35 @@ (unless xface-p (push (cons path glyph) gnus-picons-glyph-alist)) (set-glyph-face glyph 'default)) - (nconc - (list (make-annotation glyph (point) 'text)) - (when (eq major-mode 'gnus-article-mode) - (list (make-annotation " " (point) 'text))))))) + (let ((new (make-annotation glyph (point) 'text nil nil nil rightp))) + (nconc + (list new) + (when (and (eq major-mode 'gnus-article-mode) + (not gnus-picons-display-as-address) + (not part)) + (list (make-annotation " " (point) 'text nil nil nil rightp))) + (when (and part gnus-picons-display-as-address) + (let ((txt (make-annotation part (point) 'text nil nil nil rightp))) + (hide-annotation txt) + (set-extent-property txt 'its-partner new) + (set-extent-property txt 'keymap gnus-picons-map) + (set-extent-property txt 'mouse-face gnus-article-mouse-face) + (set-extent-property new 'its-partner txt) + (set-extent-property new 'keymap gnus-picons-map)))))))) (defun gnus-picons-reverse-domain-path (str) "a/b/c/d -> d/c/b/a" (mapconcat 'downcase (nreverse (message-tokenize-header str "/")) "/")) +(defun gnus-picons-toggle-extent (event) + "Toggle picon glyph at given point" + (interactive "e") + (let* ((ant1 (event-glyph-extent event)) + (ant2 (extent-property ant1 'its-partner))) + (when (and (annotationp ant1) (annotationp ant2)) + (reveal-annotation ant2) + (hide-annotation ant1)))) + (gnus-add-shutdown 'gnus-picons-close 'gnus) (defun gnus-picons-close () diff -r ad457d5f7d04 -r 0293115a14e9 lisp/gnus/gnus-range.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus/gnus-range.el Mon Aug 13 08:49:20 2007 +0200 @@ -0,0 +1,281 @@ +;;; gnus-range.el --- range and sequence functions for Gnus +;; Copyright (C) 1996,97 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen +;; Keywords: news + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;;; Code: + +;;; List and range functions + +(defun gnus-last-element (list) + "Return last element of LIST." + (while (cdr list) + (setq list (cdr list))) + (car list)) + +(defun gnus-copy-sequence (list) + "Do a complete, total copy of a list." + (let (out) + (while (consp list) + (if (consp (car list)) + (push (gnus-copy-sequence (pop list)) out) + (push (pop list) out))) + (if list + (nconc (nreverse out) list) + (nreverse out)))) + +(defun gnus-set-difference (list1 list2) + "Return a list of elements of LIST1 that do not appear in LIST2." + (let ((list1 (copy-sequence list1))) + (while list2 + (setq list1 (delq (car list2) list1)) + (setq list2 (cdr list2))) + list1)) + +(defun gnus-sorted-complement (list1 list2) + "Return a list of elements of LIST1 that do not appear in LIST2. +Both lists have to be sorted over <." + (let (out) + (if (or (null list1) (null list2)) + (or list1 list2) + (while (and list1 list2) + (cond ((= (car list1) (car list2)) + (setq list1 (cdr list1) + list2 (cdr list2))) + ((< (car list1) (car list2)) + (setq out (cons (car list1) out)) + (setq list1 (cdr list1))) + (t + (setq out (cons (car list2) out)) + (setq list2 (cdr list2))))) + (nconc (nreverse out) (or list1 list2))))) + +(defun gnus-intersection (list1 list2) + (let ((result nil)) + (while list2 + (when (memq (car list2) list1) + (setq result (cons (car list2) result))) + (setq list2 (cdr list2))) + result)) + +(defun gnus-sorted-intersection (list1 list2) + ;; LIST1 and LIST2 have to be sorted over <. + (let (out) + (while (and list1 list2) + (cond ((= (car list1) (car list2)) + (setq out (cons (car list1) out) + list1 (cdr list1) + list2 (cdr list2))) + ((< (car list1) (car list2)) + (setq list1 (cdr list1))) + (t + (setq list2 (cdr list2))))) + (nreverse out))) + +(defun gnus-set-sorted-intersection (list1 list2) + ;; LIST1 and LIST2 have to be sorted over <. + ;; This function modifies LIST1. + (let* ((top (cons nil list1)) + (prev top)) + (while (and list1 list2) + (cond ((= (car list1) (car list2)) + (setq prev list1 + list1 (cdr list1) + list2 (cdr list2))) + ((< (car list1) (car list2)) + (setcdr prev (cdr list1)) + (setq list1 (cdr list1))) + (t + (setq list2 (cdr list2))))) + (setcdr prev nil) + (cdr top))) + +(defun gnus-compress-sequence (numbers &optional always-list) + "Convert list of numbers to a list of ranges or a single range. +If ALWAYS-LIST is non-nil, this function will always release a list of +ranges." + (let* ((first (car numbers)) + (last (car numbers)) + result) + (if (null numbers) + nil + (if (not (listp (cdr numbers))) + numbers + (while numbers + (cond ((= last (car numbers)) nil) ;Omit duplicated number + ((= (1+ last) (car numbers)) ;Still in sequence + (setq last (car numbers))) + (t ;End of one sequence + (setq result + (cons (if (= first last) first + (cons first last)) + result)) + (setq first (car numbers)) + (setq last (car numbers)))) + (setq numbers (cdr numbers))) + (if (and (not always-list) (null result)) + (if (= first last) (list first) (cons first last)) + (nreverse (cons (if (= first last) first (cons first last)) + result))))))) + +(defalias 'gnus-uncompress-sequence 'gnus-uncompress-range) +(defun gnus-uncompress-range (ranges) + "Expand a list of ranges into a list of numbers. +RANGES is either a single range on the form `(num . num)' or a list of +these ranges." + (let (first last result) + (cond + ((null ranges) + nil) + ((not (listp (cdr ranges))) + (setq first (car ranges)) + (setq last (cdr ranges)) + (while (<= first last) + (setq result (cons first result)) + (setq first (1+ first))) + (nreverse result)) + (t + (while ranges + (if (atom (car ranges)) + (when (numberp (car ranges)) + (setq result (cons (car ranges) result))) + (setq first (caar ranges)) + (setq last (cdar ranges)) + (while (<= first last) + (setq result (cons first result)) + (setq first (1+ first)))) + (setq ranges (cdr ranges))) + (nreverse result))))) + +(defun gnus-add-to-range (ranges list) + "Return a list of ranges that has all articles from both RANGES and LIST. +Note: LIST has to be sorted over `<'." + (if (not ranges) + (gnus-compress-sequence list t) + (setq list (copy-sequence list)) + (unless (listp (cdr ranges)) + (setq ranges (list ranges))) + (let ((out ranges) + ilist lowest highest temp) + (while (and ranges list) + (setq ilist list) + (setq lowest (or (and (atom (car ranges)) (car ranges)) + (caar ranges))) + (while (and list (cdr list) (< (cadr list) lowest)) + (setq list (cdr list))) + (when (< (car ilist) lowest) + (setq temp list) + (setq list (cdr list)) + (setcdr temp nil) + (setq out (nconc (gnus-compress-sequence ilist t) out))) + (setq highest (or (and (atom (car ranges)) (car ranges)) + (cdar ranges))) + (while (and list (<= (car list) highest)) + (setq list (cdr list))) + (setq ranges (cdr ranges))) + (when list + (setq out (nconc (gnus-compress-sequence list t) out))) + (setq out (sort out (lambda (r1 r2) + (< (or (and (atom r1) r1) (car r1)) + (or (and (atom r2) r2) (car r2)))))) + (setq ranges out) + (while ranges + (if (atom (car ranges)) + (when (cdr ranges) + (if (atom (cadr ranges)) + (when (= (1+ (car ranges)) (cadr ranges)) + (setcar ranges (cons (car ranges) + (cadr ranges))) + (setcdr ranges (cddr ranges))) + (when (= (1+ (car ranges)) (caadr ranges)) + (setcar (cadr ranges) (car ranges)) + (setcar ranges (cadr ranges)) + (setcdr ranges (cddr ranges))))) + (when (cdr ranges) + (if (atom (cadr ranges)) + (when (= (1+ (cdar ranges)) (cadr ranges)) + (setcdr (car ranges) (cadr ranges)) + (setcdr ranges (cddr ranges))) + (when (= (1+ (cdar ranges)) (caadr ranges)) + (setcdr (car ranges) (cdadr ranges)) + (setcdr ranges (cddr ranges)))))) + (setq ranges (cdr ranges))) + out))) + +(defun gnus-remove-from-range (ranges list) + "Return a list of ranges that has all articles from LIST removed from RANGES. +Note: LIST has to be sorted over `<'." + ;; !!! This function shouldn't look like this, but I've got a headache. + (gnus-compress-sequence + (gnus-sorted-complement + (gnus-uncompress-range ranges) list))) + +(defun gnus-member-of-range (number ranges) + (if (not (listp (cdr ranges))) + (and (>= number (car ranges)) + (<= number (cdr ranges))) + (let ((not-stop t)) + (while (and ranges + (if (numberp (car ranges)) + (>= number (car ranges)) + (>= number (caar ranges))) + not-stop) + (when (if (numberp (car ranges)) + (= number (car ranges)) + (and (>= number (caar ranges)) + (<= number (cdar ranges)))) + (setq not-stop nil)) + (setq ranges (cdr ranges))) + (not not-stop)))) + +(defun gnus-range-length (range) + "Return the length RANGE would have if uncompressed." + (length (gnus-uncompress-range range))) + +(defun gnus-sublist-p (list sublist) + "Test whether all elements in SUBLIST are members of LIST." + (let ((sublistp t)) + (while sublist + (unless (memq (pop sublist) list) + (setq sublistp nil + sublist nil))) + sublistp)) + +(defun gnus-range-add (range1 range2) + "Add RANGE2 to RANGE1 destructively." + (cond + ;; If either are nil, then the job is quite easy. + ((or (null range1) (null range2)) + (or range1 range2)) + (t + ;; I don't like thinking. + (gnus-compress-sequence + (sort + (nconc + (gnus-uncompress-range range1) + (gnus-uncompress-range range2)) + '<))))) + +(provide 'gnus-range) + +;;; gnus-range.el ends here diff -r ad457d5f7d04 -r 0293115a14e9 lisp/gnus/gnus-salt.el --- a/lisp/gnus/gnus-salt.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/gnus/gnus-salt.el Mon Aug 13 08:49:20 2007 +0200 @@ -1,5 +1,5 @@ ;;; gnus-salt.el --- alternate summary mode interfaces for Gnus -;; Copyright (C) 1996 Free Software Foundation, Inc. +;; Copyright (C) 1996,97 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen @@ -25,7 +25,7 @@ ;;; Code: (require 'gnus) -(eval-when-compile (require 'cl)) +(require 'gnus-sum) ;;; ;;; gnus-pick-mode @@ -40,6 +40,17 @@ (defvar gnus-pick-mode-hook nil "Hook run in summary pick mode buffers.") +(defvar gnus-mark-unpicked-articles-as-read nil + "*If non-nil, mark all unpicked articles as read.") + +(defvar gnus-pick-elegant-flow t + "If non-nil, gnus-pick-start-reading will run gnus-summary-next-group when no articles have been picked.") + +(defvar gnus-summary-pick-line-format + "%-5P %U\%R\%z\%I\%(%[%4L: %-20,20n%]%) %s\n" + "*The format specification of the lines in pick buffers. +It accepts the same format specs that `gnus-summary-line-format' does.") + ;;; Internal variables. (defvar gnus-pick-mode-map nil) @@ -51,7 +62,7 @@ gnus-pick-mode-map "t" gnus-uu-mark-thread "T" gnus-uu-unmark-thread - " " gnus-summary-mark-as-processable + " " gnus-pick-next-page "u" gnus-summary-unmark-as-processable "U" gnus-summary-unmark-all-processable "v" gnus-uu-mark-over @@ -61,6 +72,10 @@ "E" gnus-uu-mark-by-regexp "b" gnus-uu-mark-buffer "B" gnus-uu-unmark-buffer + "." gnus-pick-article + gnus-down-mouse-2 gnus-pick-mouse-pick-region + ;;gnus-mouse-2 gnus-pick-mouse-pick + "X" gnus-pick-start-reading "\r" gnus-pick-start-reading)) (defun gnus-pick-make-menu-bar () @@ -89,17 +104,21 @@ \\{gnus-pick-mode-map}" (interactive "P") (when (eq major-mode 'gnus-summary-mode) - (make-local-variable 'gnus-pick-mode) - (setq gnus-pick-mode - (if (null arg) (not gnus-pick-mode) - (> (prefix-numeric-value arg) 0))) - (when gnus-pick-mode + (if (not (set (make-local-variable 'gnus-pick-mode) + (if (null arg) (not gnus-pick-mode) + (> (prefix-numeric-value arg) 0)))) + (remove-hook 'gnus-message-setup-hook 'gnus-pick-setup-message) ;; Make sure that we don't select any articles upon group entry. - (make-local-variable 'gnus-auto-select-first) - (setq gnus-auto-select-first nil) + (set (make-local-variable 'gnus-auto-select-first) nil) + ;; Change line format. + (setq gnus-summary-line-format gnus-summary-pick-line-format) + (setq gnus-summary-line-format-spec nil) + (gnus-update-format-specifications nil 'summary) + (gnus-update-summary-mark-positions) + (add-hook 'gnus-message-setup-hook 'gnus-pick-setup-message) + (set (make-local-variable 'gnus-summary-goto-unread) 'never) ;; Set up the menu. - (when (and menu-bar-mode - (gnus-visual-p 'pick-menu 'menu)) + (when (gnus-visual-p 'pick-menu 'menu) (gnus-pick-make-menu-bar)) (unless (assq 'gnus-pick-mode minor-mode-alist) (push '(gnus-pick-mode " Pick") minor-mode-alist)) @@ -108,25 +127,169 @@ minor-mode-map-alist)) (run-hooks 'gnus-pick-mode-hook)))) +(defun gnus-pick-setup-message () + "Make Message do the right thing on exit." + (when (and (gnus-buffer-live-p gnus-summary-buffer) + (save-excursion + (set-buffer gnus-summary-buffer) + gnus-pick-mode)) + (message-add-action + '(gnus-configure-windows 'pick t) 'send 'exit 'postpone 'kill))) + +(defvar gnus-pick-line-number 1) +(defun gnus-pick-line-number () + "Return the current line number." + (if (bobp) + (setq gnus-pick-line-number 1) + (incf gnus-pick-line-number))) + (defun gnus-pick-start-reading (&optional catch-up) "Start reading the picked articles. If given a prefix, mark all unpicked articles as read." (interactive "P") - (unless gnus-newsgroup-processable - (error "No articles have been picked")) - (gnus-summary-limit-to-articles nil) - (when catch-up - (gnus-summary-limit-mark-excluded-as-read)) - (gnus-summary-first-unread-article) - (gnus-configure-windows (if gnus-pick-display-summary 'article 'pick) t)) + (if gnus-newsgroup-processable + (progn + (gnus-summary-limit-to-articles nil) + (when (or catch-up gnus-mark-unpicked-articles-as-read) + (gnus-summary-limit-mark-excluded-as-read)) + (gnus-summary-first-article) + (gnus-configure-windows + (if gnus-pick-display-summary 'article 'pick) t)) + (if gnus-pick-elegant-flow + (progn + (when (or catch-up gnus-mark-unpicked-articles-as-read) + (gnus-summary-limit-mark-excluded-as-read)) + (if (gnus-group-quit-config gnus-newsgroup-name) + (gnus-summary-exit) + (gnus-summary-next-group))) + (error "No articles have been picked")))) + +(defun gnus-pick-article (&optional arg) + "Pick the article on the current line. +If ARG, pick the article on that line instead." + (interactive "P") + (when arg + (let (pos) + (save-excursion + (goto-char (point-min)) + (when (zerop (forward-line (1- (prefix-numeric-value arg)))) + (setq pos (point)))) + (if (not pos) + (gnus-error 2 "No such line: %s" arg) + (goto-char pos)))) + (gnus-summary-mark-as-processable 1)) + +(defun gnus-pick-mouse-pick (e) + (interactive "e") + (mouse-set-point e) + (save-excursion + (gnus-summary-mark-as-processable 1))) +(defun gnus-pick-mouse-pick-region (start-event) + "Pick articles that the mouse is dragged over. +This must be bound to a button-down mouse event." + (interactive "e") + (mouse-minibuffer-check start-event) + (let* ((echo-keystrokes 0) + (start-posn (event-start start-event)) + (start-point (posn-point start-posn)) + (start-line (1+ (count-lines 1 start-point))) + (start-window (posn-window start-posn)) + (start-frame (window-frame start-window)) + (bounds (window-edges start-window)) + (top (nth 1 bounds)) + (bottom (if (window-minibuffer-p start-window) + (nth 3 bounds) + ;; Don't count the mode line. + (1- (nth 3 bounds)))) + (click-count (1- (event-click-count start-event)))) + (setq mouse-selection-click-count click-count) + (setq mouse-selection-click-count-buffer (current-buffer)) + (mouse-set-point start-event) + ;; In case the down click is in the middle of some intangible text, + ;; use the end of that text, and put it in START-POINT. + (when (< (point) start-point) + (goto-char start-point)) + (gnus-pick-article) + (setq start-point (point)) + ;; end-of-range is used only in the single-click case. + ;; It is the place where the drag has reached so far + ;; (but not outside the window where the drag started). + (let (event end end-point last-end-point (end-of-range (point))) + (track-mouse + (while (progn + (setq event (read-event)) + (or (mouse-movement-p event) + (eq (car-safe event) 'switch-frame))) + (if (eq (car-safe event) 'switch-frame) + nil + (setq end (event-end event) + end-point (posn-point end)) + (when end-point + (setq last-end-point end-point)) + + (cond + ;; Are we moving within the original window? + ((and (eq (posn-window end) start-window) + (integer-or-marker-p end-point)) + ;; Go to START-POINT first, so that when we move to END-POINT, + ;; if it's in the middle of intangible text, + ;; point jumps in the direction away from START-POINT. + (goto-char start-point) + (goto-char end-point) + (gnus-pick-article) + ;; In case the user moved his mouse really fast, pick + ;; articles on the line between this one and the last one. + (let* ((this-line (1+ (count-lines 1 end-point))) + (min-line (min this-line start-line)) + (max-line (max this-line start-line))) + (while (< min-line max-line) + (goto-line min-line) + (gnus-pick-article) + (setq min-line (1+ min-line))) + (setq start-line this-line)) + (when (zerop (% click-count 3)) + (setq end-of-range (point)))) + (t + (let ((mouse-row (cdr (cdr (mouse-position))))) + (cond + ((null mouse-row)) + ((< mouse-row top) + (mouse-scroll-subr start-window (- mouse-row top))) + ((>= mouse-row bottom) + (mouse-scroll-subr start-window + (1+ (- mouse-row bottom))))))))))) + (when (consp event) + (let ((fun (key-binding (vector (car event))))) + ;; Run the binding of the terminating up-event, if possible. + ;; In the case of a multiple click, it gives the wrong results, + ;; because it would fail to set up a region. + (when nil + ;; (and (= (mod mouse-selection-click-count 3) 0) (fboundp fun)) + ;; In this case, we can just let the up-event execute normally. + (let ((end (event-end event))) + ;; Set the position in the event before we replay it, + ;; because otherwise it may have a position in the wrong + ;; buffer. + (setcar (cdr end) end-of-range) + ;; Delete the overlay before calling the function, + ;; because delete-overlay increases buffer-modified-tick. + (push event unread-command-events)))))))) + +(defun gnus-pick-next-page () + "Go to the next page. If at the end of the buffer, start reading articles." + (interactive) + (let ((scroll-in-place nil)) + (condition-case nil + (scroll-up) + (end-of-buffer (gnus-pick-start-reading))))) ;;; ;;; gnus-binary-mode ;;; (defvar gnus-binary-mode nil - "Minor mode for provind a binary group interface in Gnus summary buffers.") + "Minor mode for providing a binary group interface in Gnus summary buffers.") (defvar gnus-binary-mode-hook nil "Hook run in summary binary mode buffers.") @@ -162,8 +325,7 @@ (make-local-variable 'gnus-summary-display-article-function) (setq gnus-summary-display-article-function 'gnus-binary-display-article) ;; Set up the menu. - (when (and menu-bar-mode - (gnus-visual-p 'binary-menu 'menu)) + (when (gnus-visual-p 'binary-menu 'menu) (gnus-binary-make-menu-bar)) (unless (assq 'gnus-binary-mode minor-mode-alist) (push '(gnus-binary-mode " Binary") minor-mode-alist)) @@ -204,7 +366,7 @@ "Brackets used in tree nodes.") (defvar gnus-tree-parent-child-edges '(?- ?\\ ?|) - "Charaters used to connect parents with children.") + "Characters used to connect parents with children.") (defvar gnus-tree-mode-line-format "Gnus: %%b %S %Z" "*The format specification for the tree mode line.") @@ -270,8 +432,7 @@ (setq gnus-tree-line-format-spec (gnus-parse-format gnus-tree-line-format gnus-tree-line-format-alist t)) - (when (and menu-bar-mode - (gnus-visual-p 'tree-menu 'menu)) + (when (gnus-visual-p 'tree-menu 'menu) (gnus-tree-make-menu-bar)) (kill-all-local-variables) (gnus-simplify-mode-line) @@ -339,7 +500,7 @@ (goto-char (or (gnus-overlay-end gnus-selected-tree-overlay) 1))) (let* ((top (cond ((< (window-height) 4) 0) ((< (window-height) 7) 1) - (t 2))) + (t 2))) (height (1- (window-height))) (bottom (save-excursion (goto-char (point-max)) (forward-line (- height)) @@ -368,7 +529,7 @@ tot-win-height) (walk-windows (lambda (window) (incf windows))) (setq tot-win-height - (- (frame-height) + (- (frame-height) (* window-min-height (1- windows)) 2)) (let* ((window-min-height 2) @@ -383,9 +544,9 @@ (when (and win (not (eq tot wh))) (let ((selected (selected-window))) - (select-window win) - (enlarge-window (- tot wh)) - (select-window selected))))))) + (when (ignore-errors (select-window win)) + (enlarge-window (- tot wh)) + (select-window selected)))))))) ;;; Generating the tree. @@ -416,7 +577,7 @@ "***") (t gnus-tmp-from))) (gnus-tmp-open-bracket - (cond ((memq gnus-tmp-number sparse) + (cond ((memq gnus-tmp-number sparse) (caadr gnus-tree-brackets)) (dummy (caaddr gnus-tree-brackets)) (adopted (car (nth 3 gnus-tree-brackets))) @@ -497,7 +658,7 @@ (unless (zerop level) (gnus-tree-indent level) (insert (cadr gnus-tree-parent-child-edges)) - (setq col (- (setq beg (point)) (gnus-point-at-bol) 1)) + (setq col (- (setq beg (point)) (point-at-bol) 1)) ;; Draw "|" lines upwards. (while (progn (forward-line -1) @@ -516,12 +677,12 @@ ;; Recurse downwards in all children of this article. (while thread (gnus-generate-horizontal-tree - (pop thread) (if do (1+ level) level) + (pop thread) (if do (1+ level) level) (or dummyp dummy) dummy))))) (defsubst gnus-tree-indent-vertical () - (let ((len (- (* (1+ gnus-tree-node-length) gnus-tmp-indent) - (- (point) (gnus-point-at-bol))))) + (let ((len (- (* (1+ gnus-tree-node-length) gnus-tmp-indent) + (- (point) (point-at-bol))))) (when (> len 0) (insert (make-string len ? ))))) @@ -536,7 +697,9 @@ "Generate a vertical tree." (let* ((dummy (stringp (car thread))) (do (or dummy - (memq (mail-header-number (car thread)) gnus-tmp-limit))) + (and (car thread) + (memq (mail-header-number (car thread)) + gnus-tmp-limit)))) beg) (if (not do) ;; We don't want this article. @@ -557,7 +720,8 @@ (setq beg (point)) ;; Draw "-" lines leftwards. (while (progn - (forward-char -2) + (unless (bolp) + (forward-char -2)) (= (following-char) ? )) (delete-char 1) (insert (car gnus-tree-parent-child-edges))) @@ -577,7 +741,7 @@ ;; Recurse downwards in all children of this article. (while thread (gnus-generate-vertical-tree - (pop thread) (if do (1+ level) level) + (pop thread) (if do (1+ level) level) (or dummyp dummy) dummy))))) ;;; Interface functions. @@ -587,6 +751,7 @@ (when (save-excursion (set-buffer gnus-summary-buffer) (and gnus-use-trees + gnus-show-threads (vectorp (gnus-summary-article-header article)))) (save-excursion (let ((top (save-excursion @@ -594,7 +759,8 @@ (gnus-cut-thread (gnus-remove-thread (mail-header-id - (gnus-summary-article-header article)) t)))) + (gnus-summary-article-header article)) + t)))) (gnus-tmp-limit gnus-newsgroup-limit) (gnus-tmp-sparse gnus-newsgroup-sparse)) (when (or force @@ -606,7 +772,7 @@ (gnus-get-tree-buffer)) (defun gnus-tree-close (group) - ;(gnus-kill-buffer gnus-tree-buffer) + ;(gnus-kill-buffer gnus-tree-buffer) ) (defun gnus-highlight-selected-tree (article) @@ -646,6 +812,177 @@ (set-window-point (get-buffer-window (current-buffer) t) (cdr region)))))) +;;; +;;; gnus-carpal +;;; + +(defvar gnus-carpal-group-buffer-buttons + '(("next" . gnus-group-next-unread-group) + ("prev" . gnus-group-prev-unread-group) + ("read" . gnus-group-read-group) + ("select" . gnus-group-select-group) + ("catch-up" . gnus-group-catchup-current) + ("new-news" . gnus-group-get-new-news-this-group) + ("toggle-sub" . gnus-group-unsubscribe-current-group) + ("subscribe" . gnus-group-unsubscribe-group) + ("kill" . gnus-group-kill-group) + ("yank" . gnus-group-yank-group) + ("describe" . gnus-group-describe-group) + "list" + ("subscribed" . gnus-group-list-groups) + ("all" . gnus-group-list-all-groups) + ("killed" . gnus-group-list-killed) + ("zombies" . gnus-group-list-zombies) + ("matching" . gnus-group-list-matching) + ("post" . gnus-group-post-news) + ("mail" . gnus-group-mail) + ("rescan" . gnus-group-get-new-news) + ("browse-foreign" . gnus-group-browse-foreign) + ("exit" . gnus-group-exit))) + +(defvar gnus-carpal-summary-buffer-buttons + '("mark" + ("read" . gnus-summary-mark-as-read-forward) + ("tick" . gnus-summary-tick-article-forward) + ("clear" . gnus-summary-clear-mark-forward) + ("expirable" . gnus-summary-mark-as-expirable) + "move" + ("scroll" . gnus-summary-next-page) + ("next-unread" . gnus-summary-next-unread-article) + ("prev-unread" . gnus-summary-prev-unread-article) + ("first" . gnus-summary-first-unread-article) + ("best" . gnus-summary-best-unread-article) + "article" + ("headers" . gnus-summary-toggle-header) + ("uudecode" . gnus-uu-decode-uu) + ("enter-digest" . gnus-summary-enter-digest-group) + ("fetch-parent" . gnus-summary-refer-parent-article) + "mail" + ("move" . gnus-summary-move-article) + ("copy" . gnus-summary-copy-article) + ("respool" . gnus-summary-respool-article) + "threads" + ("lower" . gnus-summary-lower-thread) + ("kill" . gnus-summary-kill-thread) + "post" + ("post" . gnus-summary-post-news) + ("mail" . gnus-summary-mail) + ("followup" . gnus-summary-followup-with-original) + ("reply" . gnus-summary-reply-with-original) + ("cancel" . gnus-summary-cancel-article) + "misc" + ("exit" . gnus-summary-exit) + ("fed-up" . gnus-summary-catchup-and-goto-next-group))) + +(defvar gnus-carpal-server-buffer-buttons + '(("add" . gnus-server-add-server) + ("browse" . gnus-server-browse-server) + ("list" . gnus-server-list-servers) + ("kill" . gnus-server-kill-server) + ("yank" . gnus-server-yank-server) + ("copy" . gnus-server-copy-server) + ("exit" . gnus-server-exit))) + +(defvar gnus-carpal-browse-buffer-buttons + '(("subscribe" . gnus-browse-unsubscribe-current-group) + ("exit" . gnus-browse-exit))) + +(defvar gnus-carpal-group-buffer "*Carpal Group*") +(defvar gnus-carpal-summary-buffer "*Carpal Summary*") +(defvar gnus-carpal-server-buffer "*Carpal Server*") +(defvar gnus-carpal-browse-buffer "*Carpal Browse*") + +(defvar gnus-carpal-attached-buffer nil) + +(defvar gnus-carpal-mode-hook nil + "*Hook run in carpal mode buffers.") + +(defvar gnus-carpal-button-face 'bold + "*Face used on carpal buttons.") + +(defvar gnus-carpal-header-face 'bold-italic + "*Face used on carpal buffer headers.") + +(defvar gnus-carpal-mode-map nil) +(put 'gnus-carpal-mode 'mode-class 'special) + +(if gnus-carpal-mode-map + nil + (setq gnus-carpal-mode-map (make-keymap)) + (suppress-keymap gnus-carpal-mode-map) + (define-key gnus-carpal-mode-map " " 'gnus-carpal-select) + (define-key gnus-carpal-mode-map "\r" 'gnus-carpal-select) + (define-key gnus-carpal-mode-map gnus-mouse-2 'gnus-carpal-mouse-select)) + +(defun gnus-carpal-mode () + "Major mode for clicking buttons. + +All normal editing commands are switched off. +\\ +The following commands are available: + +\\{gnus-carpal-mode-map}" + (interactive) + (kill-all-local-variables) + (setq mode-line-modified "-- ") + (setq major-mode 'gnus-carpal-mode) + (setq mode-name "Gnus Carpal") + (setq mode-line-process nil) + (use-local-map gnus-carpal-mode-map) + (buffer-disable-undo (current-buffer)) + (setq buffer-read-only t) + (make-local-variable 'gnus-carpal-attached-buffer) + (run-hooks 'gnus-carpal-mode-hook)) + +(defun gnus-carpal-setup-buffer (type) + (let ((buffer (symbol-value (intern (format "gnus-carpal-%s-buffer" type))))) + (if (get-buffer buffer) + () + (save-excursion + (set-buffer (get-buffer-create buffer)) + (gnus-carpal-mode) + (setq gnus-carpal-attached-buffer + (intern (format "gnus-%s-buffer" type))) + (gnus-add-current-to-buffer-list) + (let ((buttons (symbol-value + (intern (format "gnus-carpal-%s-buffer-buttons" + type)))) + (buffer-read-only nil) + button) + (while buttons + (setq button (car buttons) + buttons (cdr buttons)) + (if (stringp button) + (gnus-set-text-properties + (point) + (prog2 (insert button) (point) (insert " ")) + (list 'face gnus-carpal-header-face)) + (gnus-set-text-properties + (point) + (prog2 (insert (car button)) (point) (insert " ")) + (list 'gnus-callback (cdr button) + 'face gnus-carpal-button-face + gnus-mouse-face-prop 'highlight)))) + (let ((fill-column (- (window-width) 2))) + (fill-region (point-min) (point-max))) + (set-window-point (get-buffer-window (current-buffer)) + (point-min))))))) + +(defun gnus-carpal-select () + "Select the button under point." + (interactive) + (let ((func (get-text-property (point) 'gnus-callback))) + (if (null func) + () + (pop-to-buffer (symbol-value gnus-carpal-attached-buffer)) + (call-interactively func)))) + +(defun gnus-carpal-mouse-select (event) + "Select the button under the mouse pointer." + (interactive "e") + (mouse-set-point event) + (gnus-carpal-select)) + ;;; Allow redefinition of functions. (gnus-ems-redefine) diff -r ad457d5f7d04 -r 0293115a14e9 lisp/gnus/gnus-score.el --- a/lisp/gnus/gnus-score.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/gnus/gnus-score.el Mon Aug 13 08:49:20 2007 +0200 @@ -1,5 +1,5 @@ ;;; gnus-score.el --- scoring code for Gnus -;; Copyright (C) 1995,96 Free Software Foundation, Inc. +;; Copyright (C) 1995,96,97 Free Software Foundation, Inc. ;; Author: Per Abrahamsen ;; Lars Magne Ingebrigtsen @@ -27,10 +27,11 @@ ;;; Code: (require 'gnus) -(eval-when-compile (require 'cl)) +(require 'gnus-sum) +(require 'gnus-range) -(defvar gnus-global-score-files nil - "*List of global score files and directories. +(defcustom gnus-global-score-files nil + "List of global score files and directories. Set this variable if you want to use people's score files. One entry for each score file or each score file directory. Gnus will decide by itself what score files are applicable to which group. @@ -41,10 +42,12 @@ (setq gnus-global-score-files '(\"/ftp.ifi.uio.no:/pub/larsi/ding/score/soc.motss.SCORE\" - \"/ftp.some-where:/pub/score\"))") + \"/ftp.some-where:/pub/score\"))" + :group 'gnus-score + :type '(repeat file)) -(defvar gnus-score-file-single-match-alist nil - "*Alist mapping regexps to lists of score files. +(defcustom gnus-score-file-single-match-alist nil + "Alist mapping regexps to lists of score files. Each element of this alist should be of the form (\"REGEXP\" [ \"SCORE-FILE-1\" ] [ \"SCORE-FILE-2\" ] ... ) @@ -54,10 +57,12 @@ use multiple matches, see gnus-score-file-multiple-match-alist). These score files are loaded in addition to any files returned by -gnus-score-find-score-files-function (which see).") +gnus-score-find-score-files-function (which see)." + :group 'gnus-score + :type '(repeat (cons regexp (repeat file)))) -(defvar gnus-score-file-multiple-match-alist nil - "*Alist mapping regexps to lists of score files. +(defcustom gnus-score-file-multiple-match-alist nil + "Alist mapping regexps to lists of score files. Each element of this alist should be of the form (\"REGEXP\" [ \"SCORE-FILE-1\" ] [ \"SCORE-FILE-2\" ] ... ) @@ -68,16 +73,22 @@ gnus-score-file-single-match-alist). These score files are loaded in addition to any files returned by -gnus-score-find-score-files-function (which see).") - -(defvar gnus-score-file-suffix "SCORE" - "*Suffix of the score files.") +gnus-score-find-score-files-function (which see)." + :group 'gnus-score + :type '(repeat (cons regexp (repeat file)))) -(defvar gnus-adaptive-file-suffix "ADAPT" - "*Suffix of the adaptive score files.") +(defcustom gnus-score-file-suffix "SCORE" + "Suffix of the score files." + :group 'gnus-score + :type 'string) -(defvar gnus-score-find-score-files-function 'gnus-score-find-bnews - "*Function used to find score files. +(defcustom gnus-adaptive-file-suffix "ADAPT" + "Suffix of the adaptive score files." + :group 'gnus-score + :type 'string) + +(defcustom gnus-score-find-score-files-function 'gnus-score-find-bnews + "Function used to find score files. The function will be called with the group name as the argument, and should return a list of score files to apply to that group. The score files do not actually have to exist. @@ -92,48 +103,178 @@ This variable can also be a list of functions to be called. Each function should either return a list of score files, or a list of -score alists.") - -(defvar gnus-score-interactive-default-score 1000 - "*Scoring commands will raise/lower the score with this number as the default.") +score alists." + :group 'gnus-score + :type '(radio (function-item gnus-score-find-single) + (function-item gnus-score-find-hierarchical) + (function-item gnus-score-find-bnews) + (function :tag "Other"))) -(defvar gnus-score-expiry-days 7 +(defcustom gnus-score-interactive-default-score 1000 + "*Scoring commands will raise/lower the score with this number as the default." + :group 'gnus-score + :type 'integer) + +(defcustom gnus-score-expiry-days 7 "*Number of days before unused score file entries are expired. -If this variable is nil, no score file entries will be expired.") +If this variable is nil, no score file entries will be expired." + :group 'gnus-score + :type '(choice (const :tag "never" nil) + number)) -(defvar gnus-update-score-entry-dates t +(defcustom gnus-update-score-entry-dates t "*In non-nil, update matching score entry dates. If this variable is nil, then score entries that provide matches -will be expired along with non-matching score entries.") +will be expired along with non-matching score entries." + :group 'gnus-score + :type 'boolean) + +(defcustom gnus-orphan-score nil + "*All orphans get this score added. Set in the score file." + :group 'gnus-score + :type 'integer) + +(defcustom gnus-decay-scores nil + "*If non-nil, decay non-permanent scores." + :group 'gnus-score + :type 'boolean) + +(defcustom gnus-decay-score-function 'gnus-decay-score + "*Function called to decay a score. +It is called with one parameter -- the score to be decayed." + :group 'gnus-score + :type '(radio (function-item gnus-decay-score) + (function :tag "Other"))) + +(defcustom gnus-score-decay-constant 3 + "*Decay all \"small\" scores with this amount." + :group 'gnus-score + :type 'integer) + +(defcustom gnus-score-decay-scale .05 + "*Decay all \"big\" scores with this factor." + :group 'gnus-score + :type 'number) + +(defcustom gnus-home-score-file nil + "Variable to control where interactive score entries are to go. +It can be: + + * A string + This file file will be used as the home score file. -(defvar gnus-orphan-score nil - "*All orphans get this score added. Set in the score file.") + * A function + The result of this function will be used as the home score file. + The function will be passed the name of the group as its + parameter. + + * A list + The elements in this list can be: + + * `(regexp file-name ...)' + If the `regexp' matches the group name, the first `file-name' will + will be used as the home score file. (Multiple filenames are + allowed so that one may use gnus-score-file-single-match-alist to + set this variable.) + + * A function. + If the function returns non-nil, the result will be used + as the home score file. The function will be passed the + name of the group as its parameter. + + * A string. Use the string as the home score file. -(defvar gnus-default-adaptive-score-alist + The list will be traversed from the beginning towards the end looking + for matches." + :group 'gnus-score + :type '(choice string + (repeat (choice string + (cons regexp (repeat file)) + function)) + function)) + +(defcustom gnus-home-adapt-file nil + "Variable to control where new adaptive score entries are to go. +This variable allows the same syntax as `gnus-home-score-file'." + :group 'gnus-score + :type '(choice string + (repeat (choice string + (cons regexp (repeat file)) + function)) + function)) + +(defcustom gnus-default-adaptive-score-alist '((gnus-kill-file-mark) (gnus-unread-mark) - (gnus-read-mark (from 3) (subject 30)) + (gnus-read-mark (from 3) (subject 30)) (gnus-catchup-mark (subject -10)) (gnus-killed-mark (from -1) (subject -20)) (gnus-del-mark (from -2) (subject -15))) -"*Alist of marks and scores.") +"Alist of marks and scores." +:group 'gnus-score +:type '(repeat (cons (symbol :tag "Mark") + (repeat (list (choice :tag "Header" + (const from) + (const subject) + (symbol :tag "other")) + (integer :tag "Score")))))) + +(defcustom gnus-ignored-adaptive-words nil + "List of words to be ignored when doing adaptive word scoring." + :group 'gnus-score + :type '(repeat string)) -(defvar gnus-score-mimic-keymap nil - "*Have the score entry functions pretend that they are a keymap.") +(defcustom gnus-default-ignored-adaptive-words + '("a" "i" "the" "to" "of" "and" "in" "is" "it" "for" "that" "if" "you" + "this" "be" "on" "with" "not" "have" "are" "or" "as" "from" "can" + "but" "by" "at" "an" "will" "no" "all" "was" "do" "there" "my" "one" + "so" "we" "they" "what" "would" "any" "which" "about" "get" "your" + "use" "some" "me" "then" "name" "like" "out" "when" "up" "time" + "other" "more" "only" "just" "end" "also" "know" "how" "new" "should" + "been" "than" "them" "he" "who" "make" "may" "people" "these" "now" + "their" "here" "into" "first" "could" "way" "had" "see" "work" "well" + "were" "two" "very" "where" "while" "us" "because" "good" "same" + "even" "much" "most" "many" "such" "long" "his" "over" "last" "since" + "right" "before" "our" "without" "too" "those" "why" "must" "part" + "being" "current" "back" "still" "go" "point" "value" "each" "did" + "both" "true" "off" "say" "another" "state" "might" "under" "start" + "try" "re") + "Default list of words to be ignored when doing adaptive word scoring." + :group 'gnus-score + :type '(repeat string)) -(defvar gnus-score-exact-adapt-limit 10 +(defcustom gnus-default-adaptive-word-score-alist + `((,gnus-read-mark . 30) + (,gnus-catchup-mark . -10) + (,gnus-killed-mark . -20) + (,gnus-del-mark . -15)) +"Alist of marks and scores." +:group 'gnus-score +:type '(repeat (cons (character :tag "Mark") + (integer :tag "Score")))) + +(defcustom gnus-score-mimic-keymap nil + "*Have the score entry functions pretend that they are a keymap." + :group 'gnus-score + :type 'boolean) + +(defcustom gnus-score-exact-adapt-limit 10 "*Number that says how long a match has to be before using substring matching. When doing adaptive scoring, one normally uses fuzzy or substring matching. However, if the header one matches is short, the possibility for false positives is great, so if the length of the match is less than this variable, exact matching will be used. -If this variable is nil, exact matching will always be used.") +If this variable is nil, exact matching will always be used." + :group 'gnus-score + :type '(choice (const nil) integer)) -(defvar gnus-score-uncacheable-files "ADAPT$" - "*All score files that match this regexp will not be cached.") +(defcustom gnus-score-uncacheable-files "ADAPT$" + "All score files that match this regexp will not be cached." + :group 'gnus-score + :type 'regexp) -(defvar gnus-score-default-header nil +(defcustom gnus-score-default-header nil "Default header when entering new scores. Should be one of the following symbols. @@ -149,9 +290,20 @@ d: date f: followup -If nil, the user will be asked for a header.") +If nil, the user will be asked for a header." + :group 'gnus-score + :type '(choice (const :tag "from" a) + (const :tag "subject" s) + (const :tag "body" b) + (const :tag "head" h) + (const :tag "message-id" i) + (const :tag "references" t) + (const :tag "xref" x) + (const :tag "lines" l) + (const :tag "date" d) + (const :tag "followup" f))) -(defvar gnus-score-default-type nil +(defcustom gnus-score-default-type nil "Default match type when entering new scores. Should be one of the following symbols. @@ -167,12 +319,25 @@ >: greater than number =: equal to number -If nil, the user will be asked for a match type.") +If nil, the user will be asked for a match type." + :group 'gnus-score + :type '(choice (const :tag "substring" s) + (const :tag "exact string" e) + (const :tag "fuzzy string" f) + (const :tag "regexp string" r) + (const :tag "before date" b) + (const :tag "at date" a) + (const :tag "this date" n) + (const :tag "less than number" <) + (const :tag "greater than number" >) + (const :tag "equal than number" =))) -(defvar gnus-score-default-fold nil - "Use case folding for new score file entries iff not nil.") +(defcustom gnus-score-default-fold nil + "Use case folding for new score file entries iff not nil." + :group 'gnus-score + :type 'boolean) -(defvar gnus-score-default-duration nil +(defcustom gnus-score-default-duration nil "Default duration of effect when entering new scores. Should be one of the following symbols. @@ -181,15 +346,31 @@ p: permanent i: immediate -If nil, the user will be asked for a duration.") +If nil, the user will be asked for a duration." + :group 'gnus-score + :type '(choice (const :tag "temporary" t) + (const :tag "permanent" p) + (const :tag "immediate" i))) -(defvar gnus-score-after-write-file-function nil - "*Function called with the name of the score file just written to disk.") +(defcustom gnus-score-after-write-file-function nil + "Function called with the name of the score file just written to disk." + :group 'gnus-score + :type 'function) ;; Internal variables. +(defvar gnus-adaptive-word-syntax-table + (let ((table (copy-syntax-table (standard-syntax-table))) + (numbers '(?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9))) + (while numbers + (modify-syntax-entry (pop numbers) " " table)) + (modify-syntax-entry ?' "w" table) + table) + "Syntax table used when doing adaptive word scoring.") + +(defvar gnus-scores-exclude-files nil) (defvar gnus-internal-global-score-files nil) (defvar gnus-score-file-list nil) @@ -197,6 +378,7 @@ (defvar gnus-score-help-winconf nil) (defvar gnus-adaptive-score-alist gnus-default-adaptive-score-alist) +(defvar gnus-adaptive-word-score-alist gnus-default-adaptive-word-score-alist) (defvar gnus-score-trace nil) (defvar gnus-score-edit-buffer nil) @@ -210,7 +392,7 @@ files: List of other score files to load when loading this one. eval: Sexp to be evaluated when the score file is loaded. -String entries have the form (HEADER (MATCH TYPE SCORE DATE) ...) +String entries have the form (HEADER (MATCH TYPE SCORE DATE) ...) where HEADER is the header being scored, MATCH is the string we are looking for, TYPE is a flag indicating whether it should use regexp or substring matching, SCORE is the score to add and DATE is the date @@ -227,10 +409,10 @@ ("subject" 1 gnus-score-string) ("from" 2 gnus-score-string) ("date" 3 gnus-score-date) - ("message-id" 4 gnus-score-string) - ("references" 5 gnus-score-string) - ("chars" 6 gnus-score-integer) - ("lines" 7 gnus-score-integer) + ("message-id" 4 gnus-score-string) + ("references" 5 gnus-score-string) + ("chars" 6 gnus-score-integer) + ("lines" 7 gnus-score-integer) ("xref" 8 gnus-score-string) ("head" -1 gnus-score-body) ("body" -1 gnus-score-body) @@ -238,25 +420,22 @@ ("followup" 2 gnus-score-followup) ("thread" 5 gnus-score-thread))) -(eval-and-compile - (autoload 'gnus-uu-ctl-map "gnus-uu" nil nil 'keymap)) - ;;; Summary mode score maps. -(gnus-define-keys - (gnus-summary-score-map "V" gnus-summary-mode-map) - "s" gnus-summary-set-score - "a" gnus-summary-score-entry - "S" gnus-summary-current-score - "c" gnus-score-change-score-file - "m" gnus-score-set-mark-below - "x" gnus-score-set-expunge-below - "R" gnus-summary-rescore - "e" gnus-score-edit-current-scores - "f" gnus-score-edit-file - "F" gnus-score-flush-cache - "t" gnus-score-find-trace - "C" gnus-score-customize) +(gnus-define-keys (gnus-summary-score-map "V" gnus-summary-mode-map) + "s" gnus-summary-set-score + "a" gnus-summary-score-entry + "S" gnus-summary-current-score + "c" gnus-score-change-score-file + "C" gnus-score-customize + "m" gnus-score-set-mark-below + "x" gnus-score-set-expunge-below + "R" gnus-summary-rescore + "e" gnus-score-edit-current-scores + "f" gnus-score-edit-file + "F" gnus-score-flush-cache + "t" gnus-score-find-trace + "w" gnus-score-find-favourite-words) ;; Summary score file commands @@ -271,20 +450,11 @@ (interactive "P") (gnus-summary-increase-score (- (gnus-score-default score)))) -(defvar gnus-score-default-header nil - "*The default header to score on when entering a score rule interactively.") - -(defvar gnus-score-default-type nil - "*The default score type to use when entering a score rule interactively.") - -(defvar gnus-score-default-duration nil - "*The default score duration to use on when entering a score rule interactively.") - (defun gnus-score-kill-help-buffer () (when (get-buffer "*Score Help*") (kill-buffer "*Score Help*") - (and gnus-score-help-winconf - (set-window-configuration gnus-score-help-winconf)))) + (when gnus-score-help-winconf + (set-window-configuration gnus-score-help-winconf)))) (defun gnus-summary-increase-score (&optional score) "Make a score entry based on the current article. @@ -314,15 +484,15 @@ (?f f "fuzzy string" string) (?r r "regexp string" string) (?z s "substring" body-string) - (?p s "regexp string" body-string) + (?p r "regexp string" body-string) (?b before "before date" date) - (?a at "at date" date) + (?a at "at date" date) (?n now "this date" date) (?< < "less than number" number) - (?> > "greater than number" number) + (?> > "greater than number" number) (?= = "equal to number" number))) (char-to-perm - (list (list ?t (current-time-string) "temporary") + (list (list ?t (current-time-string) "temporary") '(?p perm "permanent") '(?i now "immediate"))) (mimic gnus-score-mimic-keymap) (hchar (and gnus-score-default-header @@ -355,7 +525,7 @@ (if mimic (error "%c %c" prefix hchar) (error ""))) (when (/= (downcase hchar) hchar) - ;; This was a majuscle, so we end reading and set the defaults. + ;; This was a majuscule, so we end reading and set the defaults. (if mimic (message "%c %c" prefix hchar) (message "")) (setq tchar (or tchar ?s) pchar (or pchar ?t))) @@ -368,8 +538,8 @@ (message "%s header '%s' with match type (%s?): " (if increase "Increase" "Lower") (nth 1 entry) - (mapconcat (lambda (s) - (if (eq (nth 4 entry) + (mapconcat (lambda (s) + (if (eq (nth 4 entry) (nth 3 s)) (char-to-string (car s)) "")) @@ -380,11 +550,11 @@ (gnus-score-insert-help "Match type" (delq nil - (mapcar (lambda (s) - (if (eq (nth 4 entry) + (mapcar (lambda (s) + (if (eq (nth 4 entry) (nth 3 s)) s nil)) - char-to-type )) + char-to-type)) 2))) (gnus-score-kill-help-buffer) @@ -392,7 +562,7 @@ (if mimic (error "%c %c" prefix hchar) (error ""))) (when (/= (downcase tchar) tchar) - ;; It was a majuscle, so we end reading and use the default. + ;; It was a majuscule, so we end reading and use the default. (if mimic (message "%c %c %c" prefix hchar tchar) (message "")) (setq pchar (or pchar ?p))) @@ -414,6 +584,12 @@ (if mimic (message "%c %c %c" prefix hchar tchar pchar) (message "")) (unless (setq temporary (cadr (assq pchar char-to-perm))) + ;; Deal with der(r)ided superannuated paradigms. + (when (and (eq (1+ prefix) 77) + (eq (+ hchar 12) 109) + (eq tchar 114) + (eq (- pchar 4) 111)) + (error "You rang?")) (if mimic (error "%c %c %c %c" prefix hchar tchar pchar) (error "")))) @@ -439,10 +615,10 @@ (nth 1 entry) ; Header match ; Match type ; Type - (if (eq 's score) nil score) ; Score - (if (eq 'perm temporary) ; Temp + (if (eq score 's) nil score) ; Score + (if (eq temporary 'perm) ; Temp nil - temporary) + temporary) (not (nth 3 entry))) ; Prompt )) @@ -461,11 +637,11 @@ ;; find the longest string to display (while list (setq n (length (nth idx (car list)))) - (or (> max n) - (setq max n)) + (unless (> max n) + (setq max n)) (setq list (cdr list))) (setq max (+ max 4)) ; %c, `:', SPACE, a SPACE at end - (setq n (/ (1- (window-width)) max)) ; items per line + (setq n (/ (1- (window-width)) max)) ; items per line (setq width (/ (1- (window-width)) n)) ; width of each item ;; insert `n' items, each in a field of width `width' (while alist @@ -504,7 +680,7 @@ (defun gnus-newsgroup-score-alist () (or - (let ((param-file (gnus-group-get-parameter + (let ((param-file (gnus-group-find-parameter gnus-newsgroup-name 'score-file))) (when param-file (gnus-score-load param-file))) @@ -519,8 +695,8 @@ gnus-score-alist (gnus-newsgroup-score-alist))))) -(defun gnus-summary-score-entry - (header match type score date &optional prompt silent) +(defun gnus-summary-score-entry (header match type score date + &optional prompt silent) "Enter score file entry. HEADER is the header being scored. MATCH is the string we are looking for. @@ -544,7 +720,8 @@ (current-time-string)) (t nil)))) ;; Regexp is the default type. - (if (eq type t) (setq type 'r)) + (when (eq type t) + (setq type 'r)) ;; Simplify matches... (cond ((or (eq type 'r) (eq type 's) (eq type nil)) (setq match (if match (gnus-simplify-subject-re match) ""))) @@ -553,48 +730,53 @@ (let ((score (gnus-score-default score)) (header (format "%s" (downcase header))) new) - (and prompt (setq match (read-string - (format "Match %s on %s, %s: " - (cond ((eq date 'now) - "now") - ((stringp date) - "temp") - (t "permanent")) - header - (if (< score 0) "lower" "raise")) - (if (numberp match) - (int-to-string match) - match)))) + (when prompt + (setq match (read-string + (format "Match %s on %s, %s: " + (cond ((eq date 'now) + "now") + ((stringp date) + "temp") + (t "permanent")) + header + (if (< score 0) "lower" "raise")) + (if (numberp match) + (int-to-string match) + match)))) ;; Get rid of string props. (setq match (format "%s" match)) ;; If this is an integer comparison, we transform from string to int. - (and (eq (nth 2 (assoc header gnus-header-index)) 'gnus-score-integer) - (setq match (string-to-int match))) + (when (eq (nth 2 (assoc header gnus-header-index)) 'gnus-score-integer) + (setq match (string-to-int match))) (unless (eq date 'now) ;; Add the score entry to the score file. (when (= score gnus-score-interactive-default-score) - (setq score nil)) + (setq score nil)) (let ((old (gnus-score-get header)) elem) (setq new (cond - (type (list match score (and date (gnus-day-number date)) type)) + (type + (list match score + (and date (if (numberp date) date + (gnus-day-number date))) + type)) (date (list match score (gnus-day-number date))) (score (list match score)) (t (list match)))) ;; We see whether we can collapse some score entries. ;; This isn't quite correct, because there may be more elements - ;; later on with the same key that have matching elems... Hm. + ;; later on with the same key that have matching elems... Hm. (if (and old (setq elem (assoc match old)) (eq (nth 3 elem) (nth 3 new)) (or (and (numberp (nth 2 elem)) (numberp (nth 2 new))) (and (not (nth 2 elem)) (not (nth 2 new))))) ;; Yup, we just add this new score to the old elem. - (setcar (cdr elem) (+ (or (nth 1 elem) + (setcar (cdr elem) (+ (or (nth 1 elem) gnus-score-interactive-default-score) (or (nth 1 new) gnus-score-interactive-default-score))) @@ -617,7 +799,7 @@ "Simulate the effect of a score file entry. HEADER is the header being scored. MATCH is the string we are looking for. -TYPE is a flag indicating if it is a regexp or substring. +TYPE is the score type. SCORE is the score to add." (interactive (list (completing-read "Header: " gnus-header-index @@ -627,12 +809,12 @@ (y-or-n-p "Use regexp match? ") (prefix-numeric-value current-prefix-arg))) (save-excursion - (or (and (stringp match) (> (length match) 0)) - (error "No match")) + (unless (and (stringp match) (> (length match) 0)) + (error "No match")) (goto-char (point-min)) (let ((regexp (cond ((eq type 'f) (gnus-simplify-subject-fuzzy match)) - ((eq type 'r) + ((eq type 'r) match) ((eq type 'e) (concat "\\`" (regexp-quote match) "\\'")) @@ -642,11 +824,11 @@ (let ((content (gnus-summary-header header 'noerr)) (case-fold-search t)) (and content - (if (if (eq type 'f) - (string-equal (gnus-simplify-subject-fuzzy content) - regexp) - (string-match regexp content)) - (gnus-summary-raise-score score)))) + (when (if (eq type 'f) + (string-equal (gnus-simplify-subject-fuzzy content) + regexp) + (string-match regexp content)) + (gnus-summary-raise-score score)))) (beginning-of-line 2))))) (defun gnus-summary-score-crossposting (score date) @@ -656,15 +838,16 @@ (let ((xref (gnus-summary-header "xref")) (start 0) group) - (or xref (error "This article is not crossposted")) + (unless xref + (error "This article is not crossposted")) (while (string-match " \\([^ \t]+\\):" xref start) (setq start (match-end 0)) - (if (not (string= - (setq group - (substring xref (match-beginning 1) (match-end 1))) - gnus-newsgroup-name)) - (gnus-summary-score-entry - "xref" (concat " " group ":") nil score date t))))) + (when (not (string= + (setq group + (substring xref (match-beginning 1) (match-end 1))) + gnus-newsgroup-name)) + (gnus-summary-score-entry + "xref" (concat " " group ":") nil score date t))))) ;;; @@ -724,7 +907,7 @@ (when (gnus-buffer-live-p gnus-summary-buffer) (save-excursion (save-restriction - (goto-char (point-min)) + (message-narrow-to-headers) (let ((id (mail-fetch-field "message-id"))) (when id (set-buffer gnus-summary-buffer) @@ -769,7 +952,7 @@ "Raise the score of the current article by N." (interactive "p") (gnus-set-global-variables) - (gnus-summary-set-score (+ (gnus-summary-article-score) + (gnus-summary-set-score (+ (gnus-summary-article-score) (or n gnus-score-interactive-default-score )))) (defun gnus-summary-set-score (n) @@ -783,12 +966,12 @@ (gnus-summary-update-mark (if (= n (or gnus-summary-default-score 0)) ? (if (< n (or gnus-summary-default-score 0)) - gnus-score-below-mark gnus-score-over-mark)) 'score)) + gnus-score-below-mark gnus-score-over-mark)) + 'score)) (let* ((article (gnus-summary-article-number)) (score (assq article gnus-newsgroup-scored))) (if score (setcdr score n) - (setq gnus-newsgroup-scored - (cons (cons article n) gnus-newsgroup-scored)))) + (push (cons article n) gnus-newsgroup-scored))) (gnus-summary-update-line))) (defun gnus-summary-current-score () @@ -808,8 +991,10 @@ (defun gnus-score-edit-current-scores (file) "Edit the current score alist." (interactive (list gnus-current-score-file)) + (gnus-set-global-variables) (let ((winconf (current-window-configuration))) - (and (buffer-name gnus-summary-buffer) (gnus-score-save)) + (when (buffer-name gnus-summary-buffer) + (gnus-score-save)) (gnus-make-directory (file-name-directory file)) (setq gnus-score-edit-buffer (find-file-noselect file)) (gnus-configure-windows 'edit-score) @@ -826,7 +1011,8 @@ (interactive (list (read-file-name "Edit score file: " gnus-kill-files-directory))) (gnus-make-directory (file-name-directory file)) - (and (buffer-name gnus-summary-buffer) (gnus-score-save)) + (when (buffer-name gnus-summary-buffer) + (gnus-score-save)) (let ((winconf (current-window-configuration))) (setq gnus-score-edit-buffer (find-file-noselect file)) (gnus-configure-windows 'edit-score) @@ -843,7 +1029,7 @@ (let* ((file (expand-file-name (or (and (string-match (concat "^" (expand-file-name - gnus-kill-files-directory)) + gnus-kill-files-directory)) (expand-file-name file)) file) (concat (file-name-as-directory gnus-kill-files-directory) @@ -859,13 +1045,13 @@ (setq alist (gnus-score-load-score-alist file)) ;; We add '(touched) to the alist to signify that it hasn't been ;; touched (yet). - (or (assq 'touched alist) (setq alist (cons (list 'touched nil) alist))) + (unless (assq 'touched alist) + (push (list 'touched nil) alist)) ;; If it is a global score file, we make it read-only. (and global (not (assq 'read-only alist)) - (setq alist (cons (list 'read-only t) alist))) - (setq gnus-score-cache - (cons (cons file alist) gnus-score-cache))) + (push (list 'read-only t) alist)) + (push (cons file alist) gnus-score-cache)) (let ((a alist) found) (while a @@ -890,13 +1076,20 @@ (car (gnus-score-get 'thread-mark-and-expunge alist))) (adapt-file (car (gnus-score-get 'adapt-file alist))) (local (gnus-score-get 'local alist)) + (decay (car (gnus-score-get 'decay alist))) (eval (car (gnus-score-get 'eval alist)))) + ;; Perform possible decays. + (when (and gnus-decay-scores + (gnus-decay-scores + alist (or decay (gnus-time-to-day (current-time))))) + (gnus-score-set 'touched '(t) alist) + (gnus-score-set 'decay (list (gnus-time-to-day (current-time))))) ;; We do not respect eval and files atoms from global score ;; files. (and files (not global) (setq lists (apply 'append lists (mapcar (lambda (file) - (gnus-score-load-file file)) + (gnus-score-load-file file)) (if adapt-file (cons adapt-file files) files))))) (and eval (not global) (eval eval)) @@ -904,9 +1097,10 @@ (setq gnus-scores-exclude-files (nconc (mapcar - (lambda (sfile) + (lambda (sfile) (expand-file-name sfile (file-name-directory file))) - exclude-files) gnus-scores-exclude-files)) + exclude-files) + gnus-scores-exclude-files)) (if (not local) () (save-excursion @@ -918,7 +1112,8 @@ (make-local-variable (caar local)) (set (caar local) (nth 1 (car local))))) (setq local (cdr local))))) - (if orphan (setq gnus-orphan-score orphan)) + (when orphan + (setq gnus-orphan-score orphan)) (setq gnus-adaptive-score-alist (cond ((equal adapt '(t)) (setq gnus-newsgroup-adaptive t) @@ -950,19 +1145,21 @@ (setq gnus-score-alist (cdr cache)) (setq gnus-score-alist nil) (gnus-score-load-score-alist file) - (or gnus-score-alist - (setq gnus-score-alist (copy-alist '((touched nil))))) - (setq gnus-score-cache - (cons (cons file gnus-score-alist) gnus-score-cache))))) + (unless gnus-score-alist + (setq gnus-score-alist (copy-alist '((touched nil))))) + (push (cons file gnus-score-alist) gnus-score-cache)))) (defun gnus-score-remove-from-cache (file) (setq gnus-score-cache (delq (assoc file gnus-score-cache) gnus-score-cache))) (defun gnus-score-load-score-alist (file) + "Read score FILE." (let (alist) (if (not (file-readable-p file)) + ;; Couldn't read file. (setq gnus-score-alist nil) + ;; Read file. (save-excursion (gnus-set-work-buffer) (insert-file-contents file) @@ -973,11 +1170,7 @@ (condition-case () (read (current-buffer)) (error - (progn - (gnus-message 3 "Problem with score file %s" file) - (ding) - (sit-for 2) - nil)))))) + (gnus-error 3.2 "Problem with score file %s" file)))))) (if (eq (car alist) 'setq) ;; This is an old-style score file. (setq gnus-score-alist (gnus-score-transform-old-to-new alist)) @@ -1033,18 +1226,18 @@ (gnus-message 3 err) (sit-for 2) nil) - alist))))) + alist))))) (defun gnus-score-transform-old-to-new (alist) (let* ((alist (nth 2 alist)) out entry) - (if (eq (car alist) 'quote) - (setq alist (nth 1 alist))) + (when (eq (car alist) 'quote) + (setq alist (nth 1 alist))) (while alist (setq entry (car alist)) (if (stringp (car entry)) (let ((scor (cdr entry))) - (setq out (cons entry out)) + (push entry out) (while scor (setcar scor (list (caar scor) (nth 2 (car scor)) @@ -1052,67 +1245,62 @@ (gnus-day-number (nth 3 (car scor)))) (if (nth 1 (car scor)) 'r 's))) (setq scor (cdr scor)))) - (setq out (cons (if (not (listp (cdr entry))) - (list (car entry) (cdr entry)) - entry) - out))) + (push (if (not (listp (cdr entry))) + (list (car entry) (cdr entry)) + entry) + out)) (setq alist (cdr alist))) (cons (list 'touched t) (nreverse out)))) (defun gnus-score-save () ;; Save all score information. - (let ((cache gnus-score-cache)) + (let ((cache gnus-score-cache) + entry score file) (save-excursion (setq gnus-score-alist nil) - (set-buffer (get-buffer-create "*Score*")) - (buffer-disable-undo (current-buffer)) - (let (entry score file) - (while cache - (setq entry (car cache) - cache (cdr cache) - file (car entry) - score (cdr entry)) - (if (or (not (equal (gnus-score-get 'touched score) '(t))) - (gnus-score-get 'read-only score) - (and (file-exists-p file) - (not (file-writable-p file)))) - () - (setq score (setcdr entry (delq (assq 'touched score) score))) - (erase-buffer) - (let (emacs-lisp-mode-hook) - (if (string-match - (concat (regexp-quote gnus-adaptive-file-suffix) - "$") file) - ;; This is an adaptive score file, so we do not run - ;; it through `pp'. These files can get huge, and - ;; are not meant to be edited by human hands. - (prin1 score (current-buffer)) - ;; This is a normal score file, so we print it very - ;; prettily. - (pp score (current-buffer)))) - (if (not (gnus-make-directory (file-name-directory file))) - () - ;; If the score file is empty, we delete it. - (if (zerop (buffer-size)) - (delete-file file) - ;; There are scores, so we write the file. - (when (file-writable-p file) - (write-region (point-min) (point-max) file nil 'silent) - (and gnus-score-after-write-file-function - (funcall gnus-score-after-write-file-function file))))) - (and gnus-score-uncacheable-files - (string-match gnus-score-uncacheable-files file) - (gnus-score-remove-from-cache file))))) + (nnheader-set-temp-buffer " *Gnus Scores*") + (while cache + (current-buffer) + (setq entry (pop cache) + file (car entry) + score (cdr entry)) + (if (or (not (equal (gnus-score-get 'touched score) '(t))) + (gnus-score-get 'read-only score) + (and (file-exists-p file) + (not (file-writable-p file)))) + () + (setq score (setcdr entry (delq (assq 'touched score) score))) + (erase-buffer) + (let (emacs-lisp-mode-hook) + (if (string-match + (concat (regexp-quote gnus-adaptive-file-suffix) + "$") + file) + ;; This is an adaptive score file, so we do not run + ;; it through `pp'. These files can get huge, and + ;; are not meant to be edited by human hands. + (gnus-prin1 score) + ;; This is a normal score file, so we print it very + ;; prettily. + (pp score (current-buffer)))) + (gnus-make-directory (file-name-directory file)) + ;; If the score file is empty, we delete it. + (if (zerop (buffer-size)) + (delete-file file) + ;; There are scores, so we write the file. + (when (file-writable-p file) + (gnus-write-buffer file) + (when gnus-score-after-write-file-function + (funcall gnus-score-after-write-file-function file))))) + (and gnus-score-uncacheable-files + (string-match gnus-score-uncacheable-files file) + (gnus-score-remove-from-cache file))) (kill-buffer (current-buffer))))) - -(defun gnus-score-headers (score-files &optional trace) - ;; Score `gnus-newsgroup-headers'. - (let (scores news) - ;; PLM: probably this is not the best place to clear orphan-score - (setq gnus-orphan-score nil) - (setq gnus-scores-articles nil) - (setq gnus-scores-exclude-files nil) - ;; Load the score files. + +(defun gnus-score-load-files (score-files) + "Load all score files in SCORE-FILES." + ;; Load the score files. + (let (scores) (while score-files (if (stringp (car score-files)) ;; It is a string, which means that it's a score file name, @@ -1131,6 +1319,16 @@ (member (car c) gnus-scores-exclude-files) (setq scores (delq (car s) scores))) (setq s (cdr s))))) + scores)) + +(defun gnus-score-headers (score-files &optional trace) + ;; Score `gnus-newsgroup-headers'. + (let (scores news) + ;; PLM: probably this is not the best place to clear orphan-score + (setq gnus-orphan-score nil + gnus-scores-articles nil + gnus-scores-exclude-files nil + scores (gnus-score-load-files score-files)) (setq news scores) ;; Do the scoring. (while news @@ -1151,10 +1349,10 @@ ;; WARNING: The assq makes the function O(N*S) while it could ;; be written as O(N+S), where N is (length gnus-newsgroup-headers) ;; and S is (length gnus-newsgroup-scored). - (or (assq (mail-header-number header) gnus-newsgroup-scored) - (setq gnus-scores-articles ;Total of 2 * N cons-cells used. - (cons (cons header (or gnus-summary-default-score 0)) - gnus-scores-articles)))) + (unless (assq (mail-header-number header) gnus-newsgroup-scored) + (setq gnus-scores-articles ;Total of 2 * N cons-cells used. + (cons (cons header (or gnus-summary-default-score 0)) + gnus-scores-articles)))) (save-excursion (set-buffer (get-buffer-create "*Headers*")) @@ -1185,14 +1383,21 @@ ;; Add articles to `gnus-newsgroup-scored'. (while gnus-scores-articles - (or (= gnus-summary-default-score (cdar gnus-scores-articles)) - (setq gnus-newsgroup-scored - (cons (cons (mail-header-number - (caar gnus-scores-articles)) - (cdar gnus-scores-articles)) - gnus-newsgroup-scored))) + (when (or (/= gnus-summary-default-score + (cdar gnus-scores-articles)) + gnus-save-score) + (push (cons (mail-header-number (caar gnus-scores-articles)) + (cdar gnus-scores-articles)) + gnus-newsgroup-scored)) (setq gnus-scores-articles (cdr gnus-scores-articles))) + (let (score) + (while (setq score (pop scores)) + (while score + (when (listp (caar score)) + (gnus-score-advanced (car score) trace)) + (pop score)))) + (gnus-message 5 "Scoring...done")))))) @@ -1205,8 +1410,8 @@ this (aref (car art) index) tref (aref (car art) refind) articles (cdr articles)) - (if (string-equal tref "") ;no references line - (setq id-list (cons this id-list)))) + (when (string-equal tref "") ;no references line + (push this id-list))) id-list)) ;; Orphan functions written by plm@atcmp.nl (Peter Mutsaers). @@ -1224,24 +1429,22 @@ this (aref (car art) gnus-score-index) articles (cdr articles)) ;;completely skip if this is empty (not a child, so not an orphan) - (if (not (string= this "")) - (if (equal last this) - ;; O(N*H) cons-cells used here, where H is the number of - ;; headers. - (setq alike (cons art alike)) - (if last - (progn - ;; Insert the line, with a text property on the - ;; terminating newline referring to the articles with - ;; this line. - (insert last ?\n) - (put-text-property (1- (point)) (point) 'articles alike))) - (setq alike (list art) - last this)))) - (and last ; Bwadr, duplicate code. - (progn - (insert last ?\n) - (put-text-property (1- (point)) (point) 'articles alike))) + (when (not (string= this "")) + (if (equal last this) + ;; O(N*H) cons-cells used here, where H is the number of + ;; headers. + (push art alike) + (when last + ;; Insert the line, with a text property on the + ;; terminating newline referring to the articles with + ;; this line. + (insert last ?\n) + (put-text-property (1- (point)) (point) 'articles alike)) + (setq alike (list art) + last this)))) + (when last ; Bwadr, duplicate code. + (insert last ?\n) + (put-text-property (1- (point)) (point) 'articles alike)) ;; PLM: now delete those lines that contain an entry from new-thread-ids (while new-thread-ids @@ -1249,7 +1452,7 @@ new-thread-ids (cdr new-thread-ids)) (goto-char (point-min)) (while (search-forward this-id nil t) - ;; found a match. remove this line + ;; found a match. remove this line (beginning-of-line) (kill-line 1))) @@ -1276,7 +1479,7 @@ scores (cdr scores) entries (assoc header alist)) (while (cdr entries) ;First entry is the header index. - (let* ((rest (cdr entries)) + (let* ((rest (cdr entries)) (kill (car rest)) (match (nth 0 kill)) (type (or (nth 3 kill) '>)) @@ -1294,18 +1497,14 @@ ;; matches on numbers that any cleverness will take more ;; time than one would gain. (while articles - (and (funcall match-func - (or (aref (caar articles) gnus-score-index) 0) - match) - (progn - (and trace (setq gnus-score-trace - (cons - (cons - (car-safe (rassq alist gnus-score-cache)) - kill) - gnus-score-trace))) - (setq found t) - (setcdr (car articles) (+ score (cdar articles))))) + (when (funcall match-func + (or (aref (caar articles) gnus-score-index) 0) + match) + (when trace + (push (cons (car-safe (rassq alist gnus-score-cache)) kill) + gnus-score-trace)) + (setq found t) + (setcdr (car articles) (+ score (cdar articles)))) (setq articles (cdr articles))) ;; Update expire date (cond ((null date)) ;Permanent entry. @@ -1321,7 +1520,7 @@ (defun gnus-score-date (scores header now expire &optional trace) (let ((gnus-score-index (nth 1 (assoc header gnus-header-index))) - entries alist) + entries alist match match-func article) ;; Find matches. (while scores @@ -1329,45 +1528,48 @@ scores (cdr scores) entries (assoc header alist)) (while (cdr entries) ;First entry is the header index. - (let* ((rest (cdr entries)) + (let* ((rest (cdr entries)) (kill (car rest)) - (match (timezone-make-date-sortable (nth 0 kill))) (type (or (nth 3 kill) 'before)) (score (or (nth 1 kill) gnus-score-interactive-default-score)) (date (nth 2 kill)) (found nil) - (match-func - (cond ((eq type 'after) 'string<) - ((eq type 'before) 'gnus-string>) - ((eq type 'at) 'string=) - (t (error "Illegal match type: %s" type)))) (articles gnus-scores-articles) l) + (cond + ((eq type 'after) + (setq match-func 'string< + match (gnus-date-iso8601 (nth 0 kill)))) + ((eq type 'before) + (setq match-func 'gnus-string> + match (gnus-date-iso8601 (nth 0 kill)))) + ((eq type 'at) + (setq match-func 'string= + match (gnus-date-iso8601 (nth 0 kill)))) + ((eq type 'regexp) + (setq match-func 'string-match + match (nth 0 kill))) + (t (error "Illegal match type: %s" type))) ;; Instead of doing all the clever stuff that ;; `gnus-score-string' does to minimize searches and stuff, ;; I will assume that people generally will put so few ;; matches on numbers that any cleverness will take more ;; time than one would gain. - (while articles - (and - (setq l (aref (caar articles) gnus-score-index)) - (funcall match-func match (timezone-make-date-sortable l)) - (progn - (and trace (setq gnus-score-trace - (cons - (cons - (car-safe (rassq alist gnus-score-cache)) - kill) - gnus-score-trace))) - (setq found t) - (setcdr (car articles) (+ score (cdar articles))))) - (setq articles (cdr articles))) + (while (setq article (pop articles)) + (when (and + (setq l (aref (car article) gnus-score-index)) + (funcall match-func match (gnus-date-iso8601 l))) + (when trace + (push (cons (car-safe (rassq alist gnus-score-cache)) kill) + gnus-score-trace)) + (setq found t) + (setcdr article (+ score (cdr article))))) ;; Update expire date (cond ((null date)) ;Permanent entry. ((and found gnus-update-score-entry-dates) ;Match, update date. (gnus-score-set 'touched '(t) alist) (setcar (nthcdr 2 kill) now)) - ((and expire (< date expire)) ;Old entry, remove. + ((and expire (< date expire)) ;Old entry, remove. (gnus-score-set 'touched '(t) alist) (setcdr entries (cdr rest)) (setq rest entries))) @@ -1376,12 +1578,12 @@ (defun gnus-score-body (scores header now expire &optional trace) (save-excursion - (set-buffer nntp-server-buffer) (setq gnus-scores-articles (sort gnus-scores-articles (lambda (a1 a2) (< (mail-header-number (car a1)) (mail-header-number (car a2)))))) + (set-buffer nntp-server-buffer) (save-restriction (let* ((buffer-read-only nil) (articles gnus-scores-articles) @@ -1393,20 +1595,16 @@ (t 'gnus-request-article))) entries alist ofunc article last) (when articles - (while (cdr articles) - (setq articles (cdr articles))) - (setq last (mail-header-number (caar articles))) - (setq articles gnus-scores-articles) + (setq last (mail-header-number (caar (last articles)))) ;; Not all backends support partial fetching. In that case, ;; we just fetch the entire article. - (or (gnus-check-backend-function - (and (string-match "^gnus-" (symbol-name request-func)) - (intern (substring (symbol-name request-func) - (match-end 0)))) - gnus-newsgroup-name) - (progn - (setq ofunc request-func) - (setq request-func 'gnus-request-article))) + (unless (gnus-check-backend-function + (and (string-match "^gnus-" (symbol-name request-func)) + (intern (substring (symbol-name request-func) + (match-end 0)))) + gnus-newsgroup-name) + (setq ofunc request-func) + (setq request-func 'gnus-request-article)) (while articles (setq article (mail-header-number (caar articles))) (gnus-message 7 "Scoring on article %s of %s..." article last) @@ -1416,26 +1614,25 @@ ;; If just parts of the article is to be searched, but the ;; backend didn't support partial fetching, we just narrow ;; to the relevant parts. - (if ofunc - (if (eq ofunc 'gnus-request-head) - (narrow-to-region - (point) - (or (search-forward "\n\n" nil t) (point-max))) + (when ofunc + (if (eq ofunc 'gnus-request-head) (narrow-to-region - (or (search-forward "\n\n" nil t) (point)) - (point-max)))) + (point) + (or (search-forward "\n\n" nil t) (point-max))) + (narrow-to-region + (or (search-forward "\n\n" nil t) (point)) + (point-max)))) (setq scores all-scores) ;; Find matches. (while scores - (setq alist (car scores) - scores (cdr scores) + (setq alist (pop scores) entries (assoc header alist)) (while (cdr entries) ;First entry is the header index. - (let* ((rest (cdr entries)) + (let* ((rest (cdr entries)) (kill (car rest)) (match (nth 0 kill)) (type (or (nth 3 kill) 's)) - (score (or (nth 1 kill) + (score (or (nth 1 kill) gnus-score-interactive-default-score)) (date (nth 2 kill)) (found nil) @@ -1452,32 +1649,33 @@ (t (error "Illegal match type: %s" type))))) (goto-char (point-min)) - (if (funcall search-func match nil t) - ;; Found a match, update scores. - (progn - (setcdr (car articles) (+ score (cdar articles))) - (setq found t) - (and trace (setq gnus-score-trace - (cons - (cons - (car-safe - (rassq alist gnus-score-cache)) - kill) - gnus-score-trace))))) + (when (funcall search-func match nil t) + ;; Found a match, update scores. + (setcdr (car articles) (+ score (cdar articles))) + (setq found t) + (when trace + (push + (cons (car-safe (rassq alist gnus-score-cache)) kill) + gnus-score-trace))) ;; Update expire date - (cond - ((null date)) ;Permanent entry. - ((and found gnus-update-score-entry-dates) ;Match, update date. - (gnus-score-set 'touched '(t) alist) - (setcar (nthcdr 2 kill) now)) - ((and expire (< date expire)) ;Old entry, remove. - (gnus-score-set 'touched '(t) alist) - (setcdr entries (cdr rest)) - (setq rest entries))) + (unless trace + (cond + ((null date)) ;Permanent entry. + ((and found gnus-update-score-entry-dates) + ;; Match, update date. + (gnus-score-set 'touched '(t) alist) + (setcar (nthcdr 2 kill) now)) + ((and expire (< date expire)) ;Old entry, remove. + (gnus-score-set 'touched '(t) alist) + (setcdr entries (cdr rest)) + (setq rest entries)))) (setq entries rest))))) (setq articles (cdr articles))))))) nil) +(defun gnus-score-thread (scores header now expire &optional trace) + (gnus-score-followup scores header now expire trace t)) + (defun gnus-score-followup (scores header now expire &optional trace thread) ;; Insert the unique article headers in the buffer. (let ((gnus-score-index (nth 1 (assoc header gnus-header-index))) @@ -1505,17 +1703,15 @@ this (aref (car art) gnus-score-index) articles (cdr articles)) (if (equal last this) - (setq alike (cons art alike)) - (if last - (progn - (insert last ?\n) - (put-text-property (1- (point)) (point) 'articles alike))) + (push art alike) + (when last + (insert last ?\n) + (put-text-property (1- (point)) (point) 'articles alike)) (setq alike (list art) last this))) - (and last ; Bwadr, duplicate code. - (progn - (insert last ?\n) - (put-text-property (1- (point)) (point) 'articles alike))) + (when last ; Bwadr, duplicate code. + (insert last ?\n) + (put-text-property (1- (point)) (point) 'articles alike)) ;; Find matches. (while scores @@ -1523,7 +1719,7 @@ scores (cdr scores) entries (assoc header alist)) (while (cdr entries) ;First entry is the header index. - (let* ((rest (cdr entries)) + (let* ((rest (cdr entries)) (kill (car rest)) (match (nth 0 kill)) (type (or (nth 3 kill) 's)) @@ -1569,7 +1765,7 @@ ((and found gnus-update-score-entry-dates) ;Match, update date. (gnus-score-set 'touched '(t) alist) (setcar (nthcdr 2 kill) now)) - ((and expire (< date expire)) ;Old entry, remove. + ((and expire (< date expire)) ;Old entry, remove. (gnus-score-set 'touched '(t) alist) (setcdr entries (cdr rest)) (setq rest entries))) @@ -1607,7 +1803,8 @@ ;; Insert the unique article headers in the buffer. (let ((gnus-score-index (nth 1 (assoc header gnus-header-index))) ;; gnus-score-index is used as a free variable. - alike last this art entries alist articles scores fuzzy) + alike last this art entries alist articles + fuzzies arts words kill) ;; Sorting the articles costs os O(N*log N) but will allow us to ;; only match with each unique header. Thus the actual matching @@ -1619,172 +1816,224 @@ articles gnus-scores-articles) (erase-buffer) - (while articles - (setq art (car articles) - this (aref (car art) gnus-score-index) - articles (cdr articles)) + (while (setq art (pop articles)) + (setq this (aref (car art) gnus-score-index)) (if (equal last this) ;; O(N*H) cons-cells used here, where H is the number of ;; headers. - (setq alike (cons art alike)) - (if last - (progn - ;; Insert the line, with a text property on the - ;; terminating newline referring to the articles with - ;; this line. - (insert last ?\n) - (put-text-property (1- (point)) (point) 'articles alike))) + (push art alike) + (when last + ;; Insert the line, with a text property on the + ;; terminating newline referring to the articles with + ;; this line. + (insert last ?\n) + (put-text-property (1- (point)) (point) 'articles alike)) (setq alike (list art) last this))) - (and last ; Bwadr, duplicate code. - (progn - (insert last ?\n) - (put-text-property (1- (point)) (point) 'articles alike))) + (when last ; Bwadr, duplicate code. + (insert last ?\n) + (put-text-property (1- (point)) (point) 'articles alike)) - ;; Find ordinary matches. - (setq scores score-list) - (while scores - (setq alist (car scores) - scores (cdr scores) + ;; Go through all the score alists and pick out the entries + ;; for this header. + (while score-list + (setq alist (pop score-list) + ;; There's only one instance of this header for + ;; each score alist. entries (assoc header alist)) (while (cdr entries) ;First entry is the header index. - (let* ((rest (cdr entries)) - (kill (car rest)) + (let* ((kill (cadr entries)) (match (nth 0 kill)) (type (or (nth 3 kill) 's)) (score (or (nth 1 kill) gnus-score-interactive-default-score)) (date (nth 2 kill)) (found nil) (mt (aref (symbol-name type) 0)) - (case-fold-search - (not (or (= mt ?R) (= mt ?S) (= mt ?E) (= mt ?F)))) + (case-fold-search (not (memq mt '(?R ?S ?E ?F)))) (dmt (downcase mt)) (search-func (cond ((= dmt ?r) 're-search-forward) ((or (= dmt ?e) (= dmt ?s) (= dmt ?f)) 'search-forward) - (t (error "Illegal match type: %s" type)))) - arts art) - (if (= dmt ?f) - (setq fuzzy t) - ;; Do non-fuzzy matching. + ((= dmt ?w) nil) + (t (error "Illegal match type: %s" type))))) + (cond + ;; Fuzzy matches. We save these for later. + ((= dmt ?f) + (push (cons entries alist) fuzzies)) + ;; Word matches. Save these for even later. + ((= dmt ?w) + (push (cons entries alist) words)) + ;; Exact matches. + ((= dmt ?e) + ;; Do exact matching. (goto-char (point-min)) - (if (= dmt ?e) - ;; Do exact matching. - (while (and (not (eobp)) - (funcall search-func match nil t)) - (and (= (progn (beginning-of-line) (point)) - (match-beginning 0)) - (= (progn (end-of-line) (point)) - (match-end 0)) - (progn - (setq found (setq arts (get-text-property - (point) 'articles))) - ;; Found a match, update scores. - (if trace - (while arts - (setq art (car arts) - arts (cdr arts)) - (setcdr art (+ score (cdr art))) - (setq gnus-score-trace - (cons - (cons - (car-safe - (rassq alist gnus-score-cache)) - kill) - gnus-score-trace))) - (while arts - (setq art (car arts) - arts (cdr arts)) - (setcdr art (+ score (cdr art))))))) - (forward-line 1)) - ;; Do regexp and substring matching. - (and (string= match "") (setq match "\n")) - (while (and (not (eobp)) - (funcall search-func match nil t)) - (goto-char (match-beginning 0)) - (end-of-line) - (setq found (setq arts (get-text-property (point) 'articles))) - ;; Found a match, update scores. - (if trace - (while arts - (setq art (pop arts)) - (setcdr art (+ score (cdr art))) - (push (cons - (car-safe (rassq alist gnus-score-cache)) - kill) + (while (and (not (eobp)) + (funcall search-func match nil t)) + ;; Is it really exact? + (and (eolp) + (= (point-at-bol) (match-beginning 0)) + ;; Yup. + (progn + (setq found (setq arts (get-text-property + (point) 'articles))) + ;; Found a match, update scores. + (if trace + (while (setq art (pop arts)) + (setcdr art (+ score (cdr art))) + (push + (cons + (car-safe (rassq alist gnus-score-cache)) + kill) gnus-score-trace)) - (while arts - (setq art (pop arts)) - (setcdr art (+ score (cdr art))))) - (forward-line 1))) - ;; Update expire date + (while (setq art (pop arts)) + (setcdr art (+ score (cdr art))))))) + (forward-line 1))) + ;; Regexp and substring matching. + (t + (goto-char (point-min)) + (when (string= match "") + (setq match "\n")) + (while (and (not (eobp)) + (funcall search-func match nil t)) + (goto-char (match-beginning 0)) + (end-of-line) + (setq found (setq arts (get-text-property (point) 'articles))) + ;; Found a match, update scores. + (if trace + (while (setq art (pop arts)) + (setcdr art (+ score (cdr art))) + (push (cons (car-safe (rassq alist gnus-score-cache)) kill) + gnus-score-trace)) + (while (setq art (pop arts)) + (setcdr art (+ score (cdr art))))) + (forward-line 1)))) + ;; Update expiry date + (if trace + (setq entries (cdr entries)) (cond - ((null date)) ;Permanent entry. - ((and found gnus-update-score-entry-dates) ;Match, update date. + ;; Permanent entry. + ((null date) + (setq entries (cdr entries))) + ;; We have a match, so we update the date. + ((and found gnus-update-score-entry-dates) (gnus-score-set 'touched '(t) alist) - (setcar (nthcdr 2 kill) now)) - ((and expire (< date expire)) ;Old entry, remove. + (setcar (nthcdr 2 kill) now) + (setq entries (cdr entries))) + ;; This entry has expired, so we remove it. + ((and expire (< date expire)) (gnus-score-set 'touched '(t) alist) - (setcdr entries (cdr rest)) - (setq rest entries)))) - (setq entries rest)))) + (setcdr entries (cddr entries))) + ;; No match; go to next entry. + (t + (setq entries (cdr entries)))))))) ;; Find fuzzy matches. - (when fuzzy - (setq scores score-list) + (when fuzzies + ;; Simplify the entire buffer for easy matching. (gnus-simplify-buffer-fuzzy) - (while scores - (setq alist (car scores) - scores (cdr scores) - entries (assoc header alist)) - (while (cdr entries) ;First entry is the header index. - (let* ((rest (cdr entries)) - (kill (car rest)) - (match (nth 0 kill)) - (type (or (nth 3 kill) 's)) - (score (or (nth 1 kill) gnus-score-interactive-default-score)) + (while (setq kill (cadaar fuzzies)) + (let* ((match (nth 0 kill)) + (type (nth 3 kill)) + (score (or (nth 1 kill) gnus-score-interactive-default-score)) + (date (nth 2 kill)) + (mt (aref (symbol-name type) 0)) + (case-fold-search (not (= mt ?F))) + found) + (goto-char (point-min)) + (while (and (not (eobp)) + (search-forward match nil t)) + (when (and (= (point-at-bol) (match-beginning 0)) + (eolp)) + (setq found (setq arts (get-text-property (point) 'articles))) + (if trace + (while (setq art (pop arts)) + (setcdr art (+ score (cdr art))) + (push (cons + (car-safe (rassq (cdar fuzzies) gnus-score-cache)) + kill) + gnus-score-trace)) + ;; Found a match, update scores. + (while (setq art (pop arts)) + (setcdr art (+ score (cdr art)))))) + (forward-line 1)) + ;; Update expiry date + (cond + ;; Permanent. + ((null date) + ) + ;; Match, update date. + ((and found gnus-update-score-entry-dates) + (gnus-score-set 'touched '(t) (cdar fuzzies)) + (setcar (nthcdr 2 kill) now)) + ;; Old entry, remove. + ((and expire (< date expire)) + (gnus-score-set 'touched '(t) (cdar fuzzies)) + (setcdr (caar fuzzies) (cddaar fuzzies)))) + (setq fuzzies (cdr fuzzies))))) + + (when words + ;; Enter all words into the hashtb. + (let ((hashtb (gnus-make-hashtable + (* 10 (count-lines (point-min) (point-max)))))) + (gnus-enter-score-words-into-hashtb hashtb) + (while (setq kill (cadaar words)) + (let* ((score (or (nth 1 kill) gnus-score-interactive-default-score)) (date (nth 2 kill)) - (found nil) - (mt (aref (symbol-name type) 0)) - (case-fold-search (not (= mt ?F))) - (dmt (downcase mt)) - arts art) - (when (= dmt ?f) - (goto-char (point-min)) - (while (and (not (eobp)) - (search-forward match nil t)) - (when (and (= (progn (beginning-of-line) (point)) - (match-beginning 0)) - (= (progn (end-of-line) (point)) - (match-end 0))) - (setq found (setq arts (get-text-property - (point) 'articles))) - ;; Found a match, update scores. - (if trace - (while arts - (setq art (pop arts)) - (setcdr art (+ score (cdr art))) - (push (cons - (car-safe (rassq alist gnus-score-cache)) - kill) - gnus-score-trace)) - (while arts - (setq art (pop arts)) - (setcdr art (+ score (cdr art)))))) - (forward-line 1)) - ;; Update expire date - (unless trace - (cond - ((null date)) ;Permanent entry. - ((and found gnus-update-score-entry-dates) ;Match, update date. - (gnus-score-set 'touched '(t) alist) - (setcar (nthcdr 2 kill) now)) - ((and expire (< date expire)) ;Old entry, remove. - (gnus-score-set 'touched '(t) alist) - (setcdr entries (cdr rest)) - (setq rest entries))))) - (setq entries rest)))))) - nil) + found) + (when (setq arts (intern-soft (nth 0 kill) hashtb)) + (setq arts (symbol-value arts)) + (setq found t) + (if trace + (while (setq art (pop arts)) + (setcdr art (+ score (cdr art))) + (push (cons + (car-safe (rassq (cdar words) gnus-score-cache)) + kill) + gnus-score-trace)) + ;; Found a match, update scores. + (while (setq art (pop arts)) + (setcdr art (+ score (cdr art)))))) + ;; Update expiry date + (cond + ;; Permanent. + ((null date) + ) + ;; Match, update date. + ((and found gnus-update-score-entry-dates) + (gnus-score-set 'touched '(t) (cdar words)) + (setcar (nthcdr 2 kill) now)) + ;; Old entry, remove. + ((and expire (< date expire)) + (gnus-score-set 'touched '(t) (cdar words)) + (setcdr (caar words) (cddaar words)))) + (setq words (cdr words)))))) + nil)) + +(defun gnus-enter-score-words-into-hashtb (hashtb) + ;; Find all the words in the buffer and enter them into + ;; the hashtable. + (let ((syntab (syntax-table)) + word val) + (goto-char (point-min)) + (unwind-protect + (progn + (set-syntax-table gnus-adaptive-word-syntax-table) + (while (re-search-forward "\\b\\w+\\b" nil t) + (setq val + (gnus-gethash + (setq word (downcase (buffer-substring + (match-beginning 0) (match-end 0)))) + hashtb)) + (gnus-sethash + word + (append (get-text-property (point-at-eol) 'articles) val) + hashtb))) + (set-syntax-table syntab)) + ;; Make all the ignorable words ignored. + (let ((ignored (append gnus-ignored-adaptive-words + gnus-default-ignored-adaptive-words))) + (while ignored + (gnus-sethash (pop ignored) nil hashtb))))) (defun gnus-score-string< (a1 a2) ;; Compare headers in articles A2 and A2. @@ -1792,10 +2041,6 @@ (string-lessp (aref (car a1) gnus-score-index) (aref (car a2) gnus-score-index))) -(defun gnus-score-build-cons (article) - ;; Build a `gnus-newsgroup-scored' type cons from ARTICLE. - (cons (mail-header-number (car article)) (cdr article))) - (defun gnus-current-score-file-nondirectory (&optional score-file) (let ((score-file (or score-file gnus-current-score-file))) (if score-file @@ -1803,74 +2048,129 @@ "none"))) (defun gnus-score-adaptive () - (save-excursion - (let* ((malist (gnus-copy-sequence gnus-adaptive-score-alist)) - (alist malist) - (date (current-time-string)) - (data gnus-newsgroup-data) - elem headers match) - ;; First we transform the adaptive rule alist into something - ;; that's faster to process. - (while malist - (setq elem (car malist)) - (if (symbolp (car elem)) - (setcar elem (symbol-value (car elem)))) - (setq elem (cdr elem)) - (while elem - (setcdr (car elem) - (cons (if (eq (caar elem) 'followup) - "references" - (symbol-name (caar elem))) - (cdar elem))) - (setcar (car elem) - `(lambda (h) - (,(intern - (concat "mail-header-" - (if (eq (caar elem) 'followup) - "message-id" - (downcase (symbol-name (caar elem)))))) - h))) - (setq elem (cdr elem))) - (setq malist (cdr malist))) - ;; We change the score file to the adaptive score file. + "Create adaptive score rules for this newsgroup." + (when gnus-use-adaptive-scoring + ;; We change the score file to the adaptive score file. + (save-excursion + (set-buffer gnus-summary-buffer) + (gnus-score-load-file + (or gnus-newsgroup-adaptive-score-file + (gnus-score-file-name + gnus-newsgroup-name gnus-adaptive-file-suffix)))) + ;; Perform ordinary line scoring. + (when (or (not (listp gnus-use-adaptive-scoring)) + (memq 'line gnus-use-adaptive-scoring)) (save-excursion - (set-buffer gnus-summary-buffer) - (gnus-score-load-file - (or gnus-newsgroup-adaptive-score-file - (gnus-score-file-name - gnus-newsgroup-name gnus-adaptive-file-suffix)))) - ;; The we score away. - (while data - (setq elem (cdr (assq (gnus-data-mark (car data)) alist))) - (if (or (not elem) - (gnus-data-pseudo-p (car data))) - () - (when (setq headers (gnus-data-header (car data))) - (while elem - (setq match (funcall (caar elem) headers)) - (gnus-summary-score-entry - (nth 1 (car elem)) match - (cond - ((numberp match) - '=) - ((equal (nth 1 (car elem)) "date") - 'a) - (t - ;; Whether we use substring or exact matches are controlled - ;; here. - (if (or (not gnus-score-exact-adapt-limit) - (< (length match) gnus-score-exact-adapt-limit)) - 'e - (if (equal (nth 1 (car elem)) "subject") - 'f 's)))) - (nth 2 (car elem)) date nil t) - (setq elem (cdr elem))))) - (setq data (cdr data)))))) + (let* ((malist (gnus-copy-sequence gnus-adaptive-score-alist)) + (alist malist) + (date (current-time-string)) + (data gnus-newsgroup-data) + elem headers match) + ;; First we transform the adaptive rule alist into something + ;; that's faster to process. + (while malist + (setq elem (car malist)) + (when (symbolp (car elem)) + (setcar elem (symbol-value (car elem)))) + (setq elem (cdr elem)) + (while elem + (setcdr (car elem) + (cons (if (eq (caar elem) 'followup) + "references" + (symbol-name (caar elem))) + (cdar elem))) + (setcar (car elem) + `(lambda (h) + (,(intern + (concat "mail-header-" + (if (eq (caar elem) 'followup) + "message-id" + (downcase (symbol-name (caar elem)))))) + h))) + (setq elem (cdr elem))) + (setq malist (cdr malist))) + ;; Then we score away. + (while data + (setq elem (cdr (assq (gnus-data-mark (car data)) alist))) + (if (or (not elem) + (gnus-data-pseudo-p (car data))) + () + (when (setq headers (gnus-data-header (car data))) + (while elem + (setq match (funcall (caar elem) headers)) + (gnus-summary-score-entry + (nth 1 (car elem)) match + (cond + ((numberp match) + '=) + ((equal (nth 1 (car elem)) "date") + 'a) + (t + ;; Whether we use substring or exact matches is + ;; controlled here. + (if (or (not gnus-score-exact-adapt-limit) + (< (length match) gnus-score-exact-adapt-limit)) + 'e + (if (equal (nth 1 (car elem)) "subject") + 'f 's)))) + (nth 2 (car elem)) date nil t) + (setq elem (cdr elem))))) + (setq data (cdr data)))))) + + ;; Perform adaptive word scoring. + (when (and (listp gnus-use-adaptive-scoring) + (memq 'word gnus-use-adaptive-scoring)) + (nnheader-temp-write nil + (let* ((hashtb (gnus-make-hashtable 1000)) + (date (gnus-day-number (current-time-string))) + (data gnus-newsgroup-data) + (syntab (syntax-table)) + word d score val) + (unwind-protect + (progn + (set-syntax-table gnus-adaptive-word-syntax-table) + ;; Go through all articles. + (while (setq d (pop data)) + (when (and + (not (gnus-data-pseudo-p d)) + (setq score + (cdr (assq + (gnus-data-mark d) + gnus-adaptive-word-score-alist)))) + ;; This article has a mark that should lead to + ;; adaptive word rules, so we insert the subject + ;; and find all words in that string. + (insert (mail-header-subject (gnus-data-header d))) + (downcase-region (point-min) (point-max)) + (goto-char (point-min)) + (while (re-search-forward "\\b\\w+\\b" nil t) + ;; Put the word and score into the hashtb. + (setq val (gnus-gethash (setq word (match-string 0)) + hashtb)) + (gnus-sethash word (+ (or val 0) score) hashtb)) + (erase-buffer)))) + (set-syntax-table syntab)) + ;; Make all the ignorable words ignored. + (let ((ignored (append gnus-ignored-adaptive-words + gnus-default-ignored-adaptive-words))) + (while ignored + (gnus-sethash (pop ignored) nil hashtb))) + ;; Now we have all the words and scores, so we + ;; add these rules to the ADAPT file. + (set-buffer gnus-summary-buffer) + (mapatoms + (lambda (word) + (when (symbol-value word) + (gnus-summary-score-entry + "subject" (symbol-name word) 'w (symbol-value word) + date nil t))) + hashtb)))))) (defun gnus-score-edit-done () (let ((bufnam (buffer-file-name (current-buffer))) (winconf gnus-prev-winconf)) - (and winconf (set-window-configuration winconf)) + (when winconf + (set-window-configuration winconf)) (gnus-score-remove-from-cache bufnam) (gnus-score-load-file bufnam))) @@ -1880,25 +2180,59 @@ (let ((gnus-newsgroup-headers (list (gnus-summary-article-header))) (gnus-newsgroup-scored nil) - (buf (current-buffer)) trace) - (when (get-buffer "*Gnus Scores*") - (save-excursion - (set-buffer "*Gnus Scores*") - (erase-buffer))) + (save-excursion + (nnheader-set-temp-buffer "*Score Trace*")) (setq gnus-score-trace nil) (gnus-possibly-score-headers 'trace) (if (not (setq trace gnus-score-trace)) (gnus-error 1 "No score rules apply to the current article.") - (pop-to-buffer "*Gnus Scores*") + (set-buffer "*Score Trace*") (gnus-add-current-to-buffer-list) - (erase-buffer) (while trace (insert (format "%S -> %s\n" (cdar trace) (file-name-nondirectory (caar trace)))) (setq trace (cdr trace))) (goto-char (point-min)) - (pop-to-buffer buf)))) + (gnus-configure-windows 'score-trace)))) + +(defun gnus-score-find-favourite-words () + "List words used in scoring." + (interactive) + (let ((alists (gnus-score-load-files (gnus-all-score-files))) + alist rule rules kill) + ;; Go through all the score alists for this group + ;; and find all `w' rules. + (while (setq alist (pop alists)) + (while (setq rule (pop alist)) + (when (and (stringp (car rule)) + (equal "subject" (downcase (pop rule)))) + (while (setq kill (pop rule)) + (when (memq (nth 3 kill) '(w W word Word)) + (push (cons (or (nth 1 kill) + gnus-score-interactive-default-score) + (car kill)) + rules)))))) + (setq rules (sort rules (lambda (r1 r2) + (string-lessp (cdr r1) (cdr r2))))) + ;; Add up words that have appeared several times. + (let ((r rules)) + (while (cdr r) + (if (equal (cdar r) (cdadr r)) + (progn + (setcar (car r) (+ (caar r) (caadr r))) + (setcdr r (cddr r))) + (pop r)))) + ;; Insert the words. + (nnheader-set-temp-buffer "*Score Words*") + (if (not (setq rules (sort rules (lambda (r1 r2) (> (car r1) (car r2)))))) + (gnus-error 3 "No word score rules") + (while rules + (insert (format "%-5d: %s\n" (caar rules) (cdar rules))) + (pop rules)) + (gnus-add-current-to-buffer-list) + (goto-char (point-min)) + (gnus-configure-windows 'score-words)))) (defun gnus-summary-rescore () "Redo the entire scoring process in the current summary." @@ -1950,7 +2284,7 @@ (gnus-summary-next-subject 1 t))) (defun gnus-score-default (level) - (if level (prefix-numeric-value level) + (if level (prefix-numeric-value level) gnus-score-interactive-default-score)) (defun gnus-summary-raise-thread (&optional score) @@ -1966,8 +2300,8 @@ (setq articles (cdr articles)))) (setq e (point))) (let ((gnus-summary-check-current t)) - (or (zerop (gnus-summary-next-subject 1 t)) - (goto-char e)))) + (unless (zerop (gnus-summary-next-subject 1 t)) + (goto-char e)))) (gnus-summary-recenter) (gnus-summary-position-point) (gnus-set-mode-line 'summary)) @@ -1992,9 +2326,9 @@ (defun gnus-score-score-files (group) "Return a list of all possible score files." ;; Search and set any global score files. - (and gnus-global-score-files - (or gnus-internal-global-score-files - (gnus-score-search-global-directories gnus-global-score-files))) + (when gnus-global-score-files + (unless gnus-internal-global-score-files + (gnus-score-search-global-directories gnus-global-score-files))) ;; Fix the kill-file dir variable. (setq gnus-kill-files-directory (file-name-as-directory gnus-kill-files-directory)) @@ -2028,17 +2362,20 @@ (defun gnus-score-score-files-1 (dir) "Return all possible score files under DIR." - (let ((files (directory-files (expand-file-name dir) t nil t)) + (let ((files (list (expand-file-name dir))) (regexp (gnus-score-file-regexp)) - out file) + (case-fold-search nil) + seen out file) (while (setq file (pop files)) (cond ;; Ignore "." and "..". ((member (file-name-nondirectory file) '("." "..")) nil) - ;; Recurse down directories. - ((file-directory-p file) - (setq out (nconc (gnus-score-score-files-1 file) out))) + ;; Add subtrees of directory to also be searched. + ((and (file-directory-p file) + (not (member (file-truename file) seen))) + (push (file-truename file) seen) + (setq files (nconc (directory-files file t nil t) files))) ;; Add files to the list of score files. ((string-match regexp file) (push file out)))) @@ -2074,7 +2411,7 @@ (goto-char (point-min)) ;; First remove the suffix itself. (when (re-search-forward (concat "." score-regexp) nil t) - (replace-match "" t t) + (replace-match "" t t) (goto-char (point-min)) (if (looking-at (regexp-quote kill-dir)) ;; If the file name was just "SCORE", `klen' is one character @@ -2089,17 +2426,16 @@ "[/:" (if trans (char-to-string trans) "") "]"))) (while (re-search-forward regexp nil t) (replace-match "." t t))) - ;; Cludge to get rid of "nntp+" problems. + ;; Kludge to get rid of "nntp+" problems. (goto-char (point-min)) - (and (looking-at "nn[a-z]+\\+") - (progn - (search-forward "+") - (forward-char -1) - (insert "\\"))) + (when (looking-at "nn[a-z]+\\+") + (search-forward "+") + (forward-char -1) + (insert "\\") + (forward-char 1)) ;; Kludge to deal with "++". - (goto-char (point-min)) - (while (search-forward "++" nil t) - (replace-match "\\+\\+" t t)) + (while (search-forward "+" nil t) + (replace-match "\\+" t t)) ;; Translate "all" to ".*". (goto-char (point-min)) (while (search-forward "all" nil t) @@ -2109,26 +2445,26 @@ (if (looking-at "not.") (progn (setq not-match t) - (setq regexp (buffer-substring 5 (point-max)))) - (setq regexp (buffer-substring 1 (point-max))) + (setq regexp (concat "^" (buffer-substring 5 (point-max))))) + (setq regexp (concat "^" (buffer-substring 1 (point-max)))) (setq not-match nil)) ;; Finally - if this resulting regexp matches the group name, ;; we add this score file to the list of score files ;; applicable to this group. - (if (or (and not-match - (not (string-match regexp group))) - (and (not not-match) - (string-match regexp group))) - (setq ofiles (cons (car sfiles) ofiles)))) + (when (or (and not-match + (not (string-match regexp group))) + (and (not not-match) + (string-match regexp group))) + (push (car sfiles) ofiles))) (setq sfiles (cdr sfiles))) (kill-buffer (current-buffer)) ;; Slight kludge here - the last score file returned should be - ;; the local score file, whether it exists or not. This is so + ;; the local score file, whether it exists or not. This is so ;; that any score commands the user enters will go to the right ;; file, and not end up in some global score file. (let ((localscore (gnus-score-file-name group))) (setq ofiles (cons localscore (delete localscore ofiles)))) - (nreverse ofiles)))) + (gnus-sort-score-files (nreverse ofiles))))) (defun gnus-score-find-single (group) "Return list containing the score file for GROUP." @@ -2139,17 +2475,61 @@ (defun gnus-score-find-hierarchical (group) "Return list of score files for GROUP. This includes the score file for the group and all its parents." - (let ((all (copy-sequence '(nil))) - (start 0)) + (let* ((prefix (gnus-group-real-prefix group)) + (all (list nil)) + (group (gnus-group-real-name group)) + (start 0)) (while (string-match "\\." group (1+ start)) (setq start (match-beginning 0)) - (setq all (cons (substring group 0 start) all))) - (setq all (cons group all)) - (nconc - (mapcar (lambda (newsgroup) - (gnus-score-file-name newsgroup gnus-adaptive-file-suffix)) - (setq all (nreverse all))) - (mapcar 'gnus-score-file-name all)))) + (push (substring group 0 start) all)) + (push group all) + (setq all + (nconc + (mapcar (lambda (group) + (gnus-score-file-name group gnus-adaptive-file-suffix)) + (setq all (nreverse all))) + (mapcar 'gnus-score-file-name all))) + (if (equal prefix "") + all + (mapcar + (lambda (file) + (concat (file-name-directory file) prefix + (file-name-nondirectory file))) + all)))) + +(defun gnus-score-file-rank (file) + "Return a number that says how specific score FILE is. +Destroys the current buffer." + (if (member file gnus-internal-global-score-files) + 0 + (when (string-match + (concat "^" (regexp-quote + (expand-file-name + (file-name-as-directory gnus-kill-files-directory)))) + file) + (setq file (substring file (match-end 0)))) + (insert file) + (goto-char (point-min)) + (let ((beg (point)) + elems) + (while (re-search-forward "[./]" nil t) + (push (buffer-substring beg (1- (point))) + elems)) + (erase-buffer) + (setq elems (delete "all" elems)) + (length elems)))) + +(defun gnus-sort-score-files (files) + "Sort FILES so that the most general files come first." + (nnheader-temp-write nil + (let ((alist + (mapcar + (lambda (file) + (cons (inline (gnus-score-file-rank file)) file)) + files))) + (mapcar + (lambda (f) (cdr f)) + (sort alist (lambda (f1 f2) (< (car f1) (car f2)))))))) (defun gnus-score-find-alist (group) "Return list of score files for GROUP. @@ -2161,30 +2541,30 @@ (cdr score-files) ;ensures caching groups with no matches ;; handle the multiple match alist (while alist - (and (string-match (caar alist) group) - (setq score-files - (nconc score-files (copy-sequence (cdar alist))))) + (when (string-match (caar alist) group) + (setq score-files + (nconc score-files (copy-sequence (cdar alist))))) (setq alist (cdr alist))) (setq alist gnus-score-file-single-match-alist) ;; handle the single match alist (while alist - (and (string-match (caar alist) group) - ;; progn used just in case ("regexp") has no files - ;; and score-files is still nil. -sj - ;; this can be construed as a "stop searching here" feature :> - ;; and used to simplify regexps in the single-alist - (progn - (setq score-files - (nconc score-files (copy-sequence (cdar alist)))) - (setq alist nil))) + (when (string-match (caar alist) group) + ;; progn used just in case ("regexp") has no files + ;; and score-files is still nil. -sj + ;; this can be construed as a "stop searching here" feature :> + ;; and used to simplify regexps in the single-alist + (setq score-files + (nconc score-files (copy-sequence (cdar alist)))) + (setq alist nil)) (setq alist (cdr alist))) ;; cache the score files - (setq gnus-score-file-alist-cache - (cons (cons group score-files) gnus-score-file-alist-cache)) + (push (cons group score-files) gnus-score-file-alist-cache) score-files))) -(defun gnus-possibly-score-headers (&optional trace) +(defun gnus-all-score-files (&optional group) + "Return a list of all score files for the current group." (let ((funcs gnus-score-find-score-files-function) + (group (or group gnus-newsgroup-name)) score-files) ;; Make sure funcs is a list. (and funcs @@ -2192,20 +2572,55 @@ (setq funcs (list funcs))) ;; Get the initial score files for this group. (when funcs - (setq score-files (gnus-score-find-alist gnus-newsgroup-name))) + (setq score-files (nreverse (gnus-score-find-alist group)))) + ;; Add any home adapt files. + (let ((home (gnus-home-score-file group t))) + (when home + (push home score-files) + (setq gnus-newsgroup-adaptive-score-file home))) + ;; Check whether there is a `adapt-file' group parameter. + (let ((param-file (gnus-group-find-parameter group 'adapt-file))) + (when param-file + (push param-file score-files) + (setq gnus-newsgroup-adaptive-score-file param-file))) ;; Go through all the functions for finding score files (or actual ;; scores) and add them to a list. (while funcs (when (gnus-functionp (car funcs)) (setq score-files - (nconc score-files (funcall (car funcs) gnus-newsgroup-name)))) + (nconc score-files (nreverse (funcall (car funcs) group))))) (setq funcs (cdr funcs))) + ;; Add any home score files. + (let ((home (gnus-home-score-file group))) + (when home + (push home score-files))) ;; Check whether there is a `score-file' group parameter. - (let ((param-file (gnus-group-get-parameter - gnus-newsgroup-name 'score-file))) + (let ((param-file (gnus-group-find-parameter group 'score-file))) (when param-file (push param-file score-files))) + ;; Expand all files names. + (let ((files score-files)) + (while files + (when (stringp (car files)) + (setcar files (expand-file-name + (car files) gnus-kill-files-directory))) + (pop files))) + (setq score-files (nreverse score-files)) + ;; Remove any duplicate score files. + (while (and score-files + (member (car score-files) (cdr score-files))) + (pop score-files)) + (let ((files score-files)) + (while (cdr files) + (when (member (cadr files) (cddr files)) + (setcdr files (cddr files))) + (pop files))) ;; Do the scoring if there are any score files for this group. + score-files)) + +(defun gnus-possibly-score-headers (&optional trace) + "Do scoring if scoring is required." + (let ((score-files (gnus-all-score-files))) (when score-files (gnus-score-headers score-files trace)))) @@ -2241,7 +2656,7 @@ (setq out (nconc (directory-files (car files) t (concat (gnus-score-file-regexp) "$")))) - (setq out (cons (car files) out))) + (push (car files) out)) (setq files (cdr files))) (setq gnus-internal-global-score-files out))) @@ -2253,6 +2668,81 @@ (gnus-message 1 "New score file entries will be case insensitive.") (gnus-message 1 "New score file entries will be case sensitive."))) +;;; Home score file. + +(defun gnus-home-score-file (group &optional adapt) + "Return the home score file for GROUP. +If ADAPT, return the home adaptive file instead." + (let ((list (if adapt gnus-home-adapt-file gnus-home-score-file)) + elem found) + ;; Make sure we have a list. + (unless (listp list) + (setq list (list list))) + ;; Go through the list and look for matches. + (while (and (not found) + (setq elem (pop list))) + (setq found + (cond + ;; Simple string. + ((stringp elem) + elem) + ;; Function. + ((gnus-functionp elem) + (funcall elem group)) + ;; Regexp-file cons + ((consp elem) + (when (string-match (car elem) group) + (cadr elem)))))) + (when found + (nnheader-concat gnus-kill-files-directory found)))) + +(defun gnus-hierarchial-home-score-file (group) + "Return the score file of the top-level hierarchy of GROUP." + (if (string-match "^[^.]+\\." group) + (concat (match-string 0 group) gnus-score-file-suffix) + ;; Group name without any dots. + (concat group "." gnus-score-file-suffix))) + +(defun gnus-hierarchial-home-adapt-file (group) + "Return the adapt file of the top-level hierarchy of GROUP." + (if (string-match "^[^.]+\\." group) + (concat (match-string 0 group) gnus-adaptive-file-suffix) + ;; Group name without any dots. + (concat group "." gnus-adaptive-file-suffix))) + +;;; +;;; Score decays +;;; + +(defun gnus-decay-score (score) + "Decay SCORE." + (floor + (- score + (* (if (< score 0) 1 -1) + (min score + (max gnus-score-decay-constant + (* (abs score) + gnus-score-decay-scale))))))) + +(defun gnus-decay-scores (alist day) + "Decay non-permanent scores in ALIST." + (let ((times (- (gnus-time-to-day (current-time)) day)) + kill entry updated score n) + (unless (zerop times) ;Done decays today already? + (while (setq entry (pop alist)) + (when (stringp (car entry)) + (setq entry (cdr entry)) + (while (setq kill (pop entry)) + (when (nth 2 kill) + (setq updated t) + (setq score (or (car kill) gnus-score-interactive-default-score) + n times) + (while (natnump (decf n)) + (setq score (funcall gnus-decay-score-function score))) + (setcar kill score)))))) + ;; Return whether this score file needs to be saved. By Je-haysuss! + updated)) + (provide 'gnus-score) ;;; gnus-score.el ends here diff -r ad457d5f7d04 -r 0293115a14e9 lisp/gnus/gnus-setup.el --- a/lisp/gnus/gnus-setup.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/gnus/gnus-setup.el Mon Aug 13 08:49:20 2007 +0200 @@ -1,7 +1,7 @@ ;;; gnus-setup.el --- Initialization & Setup for Gnus 5 -;; Copyright (C) 1995, 96, 97 Free Software Foundation, Inc. +;; Copyright (C) 1995, 96 Free Software Foundation, Inc. -;; Author: Steven L. Baur +;; Author: Steven L. Baur ;; Keywords: news ;; This file is part of GNU Emacs. @@ -29,24 +29,12 @@ ;; not to byte compile this, and just arrange to have the .el loaded out ;; of .emacs. -;; Dec-28 1996: Updated for better handling of preinstalled Gnus - ;;; Code: -(eval-when-compile - (require 'cl)) +(require 'cl) (defvar running-xemacs (string-match "XEmacs\\|Lucid" emacs-version)) -(defvar gnus-use-installed-gnus t - "*If non-nil Use installed version of Gnus.") - -(defvar gnus-use-installed-tm running-xemacs - "*If non-nil use installed version of tm.") - -(defvar gnus-use-installed-mailcrypt running-xemacs - "*If non-nil use installed version of mailcrypt.") - (defvar gnus-emacs-lisp-directory (if running-xemacs "/usr/local/lib/xemacs/" "/usr/local/share/emacs/") @@ -56,6 +44,10 @@ "gnus-5.0.15/lisp/") "Directory where Gnus Emacs lisp is found.") +(defvar gnus-sgnus-lisp-directory (concat gnus-emacs-lisp-directory + "sgnus/lisp/") + "Directory where September Gnus Emacs lisp is found.") + (defvar gnus-tm-lisp-directory (concat gnus-emacs-lisp-directory "site-lisp/") "Directory where TM Emacs lisp is found.") @@ -65,10 +57,10 @@ "Directory where Mailcrypt Emacs Lisp is found.") (defvar gnus-bbdb-lisp-directory (concat gnus-emacs-lisp-directory - "site-lisp/bbdb-1.51/") + "site-lisp/bbdb-1.50/") "Directory where Big Brother Database is found.") -(defvar gnus-use-tm running-xemacs +(defvar gnus-use-tm t "Set this if you want MIME support for Gnus") (defvar gnus-use-mhe nil "Set this if you want to use MH-E for mail reading") @@ -87,10 +79,13 @@ (defvar gnus-use-september nil "Set this if you are using the experimental September Gnus") -(when (and (not gnus-use-installed-gnus) - (null (member gnus-gnus-lisp-directory load-path))) - (setq load-path (cons gnus-gnus-lisp-directory load-path))) +(let ((gnus-directory (if gnus-use-september + gnus-sgnus-lisp-directory + gnus-gnus-lisp-directory))) + (when (null (member gnus-directory load-path)) + (push gnus-directory load-path))) +;;; We can't do this until we know where Gnus is. (require 'message) ;;; Tools for MIME by @@ -98,22 +93,17 @@ ;;; MORIOKA Tomohiko (when gnus-use-tm - (when (and (not gnus-use-installed-tm) - (null (member gnus-tm-lisp-directory load-path))) + (when (null (member gnus-tm-lisp-directory load-path)) (setq load-path (cons gnus-tm-lisp-directory load-path))) - ;; tm may or may not be dumped with XEmacs. In Sunpro it is, otherwise - ;; it isn't. - (unless (featurep 'mime-setup) - (load "mime-setup"))) + (load "mime-setup")) ;;; Mailcrypt by ;;; Jin Choi ;;; Patrick LoPresti (when gnus-use-mailcrypt - (when (and (not gnus-use-installed-mailcrypt) - (null (member gnus-mailcrypt-lisp-directory load-path))) - (setq load-path (cons gnus-mailcrypt-lisp-directory load-path))) + (when (null (member gnus-mailcrypt-lisp-directory load-path)) + (setq load-path (cons gnus-mailcrypt-lisp-directory load-path))) (autoload 'mc-install-write-mode "mailcrypt" nil t) (autoload 'mc-install-read-mode "mailcrypt" nil t) (add-hook 'message-mode-hook 'mc-install-write-mode) @@ -123,10 +113,9 @@ (add-hook 'mh-letter-mode-hook 'mc-install-write-mode))) ;;; BBDB by -;;; Jamie Zawinski +;;; Jamie Zawinski (when gnus-use-bbdb - ;; bbdb will never be installed with emacs. (when (null (member gnus-bbdb-lisp-directory load-path)) (setq load-path (cons gnus-bbdb-lisp-directory load-path))) (autoload 'bbdb "bbdb-com" @@ -169,49 +158,48 @@ (setq message-cite-function 'sc-cite-original) (autoload 'sc-cite-original "supercite")) -;;;### (autoloads (gnus-batch-score gnus-fetch-group gnus gnus-slave gnus-no-server gnus-update-format) "gnus" "lisp/gnus.el" (12473 2137)) +;;;### (autoloads (gnus gnus-slave gnus-no-server) "gnus" "lisp/gnus.el" (12473 2137)) ;;; Generated autoloads from lisp/gnus.el -;; Don't redo this if autoloads already exist -(unless (fboundp 'gnus) - (autoload 'gnus-update-format "gnus" "\ -Update the format specification near point." t nil) - - (autoload 'gnus-slave-no-server "gnus" "\ +(autoload 'gnus-slave-no-server "gnus" "\ Read network news as a slave without connecting to local server." t nil) - (autoload 'gnus-no-server "gnus" "\ +(autoload 'gnus-no-server "gnus" "\ Read network news. If ARG is a positive number, Gnus will use that as the startup level. If ARG is nil, Gnus will be started at level 2. If ARG is non-nil and not a positive number, Gnus will prompt the user for the name of an NNTP server to use. -As opposed to `gnus', this command will not connect to the local server." - t nil) +As opposed to `gnus', this command will not connect to the local server." t nil) - (autoload 'gnus-slave "gnus" "\ +(autoload 'gnus-slave "gnus" "\ Read news as a slave." t nil) - (autoload 'gnus "gnus" "\ +(autoload 'gnus "gnus" "\ Read network news. If ARG is non-nil and a positive number, Gnus will use that as the startup level. If ARG is non-nil and not a positive number, Gnus will prompt the user for the name of an NNTP server to use." t nil) - (autoload 'gnus-fetch-group "gnus" "\ +;;;*** + +;;; These have moved out of gnus.el into other files. +;;; FIX FIX FIX: should other things be in gnus-setup? or these not in it? +(autoload 'gnus-update-format "gnus-spec" "\ +Update the format specification near point." t nil) + +(autoload 'gnus-fetch-group "gnus-group" "\ Start Gnus if necessary and enter GROUP. Returns whether the fetching was successful or not." t nil) - (defalias 'gnus-batch-kill 'gnus-batch-score) +(defalias 'gnus-batch-kill 'gnus-batch-score) - (autoload 'gnus-batch-score "gnus" "\ +(autoload 'gnus-batch-score "gnus-kill" "\ Run batched scoring. Usage: emacs -batch -l gnus -f gnus-batch-score ... Newsgroups is a list of strings in Bnews format. If you want to score the comp hierarchy, you'd say \"comp.all\". If you would not like to -score the alt hierarchy, you'd say \"!alt.all\"." t nil)) - -;;;*** +score the alt hierarchy, you'd say \"!alt.all\"." t nil) (provide 'gnus-setup) diff -r ad457d5f7d04 -r 0293115a14e9 lisp/gnus/gnus-soup.el --- a/lisp/gnus/gnus-soup.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/gnus/gnus-soup.el Mon Aug 13 08:49:20 2007 +0200 @@ -1,5 +1,5 @@ ;;; gnus-soup.el --- SOUP packet writing support for Gnus -;; Copyright (C) 1995,96 Free Software Foundation, Inc. +;; Copyright (C) 1995,96,97 Free Software Foundation, Inc. ;; Author: Per Abrahamsen ;; Lars Magne Ingebrigtsen @@ -26,9 +26,11 @@ ;;; Code: -(require 'gnus-msg) (require 'gnus) -(eval-when-compile (require 'cl)) +(require 'gnus-art) +(require 'message) +(require 'gnus-start) +(require 'gnus-range) ;;; User Variables: @@ -44,7 +46,7 @@ (defvar 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 +This string MUST contain both %s and %d. The file number will be inserted where %d appears.") (defvar gnus-soup-unpacker "gunzip -c %s | tar xvf -" @@ -70,7 +72,7 @@ (defvar gnus-soup-index-type ?c "*Soup index type. `n' means no index file and `c' means standard Cnews overview -format.") +format.") (defvar gnus-soup-areas nil) (defvar gnus-soup-last-prefix nil) @@ -116,8 +118,8 @@ (let ((packets (directory-files gnus-soup-packet-directory t gnus-soup-packet-regexp))) (while packets - (and (gnus-soup-send-packet (car packets)) - (delete-file (car packets))) + (when (gnus-soup-send-packet (car packets)) + (delete-file (car packets))) (setq packets (cdr packets))))) (defun gnus-soup-add-article (n) @@ -163,6 +165,10 @@ "Make a SOUP packet from the SOUP areas." (interactive) (gnus-soup-read-areas) + (unless (file-exists-p gnus-soup-directory) + (message "No such directory: %s" gnus-soup-directory)) + (when (null (directory-files gnus-soup-directory nil "\\.MSG$")) + (message "No files to pack.")) (gnus-soup-pack gnus-soup-directory gnus-soup-packer)) (defun gnus-group-brew-soup (n) @@ -182,8 +188,8 @@ (let ((level (or level gnus-level-subscribed)) (newsrc (cdr gnus-newsrc-alist))) (while newsrc - (and (<= (nth 1 (car newsrc)) level) - (gnus-soup-group-brew (caar newsrc) t)) + (when (<= (nth 1 (car newsrc)) level) + (gnus-soup-group-brew (caar newsrc) t)) (setq newsrc (cdr newsrc))) (gnus-soup-save-areas))) @@ -198,34 +204,32 @@ $ emacs -batch -f gnus-batch-brew-soup ^nnml \".*emacs.*\"" (interactive) - ) + nil) ;;; Internal Functions: ;; Store the current buffer. (defun gnus-soup-store (directory prefix headers format index) ;; Create the directory, if needed. - (or (file-directory-p directory) - (gnus-make-directory directory)) - (let* ((msg-buf (find-file-noselect + (gnus-make-directory directory) + (let* ((msg-buf (nnheader-find-file-noselect (concat directory prefix ".MSG"))) (idx-buf (if (= index ?n) nil - (find-file-noselect + (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) - (and idx-buf - (progn - (setq gnus-soup-buffers (cons idx-buf gnus-soup-buffers)) - (buffer-disable-undo idx-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)) - (or (= (current-column) 0) - (insert "\n")) + (unless (= (current-column) 0) + (insert "\n")) ;; Find the "from". (goto-char (point-min)) (setq from @@ -300,7 +304,7 @@ (lambda (time) (int-to-string time)) (current-time) "-"))) (or (mail-header-references header) "") - (or (mail-header-chars header) 0) + (or (mail-header-chars header) 0) (or (mail-header-lines header) "0")))) (defun gnus-soup-save-areas () @@ -313,21 +317,20 @@ (if (not (buffer-name buf)) () (set-buffer buf) - (and (buffer-modified-p) (save-buffer)) + (when (buffer-modified-p) + (save-buffer)) (kill-buffer (current-buffer))))) (gnus-soup-write-prefixes))) (defun gnus-soup-write-prefixes () - (let ((prefix gnus-soup-last-prefix)) + (let ((prefixes gnus-soup-last-prefix) + prefix) (save-excursion - (while prefix - (gnus-set-work-buffer) - (insert (format "(setq gnus-soup-prev-prefix %d)\n" (cdar prefix))) - (gnus-make-directory (caar prefix)) - (write-region (point-min) (point-max) - (concat (caar prefix) gnus-soup-prefix-file) - nil 'nomesg) - (setq prefix (cdr prefix)))))) + (gnus-set-work-buffer) + (while (setq prefix (pop prefixes)) + (erase-buffer) + (insert (format "(setq gnus-soup-prev-prefix %d)\n" (cdr prefix))) + (gnus-write-buffer (concat (car prefix) gnus-soup-prefix-file)))))) (defun gnus-soup-pack (dir packer) (let* ((files (mapconcat 'identity @@ -342,8 +345,7 @@ (string-to-int (gnus-soup-unique-prefix dir)) files))) (dir (expand-file-name dir))) - (or (file-directory-p dir) - (gnus-make-directory dir)) + (gnus-make-directory dir) (setq gnus-soup-areas nil) (gnus-message 4 "Packing %s..." packer) (if (zerop (call-process shell-file-name @@ -363,40 +365,38 @@ though the two last may be nil if they are missing." (let (areas) (save-excursion - (set-buffer (find-file-noselect file 'force)) + (set-buffer (nnheader-find-file-noselect file 'force)) (buffer-disable-undo (current-buffer)) (goto-char (point-min)) (while (not (eobp)) - (setq areas - (cons (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-int (gnus-soup-field)))) - areas)) - (if (eq (preceding-char) ?\t) - (beginning-of-line 2))) + (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-int (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]." +file. The vector contain three strings, [prefix name encoding]." (let (replies) (save-excursion - (set-buffer (find-file-noselect file)) + (set-buffer (nnheader-find-file-noselect file)) (buffer-disable-undo (current-buffer)) (goto-char (point-min)) (while (not (eobp)) - (setq replies - (cons (vector (gnus-soup-field) (gnus-soup-field) - (gnus-soup-field)) - replies)) - (if (eq (preceding-char) ?\t) - (beginning-of-line 2))) + (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)) @@ -422,9 +422,9 @@ (format "%s\t%s\t%s%s\n" (gnus-soup-area-prefix area) - (gnus-soup-area-name area) + (gnus-soup-area-name area) (gnus-soup-area-encoding area) - (if (or (gnus-soup-area-description area) + (if (or (gnus-soup-area-description area) (gnus-soup-area-number area)) (concat "\t" (or (gnus-soup-area-description area) "") @@ -440,7 +440,7 @@ (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-kind area) (gnus-soup-reply-encoding area))))))) (defun gnus-soup-area (group) @@ -451,18 +451,18 @@ (while areas (setq area (car areas) areas (cdr areas)) - (if (equal (gnus-soup-area-name area) real-group) - (setq result area))) - (or 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))) + (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) @@ -471,13 +471,11 @@ gnus-soup-prev-prefix) (if entry () - (and (file-exists-p (concat dir gnus-soup-prefix-file)) - (condition-case nil - (load (concat dir gnus-soup-prefix-file) nil t t) - (error nil))) - (setq gnus-soup-last-prefix - (cons (setq entry (cons dir (or gnus-soup-prev-prefix 0))) - gnus-soup-last-prefix))) + (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)))) @@ -490,7 +488,7 @@ (prog1 (zerop (call-process shell-file-name nil nil nil shell-command-switch - (format "cd %s ; %s" (expand-file-name dir) + (format "cd %s ; %s" (expand-file-name dir) (format unpacker packet)))) (gnus-message 4 "Unpacking...done"))) @@ -505,12 +503,13 @@ (gnus-soup-reply-prefix (car replies)) ".MSG")) (msg-buf (and (file-exists-p msg-file) - (find-file-noselect msg-file))) + (nnheader-find-file-noselect msg-file))) (tmp-buf (get-buffer-create " *soup send*")) beg end) (cond ((/= (gnus-soup-encoding-format - (gnus-soup-reply-encoding (car replies))) ?n) + (gnus-soup-reply-encoding (car replies))) + ?n) (error "Unsupported encoding")) ((null msg-buf) t) @@ -520,8 +519,8 @@ (set-buffer msg-buf) (goto-char (point-min)) (while (not (eobp)) - (or (looking-at "#! *rnews +\\([0-9]+\\)") - (error "Bad header.")) + (unless (looking-at "#! *rnews +\\([0-9]+\\)") + (error "Bad header.")) (forward-line 1) (setq beg (point) end (+ (point) (string-to-int @@ -541,10 +540,12 @@ (gnus-message 5 "Sending news message to %s..." (mail-fetch-field "newsgroups")) (sit-for 1) - (funcall message-send-news-function)) + (let ((message-syntax-checks + 'dont-check-for-anything-just-trust-me)) + (funcall message-send-news-function))) ((string= (gnus-soup-reply-kind (car replies)) "mail") (gnus-message 5 "Sending mail to %s..." - (mail-fetch-field "to")) + (mail-fetch-field "to")) (sit-for 1) (message-send-mail)) (t diff -r ad457d5f7d04 -r 0293115a14e9 lisp/gnus/gnus-spec.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus/gnus-spec.el Mon Aug 13 08:49:20 2007 +0200 @@ -0,0 +1,526 @@ +;;; gnus-spec.el --- format spec functions for Gnus +;; Copyright (C) 1996,97 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen +;; Keywords: news + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;;; Code: + +(require 'gnus) + +;;; Internal variables. + +(defvar gnus-summary-mark-positions nil) +(defvar gnus-group-mark-positions nil) +(defvar gnus-group-indentation "") + +;; Format specs. The chunks below are the machine-generated forms +;; that are to be evaled as the result of the default format strings. +;; We write them in here to get them byte-compiled. That way the +;; default actions will be quite fast, while still retaining the full +;; flexibility of the user-defined format specs. + +;; First we have lots of dummy defvars to let the compiler know these +;; are really dynamic variables. + +(defvar gnus-tmp-unread) +(defvar gnus-tmp-replied) +(defvar gnus-tmp-score-char) +(defvar gnus-tmp-indentation) +(defvar gnus-tmp-opening-bracket) +(defvar gnus-tmp-lines) +(defvar gnus-tmp-name) +(defvar gnus-tmp-closing-bracket) +(defvar gnus-tmp-subject-or-nil) +(defvar gnus-tmp-subject) +(defvar gnus-tmp-marked) +(defvar gnus-tmp-marked-mark) +(defvar gnus-tmp-subscribed) +(defvar gnus-tmp-process-marked) +(defvar gnus-tmp-number-of-unread) +(defvar gnus-tmp-group-name) +(defvar gnus-tmp-group) +(defvar gnus-tmp-article-number) +(defvar gnus-tmp-unread-and-unselected) +(defvar gnus-tmp-news-method) +(defvar gnus-tmp-news-server) +(defvar gnus-tmp-article-number) +(defvar gnus-mouse-face) +(defvar gnus-mouse-face-prop) + +(defun gnus-summary-line-format-spec () + (insert gnus-tmp-unread gnus-tmp-replied + gnus-tmp-score-char gnus-tmp-indentation) + (gnus-put-text-property + (point) + (progn + (insert + gnus-tmp-opening-bracket + (format "%4d: %-20s" + gnus-tmp-lines + (if (> (length gnus-tmp-name) 20) + (substring gnus-tmp-name 0 20) + gnus-tmp-name)) + gnus-tmp-closing-bracket) + (point)) + gnus-mouse-face-prop gnus-mouse-face) + (insert " " gnus-tmp-subject-or-nil "\n")) + +(defvar gnus-summary-line-format-spec + (gnus-byte-code 'gnus-summary-line-format-spec)) + +(defun gnus-summary-dummy-line-format-spec () + (insert "* ") + (gnus-put-text-property + (point) + (progn + (insert ": :") + (point)) + gnus-mouse-face-prop gnus-mouse-face) + (insert " " gnus-tmp-subject "\n")) + +(defvar gnus-summary-dummy-line-format-spec + (gnus-byte-code 'gnus-summary-dummy-line-format-spec)) + +(defun gnus-group-line-format-spec () + (insert gnus-tmp-marked-mark gnus-tmp-subscribed + gnus-tmp-process-marked + gnus-group-indentation + (format "%5s: " gnus-tmp-number-of-unread)) + (gnus-put-text-property + (point) + (progn + (insert gnus-tmp-group "\n") + (1- (point))) + gnus-mouse-face-prop gnus-mouse-face)) +(defvar gnus-group-line-format-spec + (gnus-byte-code 'gnus-group-line-format-spec)) + +(defvar gnus-format-specs + `((version . ,emacs-version) + (group "%M\%S\%p\%P\%5y: %(%g%)%l\n" ,gnus-group-line-format-spec) + (summary-dummy "* %(: :%) %S\n" + ,gnus-summary-dummy-line-format-spec) + (summary "%U\%R\%z\%I\%(%[%4L: %-20,20n%]%) %s\n" + ,gnus-summary-line-format-spec)) + "Alist of format specs.") + +(defvar gnus-article-mode-line-format-spec nil) +(defvar gnus-summary-mode-line-format-spec nil) +(defvar gnus-group-mode-line-format-spec nil) + +;;; Phew. All that gruft is over, fortunately. + +;;;###autoload +(defun gnus-update-format (var) + "Update the format specification near point." + (interactive + (list + (save-excursion + (eval-defun nil) + ;; Find the end of the current word. + (re-search-forward "[ \t\n]" nil t) + ;; Search backward. + (when (re-search-backward "\\(gnus-[-a-z]+-line-format\\)" nil t) + (match-string 1))))) + (let* ((type (intern (progn (string-match "gnus-\\([-a-z]+\\)-line" var) + (match-string 1 var)))) + (entry (assq type gnus-format-specs)) + value spec) + (when entry + (setq gnus-format-specs (delq entry gnus-format-specs))) + (set + (intern (format "%s-spec" var)) + (gnus-parse-format (setq value (symbol-value (intern var))) + (symbol-value (intern (format "%s-alist" var))) + (not (string-match "mode" var)))) + (setq spec (symbol-value (intern (format "%s-spec" var)))) + (push (list type value spec) gnus-format-specs) + + (pop-to-buffer "*Gnus Format*") + (erase-buffer) + (lisp-interaction-mode) + (insert (pp-to-string spec)))) + +(defun gnus-update-format-specifications (&optional force &rest types) + "Update all (necessary) format specifications." + ;; Make the indentation array. + ;; See whether all the stored info needs to be flushed. + (when (or force + (not (equal emacs-version + (cdr (assq 'version gnus-format-specs))))) + (setq gnus-format-specs nil)) + + ;; Go through all the formats and see whether they need updating. + (let (new-format entry type val) + (while (setq type (pop types)) + ;; Jump to the proper buffer to find out the value of + ;; the variable, if possible. (It may be buffer-local.) + (save-excursion + (let ((buffer (intern (format "gnus-%s-buffer" type))) + val) + (when (and (boundp buffer) + (setq val (symbol-value buffer)) + (get-buffer val) + (buffer-name (get-buffer val))) + (set-buffer (get-buffer val))) + (setq new-format (symbol-value + (intern (format "gnus-%s-line-format" type))))) + (setq entry (cdr (assq type gnus-format-specs))) + (if (and (car entry) + (equal (car entry) new-format)) + ;; Use the old format. + (set (intern (format "gnus-%s-line-format-spec" type)) + (cadr entry)) + ;; This is a new format. + (setq val + (if (not (stringp new-format)) + ;; This is a function call or something. + new-format + ;; This is a "real" format. + (gnus-parse-format + new-format + (symbol-value + (intern (format "gnus-%s-line-format-alist" + (if (eq type 'article-mode) + 'summary-mode type)))) + (not (string-match "mode$" (symbol-name type)))))) + ;; Enter the new format spec into the list. + (if entry + (progn + (setcar (cdr entry) val) + (setcar entry new-format)) + (push (list type new-format val) gnus-format-specs)) + (set (intern (format "gnus-%s-line-format-spec" type)) val))))) + + (unless (assq 'version gnus-format-specs) + (push (cons 'version emacs-version) gnus-format-specs))) + +(defvar gnus-mouse-face-0 'highlight) +(defvar gnus-mouse-face-1 'highlight) +(defvar gnus-mouse-face-2 'highlight) +(defvar gnus-mouse-face-3 'highlight) +(defvar gnus-mouse-face-4 'highlight) + +(defun gnus-mouse-face-function (form type) + `(gnus-put-text-property + (point) (progn ,@form (point)) + gnus-mouse-face-prop + ,(if (equal type 0) + 'gnus-mouse-face + `(quote ,(symbol-value (intern (format "gnus-mouse-face-%d" type))))))) + +(defvar gnus-face-0 'bold) +(defvar gnus-face-1 'italic) +(defvar gnus-face-2 'bold-italic) +(defvar gnus-face-3 'bold) +(defvar gnus-face-4 'bold) + +(defun gnus-face-face-function (form type) + `(gnus-put-text-property + (point) (progn ,@form (point)) + 'face ',(symbol-value (intern (format "gnus-face-%d" type))))) + +(defun gnus-tilde-max-form (el max-width) + "Return a form that limits EL to MAX-WIDTH." + (let ((max (abs max-width))) + (if (symbolp el) + `(if (> (length ,el) ,max) + ,(if (< max-width 0) + `(substring ,el (- (length el) ,max)) + `(substring ,el 0 ,max)) + ,el) + `(let ((val (eval ,el))) + (if (> (length val) ,max) + ,(if (< max-width 0) + `(substring val (- (length val) ,max)) + `(substring val 0 ,max)) + val))))) + +(defun gnus-tilde-cut-form (el cut-width) + "Return a form that cuts CUT-WIDTH off of EL." + (let ((cut (abs cut-width))) + (if (symbolp el) + `(if (> (length ,el) ,cut) + ,(if (< cut-width 0) + `(substring ,el 0 (- (length el) ,cut)) + `(substring ,el ,cut)) + ,el) + `(let ((val (eval ,el))) + (if (> (length val) ,cut) + ,(if (< cut-width 0) + `(substring val 0 (- (length val) ,cut)) + `(substring val ,cut)) + val))))) + +(defun gnus-tilde-ignore-form (el ignore-value) + "Return a form that is blank when EL is IGNORE-VALUE." + (if (symbolp el) + `(if (equal ,el ,ignore-value) + "" ,el) + `(let ((val (eval ,el))) + (if (equal val ,ignore-value) + "" val)))) + +(defun gnus-parse-format (format spec-alist &optional insert) + ;; This function parses the FORMAT string with the help of the + ;; SPEC-ALIST and returns a list that can be eval'ed to return the + ;; string. If the FORMAT string contains the specifiers %( and %) + ;; the text between them will have the mouse-face text property. + (if (string-match + "\\`\\(.*\\)%[0-9]?[{(]\\(.*\\)%[0-9]?[})]\\(.*\n?\\)\\'" + format) + (gnus-parse-complex-format format spec-alist) + ;; This is a simple format. + (gnus-parse-simple-format format spec-alist insert))) + +(defun gnus-parse-complex-format (format spec-alist) + (save-excursion + (gnus-set-work-buffer) + (insert format) + (goto-char (point-min)) + (while (re-search-forward "\"" nil t) + (replace-match "\\\"" nil t)) + (goto-char (point-min)) + (insert "(\"") + (while (re-search-forward "%\\([0-9]+\\)?\\([{}()]\\)" nil t) + (let ((number (if (match-beginning 1) + (match-string 1) "0")) + (delim (aref (match-string 2) 0))) + (if (or (= delim ?\() (= delim ?\{)) + (replace-match (concat "\"(" (if (= delim ?\() "mouse" "face") + " " number " \"")) + (replace-match "\")\"")))) + (goto-char (point-max)) + (insert "\")") + (goto-char (point-min)) + (let ((form (read (current-buffer)))) + (cons 'progn (gnus-complex-form-to-spec form spec-alist))))) + +(defun gnus-complex-form-to-spec (form spec-alist) + (delq nil + (mapcar + (lambda (sform) + (if (stringp sform) + (gnus-parse-simple-format sform spec-alist t) + (funcall (intern (format "gnus-%s-face-function" (car sform))) + (gnus-complex-form-to-spec (cddr sform) spec-alist) + (nth 1 sform)))) + form))) + +(defun gnus-parse-simple-format (format spec-alist &optional insert) + ;; This function parses the FORMAT string with the help of the + ;; SPEC-ALIST and returns a list that can be eval'ed to return a + ;; string. + (let ((max-width 0) + spec flist fstring elem result dontinsert user-defined + type value pad-width spec-beg cut-width ignore-value + tilde-form tilde elem-type) + (save-excursion + (gnus-set-work-buffer) + (insert format) + (goto-char (point-min)) + (while (re-search-forward "%" nil t) + (setq user-defined nil + spec-beg nil + pad-width nil + max-width nil + cut-width nil + ignore-value nil + tilde-form nil) + (setq spec-beg (1- (point))) + + ;; Parse this spec fully. + (while + (cond + ((looking-at "\\([-.0-9]+\\)\\(,[-0-9]+\\)?") + (setq pad-width (string-to-number (match-string 1))) + (when (match-beginning 2) + (setq max-width (string-to-number (buffer-substring + (1+ (match-beginning 2)) + (match-end 2))))) + (goto-char (match-end 0))) + ((looking-at "~") + (forward-char 1) + (setq tilde (read (current-buffer)) + type (car tilde) + value (cadr tilde)) + (cond + ((memq type '(pad pad-left)) + (setq pad-width value)) + ((eq type 'pad-right) + (setq pad-width (- value))) + ((memq type '(max-right max)) + (setq max-width value)) + ((eq type 'max-left) + (setq max-width (- value))) + ((memq type '(cut cut-left)) + (setq cut-width value)) + ((eq type 'cut-right) + (setq cut-width (- value))) + ((eq type 'ignore) + (setq ignore-value + (if (stringp value) value (format "%s" value)))) + ((eq type 'form) + (setq tilde-form value)) + (t + (error "Unknown tilde type: %s" tilde))) + t) + (t + nil))) + ;; User-defined spec -- find the spec name. + (when (= (setq spec (following-char)) ?u) + (forward-char 1) + (setq user-defined (following-char))) + (forward-char 1) + (delete-region spec-beg (point)) + + ;; Now we have all the relevant data on this spec, so + ;; we start doing stuff. + (insert "%") + (if (eq spec ?%) + ;; "%%" just results in a "%". + (insert "%") + (cond + ;; Do tilde forms. + ((eq spec ?@) + (setq elem (list tilde-form ?s))) + ;; Treat user defined format specifiers specially. + (user-defined + (setq elem + (list + (list (intern (format "gnus-user-format-function-%c" + user-defined)) + 'gnus-tmp-header) + ?s))) + ;; Find the specification from `spec-alist'. + ((setq elem (cdr (assq spec spec-alist)))) + (t + (setq elem '("*" ?s)))) + (setq elem-type (cadr elem)) + ;; Insert the new format elements. + (when pad-width + (insert (number-to-string pad-width))) + ;; Create the form to be evaled. + (if (or max-width cut-width ignore-value) + (progn + (insert ?s) + (let ((el (car elem))) + (cond ((= (cadr elem) ?c) + (setq el (list 'char-to-string el))) + ((= (cadr elem) ?d) + (setq el (list 'int-to-string el)))) + (when ignore-value + (setq el (gnus-tilde-ignore-form el ignore-value))) + (when cut-width + (setq el (gnus-tilde-cut-form el cut-width))) + (when max-width + (setq el (gnus-tilde-max-form el max-width))) + (push el flist))) + (insert elem-type) + (push (car elem) flist)))) + (setq fstring (buffer-string))) + + ;; Do some postprocessing to increase efficiency. + (setq + result + (cond + ;; Emptyness. + ((string= fstring "") + nil) + ;; Not a format string. + ((not (string-match "%" fstring)) + (list fstring)) + ;; A format string with just a single string spec. + ((string= fstring "%s") + (list (car flist))) + ;; A single character. + ((string= fstring "%c") + (list (car flist))) + ;; A single number. + ((string= fstring "%d") + (setq dontinsert) + (if insert + (list `(princ ,(car flist))) + (list `(int-to-string ,(car flist))))) + ;; Just lots of chars and strings. + ((string-match "\\`\\(%[cs]\\)+\\'" fstring) + (nreverse flist)) + ;; A single string spec at the beginning of the spec. + ((string-match "\\`%[sc][^%]+\\'" fstring) + (list (car flist) (substring fstring 2))) + ;; A single string spec in the middle of the spec. + ((string-match "\\`\\([^%]+\\)%[sc]\\([^%]+\\)\\'" fstring) + (list (match-string 1 fstring) (car flist) (match-string 2 fstring))) + ;; A single string spec in the end of the spec. + ((string-match "\\`\\([^%]+\\)%[sc]\\'" fstring) + (list (match-string 1 fstring) (car flist))) + ;; A more complex spec. + (t + (list (cons 'format (cons fstring (nreverse flist))))))) + + (if insert + (when result + (if dontinsert + result + (cons 'insert result))) + (cond ((stringp result) + result) + ((consp result) + (cons 'concat result)) + (t ""))))) + +(defun gnus-eval-format (format &optional alist props) + "Eval the format variable FORMAT, using ALIST. +If PROPS, insert the result." + (let ((form (gnus-parse-format format alist props))) + (if props + (gnus-add-text-properties (point) (progn (eval form) (point)) props) + (eval form)))) + +(defun gnus-compile () + "Byte-compile the user-defined format specs." + (interactive) + (let ((entries gnus-format-specs) + (byte-compile-warnings '(unresolved callargs redefine)) + entry gnus-tmp-func) + (save-excursion + (gnus-message 7 "Compiling format specs...") + + (while entries + (setq entry (pop entries)) + (if (eq (car entry) 'version) + (setq gnus-format-specs (delq entry gnus-format-specs)) + (when (and (listp (caddr entry)) + (not (eq 'byte-code (caaddr entry)))) + (fset 'gnus-tmp-func `(lambda () ,(caddr entry))) + (byte-compile 'gnus-tmp-func) + (setcar (cddr entry) (gnus-byte-code 'gnus-tmp-func))))) + + (push (cons 'version emacs-version) gnus-format-specs) + ;; Mark the .newsrc.eld file as "dirty". + (gnus-dribble-enter " ") + (gnus-message 7 "Compiling user specs...done")))) + +(provide 'gnus-spec) + +;;; gnus-spec.el ends here diff -r ad457d5f7d04 -r 0293115a14e9 lisp/gnus/gnus-srvr.el --- a/lisp/gnus/gnus-srvr.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/gnus/gnus-srvr.el Mon Aug 13 08:49:20 2007 +0200 @@ -1,5 +1,5 @@ ;;; gnus-srvr.el --- virtual server support for Gnus -;; Copyright (C) 1995,96 Free Software Foundation, Inc. +;; Copyright (C) 1995,96,97 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; Keywords: news @@ -26,7 +26,10 @@ ;;; Code: (require 'gnus) -(eval-when-compile (require 'cl)) +(require 'gnus-spec) +(require 'gnus-group) +(require 'gnus-int) +(require 'gnus-range) (defvar gnus-server-mode-hook nil "Hook run in `gnus-server-mode' buffers.") @@ -67,20 +70,21 @@ "*Hook run after the creation of the server mode menu.") (defun gnus-server-make-menu-bar () - (gnus-visual-turn-off-edit-menu 'server) + (gnus-turn-off-edit-menu 'server) (unless (boundp 'gnus-server-server-menu) (easy-menu-define gnus-server-server-menu gnus-server-mode-map "" '("Server" ["Add" gnus-server-add-server t] ["Browse" gnus-server-read-server t] + ["Scan" gnus-server-scan-server t] ["List" gnus-server-list-servers t] ["Kill" gnus-server-kill-server t] ["Yank" gnus-server-yank-server t] ["Copy" gnus-server-copy-server t] ["Edit" gnus-server-edit-server t] - ["Exit" gnus-server-exit t] - )) + ["Regenerate" gnus-server-regenerate-server t] + ["Exit" gnus-server-exit t])) (easy-menu-define gnus-server-connections-menu gnus-server-mode-map "" @@ -88,8 +92,10 @@ ["Open" gnus-server-open-server t] ["Close" gnus-server-close-server t] ["Deny" gnus-server-deny-server t] - ["Reset" gnus-server-remove-denials t] - )) + "---" + ["Open All" gnus-server-open-all-servers t] + ["Close All" gnus-server-close-all-servers t] + ["Reset All" gnus-server-remove-denials t])) (run-hooks 'gnus-server-menu-hook))) @@ -112,12 +118,17 @@ "c" gnus-server-copy-server "a" gnus-server-add-server "e" gnus-server-edit-server + "s" gnus-server-scan-server "O" gnus-server-open-server + "\M-o" gnus-server-open-all-servers "C" gnus-server-close-server + "\M-c" gnus-server-close-all-servers "D" gnus-server-deny-server "R" gnus-server-remove-denials + "g" gnus-server-regenerate-server + "\C-c\C-i" gnus-info-find-node)) (defun gnus-server-mode () @@ -132,14 +143,13 @@ \\{gnus-server-mode-map}" (interactive) - (when (and menu-bar-mode - (gnus-visual-p 'server-menu 'menu)) + (when (gnus-visual-p 'server-menu 'menu) (gnus-server-make-menu-bar)) (kill-all-local-variables) (gnus-simplify-mode-line) (setq major-mode 'gnus-server-mode) (setq mode-name "Server") - ; (gnus-group-set-mode-line) + (gnus-set-default-directory) (setq mode-line-process nil) (use-local-map gnus-server-mode-map) (buffer-disable-undo (current-buffer)) @@ -196,13 +206,15 @@ (setq gnus-inserted-opened-servers nil) ;; First we do the real list of servers. (while alist - (push (cdr (setq server (pop alist))) done) + (push (caar alist) done) + (cdr (setq server (pop alist))) (when (and server (car server) (cdr server)) (gnus-server-insert-server-line (car server) (cdr server)))) ;; Then we insert the list of servers that have been opened in ;; this session. (while opened - (unless (member (caar opened) done) + (unless (member (cadaar opened) done) + (push (cadaar opened) done) (gnus-server-insert-server-line (setq op-ser (format "%s:%s" (caaar opened) (nth 1 (caar opened)))) (caar opened)) @@ -212,7 +224,7 @@ (gnus-server-position-point)) (defun gnus-server-server-name () - (let ((server (get-text-property (gnus-point-at-bol) 'gnus-server))) + (let ((server (get-text-property (point-at-bol) 'gnus-server))) (and server (symbol-name server)))) (defalias 'gnus-server-position-point 'gnus-goto-colon) @@ -229,7 +241,8 @@ (when entry (gnus-dribble-enter (concat "(gnus-server-set-info \"" server "\" '" - (prin1-to-string (cdr entry)) ")"))) + (prin1-to-string (cdr entry)) ") +"))) (when (or entry oentry) ;; Buffer may be narrowed. (save-restriction @@ -268,8 +281,7 @@ (gnus-dribble-enter "") (let ((buffer-read-only nil)) (gnus-delete-line)) - (setq gnus-server-killed-servers - (cons (assoc server gnus-server-alist) gnus-server-killed-servers)) + (push (assoc server gnus-server-alist) gnus-server-killed-servers) (setq gnus-server-alist (delq (car gnus-server-killed-servers) gnus-server-alist)) (gnus-server-position-point)) @@ -277,15 +289,15 @@ (defun gnus-server-yank-server () "Yank the previously killed server." (interactive) - (or gnus-server-killed-servers - (error "No killed servers to be yanked")) + (unless gnus-server-killed-servers + (error "No killed servers to be yanked")) (let ((alist gnus-server-alist) (server (gnus-server-server-name)) (killed (car gnus-server-killed-servers))) - (if (not server) + (if (not server) (setq gnus-server-alist (nconc gnus-server-alist (list killed))) (if (string= server (caar gnus-server-alist)) - (setq gnus-server-alist (cons killed gnus-server-alist)) + (push killed gnus-server-alist) (while (and (cdr alist) (not (string= server (caadr alist)))) (setq alist (cdr alist))) @@ -329,7 +341,8 @@ "Force an open of SERVER." (interactive (list (gnus-server-server-name))) (let ((method (gnus-server-to-method server))) - (or method (error "No such server: %s" server)) + (unless method + (error "No such server: %s" server)) (gnus-server-set-status method 'ok) (prog1 (or (gnus-open-server method) @@ -337,22 +350,38 @@ (gnus-server-update-server server) (gnus-server-position-point)))) +(defun gnus-server-open-all-servers () + "Open all servers." + (interactive) + (let ((servers gnus-inserted-opened-servers)) + (while servers + (gnus-server-open-server (car (pop servers)))))) + (defun gnus-server-close-server (server) "Close SERVER." (interactive (list (gnus-server-server-name))) (let ((method (gnus-server-to-method server))) - (or method (error "No such server: %s" server)) + (unless method + (error "No such server: %s" server)) (gnus-server-set-status method 'closed) (prog1 (gnus-close-server method) (gnus-server-update-server server) (gnus-server-position-point)))) +(defun gnus-server-close-all-servers () + "Close all servers." + (interactive) + (let ((servers gnus-inserted-opened-servers)) + (while servers + (gnus-server-close-server (car (pop servers)))))) + (defun gnus-server-deny-server (server) "Make sure SERVER will never be attempted opened." (interactive (list (gnus-server-server-name))) (let ((method (gnus-server-to-method server))) - (or method (error "No such server: %s" server)) + (unless method + (error "No such server: %s" server)) (gnus-server-set-status method 'denied)) (gnus-server-update-server server) (gnus-server-position-point) @@ -371,19 +400,21 @@ (defun gnus-server-copy-server (from to) (interactive (list - (or (gnus-server-server-name) - (error "No server on the current line")) + (unless (gnus-server-server-name) + (error "No server on the current line")) (read-string "Copy to: "))) - (or from (error "No server on current line")) - (or (and to (not (string= to ""))) (error "No name to copy to")) - (and (assoc to gnus-server-alist) (error "%s already exists" to)) - (or (assoc from gnus-server-alist) - (error "%s: no such server" from)) + (unless from + (error "No server on current line")) + (unless (and to (not (string= to ""))) + (error "No name to copy to")) + (when (assoc to gnus-server-alist) + (error "%s already exists" to)) + (unless (assoc from gnus-server-alist) + (error "%s: no such server" from)) (let ((to-entry (gnus-copy-sequence (assoc from gnus-server-alist)))) (setcar to-entry to) (setcar (nthcdr 2 to-entry) to) - (setq gnus-server-killed-servers - (cons to-entry gnus-server-killed-servers)) + (push to-entry gnus-server-killed-servers) (gnus-server-yank-server))) (defun gnus-server-add-server (how where) @@ -391,20 +422,20 @@ (list (intern (completing-read "Server method: " gnus-valid-select-methods nil t)) (read-string "Server name: "))) - (setq gnus-server-killed-servers - (cons (list where how where) gnus-server-killed-servers)) + (when (assq where gnus-server-alist) + (error "Server with that name already defined")) + (push (list where how where) gnus-server-killed-servers) (gnus-server-yank-server)) (defun gnus-server-goto-server (server) "Jump to a server line." (interactive (list (completing-read "Goto server: " gnus-server-alist nil t))) - (let ((to (text-property-any (point-min) (point-max) + (let ((to (text-property-any (point-min) (point-max) 'gnus-server (intern server)))) - (and to - (progn - (goto-char to) - (gnus-server-position-point))))) + (when to + (goto-char to) + (gnus-server-position-point)))) (defun gnus-server-edit-server (server) "Edit the server on the current line." @@ -413,39 +444,21 @@ (error "No server on current line")) (unless (assoc server gnus-server-alist) (error "This server can't be edited")) - (let ((winconf (current-window-configuration)) - (info (cdr (assoc server gnus-server-alist)))) + (let ((info (cdr (assoc server gnus-server-alist)))) (gnus-close-server info) - (get-buffer-create gnus-server-edit-buffer) - (gnus-configure-windows 'edit-server) - (gnus-add-current-to-buffer-list) - (emacs-lisp-mode) - (make-local-variable 'gnus-prev-winconf) - (setq gnus-prev-winconf winconf) - (use-local-map (copy-keymap (current-local-map))) - (let ((done-func '(lambda () - "Exit editing mode and update the information." - (interactive) - (gnus-server-edit-server-done 'group)))) - (setcar (cdr (nth 4 done-func)) server) - (local-set-key "\C-c\C-c" done-func)) - (erase-buffer) - (insert ";; Type `C-c C-c' after you have edited the server.\n\n") - (insert (pp-to-string info)))) + (gnus-edit-form + info "Editing the server." + `(lambda (form) + (gnus-server-set-info ,server form) + (gnus-server-list-servers) + (gnus-server-position-point))))) -(defun gnus-server-edit-server-done (server) - (interactive) - (set-buffer (get-buffer-create gnus-server-edit-buffer)) - (goto-char (point-min)) - (let ((form (read (current-buffer))) - (winconf gnus-prev-winconf)) - (gnus-server-set-info server form) - (kill-buffer (current-buffer)) - (and winconf (set-window-configuration winconf)) - (set-buffer gnus-server-buffer) - (gnus-server-update-server server) - (gnus-server-list-servers) - (gnus-server-position-point))) +(defun gnus-server-scan-server (server) + "Request a scan from the current server." + (interactive (list (gnus-server-server-name))) + (gnus-message 3 "Scanning %s...done" server) + (gnus-request-scan nil (gnus-server-to-method server)) + (gnus-message 3 "Scanning %s...done" server)) (defun gnus-server-read-server (server) "Browse a server." @@ -502,21 +515,19 @@ "\C-c\C-i" gnus-info-find-node)) (defun gnus-browse-make-menu-bar () - (gnus-visual-turn-off-edit-menu 'browse) - (or - (boundp 'gnus-browse-menu) - (progn - (easy-menu-define - gnus-browse-menu gnus-browse-mode-map "" - '("Browse" - ["Subscribe" gnus-browse-unsubscribe-current-group t] - ["Read" gnus-browse-read-group t] - ["Select" gnus-browse-read-group t] - ["Next" gnus-browse-next-group t] - ["Prev" gnus-browse-next-group t] - ["Exit" gnus-browse-exit t] - )) - (run-hooks 'gnus-browse-menu-hook)))) + (gnus-turn-off-edit-menu 'browse) + (unless (boundp 'gnus-browse-menu) + (easy-menu-define + gnus-browse-menu gnus-browse-mode-map "" + '("Browse" + ["Subscribe" gnus-browse-unsubscribe-current-group t] + ["Read" gnus-browse-read-group t] + ["Select" gnus-browse-read-group t] + ["Next" gnus-browse-next-group t] + ["Prev" gnus-browse-next-group t] + ["Exit" gnus-browse-exit t] + )) + (run-hooks 'gnus-browse-menu-hook))) (defvar gnus-browse-current-method nil) (defvar gnus-browse-return-buffer nil) @@ -535,14 +546,19 @@ (gnus-message 1 "Unable to contact server: %s" (gnus-status-message method)) nil) - ((not (gnus-request-list method)) + ((not + (prog2 + (gnus-message 6 "Reading active file...") + (gnus-request-list method) + (gnus-message 6 "Reading active file...done"))) (gnus-message 1 "Couldn't request list: %s" (gnus-status-message method)) nil) (t (get-buffer-create gnus-browse-buffer) (gnus-add-current-to-buffer-list) - (and gnus-carpal (gnus-carpal-setup-buffer 'browse)) + (when gnus-carpal + (gnus-carpal-setup-buffer 'browse)) (gnus-configure-windows 'browse) (buffer-disable-undo (current-buffer)) (let ((buffer-read-only nil)) @@ -556,14 +572,14 @@ (set-buffer nntp-server-buffer) (let ((cur (current-buffer))) (goto-char (point-min)) - (or (string= gnus-ignored-newsgroups "") - (delete-matching-lines gnus-ignored-newsgroups)) + (unless (string= gnus-ignored-newsgroups "") + (delete-matching-lines gnus-ignored-newsgroups)) (while (re-search-forward "\\(^[^ \t]+\\)[ \t]+[0-9]+[ \t]+[0-9]+" nil t) (goto-char (match-end 1)) - (setq groups (cons (cons (match-string 1) - (max 0 (- (1+ (read cur)) (read cur)))) - groups))))) + (push (cons (match-string 1) + (max 0 (- (1+ (read cur)) (read cur)))) + groups)))) (setq groups (sort groups (lambda (l1 l2) (string< (car l1) (car l2))))) @@ -596,8 +612,7 @@ 3) `\\[gnus-browse-exit]' to return to the group buffer." (interactive) (kill-all-local-variables) - (when (and menu-bar-mode - (gnus-visual-p 'browse-menu 'menu)) + (when (gnus-visual-p 'browse-menu 'menu) (gnus-browse-make-menu-bar)) (gnus-simplify-mode-line) (setq major-mode 'gnus-browse-mode) @@ -606,17 +621,18 @@ (use-local-map gnus-browse-mode-map) (buffer-disable-undo (current-buffer)) (setq truncate-lines t) + (gnus-set-default-directory) (setq buffer-read-only t) (run-hooks 'gnus-browse-mode-hook)) (defun gnus-browse-read-group (&optional no-article) "Enter the group at the current line." (interactive) - (let ((group (gnus-browse-group-name))) - (or (gnus-group-read-ephemeral-group - group gnus-browse-current-method nil - (cons (current-buffer) 'browse)) - (error "Couldn't enter %s" group)))) + (let ((group (gnus-group-real-name (gnus-browse-group-name)))) + (unless (gnus-group-read-ephemeral-group + group gnus-browse-current-method nil + (cons (current-buffer) 'browse)) + (error "Couldn't enter %s" group)))) (defun gnus-browse-select-group () "Select the current group." @@ -648,13 +664,14 @@ (zerop (gnus-browse-next-group ward))) (decf arg)) (gnus-group-position-point) - (if (/= 0 arg) (gnus-message 7 "No more newsgroups")) + (when (/= 0 arg) + (gnus-message 7 "No more newsgroups")) arg)) (defun gnus-browse-group-name () (save-excursion (beginning-of-line) - (when (re-search-forward ": \\(.*\\)$" (gnus-point-at-eol) t) + (when (re-search-forward ": \\(.*\\)$" (point-at-eol) t) (gnus-group-prefixed-name (match-string 1) gnus-browse-current-method)))) (defun gnus-browse-unsubscribe-group () @@ -665,8 +682,12 @@ (save-excursion (beginning-of-line) ;; If this group it killed, then we want to subscribe it. - (if (= (following-char) ?K) (setq sub t)) + (when (= (following-char) ?K) + (setq sub t)) (setq group (gnus-browse-group-name)) + ;; Make sure the group has been properly removed before we + ;; subscribe to it. + (gnus-kill-ephemeral-group group) (delete-char 1) (if sub (progn @@ -703,6 +724,19 @@ (gnus-message 6 (substitute-command-keys "\\\\[gnus-group-next-group]:Forward \\[gnus-group-prev-group]:Backward \\[gnus-browse-exit]:Exit \\[gnus-info-find-node]:Run Info \\[gnus-browse-describe-briefly]:This help"))) +(defun gnus-server-regenerate-server () + "Issue a command to the server to regenerate all its data structures." + (interactive) + (let ((server (gnus-server-server-name))) + (unless server + (error "No server on the current line")) + (if (not (gnus-check-backend-function + 'request-regenerate (car (gnus-server-to-method server)))) + (error "This backend doesn't support regeneration") + (gnus-message 5 "Requesing regeneration of %s..." server) + (when (gnus-request-regenerate server) + (gnus-message 5 "Requesing regeneration of %s...done" server))))) + (provide 'gnus-srvr) ;;; gnus-srvr.el ends here. diff -r ad457d5f7d04 -r 0293115a14e9 lisp/gnus/gnus-start.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus/gnus-start.el Mon Aug 13 08:49:20 2007 +0200 @@ -0,0 +1,2438 @@ +;;; gnus-start.el --- startup functions for Gnus +;; Copyright (C) 1996,97 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen +;; Keywords: news + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;;; Code: + +(require 'gnus) +(require 'gnus-win) +(require 'gnus-int) +(require 'gnus-spec) +(require 'gnus-range) +(require 'gnus-util) +(require 'message) + +(defcustom gnus-startup-file "~/.newsrc" + "Your `.newsrc' file. +`.newsrc-SERVER' will be used instead if that exists." + :group 'gnus-start + :type 'file) + +(defcustom gnus-init-file "~/.gnus" + "Your Gnus elisp startup file. +If a file with the .el or .elc suffixes exist, it will be read +instead." + :group 'gnus-start + :type 'file) + +(defcustom gnus-site-init-file + (ignore-errors + (concat (file-name-directory + (directory-file-name installation-directory)) + "site-lisp/gnus-init")) + "The site-wide Gnus elisp startup file. +If a file with the .el or .elc suffixes exist, it will be read +instead." + :group 'gnus-start + :type 'file) + +(defcustom gnus-default-subscribed-newsgroups nil + "This variable lists what newsgroups should be subscribed the first time Gnus is used. +It should be a list of strings. +If it is `t', Gnus will not do anything special the first time it is +started; it'll just use the normal newsgroups subscription methods." + :group 'gnus-start + :type '(repeat string)) + +(defcustom gnus-use-dribble-file t + "*Non-nil means that Gnus will use a dribble file to store user updates. +If Emacs should crash without saving the .newsrc files, complete +information can be restored from the dribble file." + :group 'gnus-start + :type 'boolean) + +(defcustom gnus-dribble-directory nil + "*The directory where dribble files will be saved. +If this variable is nil, the directory where the .newsrc files are +saved will be used." + :group 'gnus-start + :type '(choice directory (const nil))) + +(defcustom gnus-check-new-newsgroups t + "*Non-nil means that Gnus will run gnus-find-new-newsgroups at startup. +This normally finds new newsgroups by comparing the active groups the +servers have already reported with those Gnus already knows, either alive +or killed. + +When any of the following are true, gnus-find-new-newsgroups will instead +ask the servers (primary, secondary, and archive servers) to list new +groups since the last time it checked: + 1. This variable is `ask-server'. + 2. This variable is a list of select methods (see below). + 3. `gnus-read-active-file' is nil or `some'. + 4. A prefix argument is given to gnus-find-new-newsgroups interactively. + +Thus, if this variable is `ask-server' or a list of select methods or +`gnus-read-active-file' is nil or `some', then the killed list is no +longer necessary, so you could safely set `gnus-save-killed-list' to nil. + +This variable can be a list of select methods which Gnus will query with +the `ask-server' method in addition to the primary, secondary, and archive +servers. + +Eg. + (setq gnus-check-new-newsgroups + '((nntp \"some.server\") (nntp \"other.server\"))) + +If this variable is nil, then you have to tell Gnus explicitly to +check for new newsgroups with \\\\[gnus-find-new-newsgroups]." + :group 'gnus-start + :type '(choice (const :tag "no" nil) + (const :tag "by brute force" t) + (const :tag "ask servers" ask-server) + (repeat :menu-tag "ask additional servers" + :tag "ask additional servers" + :value ((nntp "")) + (sexp :format "%v")))) + +(defcustom gnus-check-bogus-newsgroups nil + "*Non-nil means that Gnus will check and remove bogus newsgroup at startup. +If this variable is nil, then you have to tell Gnus explicitly to +check for bogus newsgroups with \\\\[gnus-group-check-bogus-groups]." + :group 'gnus-start + :type 'boolean) + +(defcustom gnus-read-active-file t + "*Non-nil means that Gnus will read the entire active file at startup. +If this variable is nil, Gnus will only know about the groups in your +`.newsrc' file. + +If this variable is `some', Gnus will try to only read the relevant +parts of the active file from the server. Not all servers support +this, and it might be quite slow with other servers, but this should +generally be faster than both the t and nil value. + +If you set this variable to nil or `some', you probably still want to +be told about new newsgroups that arrive. To do that, set +`gnus-check-new-newsgroups' to `ask-server'. This may not work +properly with all servers." + :group 'gnus-start + :type '(choice (const nil) + (const some) + (const t))) + +(defcustom gnus-level-subscribed 5 + "*Groups with levels less than or equal to this variable are subscribed." + :group 'gnus-start + :type 'integer) + +(defcustom gnus-level-unsubscribed 7 + "*Groups with levels less than or equal to this variable are unsubscribed. +Groups with levels less than `gnus-level-subscribed', which should be +less than this variable, are subscribed." + :group 'gnus-start + :type 'integer) + +(defcustom gnus-level-zombie 8 + "*Groups with this level are zombie groups." + :group 'gnus-start + :type 'integer) + +(defcustom gnus-level-killed 9 + "*Groups with this level are killed." + :group 'gnus-start + :type 'integer) + +(defcustom gnus-level-default-subscribed 3 + "*New subscribed groups will be subscribed at this level." + :group 'gnus-start + :type 'integer) + +(defcustom gnus-level-default-unsubscribed 6 + "*New unsubscribed groups will be unsubscribed at this level." + :group 'gnus-start + :type 'integer) + +(defcustom gnus-activate-level (1+ gnus-level-subscribed) + "*Groups higher than this level won't be activated on startup. +Setting this variable to something low might save lots of time when +you have many groups that you aren't interested in." + :group 'gnus-start + :type 'integer) + +(defcustom gnus-activate-foreign-newsgroups 4 + "*If nil, Gnus will not check foreign newsgroups at startup. +If it is non-nil, it should be a number between one and nine. Foreign +newsgroups that have a level lower or equal to this number will be +activated on startup. For instance, if you want to active all +subscribed newsgroups, but not the rest, you'd set this variable to +`gnus-level-subscribed'. + +If you subscribe to lots of newsgroups from different servers, startup +might take a while. By setting this variable to nil, you'll save time, +but you won't be told how many unread articles there are in the +groups." + :group 'gnus-start + :type 'integer) + +(defcustom gnus-save-newsrc-file t + "*Non-nil means that Gnus will save the `.newsrc' file. +Gnus always saves its own startup file, which is called +\".newsrc.eld\". The file called \".newsrc\" is in a format that can +be readily understood by other newsreaders. If you don't plan on +using other newsreaders, set this variable to nil to save some time on +exit." + :group 'gnus-start + :type 'boolean) + +(defcustom gnus-save-killed-list t + "*If non-nil, save the list of killed groups to the startup file. +If you set this variable to nil, you'll save both time (when starting +and quitting) and space (both memory and disk), but it will also mean +that Gnus has no record of which groups are new and which are old, so +the automatic new newsgroups subscription methods become meaningless. + +You should always set `gnus-check-new-newsgroups' to `ask-server' or +nil if you set this variable to nil. + +This variable can also be a regexp. In that case, all groups that do +not match this regexp will be removed before saving the list." + :group 'gnus-start + :type 'boolean) + +(defcustom gnus-ignored-newsgroups + (purecopy (mapconcat 'identity + '("^to\\." ; not "real" groups + "^[0-9. \t]+ " ; all digits in name + "[][\"#'()]" ; bogus characters + ) + "\\|")) + "A regexp to match uninteresting newsgroups in the active file. +Any lines in the active file matching this regular expression are +removed from the newsgroup list before anything else is done to it, +thus making them effectively non-existent." + :group 'gnus-start + :type 'regexp) + +(defcustom gnus-subscribe-newsgroup-method 'gnus-subscribe-zombies + "*Function called with a group name when new group is detected. +A few pre-made functions are supplied: `gnus-subscribe-randomly' +inserts new groups at the beginning of the list of groups; +`gnus-subscribe-alphabetically' inserts new groups in strict +alphabetic order; `gnus-subscribe-hierarchically' inserts new groups +in hierarchical newsgroup order; `gnus-subscribe-interactively' asks +for your decision; `gnus-subscribe-killed' kills all new groups; +`gnus-subscribe-zombies' will make all new groups into zombies." + :group 'gnus-start + :type '(radio (function-item gnus-subscribe-randomly) + (function-item gnus-subscribe-alphabetically) + (function-item gnus-subscribe-hierarchically) + (function-item gnus-subscribe-interactively) + (function-item gnus-subscribe-killed) + (function-item gnus-subscribe-zombies) + function)) + +;; Suggested by a bug report by Hallvard B Furuseth. +;; . +(defcustom gnus-subscribe-options-newsgroup-method + 'gnus-subscribe-alphabetically + "*This function is called to subscribe newsgroups mentioned on \"options -n\" lines. +If, for instance, you want to subscribe to all newsgroups in the +\"no\" and \"alt\" hierarchies, you'd put the following in your +.newsrc file: + +options -n no.all alt.all + +Gnus will the subscribe all new newsgroups in these hierarchies with +the subscription method in this variable." + :group 'gnus-start + :type '(radio (function-item gnus-subscribe-randomly) + (function-item gnus-subscribe-alphabetically) + (function-item gnus-subscribe-hierarchically) + (function-item gnus-subscribe-interactively) + (function-item gnus-subscribe-killed) + (function-item gnus-subscribe-zombies) + function)) + +(defcustom gnus-subscribe-hierarchical-interactive nil + "*If non-nil, Gnus will offer to subscribe hierarchically. +When a new hierarchy appears, Gnus will ask the user: + +'alt.binaries': Do you want to subscribe to this hierarchy? ([d]ys): + +If the user pressed `d', Gnus will descend the hierarchy, `y' will +subscribe to all newsgroups in the hierarchy and `s' will skip this +hierarchy in its entirety." + :group 'gnus-start + :type 'boolean) + +(defcustom gnus-auto-subscribed-groups + "^nnml\\|^nnfolder\\|^nnmbox\\|^nnmh\\|^nnbabyl" + "*All new groups that match this regexp will be subscribed automatically. +Note that this variable only deals with new groups. It has no effect +whatsoever on old groups. + +New groups that match this regexp will not be handled by +`gnus-subscribe-newsgroup-method'. Instead, they will +be subscribed using `gnus-subscribe-options-newsgroup-method'." + :group 'gnus-start + :type 'regexp) + +(defcustom gnus-options-subscribe nil + "*All new groups matching this regexp will be subscribed unconditionally. +Note that this variable deals only with new newsgroups. This variable +does not affect old newsgroups. + +New groups that match this regexp will not be handled by +`gnus-subscribe-newsgroup-method'. Instead, they will +be subscribed using `gnus-subscribe-options-newsgroup-method'." + :group 'gnus-start + :type '(choice regexp + (const :tag "none" nil))) + +(defcustom gnus-options-not-subscribe nil + "*All new groups matching this regexp will be ignored. +Note that this variable deals only with new newsgroups. This variable +does not affect old (already subscribed) newsgroups." + :group 'gnus-start + :type '(choice regexp + (const :tag "none" nil))) + +(defcustom gnus-modtime-botch nil + "*Non-nil means .newsrc should be deleted prior to save. +Its use is due to the bogus appearance that .newsrc was modified on +disc." + :group 'gnus-start + :type 'boolean) + +(defcustom gnus-check-bogus-groups-hook nil + "A hook run after removing bogus groups." + :group 'gnus-start + :type 'hook) + +(defcustom gnus-startup-hook nil + "A hook called at startup. +This hook is called after Gnus is connected to the NNTP server." + :group 'gnus-start + :type 'hook) + +(defcustom gnus-get-new-news-hook nil + "A hook run just before Gnus checks for new news." + :group 'gnus-start + :type 'hook) + +(defcustom gnus-after-getting-new-news-hook + (when (gnus-boundp 'display-time-timer) + '(display-time-event-handler)) + "A hook run after Gnus checks for new news." + :group 'gnus-start + :type 'hook) + +(defcustom gnus-save-newsrc-hook nil + "A hook called before saving any of the newsrc files." + :group 'gnus-start + :type 'hook) + +(defcustom gnus-save-quick-newsrc-hook nil + "A hook called just before saving the quick newsrc file. +Can be used to turn version control on or off." + :group 'gnus-start + :type 'hook) + +(defcustom gnus-save-standard-newsrc-hook nil + "A hook called just before saving the standard newsrc file. +Can be used to turn version control on or off." + :group 'gnus-start + :type 'hook) + +;;; Internal variables + +(defvar gnus-newsrc-file-version nil) +(defvar gnus-override-subscribe-method nil) +(defvar gnus-dribble-buffer nil) +(defvar gnus-newsrc-options nil + "Options line in the .newsrc file.") + +(defvar gnus-newsrc-options-n nil + "List of regexps representing groups to be subscribed/ignored unconditionally.") + +(defvar gnus-newsrc-last-checked-date nil + "Date Gnus last asked server for new newsgroups.") + +(defvar gnus-current-startup-file nil + "Startup file for the current host.") + +;; Byte-compiler warning. +(defvar gnus-group-line-format) + +;; Suggested by Brian Edmonds . +(defvar gnus-init-inhibit nil) +(defun gnus-read-init-file (&optional inhibit-next) + ;; Don't load .gnus if -q option was used. + (when init-file-user + (if gnus-init-inhibit + (setq gnus-init-inhibit nil) + (setq gnus-init-inhibit inhibit-next) + (let ((files (list gnus-site-init-file gnus-init-file)) + file) + (while files + (and (setq file (pop files)) + (or (and (file-exists-p file) + ;; Don't try to load a directory. + (not (file-directory-p file))) + (file-exists-p (concat file ".el")) + (file-exists-p (concat file ".elc"))) + (condition-case var + (load file nil t) + (error + (error "Error in %s: %s" file var))))))))) + +;; For subscribing new newsgroup + +(defun gnus-subscribe-hierarchical-interactive (groups) + (let ((groups (sort groups 'string<)) + prefixes prefix start ans group starts) + (while groups + (setq prefixes (list "^")) + (while (and groups prefixes) + (while (not (string-match (car prefixes) (car groups))) + (setq prefixes (cdr prefixes))) + (setq prefix (car prefixes)) + (setq start (1- (length prefix))) + (if (and (string-match "[^\\.]\\." (car groups) start) + (cdr groups) + (setq prefix + (concat "^" (substring (car groups) 0 (match-end 0)))) + (string-match prefix (cadr groups))) + (progn + (push prefix prefixes) + (message "Descend hierarchy %s? ([y]nsq): " + (substring prefix 1 (1- (length prefix)))) + (while (not (memq (setq ans (read-char)) '(?y ?\n ?\r ?n ?s ?q))) + (ding) + (message "Descend hierarchy %s? ([y]nsq): " + (substring prefix 1 (1- (length prefix))))) + (cond ((= ans ?n) + (while (and groups + (string-match prefix + (setq group (car groups)))) + (push group gnus-killed-list) + (gnus-sethash group group gnus-killed-hashtb) + (setq groups (cdr groups))) + (setq starts (cdr starts))) + ((= ans ?s) + (while (and groups + (string-match prefix + (setq group (car groups)))) + (gnus-sethash group group gnus-killed-hashtb) + (gnus-subscribe-alphabetically (car groups)) + (setq groups (cdr groups))) + (setq starts (cdr starts))) + ((= ans ?q) + (while groups + (setq group (car groups)) + (push group gnus-killed-list) + (gnus-sethash group group gnus-killed-hashtb) + (setq groups (cdr groups)))) + (t nil))) + (message "Subscribe %s? ([n]yq)" (car groups)) + (while (not (memq (setq ans (read-char)) '(?y ?\n ?\r ?q ?n))) + (ding) + (message "Subscribe %s? ([n]yq)" (car groups))) + (setq group (car groups)) + (cond ((= ans ?y) + (gnus-subscribe-alphabetically (car groups)) + (gnus-sethash group group gnus-killed-hashtb)) + ((= ans ?q) + (while groups + (setq group (car groups)) + (push group gnus-killed-list) + (gnus-sethash group group gnus-killed-hashtb) + (setq groups (cdr groups)))) + (t + (push group gnus-killed-list) + (gnus-sethash group group gnus-killed-hashtb))) + (setq groups (cdr groups))))))) + +(defun gnus-subscribe-randomly (newsgroup) + "Subscribe new NEWSGROUP by making it the first newsgroup." + (gnus-subscribe-newsgroup newsgroup)) + +(defun gnus-subscribe-alphabetically (newgroup) + "Subscribe new NEWSGROUP and insert it in alphabetical order." + (let ((groups (cdr gnus-newsrc-alist)) + before) + (while (and (not before) groups) + (if (string< newgroup (caar groups)) + (setq before (caar groups)) + (setq groups (cdr groups)))) + (gnus-subscribe-newsgroup newgroup before))) + +(defun gnus-subscribe-hierarchically (newgroup) + "Subscribe new NEWSGROUP and insert it in hierarchical newsgroup order." + ;; Basic ideas by mike-w@cs.aukuni.ac.nz (Mike Williams) + (save-excursion + (set-buffer (nnheader-find-file-noselect gnus-current-startup-file)) + (let ((groupkey newgroup) + before) + (while (and (not before) groupkey) + (goto-char (point-min)) + (let ((groupkey-re + (concat "^\\(" (regexp-quote groupkey) ".*\\)[!:]"))) + (while (and (re-search-forward groupkey-re nil t) + (progn + (setq before (match-string 1)) + (string< before newgroup))))) + ;; Remove tail of newsgroup name (eg. a.b.c -> a.b) + (setq groupkey + (when (string-match "^\\(.*\\)\\.[^.]+$" groupkey) + (substring groupkey (match-beginning 1) (match-end 1))))) + (gnus-subscribe-newsgroup newgroup before)) + (kill-buffer (current-buffer)))) + +(defun gnus-subscribe-interactively (group) + "Subscribe the new GROUP interactively. +It is inserted in hierarchical newsgroup order if subscribed. If not, +it is killed." + (if (gnus-y-or-n-p (format "Subscribe new newsgroup: %s " group)) + (gnus-subscribe-hierarchically group) + (push group gnus-killed-list))) + +(defun gnus-subscribe-zombies (group) + "Make the new GROUP into a zombie group." + (push group gnus-zombie-list)) + +(defun gnus-subscribe-killed (group) + "Make the new GROUP a killed group." + (push group gnus-killed-list)) + +(defun gnus-subscribe-newsgroup (newsgroup &optional next) + "Subscribe new NEWSGROUP. +If NEXT is non-nil, it is inserted before NEXT. Otherwise it is made +the first newsgroup." + (save-excursion + (goto-char (point-min)) + ;; We subscribe the group by changing its level to `subscribed'. + (gnus-group-change-level + newsgroup gnus-level-default-subscribed + gnus-level-killed (gnus-gethash (or next "dummy.group") + gnus-newsrc-hashtb)) + (gnus-message 5 "Subscribe newsgroup: %s" newsgroup))) + +(defun gnus-read-active-file-p () + "Say whether the active file has been read from `gnus-select-method'." + (memq gnus-select-method gnus-have-read-active-file)) + +;;; General various misc type functions. + +;; Silence byte-compiler. +(defvar gnus-current-headers) +(defvar gnus-thread-indent-array) +(defvar gnus-newsgroup-name) +(defvar gnus-newsgroup-headers) +(defvar gnus-group-list-mode) +(defvar gnus-group-mark-positions) +(defvar gnus-newsgroup-data) +(defvar gnus-newsgroup-unreads) +(defvar nnoo-state-alist) +(defvar gnus-current-select-method) +(defun gnus-clear-system () + "Clear all variables and buffers." + ;; Clear Gnus variables. + (let ((variables gnus-variable-list)) + (while variables + (set (car variables) nil) + (setq variables (cdr variables)))) + ;; Clear other internal variables. + (setq gnus-list-of-killed-groups nil + gnus-have-read-active-file nil + gnus-newsrc-alist nil + gnus-newsrc-hashtb nil + gnus-killed-list nil + gnus-zombie-list nil + gnus-killed-hashtb nil + gnus-active-hashtb nil + gnus-moderated-hashtb nil + gnus-description-hashtb nil + gnus-current-headers nil + gnus-thread-indent-array nil + gnus-newsgroup-headers nil + gnus-newsgroup-name nil + gnus-server-alist nil + gnus-group-list-mode nil + gnus-opened-servers nil + gnus-group-mark-positions nil + gnus-newsgroup-data nil + gnus-newsgroup-unreads nil + nnoo-state-alist nil + gnus-current-select-method nil) + (gnus-shutdown 'gnus) + ;; Kill the startup file. + (and gnus-current-startup-file + (get-file-buffer gnus-current-startup-file) + (kill-buffer (get-file-buffer gnus-current-startup-file))) + ;; Clear the dribble buffer. + (gnus-dribble-clear) + ;; Kill global KILL file buffer. + (when (get-file-buffer (gnus-newsgroup-kill-file nil)) + (kill-buffer (get-file-buffer (gnus-newsgroup-kill-file nil)))) + (gnus-kill-buffer nntp-server-buffer) + ;; Kill Gnus buffers. + (while gnus-buffer-list + (gnus-kill-buffer (pop gnus-buffer-list))) + ;; Remove Gnus frames. + (gnus-kill-gnus-frames)) + +(defun gnus-no-server-1 (&optional arg slave) + "Read network news. +If ARG is a positive number, Gnus will use that as the +startup level. If ARG is nil, Gnus will be started at level 2. +If ARG is non-nil and not a positive number, Gnus will +prompt the user for the name of an NNTP server to use. +As opposed to `gnus', this command will not connect to the local server." + (interactive "P") + (let ((val (or arg (1- gnus-level-default-subscribed)))) + (gnus val t slave) + (make-local-variable 'gnus-group-use-permanent-levels) + (setq gnus-group-use-permanent-levels val))) + +(defun gnus-1 (&optional arg dont-connect slave) + "Read network news. +If ARG is non-nil and a positive number, Gnus will use that as the +startup level. If ARG is non-nil and not a positive number, Gnus will +prompt the user for the name of an NNTP server to use." + (interactive "P") + + (if (and (get-buffer gnus-group-buffer) + (save-excursion + (set-buffer gnus-group-buffer) + (eq major-mode 'gnus-group-mode))) + (progn + (switch-to-buffer gnus-group-buffer) + (gnus-group-get-new-news)) + + (gnus-splash) + (gnus-clear-system) + (nnheader-init-server-buffer) + (gnus-read-init-file) + (setq gnus-slave slave) + + (when (and (string-match "XEmacs" (emacs-version)) + gnus-simple-splash) + (setq gnus-simple-splash nil) + (gnus-xmas-splash)) + + (let ((level (and (numberp arg) (> arg 0) arg)) + did-connect) + (unwind-protect + (progn + (unless dont-connect + (setq did-connect + (gnus-start-news-server (and arg (not level)))))) + (if (and (not dont-connect) + (not did-connect)) + (gnus-group-quit) + (run-hooks 'gnus-startup-hook) + ;; NNTP server is successfully open. + + ;; Find the current startup file name. + (setq gnus-current-startup-file + (gnus-make-newsrc-file gnus-startup-file)) + + ;; Read the dribble file. + (when (or gnus-slave gnus-use-dribble-file) + (gnus-dribble-read-file)) + + ;; Allow using GroupLens predictions. + (when gnus-use-grouplens + (bbb-login) + (add-hook 'gnus-summary-mode-hook 'gnus-grouplens-mode)) + + ;; Do the actual startup. + (gnus-setup-news nil level dont-connect) + ;; Generate the group buffer. + (gnus-group-list-groups level) + (gnus-group-first-unread-group) + (gnus-configure-windows 'group) + (gnus-group-set-mode-line)))))) + +;;;###autoload +(defun gnus-unload () + "Unload all Gnus features." + (interactive) + (unless (boundp 'load-history) + (error "Sorry, `gnus-unload' is not implemented in this Emacs version.")) + (let ((history load-history) + feature) + (while history + (and (string-match "^\\(gnus\\|nn\\)" (caar history)) + (setq feature (cdr (assq 'provide (car history)))) + (unload-feature feature 'force)) + (setq history (cdr history))))) + + +;;; +;;; Dribble file +;;; + +(defvar gnus-dribble-ignore nil) +(defvar gnus-dribble-eval-file nil) + +(defun gnus-dribble-file-name () + "Return the dribble file for the current .newsrc." + (concat + (if gnus-dribble-directory + (concat (file-name-as-directory gnus-dribble-directory) + (file-name-nondirectory gnus-current-startup-file)) + gnus-current-startup-file) + "-dribble")) + +(defun gnus-dribble-enter (string) + "Enter STRING into the dribble buffer." + (when (and (not gnus-dribble-ignore) + gnus-dribble-buffer + (buffer-name gnus-dribble-buffer)) + (let ((obuf (current-buffer))) + (set-buffer gnus-dribble-buffer) + (goto-char (point-max)) + (insert string "\n") + (set-window-point (get-buffer-window (current-buffer)) (point-max)) + (bury-buffer gnus-dribble-buffer) + (set-buffer obuf)))) + +(defun gnus-dribble-touch () + "Touch the dribble buffer." + (gnus-dribble-enter "")) + +(defun gnus-dribble-read-file () + "Read the dribble file from disk." + (let ((dribble-file (gnus-dribble-file-name))) + (save-excursion + (set-buffer (setq gnus-dribble-buffer + (get-buffer-create + (file-name-nondirectory dribble-file)))) + (gnus-add-current-to-buffer-list) + (erase-buffer) + (setq buffer-file-name dribble-file) + (auto-save-mode t) + (buffer-disable-undo (current-buffer)) + (bury-buffer (current-buffer)) + (set-buffer-modified-p nil) + (let ((auto (make-auto-save-file-name)) + (gnus-dribble-ignore t) + modes) + (when (or (file-exists-p auto) (file-exists-p dribble-file)) + ;; Load whichever file is newest -- the auto save file + ;; or the "real" file. + (if (file-newer-than-file-p auto dribble-file) + (nnheader-insert-file-contents auto) + (nnheader-insert-file-contents dribble-file)) + (unless (zerop (buffer-size)) + (set-buffer-modified-p t)) + ;; Set the file modes to reflect the .newsrc file modes. + (save-buffer) + (when (and (file-exists-p gnus-current-startup-file) + (setq modes (file-modes gnus-current-startup-file))) + (set-file-modes dribble-file modes)) + ;; Possibly eval the file later. + (when (gnus-y-or-n-p + "Auto-save file exists. Do you want to read it? ") + (setq gnus-dribble-eval-file t))))))) + +(defun gnus-dribble-eval-file () + (when gnus-dribble-eval-file + (setq gnus-dribble-eval-file nil) + (save-excursion + (let ((gnus-dribble-ignore t)) + (set-buffer gnus-dribble-buffer) + (eval-buffer (current-buffer)))))) + +(defun gnus-dribble-delete-file () + (when (file-exists-p (gnus-dribble-file-name)) + (delete-file (gnus-dribble-file-name))) + (when gnus-dribble-buffer + (save-excursion + (set-buffer gnus-dribble-buffer) + (let ((auto (make-auto-save-file-name))) + (when (file-exists-p auto) + (delete-file auto)) + (erase-buffer) + (set-buffer-modified-p nil))))) + +(defun gnus-dribble-save () + (when (and gnus-dribble-buffer + (buffer-name gnus-dribble-buffer)) + (save-excursion + (set-buffer gnus-dribble-buffer) + (save-buffer)))) + +(defun gnus-dribble-clear () + (when (gnus-buffer-exists-p gnus-dribble-buffer) + (save-excursion + (set-buffer gnus-dribble-buffer) + (erase-buffer) + (set-buffer-modified-p nil) + (setq buffer-saved-size (buffer-size))))) + + +;;; +;;; Active & Newsrc File Handling +;;; + +(defun gnus-setup-news (&optional rawfile level dont-connect) + "Setup news information. +If RAWFILE is non-nil, the .newsrc file will also be read. +If LEVEL is non-nil, the news will be set up at level LEVEL." + (let ((init (not (and gnus-newsrc-alist gnus-active-hashtb (not rawfile))))) + + (when init + ;; Clear some variables to re-initialize news information. + (setq gnus-newsrc-alist nil + gnus-active-hashtb nil) + ;; Read the newsrc file and create `gnus-newsrc-hashtb'. + (gnus-read-newsrc-file rawfile)) + + (when (and (not (assoc "archive" gnus-server-alist)) + (gnus-archive-server-wanted-p)) + (push (cons "archive" gnus-message-archive-method) + gnus-server-alist)) + + ;; If we don't read the complete active file, we fill in the + ;; hashtb here. + (when (or (null gnus-read-active-file) + (eq gnus-read-active-file 'some)) + (gnus-update-active-hashtb-from-killed)) + + ;; Read the active file and create `gnus-active-hashtb'. + ;; If `gnus-read-active-file' is nil, then we just create an empty + ;; hash table. The partial filling out of the hash table will be + ;; done in `gnus-get-unread-articles'. + (and gnus-read-active-file + (not level) + (gnus-read-active-file)) + + (unless gnus-active-hashtb + (setq gnus-active-hashtb (gnus-make-hashtable 4096))) + + ;; Initialize the cache. + (when gnus-use-cache + (gnus-cache-open)) + + ;; Possibly eval the dribble file. + (and init + (or gnus-use-dribble-file gnus-slave) + (gnus-dribble-eval-file)) + + ;; Slave Gnusii should then clear the dribble buffer. + (when (and init gnus-slave) + (gnus-dribble-clear)) + + (gnus-update-format-specifications) + + ;; See whether we need to read the description file. + (when (and (boundp 'gnus-group-line-format) + (string-match "%[-,0-9]*D" gnus-group-line-format) + (not gnus-description-hashtb) + (not dont-connect) + gnus-read-active-file) + (gnus-read-all-descriptions-files)) + + ;; Find new newsgroups and treat them. + (when (and init gnus-check-new-newsgroups (not level) + (gnus-check-server gnus-select-method) + (not gnus-slave)) + (gnus-find-new-newsgroups)) + + ;; We might read in new NoCeM messages here. + (when (and gnus-use-nocem + (not level) + (not dont-connect)) + (gnus-nocem-scan-groups)) + + ;; Read any slave files. + (gnus-master-read-slave-newsrc) + + ;; Find the number of unread articles in each non-dead group. + (let ((gnus-read-active-file (and (not level) gnus-read-active-file))) + (gnus-get-unread-articles level)) + + (when (and init gnus-check-bogus-newsgroups + gnus-read-active-file (not level) + (gnus-server-opened gnus-select-method)) + (gnus-check-bogus-newsgroups)))) + +(defun gnus-find-new-newsgroups (&optional arg) + "Search for new newsgroups and add them. +Each new newsgroup will be treated with `gnus-subscribe-newsgroup-method.' +The `-n' option line from .newsrc is respected. +If ARG (the prefix), use the `ask-server' method to query +the server for new groups." + (interactive "P") + (let ((check (if (or (and arg (not (listp gnus-check-new-newsgroups))) + (null gnus-read-active-file) + (eq gnus-read-active-file 'some)) + 'ask-server gnus-check-new-newsgroups))) + (unless (gnus-check-first-time-used) + (if (or (consp check) + (eq check 'ask-server)) + ;; Ask the server for new groups. + (gnus-ask-server-for-new-groups) + ;; Go through the active hashtb and look for new groups. + (let ((groups 0) + group new-newsgroups) + (gnus-message 5 "Looking for new newsgroups...") + (unless gnus-have-read-active-file + (gnus-read-active-file)) + (setq gnus-newsrc-last-checked-date (current-time-string)) + (unless gnus-killed-hashtb + (gnus-make-hashtable-from-killed)) + ;; Go though every newsgroup in `gnus-active-hashtb' and compare + ;; with `gnus-newsrc-hashtb' and `gnus-killed-hashtb'. + (mapatoms + (lambda (sym) + (if (or (null (setq group (symbol-name sym))) + (not (boundp sym)) + (null (symbol-value sym)) + (gnus-gethash group gnus-killed-hashtb) + (gnus-gethash group gnus-newsrc-hashtb)) + () + (let ((do-sub (gnus-matches-options-n group))) + (cond + ((eq do-sub 'subscribe) + (setq groups (1+ groups)) + (gnus-sethash group group gnus-killed-hashtb) + (funcall gnus-subscribe-options-newsgroup-method group)) + ((eq do-sub 'ignore) + nil) + (t + (setq groups (1+ groups)) + (gnus-sethash group group gnus-killed-hashtb) + (if gnus-subscribe-hierarchical-interactive + (push group new-newsgroups) + (funcall gnus-subscribe-newsgroup-method group))))))) + gnus-active-hashtb) + (when new-newsgroups + (gnus-subscribe-hierarchical-interactive new-newsgroups)) + ;; Suggested by Per Abrahamsen . + (if (> groups 0) + (gnus-message 5 "%d new newsgroup%s arrived." + groups (if (> groups 1) "s have" " has")) + (gnus-message 5 "No new newsgroups."))))))) + +(defun gnus-matches-options-n (group) + ;; Returns `subscribe' if the group is to be unconditionally + ;; subscribed, `ignore' if it is to be ignored, and nil if there is + ;; no match for the group. + + ;; First we check the two user variables. + (cond + ((and gnus-options-subscribe + (string-match gnus-options-subscribe group)) + 'subscribe) + ((and gnus-auto-subscribed-groups + (string-match gnus-auto-subscribed-groups group)) + 'subscribe) + ((and gnus-options-not-subscribe + (string-match gnus-options-not-subscribe group)) + 'ignore) + ;; Then we go through the list that was retrieved from the .newsrc + ;; file. This list has elements on the form + ;; `(REGEXP . {ignore,subscribe})'. The first match found (the list + ;; is in the reverse order of the options line) is returned. + (t + (let ((regs gnus-newsrc-options-n)) + (while (and regs + (not (string-match (caar regs) group))) + (setq regs (cdr regs))) + (and regs (cdar regs)))))) + +(defun gnus-ask-server-for-new-groups () + (let* ((date (or gnus-newsrc-last-checked-date (current-time-string))) + (methods (cons gnus-select-method + (nconc + (when (gnus-archive-server-wanted-p) + (list "archive")) + (append + (and (consp gnus-check-new-newsgroups) + gnus-check-new-newsgroups) + gnus-secondary-select-methods)))) + (groups 0) + (new-date (current-time-string)) + group new-newsgroups got-new method hashtb + gnus-override-subscribe-method) + ;; Go through both primary and secondary select methods and + ;; request new newsgroups. + (while (setq method (gnus-server-get-method nil (pop methods))) + (setq new-newsgroups nil) + (setq gnus-override-subscribe-method method) + (when (and (gnus-check-server method) + (gnus-request-newgroups date method)) + (save-excursion + (setq got-new t) + (setq hashtb (gnus-make-hashtable 100)) + (set-buffer nntp-server-buffer) + ;; Enter all the new groups into a hashtable. + (gnus-active-to-gnus-format method hashtb 'ignore)) + ;; Now all new groups from `method' are in `hashtb'. + (mapatoms + (lambda (group-sym) + (if (or (null (setq group (symbol-name group-sym))) + (not (boundp group-sym)) + (null (symbol-value group-sym)) + (gnus-gethash group gnus-newsrc-hashtb) + (member group gnus-zombie-list) + (member group gnus-killed-list)) + ;; The group is already known. + () + ;; Make this group active. + (when (symbol-value group-sym) + (gnus-set-active group (symbol-value group-sym))) + ;; Check whether we want it or not. + (let ((do-sub (gnus-matches-options-n group))) + (cond + ((eq do-sub 'subscribe) + (incf groups) + (gnus-sethash group group gnus-killed-hashtb) + (funcall gnus-subscribe-options-newsgroup-method group)) + ((eq do-sub 'ignore) + nil) + (t + (incf groups) + (gnus-sethash group group gnus-killed-hashtb) + (if gnus-subscribe-hierarchical-interactive + (push group new-newsgroups) + (funcall gnus-subscribe-newsgroup-method group))))))) + hashtb)) + (when new-newsgroups + (gnus-subscribe-hierarchical-interactive new-newsgroups))) + ;; Suggested by Per Abrahamsen . + (when (> groups 0) + (gnus-message 6 "%d new newsgroup%s arrived." + groups (if (> groups 1) "s have" " has"))) + (when got-new + (setq gnus-newsrc-last-checked-date new-date)) + got-new)) + +(defun gnus-check-first-time-used () + (if (or (> (length gnus-newsrc-alist) 1) + (file-exists-p gnus-startup-file) + (file-exists-p (concat gnus-startup-file ".el")) + (file-exists-p (concat gnus-startup-file ".eld"))) + nil + (gnus-message 6 "First time user; subscribing you to default groups") + (unless (gnus-read-active-file-p) + (gnus-read-active-file)) + (setq gnus-newsrc-last-checked-date (current-time-string)) + (let ((groups gnus-default-subscribed-newsgroups) + group) + (if (eq groups t) + nil + (setq groups (or groups gnus-backup-default-subscribed-newsgroups)) + (mapatoms + (lambda (sym) + (if (null (setq group (symbol-name sym))) + () + (let ((do-sub (gnus-matches-options-n group))) + (cond + ((eq do-sub 'subscribe) + (gnus-sethash group group gnus-killed-hashtb) + (funcall gnus-subscribe-options-newsgroup-method group)) + ((eq do-sub 'ignore) + nil) + (t + (push group gnus-killed-list)))))) + gnus-active-hashtb) + (while groups + (when (gnus-active (car groups)) + (gnus-group-change-level + (car groups) gnus-level-default-subscribed gnus-level-killed)) + (setq groups (cdr groups))) + (gnus-group-make-help-group) + (when gnus-novice-user + (gnus-message 7 "`A k' to list killed groups")))))) + +(defun gnus-subscribe-group (group previous &optional method) + (gnus-group-change-level + (if method + (list t group gnus-level-default-subscribed nil nil method) + group) + gnus-level-default-subscribed gnus-level-killed previous t)) + +;; `gnus-group-change-level' is the fundamental function for changing +;; subscription levels of newsgroups. This might mean just changing +;; from level 1 to 2, which is pretty trivial, from 2 to 6 or back +;; again, which subscribes/unsubscribes a group, which is equally +;; trivial. Changing from 1-7 to 8-9 means that you kill a group, and +;; from 8-9 to 1-7 means that you remove the group from the list of +;; killed (or zombie) groups and add them to the (kinda) subscribed +;; groups. And last but not least, moving from 8 to 9 and 9 to 8, +;; which is trivial. +;; ENTRY can either be a string (newsgroup name) or a list (if +;; FROMKILLED is t, it's a list on the format (NUM INFO-LIST), +;; otherwise it's a list in the format of the `gnus-newsrc-hashtb' +;; entries. +;; LEVEL is the new level of the group, OLDLEVEL is the old level and +;; PREVIOUS is the group (in hashtb entry format) to insert this group +;; after. +(defun gnus-group-change-level (entry level &optional oldlevel + previous fromkilled) + (let (group info active num) + ;; Glean what info we can from the arguments + (if (consp entry) + (if fromkilled (setq group (nth 1 entry)) + (setq group (car (nth 2 entry)))) + (setq group entry)) + (when (and (stringp entry) + oldlevel + (< oldlevel gnus-level-zombie)) + (setq entry (gnus-gethash entry gnus-newsrc-hashtb))) + (if (and (not oldlevel) + (consp entry)) + (setq oldlevel (gnus-info-level (nth 2 entry))) + (setq oldlevel (or oldlevel 9))) + (when (stringp previous) + (setq previous (gnus-gethash previous gnus-newsrc-hashtb))) + + (if (and (>= oldlevel gnus-level-zombie) + (gnus-gethash group gnus-newsrc-hashtb)) + ;; We are trying to subscribe a group that is already + ;; subscribed. + () ; Do nothing. + + (unless (gnus-ephemeral-group-p group) + (gnus-dribble-enter + (format "(gnus-group-change-level %S %S %S %S %S)" + group level oldlevel (car (nth 2 previous)) fromkilled))) + + ;; Then we remove the newgroup from any old structures, if needed. + ;; If the group was killed, we remove it from the killed or zombie + ;; list. If not, and it is in fact going to be killed, we remove + ;; it from the newsrc hash table and assoc. + (cond + ((>= oldlevel gnus-level-zombie) + (if (= oldlevel gnus-level-zombie) + (setq gnus-zombie-list (delete group gnus-zombie-list)) + (setq gnus-killed-list (delete group gnus-killed-list)))) + (t + (when (and (>= level gnus-level-zombie) + entry) + (gnus-sethash (car (nth 2 entry)) nil gnus-newsrc-hashtb) + (when (nth 3 entry) + (setcdr (gnus-gethash (car (nth 3 entry)) + gnus-newsrc-hashtb) + (cdr entry))) + (setcdr (cdr entry) (cdddr entry))))) + + ;; Finally we enter (if needed) the list where it is supposed to + ;; go, and change the subscription level. If it is to be killed, + ;; we enter it into the killed or zombie list. + (cond + ((>= level gnus-level-zombie) + ;; Remove from the hash table. + (gnus-sethash group nil gnus-newsrc-hashtb) + ;; We do not enter foreign groups into the list of dead + ;; groups. + (unless (gnus-group-foreign-p group) + (if (= level gnus-level-zombie) + (push group gnus-zombie-list) + (push group gnus-killed-list)))) + (t + ;; If the list is to be entered into the newsrc assoc, and + ;; it was killed, we have to create an entry in the newsrc + ;; hashtb format and fix the pointers in the newsrc assoc. + (if (< oldlevel gnus-level-zombie) + ;; It was alive, and it is going to stay alive, so we + ;; just change the level and don't change any pointers or + ;; hash table entries. + (setcar (cdaddr entry) level) + (if (listp entry) + (setq info (cdr entry) + num (car entry)) + (setq active (gnus-active group)) + (setq num + (if active (- (1+ (cdr active)) (car active)) t)) + ;; Check whether the group is foreign. If so, the + ;; foreign select method has to be entered into the + ;; info. + (let ((method (or gnus-override-subscribe-method + (gnus-group-method group)))) + (if (eq method gnus-select-method) + (setq info (list group level nil)) + (setq info (list group level nil nil method))))) + (unless previous + (setq previous + (let ((p gnus-newsrc-alist)) + (while (cddr p) + (setq p (cdr p))) + p))) + (setq entry (cons info (cddr previous))) + (if (cdr previous) + (progn + (setcdr (cdr previous) entry) + (gnus-sethash group (cons num (cdr previous)) + gnus-newsrc-hashtb)) + (setcdr previous entry) + (gnus-sethash group (cons num previous) + gnus-newsrc-hashtb)) + (when (cdr entry) + (setcdr (gnus-gethash (caadr entry) gnus-newsrc-hashtb) entry)) + (gnus-dribble-enter + (format + "(gnus-group-set-info '%S)" info))))) + (when gnus-group-change-level-function + (funcall gnus-group-change-level-function group level oldlevel))))) + +(defun gnus-kill-newsgroup (newsgroup) + "Obsolete function. Kills a newsgroup." + (gnus-group-change-level + (gnus-gethash newsgroup gnus-newsrc-hashtb) gnus-level-killed)) + +(defun gnus-check-bogus-newsgroups (&optional confirm) + "Remove bogus newsgroups. +If CONFIRM is non-nil, the user has to confirm the deletion of every +newsgroup." + (let ((newsrc (cdr gnus-newsrc-alist)) + bogus group entry info) + (gnus-message 5 "Checking bogus newsgroups...") + (unless (gnus-read-active-file-p) + (gnus-read-active-file)) + (when (gnus-read-active-file-p) + ;; Find all bogus newsgroup that are subscribed. + (while newsrc + (setq info (pop newsrc) + group (gnus-info-group info)) + (unless (or (gnus-active group) ; Active + (gnus-info-method info)) ; Foreign + ;; Found a bogus newsgroup. + (push group bogus))) + (if confirm + (map-y-or-n-p + "Remove bogus group %s? " + (lambda (group) + ;; Remove all bogus subscribed groups by first killing them, and + ;; then removing them from the list of killed groups. + (when (setq entry (gnus-gethash group gnus-newsrc-hashtb)) + (gnus-group-change-level entry gnus-level-killed) + (setq gnus-killed-list (delete group gnus-killed-list)))) + bogus) + (while (setq group (pop bogus)) + ;; Remove all bogus subscribed groups by first killing them, and + ;; then removing them from the list of killed groups. + (when (setq entry (gnus-gethash group gnus-newsrc-hashtb)) + (gnus-group-change-level entry gnus-level-killed) + (setq gnus-killed-list (delete group gnus-killed-list))))) + ;; Then we remove all bogus groups from the list of killed and + ;; zombie groups. They are removed without confirmation. + (let ((dead-lists '(gnus-killed-list gnus-zombie-list)) + killed) + (while dead-lists + (setq killed (symbol-value (car dead-lists))) + (while killed + (unless (gnus-active (setq group (pop killed))) + ;; The group is bogus. + ;; !!!Slow as hell. + (set (car dead-lists) + (delete group (symbol-value (car dead-lists)))))) + (setq dead-lists (cdr dead-lists)))) + (run-hooks 'gnus-check-bogus-groups-hook) + (gnus-message 5 "Checking bogus newsgroups...done")))) + +(defun gnus-check-duplicate-killed-groups () + "Remove duplicates from the list of killed groups." + (interactive) + (let ((killed gnus-killed-list)) + (while killed + (gnus-message 9 "%d" (length killed)) + (setcdr killed (delete (car killed) (cdr killed))) + (setq killed (cdr killed))))) + +;; We want to inline a function from gnus-cache, so we cheat here: +(eval-when-compile + (defvar gnus-cache-active-hashtb) + (defun gnus-cache-possibly-alter-active (group active) + "Alter the ACTIVE info for GROUP to reflect the articles in the cache." + (when gnus-cache-active-hashtb + (let ((cache-active (gnus-gethash group gnus-cache-active-hashtb))) + (and cache-active + (< (car cache-active) (car active)) + (setcar active (car cache-active))) + (and cache-active + (> (cdr cache-active) (cdr active)) + (setcdr active (cdr cache-active))))))) + +(defun gnus-get-unread-articles-in-group (info active &optional update) + (when active + ;; Allow the backend to update the info in the group. + (when (and update + (gnus-request-update-info + info (gnus-find-method-for-group (gnus-info-group info)))) + (gnus-activate-group (gnus-info-group info) nil t)) + (let* ((range (gnus-info-read info)) + (num 0)) + ;; If a cache is present, we may have to alter the active info. + (when (and gnus-use-cache info) + (inline (gnus-cache-possibly-alter-active + (gnus-info-group info) active))) + ;; Modify the list of read articles according to what articles + ;; are available; then tally the unread articles and add the + ;; number to the group hash table entry. + (cond + ((zerop (cdr active)) + (setq num 0)) + ((not range) + (setq num (- (1+ (cdr active)) (car active)))) + ((not (listp (cdr range))) + ;; Fix a single (num . num) range according to the + ;; active hash table. + ;; Fix by Carsten Bormann . + (and (< (cdr range) (car active)) (setcdr range (1- (car active)))) + (and (> (cdr range) (cdr active)) (setcdr range (cdr active))) + ;; Compute number of unread articles. + (setq num (max 0 (- (cdr active) (- (1+ (cdr range)) (car range)))))) + (t + ;; The read list is a list of ranges. Fix them according to + ;; the active hash table. + ;; First peel off any elements that are below the lower + ;; active limit. + (while (and (cdr range) + (>= (car active) + (or (and (atom (cadr range)) (cadr range)) + (caadr range)))) + (if (numberp (car range)) + (setcar range + (cons (car range) + (or (and (numberp (cadr range)) + (cadr range)) + (cdadr range)))) + (setcdr (car range) + (or (and (numberp (nth 1 range)) (nth 1 range)) + (cdadr range)))) + (setcdr range (cddr range))) + ;; Adjust the first element to be the same as the lower limit. + (when (and (not (atom (car range))) + (< (cdar range) (car active))) + (setcdr (car range) (1- (car active)))) + ;; Then we want to peel off any elements that are higher + ;; than the upper active limit. + (let ((srange range)) + ;; Go past all legal elements. + (while (and (cdr srange) + (<= (or (and (atom (cadr srange)) + (cadr srange)) + (caadr srange)) + (cdr active))) + (setq srange (cdr srange))) + (when (cdr srange) + ;; Nuke all remaining illegal elements. + (setcdr srange nil)) + + ;; Adjust the final element. + (when (and (not (atom (car srange))) + (> (cdar srange) (cdr active))) + (setcdr (car srange) (cdr active)))) + ;; Compute the number of unread articles. + (while range + (setq num (+ num (- (1+ (or (and (atom (car range)) (car range)) + (cdar range))) + (or (and (atom (car range)) (car range)) + (caar range))))) + (setq range (cdr range))) + (setq num (max 0 (- (cdr active) num))))) + ;; Set the number of unread articles. + (when info + (setcar (gnus-gethash (gnus-info-group info) gnus-newsrc-hashtb) num)) + num))) + +;; Go though `gnus-newsrc-alist' and compare with `gnus-active-hashtb' +;; and compute how many unread articles there are in each group. +(defun gnus-get-unread-articles (&optional level) + (let* ((newsrc (cdr gnus-newsrc-alist)) + (level (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)) + level)) + info group active method) + (gnus-message 5 "Checking new news...") + + (while newsrc + (setq active (gnus-active (setq group (gnus-info-group + (setq info (pop newsrc)))))) + + ;; Check newsgroups. If the user doesn't want to check them, or + ;; they can't be checked (for instance, if the news server can't + ;; be reached) we just set the number of unread articles in this + ;; newsgroup to t. This means that Gnus thinks that there are + ;; unread articles, but it has no idea how many. + (if (and (setq method (gnus-info-method info)) + (not (gnus-server-equal + gnus-select-method + (setq method (gnus-server-get-method nil method)))) + (not (gnus-secondary-method-p method))) + ;; These groups are foreign. Check the level. + (when (<= (gnus-info-level info) foreign-level) + (setq active (gnus-activate-group group 'scan)) + (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)))) + ;; These groups are native or secondary. + (when (and (<= (gnus-info-level info) level) + (not gnus-read-active-file)) + (setq active (gnus-activate-group group 'scan)) + (inline (gnus-close-group group)))) + + ;; Get the number of unread articles in the group. + (if active + (inline (gnus-get-unread-articles-in-group info active 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-gethash group gnus-newsrc-hashtb) t))) + + (gnus-message 5 "Checking new news...done"))) + +;; Create a hash table out of the newsrc alist. The `car's of the +;; alist elements are used as keys. +(defun gnus-make-hashtable-from-newsrc-alist () + (let ((alist gnus-newsrc-alist) + (ohashtb gnus-newsrc-hashtb) + prev) + (setq gnus-newsrc-hashtb (gnus-make-hashtable (length alist))) + (setq alist + (setq prev (setq gnus-newsrc-alist + (if (equal (caar gnus-newsrc-alist) + "dummy.group") + gnus-newsrc-alist + (cons (list "dummy.group" 0 nil) alist))))) + (while alist + (gnus-sethash + (caar alist) + (cons (and ohashtb (car (gnus-gethash (caar alist) ohashtb))) + prev) + gnus-newsrc-hashtb) + (setq prev alist + alist (cdr alist))))) + +(defun gnus-make-hashtable-from-killed () + "Create a hash table from the killed and zombie lists." + (let ((lists '(gnus-killed-list gnus-zombie-list)) + list) + (setq gnus-killed-hashtb + (gnus-make-hashtable + (+ (length gnus-killed-list) (length gnus-zombie-list)))) + (while lists + (setq list (symbol-value (pop lists))) + (while list + (gnus-sethash (car list) (pop list) gnus-killed-hashtb))))) + +(defun gnus-activate-group (group &optional scan dont-check method) + ;; Check whether a group has been activated or not. + ;; If SCAN, request a scan of that group as well. + (let ((method (or method (gnus-find-method-for-group group))) + active) + (and (gnus-check-server method) + ;; We escape all bugs and quit here to make it possible to + ;; continue if a group is so out-there that it reports bugs + ;; and stuff. + (progn + (and scan + (gnus-check-backend-function 'request-scan (car method)) + (gnus-request-scan group method)) + t) + (condition-case () + (gnus-request-group group dont-check method) + (error nil) + (quit nil)) + (gnus-set-active group (setq active (gnus-parse-active))) + ;; Return the new active info. + active))) + +(defun gnus-parse-active () + "Parse active info in the nntp server buffer." + (save-excursion + (set-buffer nntp-server-buffer) + (goto-char (point-min)) + ;; Parse the result we got from `gnus-request-group'. + (when (looking-at "[0-9]+ [0-9]+ \\([0-9]+\\) [0-9]+") + (goto-char (match-beginning 1)) + (cons (read (current-buffer)) + (read (current-buffer)))))) + +(defun gnus-make-articles-unread (group articles) + "Mark ARTICLES in GROUP as unread." + (let* ((info (nth 2 (or (gnus-gethash group gnus-newsrc-hashtb) + (gnus-gethash (gnus-group-real-name group) + gnus-newsrc-hashtb)))) + (ranges (gnus-info-read info)) + news article) + (while articles + (when (gnus-member-of-range + (setq article (pop articles)) ranges) + (push article news))) + (when news + (gnus-info-set-read + info (gnus-remove-from-range (gnus-info-read info) (nreverse news))) + (gnus-group-update-group group t)))) + +;; Enter all dead groups into the hashtb. +(defun gnus-update-active-hashtb-from-killed () + (let ((hashtb (setq gnus-active-hashtb (gnus-make-hashtable 4096))) + (lists (list gnus-killed-list gnus-zombie-list)) + killed) + (while lists + (setq killed (car lists)) + (while killed + (gnus-sethash (car killed) nil hashtb) + (setq killed (cdr killed))) + (setq lists (cdr lists))))) + +(defun gnus-get-killed-groups () + "Go through the active hashtb and mark all unknown groups as killed." + ;; First make sure active file has been read. + (unless (gnus-read-active-file-p) + (let ((gnus-read-active-file t)) + (gnus-read-active-file))) + (unless gnus-killed-hashtb + (gnus-make-hashtable-from-killed)) + ;; Go through all newsgroups that are known to Gnus - enlarge kill list. + (mapatoms + (lambda (sym) + (let ((groups 0) + (group (symbol-name sym))) + (if (or (null group) + (gnus-gethash group gnus-killed-hashtb) + (gnus-gethash group gnus-newsrc-hashtb)) + () + (let ((do-sub (gnus-matches-options-n group))) + (if (or (eq do-sub 'subscribe) (eq do-sub 'ignore)) + () + (setq groups (1+ groups)) + (push group gnus-killed-list) + (gnus-sethash group group gnus-killed-hashtb)))))) + gnus-active-hashtb) + (gnus-dribble-touch)) + +;; Get the active file(s) from the backend(s). +(defun gnus-read-active-file () + (gnus-group-set-mode-line) + (let ((methods + (append + (if (gnus-check-server gnus-select-method) + ;; The native server is available. + (cons gnus-select-method gnus-secondary-select-methods) + ;; The native server is down, so we just do the + ;; secondary ones. + gnus-secondary-select-methods) + ;; Also read from the archive server. + (when (gnus-archive-server-wanted-p) + (list "archive")))) + list-type) + (setq gnus-have-read-active-file nil) + (save-excursion + (set-buffer nntp-server-buffer) + (while methods + (let* ((method (if (stringp (car methods)) + (gnus-server-get-method nil (car methods)) + (car methods))) + (where (nth 1 method)) + (mesg (format "Reading active file%s via %s..." + (if (and where (not (zerop (length where)))) + (concat " from " where) "") + (car method)))) + (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)) + (gnus-request-scan nil method)) + (cond + ((and (eq gnus-read-active-file 'some) + (gnus-check-backend-function 'retrieve-groups (car method))) + (let ((newsrc (cdr gnus-newsrc-alist)) + (gmethod (gnus-server-get-method nil method)) + groups info) + (while (setq info (pop newsrc)) + (when (gnus-server-equal + (gnus-find-method-for-group + (gnus-info-group info) info) + gmethod) + (push (gnus-group-real-name (gnus-info-group info)) + groups))) + (when groups + (gnus-check-server method) + (setq list-type (gnus-retrieve-groups groups method)) + (cond + ((not list-type) + (gnus-error + 1.2 "Cannot read partial active file from %s server." + (car method))) + ((eq list-type 'active) + (gnus-active-to-gnus-format method gnus-active-hashtb)) + (t + (gnus-groups-to-gnus-format method gnus-active-hashtb)))))) + ((null method) + t) + (t + (if (not (gnus-request-list method)) + (unless (equal method gnus-message-archive-method) + (gnus-error 1 "Cannot read active file from %s server." + (car method))) + (gnus-message 5 mesg) + (gnus-active-to-gnus-format method gnus-active-hashtb) + ;; We mark this active file as read. + (push method gnus-have-read-active-file) + (gnus-message 5 "%sdone" mesg)))))) + (setq methods (cdr methods)))))) + + +(defun gnus-ignored-newsgroups-has-to-p () + "T only when gnus-ignored-newsgroups includes \"^to\\\\.\" as an element." + ;; note this regexp is the same as: + ;; (concat (regexp-quote "^to\\.") "\\($\\|" (regexp-quote "\\|") "\\)") + (string-match "\\^to\\\\\\.\\($\\|\\\\|\\)" + gnus-ignored-newsgroups)) + +;; Read an active file and place the results in `gnus-active-hashtb'. +(defun gnus-active-to-gnus-format (&optional method hashtb ignore-errors) + (unless method + (setq method gnus-select-method)) + (let ((cur (current-buffer)) + (hashtb (or hashtb + (if (and gnus-active-hashtb + (not (equal method gnus-select-method))) + gnus-active-hashtb + (setq gnus-active-hashtb + (if (equal method gnus-select-method) + (gnus-make-hashtable + (count-lines (point-min) (point-max))) + (gnus-make-hashtable 4096))))))) + ;; Delete unnecessary lines, cleaned up dmoore@ucsd.edu 31.10.1996 + (goto-char (point-min)) + (cond ((gnus-ignored-newsgroups-has-to-p) + (delete-matching-lines gnus-ignored-newsgroups)) + ((string= gnus-ignored-newsgroups "") + (delete-matching-lines "^to\\.")) + (t + (delete-matching-lines (concat "^to\\.\\|" + gnus-ignored-newsgroups)))) + + ;; Make the group names readable as a lisp expression even if they + ;; contain special characters. + ;; Fix by Luc Van Eycken . + (goto-char (point-max)) + (while (re-search-backward "[][';?()#]" nil t) + (insert ?\\)) + + ;; If these are groups from a foreign select method, we insert the + ;; group prefix in front of the group names. + (and method (not (gnus-server-equal + (gnus-server-get-method nil method) + (gnus-server-get-method nil gnus-select-method))) + (let ((prefix (gnus-group-prefixed-name "" method))) + (goto-char (point-min)) + (while (and (not (eobp)) + (progn (insert prefix) + (zerop (forward-line 1))))))) + ;; Store the active file in a hash table. + (goto-char (point-min)) + (let (group max min) + (while (not (eobp)) + (condition-case () + (progn + (narrow-to-region (point) (point-at-eol)) + ;; group gets set to a symbol interned in the hash table + ;; (what a hack!!) - jwz + (setq group (let ((obarray hashtb)) (read cur))) + (if (and (numberp (setq max (read cur))) + (numberp (setq min (read cur))) + (progn + (skip-chars-forward " \t") + (not + (or (= (following-char) ?=) + (= (following-char) ?x) + (= (following-char) ?j))))) + (progn + (set group (cons min max)) + ;; if group is moderated, stick in moderation table + (when (= (following-char) ?m) + (unless gnus-moderated-hashtb + (setq gnus-moderated-hashtb (gnus-make-hashtable))) + (gnus-sethash (symbol-name group) t + gnus-moderated-hashtb))) + (set group nil))) + (error + (and group + (symbolp group) + (set group nil)) + (unless ignore-errors + (gnus-message 3 "Warning - illegal active: %s" + (buffer-substring + (point-at-bol) (point-at-eol)))))) + (widen) + (forward-line 1))))) + +(defun gnus-groups-to-gnus-format (method &optional hashtb) + ;; Parse a "groups" active file. + (let ((cur (current-buffer)) + (hashtb (or hashtb + (if (and method gnus-active-hashtb) + gnus-active-hashtb + (setq gnus-active-hashtb + (gnus-make-hashtable + (count-lines (point-min) (point-max))))))) + (prefix (and method + (not (gnus-server-equal + (gnus-server-get-method nil method) + (gnus-server-get-method nil gnus-select-method))) + (gnus-group-prefixed-name "" method)))) + + (goto-char (point-min)) + ;; We split this into to separate loops, one with the prefix + ;; and one without to speed the reading up somewhat. + (if prefix + (let (min max opoint group) + (while (not (eobp)) + (condition-case () + (progn + (read cur) (read cur) + (setq min (read cur) + max (read cur) + opoint (point)) + (skip-chars-forward " \t") + (insert prefix) + (goto-char opoint) + (set (let ((obarray hashtb)) (read cur)) + (cons min max))) + (error (and group (symbolp group) (set group nil)))) + (forward-line 1))) + (let (min max group) + (while (not (eobp)) + (condition-case () + (when (= (following-char) ?2) + (read cur) (read cur) + (setq min (read cur) + max (read cur)) + (set (setq group (let ((obarray hashtb)) (read cur))) + (cons min max))) + (error (and group (symbolp group) (set group nil)))) + (forward-line 1)))))) + +(defun gnus-read-newsrc-file (&optional force) + "Read startup file. +If FORCE is non-nil, the .newsrc file is read." + ;; Reset variables that might be defined in the .newsrc.eld file. + (let ((variables gnus-variable-list)) + (while variables + (set (car variables) nil) + (setq variables (cdr variables)))) + (let* ((newsrc-file gnus-current-startup-file) + (quick-file (concat newsrc-file ".el"))) + (save-excursion + ;; We always load the .newsrc.eld file. If always contains + ;; much information that can not be gotten from the .newsrc + ;; file (ticked articles, killed groups, foreign methods, etc.) + (gnus-read-newsrc-el-file quick-file) + + (when (and (file-exists-p gnus-current-startup-file) + (or force + (and (file-newer-than-file-p newsrc-file quick-file) + (file-newer-than-file-p newsrc-file + (concat quick-file "d"))) + (not gnus-newsrc-alist))) + ;; We read the .newsrc file. Note that if there if a + ;; .newsrc.eld file exists, it has already been read, and + ;; the `gnus-newsrc-hashtb' has been created. While reading + ;; the .newsrc file, Gnus will only use the information it + ;; can find there for changing the data already read - + ;; i. e., reading the .newsrc file will not trash the data + ;; already read (except for read articles). + (save-excursion + (gnus-message 5 "Reading %s..." newsrc-file) + (set-buffer (nnheader-find-file-noselect newsrc-file)) + (buffer-disable-undo (current-buffer)) + (gnus-newsrc-to-gnus-format) + (kill-buffer (current-buffer)) + (gnus-message 5 "Reading %s...done" newsrc-file))) + + ;; Convert old to new. + (gnus-convert-old-newsrc)))) + +(defun gnus-convert-old-newsrc () + "Convert old newsrc into the new format, if needed." + (let ((fcv (and gnus-newsrc-file-version + (gnus-continuum-version gnus-newsrc-file-version)))) + (cond + ;; No .newsrc.eld file was loaded. + ((null fcv) nil) + ;; Gnus 5 .newsrc.eld was loaded. + ((< fcv (gnus-continuum-version "September Gnus v0.1")) + (gnus-convert-old-ticks))))) + +(defun gnus-convert-old-ticks () + (let ((newsrc (cdr gnus-newsrc-alist)) + marks info dormant ticked) + (while (setq info (pop newsrc)) + (when (setq marks (gnus-info-marks info)) + (setq dormant (cdr (assq 'dormant marks)) + ticked (cdr (assq 'tick marks))) + (when (or dormant ticked) + (gnus-info-set-read + info + (gnus-add-to-range + (gnus-info-read info) + (nconc (gnus-uncompress-range dormant) + (gnus-uncompress-range ticked))))))))) + +(defun gnus-read-newsrc-el-file (file) + (let ((ding-file (concat file "d"))) + ;; We always, always read the .eld file. + (gnus-message 5 "Reading %s..." ding-file) + (let (gnus-newsrc-assoc) + (condition-case nil + (load ding-file t t t) + (error + (gnus-error 1 "Error in %s" ding-file))) + (when gnus-newsrc-assoc + (setq gnus-newsrc-alist gnus-newsrc-assoc))) + (gnus-make-hashtable-from-newsrc-alist) + (when (file-newer-than-file-p file ding-file) + ;; Old format quick file + (gnus-message 5 "Reading %s..." file) + ;; The .el file is newer than the .eld file, so we read that one + ;; as well. + (gnus-read-old-newsrc-el-file file)))) + +;; Parse the old-style quick startup file +(defun gnus-read-old-newsrc-el-file (file) + (let (newsrc killed marked group m info) + (prog1 + (let ((gnus-killed-assoc nil) + gnus-marked-assoc gnus-newsrc-alist gnus-newsrc-assoc) + (prog1 + (ignore-errors + (load file t t t)) + (setq newsrc gnus-newsrc-assoc + killed gnus-killed-assoc + marked gnus-marked-assoc))) + (setq gnus-newsrc-alist nil) + (while (setq group (pop newsrc)) + (if (setq info (gnus-get-info (car group))) + (progn + (gnus-info-set-read info (cddr group)) + (gnus-info-set-level + info (if (nth 1 group) gnus-level-default-subscribed + gnus-level-default-unsubscribed)) + (push info gnus-newsrc-alist)) + (push (setq info + (list (car group) + (if (nth 1 group) gnus-level-default-subscribed + gnus-level-default-unsubscribed) + (cddr group))) + gnus-newsrc-alist)) + ;; Copy marks into info. + (when (setq m (assoc (car group) marked)) + (unless (nthcdr 3 info) + (nconc info (list nil))) + (gnus-info-set-marks + info (list (cons 'tick (gnus-compress-sequence + (sort (cdr m) '<) t)))))) + (setq newsrc killed) + (while newsrc + (setcar newsrc (caar newsrc)) + (setq newsrc (cdr newsrc))) + (setq gnus-killed-list killed)) + ;; The .el file version of this variable does not begin with + ;; "options", while the .eld version does, so we just add it if it + ;; isn't there. + (when + gnus-newsrc-options + (when (not (string-match "^ *options" gnus-newsrc-options)) + (setq gnus-newsrc-options (concat "options " gnus-newsrc-options))) + (when (not (string-match "\n$" gnus-newsrc-options)) + (setq gnus-newsrc-options (concat gnus-newsrc-options "\n"))) + ;; Finally, if we read some options lines, we parse them. + (unless (string= gnus-newsrc-options "") + (gnus-newsrc-parse-options gnus-newsrc-options))) + + (setq gnus-newsrc-alist (nreverse gnus-newsrc-alist)) + (gnus-make-hashtable-from-newsrc-alist))) + +(defun gnus-make-newsrc-file (file) + "Make server dependent file name by catenating FILE and server host name." + (let* ((file (expand-file-name file nil)) + (real-file (concat file "-" (nth 1 gnus-select-method)))) + (if (or (file-exists-p real-file) + (file-exists-p (concat real-file ".el")) + (file-exists-p (concat real-file ".eld"))) + real-file file))) + +(defun gnus-newsrc-to-gnus-format () + (setq gnus-newsrc-options "") + (setq gnus-newsrc-options-n nil) + + (unless gnus-active-hashtb + (setq gnus-active-hashtb (gnus-make-hashtable 4096))) + (let ((buf (current-buffer)) + (already-read (> (length gnus-newsrc-alist) 1)) + group subscribed options-symbol newsrc Options-symbol + symbol reads num1) + (goto-char (point-min)) + ;; We intern the symbol `options' in the active hashtb so that we + ;; can `eq' against it later. + (set (setq options-symbol (intern "options" gnus-active-hashtb)) nil) + (set (setq Options-symbol (intern "Options" gnus-active-hashtb)) nil) + + (while (not (eobp)) + ;; We first read the first word on the line by narrowing and + ;; then reading into `gnus-active-hashtb'. Most groups will + ;; already exist in that hashtb, so this will save some string + ;; space. + (narrow-to-region + (point) + (progn (skip-chars-forward "^ \t!:\n") (point))) + (goto-char (point-min)) + (setq symbol + (and (/= (point-min) (point-max)) + (let ((obarray gnus-active-hashtb)) (read buf)))) + (widen) + ;; Now, the symbol we have read is either `options' or a group + ;; name. If it is an options line, we just add it to a string. + (cond + ((or (eq symbol options-symbol) + (eq symbol Options-symbol)) + (setq gnus-newsrc-options + ;; This concating is quite inefficient, but since our + ;; thorough studies show that approx 99.37% of all + ;; .newsrc files only contain a single options line, we + ;; don't give a damn, frankly, my dear. + (concat gnus-newsrc-options + (buffer-substring + (point-at-bol) + ;; Options may continue on the next line. + (or (and (re-search-forward "^[^ \t]" nil 'move) + (progn (beginning-of-line) (point))) + (point))))) + (forward-line -1)) + (symbol + ;; Group names can be just numbers. + (when (numberp symbol) + (setq symbol (intern (int-to-string symbol) gnus-active-hashtb))) + (unless (boundp symbol) + (set symbol nil)) + ;; It was a group name. + (setq subscribed (= (following-char) ?:) + group (symbol-name symbol) + reads nil) + (if (eolp) + ;; If the line ends here, this is clearly a buggy line, so + ;; we put point a the beginning of line and let the cond + ;; below do the error handling. + (beginning-of-line) + ;; We skip to the beginning of the ranges. + (skip-chars-forward "!: \t")) + ;; We are now at the beginning of the list of read articles. + ;; We read them range by range. + (while + (cond + ((looking-at "[0-9]+") + ;; We narrow and read a number instead of buffer-substring/ + ;; string-to-int because it's faster. narrow/widen is + ;; faster than save-restriction/narrow, and save-restriction + ;; produces a garbage object. + (setq num1 (progn + (narrow-to-region (match-beginning 0) (match-end 0)) + (read buf))) + (widen) + ;; If the next character is a dash, then this is a range. + (if (= (following-char) ?-) + (progn + ;; We read the upper bound of the range. + (forward-char 1) + (if (not (looking-at "[0-9]+")) + ;; This is a buggy line, by we pretend that + ;; it's kinda OK. Perhaps the user should be + ;; dinged? + (push num1 reads) + (push + (cons num1 + (progn + (narrow-to-region (match-beginning 0) + (match-end 0)) + (read buf))) + reads) + (widen))) + ;; It was just a simple number, so we add it to the + ;; list of ranges. + (push num1 reads)) + ;; If the next char in ?\n, then we have reached the end + ;; of the line and return nil. + (/= (following-char) ?\n)) + ((= (following-char) ?\n) + ;; End of line, so we end. + nil) + (t + ;; Not numbers and not eol, so this might be a buggy + ;; line... + (unless (eobp) + ;; If it was eob instead of ?\n, we allow it. + ;; The line was buggy. + (setq group nil) + (gnus-error 3.1 "Mangled line: %s" + (buffer-substring (point-at-bol) + (point-at-eol)))) + nil)) + ;; Skip past ", ". Spaces are illegal in these ranges, but + ;; we allow them, because it's a common mistake to put a + ;; space after the comma. + (skip-chars-forward ", ")) + + ;; We have already read .newsrc.eld, so we gently update the + ;; data in the hash table with the information we have just + ;; read. + (when group + (let ((info (gnus-get-info group)) + level) + (if info + ;; There is an entry for this file in the alist. + (progn + (gnus-info-set-read info (nreverse reads)) + ;; We update the level very gently. In fact, we + ;; only change it if there's been a status change + ;; from subscribed to unsubscribed, or vice versa. + (setq level (gnus-info-level info)) + (cond ((and (<= level gnus-level-subscribed) + (not subscribed)) + (setq level (if reads + gnus-level-default-unsubscribed + (1+ gnus-level-default-unsubscribed)))) + ((and (> level gnus-level-subscribed) subscribed) + (setq level gnus-level-default-subscribed))) + (gnus-info-set-level info level)) + ;; This is a new group. + (setq info (list group + (if subscribed + gnus-level-default-subscribed + (if reads + (1+ gnus-level-subscribed) + gnus-level-default-unsubscribed)) + (nreverse reads)))) + (push info newsrc))))) + (forward-line 1)) + + (setq newsrc (nreverse newsrc)) + + (if (not already-read) + () + ;; We now have two newsrc lists - `newsrc', which is what we + ;; have read from .newsrc, and `gnus-newsrc-alist', which is + ;; what we've read from .newsrc.eld. We have to merge these + ;; lists. We do this by "attaching" any (foreign) groups in the + ;; gnus-newsrc-alist to the (native) group that precedes them. + (let ((rc (cdr gnus-newsrc-alist)) + (prev gnus-newsrc-alist) + entry mentry) + (while rc + (or (null (nth 4 (car rc))) ; It's a native group. + (assoc (caar rc) newsrc) ; It's already in the alist. + (if (setq entry (assoc (caar prev) newsrc)) + (setcdr (setq mentry (memq entry newsrc)) + (cons (car rc) (cdr mentry))) + (push (car rc) newsrc))) + (setq prev rc + rc (cdr rc))))) + + (setq gnus-newsrc-alist newsrc) + ;; We make the newsrc hashtb. + (gnus-make-hashtable-from-newsrc-alist) + + ;; Finally, if we read some options lines, we parse them. + (unless (string= gnus-newsrc-options "") + (gnus-newsrc-parse-options gnus-newsrc-options)))) + +;; Parse options lines to find "options -n !all rec.all" and stuff. +;; The return value will be a list on the form +;; ((regexp1 . ignore) +;; (regexp2 . subscribe)...) +;; When handling new newsgroups, groups that match a `ignore' regexp +;; will be ignored, and groups that match a `subscribe' regexp will be +;; subscribed. A line like +;; options -n !all rec.all +;; will lead to a list that looks like +;; (("^rec\\..+" . subscribe) +;; ("^.+" . ignore)) +;; So all "rec.*" groups will be subscribed, while all the other +;; groups will be ignored. Note that "options -n !all rec.all" is very +;; different from "options -n rec.all !all". +(defun gnus-newsrc-parse-options (options) + (let (out eol) + (save-excursion + (gnus-set-work-buffer) + (insert (regexp-quote options)) + ;; First we treat all continuation lines. + (goto-char (point-min)) + (while (re-search-forward "\n[ \t]+" nil t) + (replace-match " " t t)) + ;; Then we transform all "all"s into ".+"s. + (goto-char (point-min)) + (while (re-search-forward "\\ball\\b" nil t) + (replace-match ".+" t t)) + (goto-char (point-min)) + ;; We remove all other options than the "-n" ones. + (while (re-search-forward "[ \t]-[^n][^-]*" nil t) + (replace-match " ") + (forward-char -1)) + (goto-char (point-min)) + + ;; We are only interested in "options -n" lines - we + ;; ignore the other option lines. + (while (re-search-forward "[ \t]-n" nil t) + (setq eol + (or (save-excursion + (and (re-search-forward "[ \t]-n" (point-at-eol) t) + (- (point) 2))) + (point-at-eol))) + ;; Search for all "words"... + (while (re-search-forward "[^ \t,\n]+" eol t) + (if (= (char-after (match-beginning 0)) ?!) + ;; If the word begins with a bang (!), this is a "not" + ;; spec. We put this spec (minus the bang) and the + ;; symbol `ignore' into the list. + (push (cons (concat + "^" (buffer-substring + (1+ (match-beginning 0)) + (match-end 0))) + 'ignore) + out) + ;; There was no bang, so this is a "yes" spec. + (push (cons (concat "^" (match-string 0)) + 'subscribe) + out)))) + + (setq gnus-newsrc-options-n out)))) + +(defun gnus-save-newsrc-file (&optional force) + "Save .newsrc file." + ;; Note: We cannot save .newsrc file if all newsgroups are removed + ;; from the variable gnus-newsrc-alist. + (when (and (or gnus-newsrc-alist gnus-killed-list) + gnus-current-startup-file) + (save-excursion + (if (and (or gnus-use-dribble-file gnus-slave) + (not force) + (or (not gnus-dribble-buffer) + (not (buffer-name gnus-dribble-buffer)) + (zerop (save-excursion + (set-buffer gnus-dribble-buffer) + (buffer-size))))) + (gnus-message 4 "(No changes need to be saved)") + (run-hooks 'gnus-save-newsrc-hook) + (if gnus-slave + (gnus-slave-save-newsrc) + ;; Save .newsrc. + (when gnus-save-newsrc-file + (gnus-message 5 "Saving %s..." gnus-current-startup-file) + (gnus-gnus-to-newsrc-format) + (gnus-message 5 "Saving %s...done" gnus-current-startup-file)) + ;; Save .newsrc.eld. + (set-buffer (get-buffer-create " *Gnus-newsrc*")) + (make-local-variable 'version-control) + (setq version-control 'never) + (setq buffer-file-name + (concat gnus-current-startup-file ".eld")) + (setq default-directory (file-name-directory buffer-file-name)) + (gnus-add-current-to-buffer-list) + (buffer-disable-undo (current-buffer)) + (erase-buffer) + (gnus-message 5 "Saving %s.eld..." gnus-current-startup-file) + (gnus-gnus-to-quick-newsrc-format) + (run-hooks 'gnus-save-quick-newsrc-hook) + (save-buffer) + (kill-buffer (current-buffer)) + (gnus-message + 5 "Saving %s.eld...done" gnus-current-startup-file)) + (gnus-dribble-delete-file) + (gnus-group-set-mode-line))))) + +(defun gnus-gnus-to-quick-newsrc-format () + "Insert Gnus variables such as gnus-newsrc-alist in lisp format." + (let ((print-quoted t)) + (insert ";; -*- emacs-lisp -*-\n") + (insert ";; Gnus startup file.\n") + (insert + ";; Never delete this file - touch .newsrc instead to force Gnus\n") + (insert ";; to read .newsrc.\n") + (insert "(setq gnus-newsrc-file-version " + (prin1-to-string gnus-version) ")\n") + (let* ((gnus-killed-list + (if (and gnus-save-killed-list + (stringp gnus-save-killed-list)) + (gnus-strip-killed-list) + gnus-killed-list)) + (variables + (if gnus-save-killed-list gnus-variable-list + ;; Remove the `gnus-killed-list' from the list of variables + ;; to be saved, if required. + (delq 'gnus-killed-list (copy-sequence gnus-variable-list)))) + ;; Peel off the "dummy" group. + (gnus-newsrc-alist (cdr gnus-newsrc-alist)) + variable) + ;; Insert the variables into the file. + (while variables + (when (and (boundp (setq variable (pop variables))) + (symbol-value variable)) + (insert "(setq " (symbol-name variable) " '") + (gnus-prin1 (symbol-value variable)) + (insert ")\n")))))) + +(defun gnus-strip-killed-list () + "Return the killed list minus the groups that match `gnus-save-killed-list'." + (let ((list gnus-killed-list) + olist) + (while list + (when (string-match gnus-save-killed-list) + (push (car list) olist)) + (pop list)) + (nreverse olist))) + +(defun gnus-gnus-to-newsrc-format () + ;; Generate and save the .newsrc file. + (save-excursion + (set-buffer (create-file-buffer gnus-current-startup-file)) + (let ((newsrc (cdr gnus-newsrc-alist)) + (standard-output (current-buffer)) + info ranges range method) + (setq buffer-file-name gnus-current-startup-file) + (setq default-directory (file-name-directory buffer-file-name)) + (buffer-disable-undo (current-buffer)) + (erase-buffer) + ;; Write options. + (when gnus-newsrc-options + (insert gnus-newsrc-options)) + ;; Write subscribed and unsubscribed. + (while (setq info (pop newsrc)) + ;; Don't write foreign groups to .newsrc. + (when (or (null (setq method (gnus-info-method info))) + (equal method "native") + (gnus-server-equal method gnus-select-method)) + (insert (gnus-info-group info) + (if (> (gnus-info-level info) gnus-level-subscribed) + "!" ":")) + (when (setq ranges (gnus-info-read info)) + (insert " ") + (if (not (listp (cdr ranges))) + (if (= (car ranges) (cdr ranges)) + (princ (car ranges)) + (princ (car ranges)) + (insert "-") + (princ (cdr ranges))) + (while (setq range (pop ranges)) + (if (or (atom range) (= (car range) (cdr range))) + (princ (or (and (atom range) range) (car range))) + (princ (car range)) + (insert "-") + (princ (cdr range))) + (when ranges + (insert ","))))) + (insert "\n"))) + (make-local-variable 'version-control) + (setq version-control 'never) + ;; It has been reported that sometime the modtime on the .newsrc + ;; file seems to be off. We really do want to overwrite it, so + ;; we clear the modtime here before saving. It's a bit odd, + ;; though... + ;; sometimes the modtime clear isn't sufficient. most brute force: + ;; delete the silly thing entirely first. but this fails to provide + ;; such niceties as .newsrc~ creation. + (if gnus-modtime-botch + (delete-file gnus-startup-file) + (clear-visited-file-modtime)) + (run-hooks 'gnus-save-standard-newsrc-hook) + (save-buffer) + (kill-buffer (current-buffer))))) + + +;;; +;;; Slave functions. +;;; + +(defun gnus-slave-save-newsrc () + (save-excursion + (set-buffer gnus-dribble-buffer) + (let ((slave-name + (make-temp-name (concat gnus-current-startup-file "-slave-")))) + (gnus-write-buffer slave-name)))) + +(defun gnus-master-read-slave-newsrc () + (let ((slave-files + (directory-files + (file-name-directory gnus-current-startup-file) + t (concat + "^" (regexp-quote + (concat + (file-name-nondirectory gnus-current-startup-file) + "-slave-"))) + t)) + file) + (if (not slave-files) + () ; There are no slave files to read. + (gnus-message 7 "Reading slave newsrcs...") + (save-excursion + (set-buffer (get-buffer-create " *gnus slave*")) + (buffer-disable-undo (current-buffer)) + (setq slave-files + (sort (mapcar (lambda (file) + (list (nth 5 (file-attributes file)) file)) + slave-files) + (lambda (f1 f2) + (or (< (caar f1) (caar f2)) + (< (nth 1 (car f1)) (nth 1 (car f2))))))) + (while slave-files + (erase-buffer) + (setq file (nth 1 (car slave-files))) + (insert-file-contents file) + (when (condition-case () + (progn + (eval-buffer (current-buffer)) + t) + (error + (gnus-error 3.2 "Possible error in %s" file) + nil)) + (unless gnus-slave ; Slaves shouldn't delete these files. + (ignore-errors + (delete-file file)))) + (setq slave-files (cdr slave-files)))) + (gnus-dribble-touch) + (gnus-message 7 "Reading slave newsrcs...done")))) + + +;;; +;;; Group description. +;;; + +(defun gnus-read-all-descriptions-files () + (let ((methods (cons gnus-select-method + (nconc + (when (gnus-archive-server-wanted-p) + (list "archive")) + gnus-secondary-select-methods)))) + (while methods + (gnus-read-descriptions-file (car methods)) + (setq methods (cdr methods))) + t)) + +(defun gnus-read-descriptions-file (&optional method) + (let ((method (or method gnus-select-method)) + group) + (when (stringp method) + (setq method (gnus-server-to-method method))) + ;; We create the hashtable whether we manage to read the desc file + ;; to avoid trying to re-read after a failed read. + (unless gnus-description-hashtb + (setq gnus-description-hashtb + (gnus-make-hashtable (length gnus-active-hashtb)))) + ;; Mark this method's desc file as read. + (gnus-sethash (gnus-group-prefixed-name "" method) "Has read" + gnus-description-hashtb) + + (gnus-message 5 "Reading descriptions file via %s..." (car method)) + (cond + ((not (gnus-check-server method)) + (gnus-message 1 "Couldn't open server") + nil) + ((not (gnus-request-list-newsgroups method)) + (gnus-message 1 "Couldn't read newsgroups descriptions") + nil) + (t + (save-excursion + (save-restriction + (set-buffer nntp-server-buffer) + (goto-char (point-min)) + (when (or (search-forward "\n.\n" nil t) + (goto-char (point-max))) + (beginning-of-line) + (narrow-to-region (point-min) (point))) + ;; If these are groups from a foreign select method, we insert the + ;; group prefix in front of the group names. + (and method (not (gnus-server-equal + (gnus-server-get-method nil method) + (gnus-server-get-method nil gnus-select-method))) + (let ((prefix (gnus-group-prefixed-name "" method))) + (goto-char (point-min)) + (while (and (not (eobp)) + (progn (insert prefix) + (zerop (forward-line 1))))))) + (goto-char (point-min)) + (while (not (eobp)) + ;; If we get an error, we set group to 0, which is not a + ;; symbol... + (setq group + (condition-case () + (let ((obarray gnus-description-hashtb)) + ;; Group is set to a symbol interned in this + ;; hash table. + (read nntp-server-buffer)) + (error 0))) + (skip-chars-forward " \t") + ;; ... which leads to this line being effectively ignored. + (when (symbolp group) + (set group (buffer-substring + (point) (progn (end-of-line) (point))))) + (forward-line 1)))) + (gnus-message 5 "Reading descriptions file...done") + t)))) + +(defun gnus-group-get-description (group) + "Get the description of a group by sending XGTITLE to the server." + (when (gnus-request-group-description group) + (save-excursion + (set-buffer nntp-server-buffer) + (goto-char (point-min)) + (when (looking-at "[^ \t]+[ \t]+\\(.*\\)") + (match-string 1))))) + +;;;###autoload +(defun gnus-declare-backend (name &rest abilities) + "Declare backend NAME with ABILITIES as a Gnus backend." + (setq gnus-valid-select-methods + (nconc gnus-valid-select-methods + (list (apply 'list name abilities))))) + +(defun gnus-set-default-directory () + "Set the default directory in the current buffer to `gnus-default-directory'. +If this variable is nil, don't do anything." + (setq default-directory + (if (and gnus-default-directory + (file-exists-p gnus-default-directory)) + (file-name-as-directory (expand-file-name gnus-default-directory)) + default-directory))) + +(provide 'gnus-start) + +;;; gnus-start.el ends here diff -r ad457d5f7d04 -r 0293115a14e9 lisp/gnus/gnus-sum.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus/gnus-sum.el Mon Aug 13 08:49:20 2007 +0200 @@ -0,0 +1,8499 @@ +;;; gnus-sum.el --- summary mode commands for Gnus +;; Copyright (C) 1996,97 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen +;; Keywords: news + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;;; Code: + +(require 'gnus) +(require 'gnus-group) +(require 'gnus-spec) +(require 'gnus-range) +(require 'gnus-int) +(require 'gnus-undo) + +(defcustom gnus-kill-summary-on-exit t + "*If non-nil, kill the summary buffer when you exit from it. +If nil, the summary will become a \"*Dead Summary*\" buffer, and +it will be killed sometime later." + :group 'gnus-summary-exit + :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 read (or +just marked as read) article, the old article will not normally be +displayed in the Summary buffer. If this variable is non-nil, Gnus +will attempt to grab the headers to the old articles, and thereby +build complete threads. If it has the value `some', only enough +headers to connect otherwise loose threads will be displayed. +This variable can also be a number. In that case, no more than that +number of old headers will be fetched. + +The server has to support NOV for any of this to work." + :group 'gnus-thread + :type '(choice (const :tag "off" nil) + (const some) + number + (sexp :menu-tag "other" t))) + +(defcustom gnus-summary-make-false-root 'adopt + "*nil means that Gnus won't gather loose threads. +If the root of a thread has expired or been read in a previous +session, the information necessary to build a complete thread has been +lost. Instead of having many small sub-threads from this original thread +scattered all over the summary buffer, Gnus can gather them. + +If non-nil, Gnus will try to gather all loose sub-threads from an +original thread into one large thread. + +If this variable is non-nil, it should be one of `none', `adopt', +`dummy' or `empty'. + +If this variable is `none', Gnus will not make a false root, but just +present the sub-threads after another. +If this variable is `dummy', Gnus will create a dummy root that will +have all the sub-threads as children. +If this variable is `adopt', Gnus will make one of the \"children\" +the parent and mark all the step-children as such. +If this variable is `empty', the \"children\" are printed with empty +subject fields. (Or rather, they will be printed with a string +given by the `gnus-summary-same-subject' variable.)" + :group 'gnus-thread + :type '(choice (const :tag "off" nil) + (const none) + (const dummy) + (const adopt) + (const empty))) + +(defcustom gnus-summary-gather-exclude-subject "^ *$\\|^(none)$" + "*A regexp to match subjects to be excluded from loose thread gathering. +As loose thread gathering is done on subjects only, that means that +there can be many false gatherings performed. By rooting out certain +common subjects, gathering might become saner." + :group 'gnus-thread + :type 'regexp) + +(defcustom gnus-summary-gather-subject-limit nil + "*Maximum length of subject comparisons when gathering loose threads. +Use nil to compare full subjects. Setting this variable to a low +number will help gather threads that have been corrupted by +newsreaders chopping off subject lines, but it might also mean that +unrelated articles that have subject that happen to begin with the +same few characters will be incorrectly gathered. + +If this variable is `fuzzy', Gnus will use a fuzzy algorithm when +comparing subjects." + :group 'gnus-thread + :type '(choice (const :tag "off" nil) + (const fuzzy) + (sexp :menu-tag "on" t))) + +(defcustom gnus-simplify-ignored-prefixes nil + "*Regexp, matches for which are removed from subject lines when simplifying fuzzily." + :group 'gnus-thread + :type '(choice (const :tag "off" nil) + regexp)) + +(defcustom gnus-build-sparse-threads nil + "*If non-nil, fill in the gaps in threads. +If `some', only fill in the gaps that are needed to tie loose threads +together. If `more', fill in all leaf nodes that Gnus can find. If +non-nil and non-`some', fill in all gaps that Gnus manages to guess." + :group 'gnus-thread + :type '(choice (const :tag "off" nil) + (const some) + (const more) + (sexp :menu-tag "all" t))) + +(defcustom gnus-summary-thread-gathering-function 'gnus-gather-threads-by-subject + "Function used for gathering loose threads. +There are two pre-defined functions: `gnus-gather-threads-by-subject', +which only takes Subjects into consideration; and +`gnus-gather-threads-by-references', which compared the References +headers of the articles to find matches." + :group 'gnus-thread + :type '(set (function-item gnus-gather-threads-by-subject) + (function-item gnus-gather-threads-by-references) + (function :tag "other"))) + +;; Added by Per Abrahamsen . +(defcustom gnus-summary-same-subject "" + "*String indicating that the current article has the same subject as the previous. +This variable will only be used if the value of +`gnus-summary-make-false-root' is `empty'." + :group 'gnus-summary-format + :type 'string) + +(defcustom gnus-summary-goto-unread t + "*If t, marking commands will go to the next unread article. +If `never', commands that usually go to the next unread article, will +go to the next article, whether it is read or not. +If nil, only the marking commands will go to the next (un)read article." + :group 'gnus-summary-marks + :link '(custom-manual "(gnus)Setting Marks") + :type '(choice (const :tag "off" nil) + (const never) + (sexp :menu-tag "on" t))) + +(defcustom gnus-summary-default-score 0 + "*Default article score level. +If this variable is nil, scoring will be disabled." + :group 'gnus-score + :type '(choice (const :tag "disable") + integer)) + +(defcustom gnus-summary-zcore-fuzz 0 + "*Fuzziness factor for the zcore in the summary buffer. +Articles with scores closer than this to `gnus-summary-default-score' +will not be marked." + :group 'gnus-summary-format + :type 'integer) + +(defcustom gnus-simplify-subject-fuzzy-regexp nil + "*Strings to be removed when doing fuzzy matches. +This can either be a regular expression or list of regular expressions +that will be removed from subject strings if fuzzy subject +simplification is selected." + :group 'gnus-thread + :type '(repeat regexp)) + +(defcustom gnus-show-threads t + "*If non-nil, display threads in summary mode." + :group 'gnus-thread + :type 'boolean) + +(defcustom gnus-thread-hide-subtree nil + "*If non-nil, hide all threads initially. +If threads are hidden, you have to run the command +`gnus-summary-show-thread' by hand or use `gnus-select-article-hook' +to expose hidden threads." + :group 'gnus-thread + :type 'boolean) + +(defcustom gnus-thread-hide-killed t + "*If non-nil, hide killed threads automatically." + :group 'gnus-thread + :type 'boolean) + +(defcustom gnus-thread-ignore-subject nil + "*If non-nil, ignore subjects and do all threading based on the Reference header. +If nil, which is the default, articles that have different subjects +from their parents will start separate threads." + :group 'gnus-thread + :type 'boolean) + +(defcustom gnus-thread-operation-ignore-subject t + "*If non-nil, subjects will be ignored when doing thread commands. +This affects commands like `gnus-summary-kill-thread' and +`gnus-summary-lower-thread'. + +If this variable is nil, articles in the same thread with different +subjects will not be included in the operation in question. If this +variable is `fuzzy', only articles that have subjects that are fuzzily +equal will be included." + :group 'gnus-thread + :type '(choice (const :tag "off" nil) + (const fuzzy) + (sexp :tag "on" t))) + +(defcustom gnus-thread-indent-level 4 + "*Number that says how much each sub-thread should be indented." + :group 'gnus-thread + :type 'integer) + +(defcustom gnus-auto-extend-newsgroup t + "*If non-nil, extend newsgroup forward and backward when requested." + :group 'gnus-summary-choose + :type 'boolean) + +(defcustom gnus-auto-select-first t + "*If nil, don't select the first unread article when entering a group. +If this variable is `best', select the highest-scored unread article +in the group. If neither nil nor `best', select the first unread +article. + +If you want to prevent automatic selection of the first unread article +in some newsgroups, set the variable to nil in +`gnus-select-group-hook'." + :group 'gnus-group-select + :type '(choice (const :tag "none" nil) + (const best) + (sexp :menu-tag "first" t))) + +(defcustom gnus-auto-select-next t + "*If non-nil, offer to go to the next group from the end of the previous. +If the value is t and the next newsgroup is empty, Gnus will exit +summary mode and go back to group mode. If the value is neither nil +nor t, Gnus will select the following unread newsgroup. In +particular, if the value is the symbol `quietly', the next unread +newsgroup will be selected without any confirmation, and if it is +`almost-quietly', the next group will be selected without any +confirmation if you are located on the last article in the group. +Finally, if this variable is `slightly-quietly', the `Z n' command +will go to the next group without confirmation." + :group 'gnus-summary-maneuvering + :type '(choice (const :tag "off" nil) + (const quietly) + (const almost-quietly) + (const slightly-quietly) + (sexp :menu-tag "on" t))) + +(defcustom gnus-auto-select-same nil + "*If non-nil, select the next article with the same subject." + :group 'gnus-summary-maneuvering + :type 'boolean) + +(defcustom gnus-summary-check-current nil + "*If non-nil, consider the current article when moving. +The \"unread\" movement commands will stay on the same line if the +current article is unread." + :group 'gnus-summary-maneuvering + :type 'boolean) + +(defcustom gnus-auto-center-summary t + "*If non-nil, always center the current summary buffer. +In particular, if `vertical' do only vertical recentering. If non-nil +and non-`vertical', do both horizontal and vertical recentering." + :group 'gnus-summary-maneuvering + :type '(choice (const :tag "none" nil) + (const vertical) + (sexp :menu-tag "both" t))) + +(defcustom gnus-show-all-headers nil + "*If non-nil, don't hide any headers." + :group 'gnus-article-hiding + :group 'gnus-article-headers + :type 'boolean) + +(defcustom gnus-single-article-buffer t + "*If non-nil, display all articles in the same buffer. +If nil, each group will get its own article buffer." + :group 'gnus-article-various + :type 'boolean) + +(defcustom gnus-break-pages t + "*If non-nil, do page breaking on articles. +The page delimiter is specified by the `gnus-page-delimiter' +variable." + :group 'gnus-article-various + :type 'boolean) + +(defcustom gnus-show-mime nil + "*If non-nil, do mime processing of articles. +The articles will simply be fed to the function given by +`gnus-show-mime-method'." + :group 'gnus-article-mime + :type 'boolean) + +(defcustom gnus-move-split-methods nil + "*Variable used to suggest where articles are to be moved to. +It uses the same syntax as the `gnus-split-methods' variable." + :group 'gnus-summary-mail + :type '(repeat (choice (list function) + (cons regexp (repeat string)) + sexp))) + +;; Mark variables suggested by Thomas Michanek +;; . + +(defcustom gnus-unread-mark ? + "*Mark used for unread articles." + :group 'gnus-summary-marks + :type 'character) + +(defcustom gnus-ticked-mark ?! + "*Mark used for ticked articles." + :group 'gnus-summary-marks + :type 'character) + +(defcustom gnus-dormant-mark ?? + "*Mark used for dormant articles." + :group 'gnus-summary-marks + :type 'character) + +(defcustom gnus-del-mark ?r + "*Mark used for del'd articles." + :group 'gnus-summary-marks + :type 'character) + +(defcustom gnus-read-mark ?R + "*Mark used for read articles." + :group 'gnus-summary-marks + :type 'character) + +(defcustom gnus-expirable-mark ?E + "*Mark used for expirable articles." + :group 'gnus-summary-marks + :type 'character) + +(defcustom gnus-killed-mark ?K + "*Mark used for killed articles." + :group 'gnus-summary-marks + :type 'character) + +(defcustom gnus-souped-mark ?F + "*Mark used for killed 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 + :type 'character) + +(defcustom gnus-low-score-mark ?Y + "*Mark used for articles with a low score." + :group 'gnus-summary-marks + :type 'character) + +(defcustom gnus-catchup-mark ?C + "*Mark used for articles that are caught up." + :group 'gnus-summary-marks + :type 'character) + +(defcustom gnus-replied-mark ?A + "*Mark used for articles that have been replied to." + :group 'gnus-summary-marks + :type 'character) + +(defcustom gnus-cached-mark ?* + "*Mark used for articles that are in the cache." + :group 'gnus-summary-marks + :type 'character) + +(defcustom gnus-saved-mark ?S + "*Mark used for articles that have been saved to." + :group 'gnus-summary-marks + :type 'character) + +(defcustom gnus-ancient-mark ?O + "*Mark used for ancient articles." + :group 'gnus-summary-marks + :type 'character) + +(defcustom gnus-sparse-mark ?Q + "*Mark used for sparsely reffed articles." + :group 'gnus-summary-marks + :type 'character) + +(defcustom gnus-canceled-mark ?G + "*Mark used for canceled articles." + :group 'gnus-summary-marks + :type 'character) + +(defcustom gnus-duplicate-mark ?M + "*Mark used for duplicate articles." + :group 'gnus-summary-marks + :type 'character) + +(defcustom gnus-score-over-mark ?+ + "*Score mark used for articles with high scores." + :group 'gnus-summary-marks + :type 'character) + +(defcustom gnus-score-below-mark ?- + "*Score mark used for articles with low scores." + :group 'gnus-summary-marks + :type 'character) + +(defcustom gnus-empty-thread-mark ? + "*There is no thread under the article." + :group 'gnus-summary-marks + :type 'character) + +(defcustom gnus-not-empty-thread-mark ?= + "*There is a thread under the article." + :group 'gnus-summary-marks + :type 'character) + +(defcustom gnus-view-pseudo-asynchronously nil + "*If non-nil, Gnus will view pseudo-articles asynchronously." + :group 'gnus-extract-view + :type 'boolean) + +(defcustom gnus-view-pseudos nil + "*If `automatic', pseudo-articles will be viewed automatically. +If `not-confirm', pseudos will be viewed automatically, and the user +will not be asked to confirm the command." + :group 'gnus-extract-view + :type '(choice (const :tag "off" nil) + (const automatic) + (const not-confirm))) + +(defcustom gnus-view-pseudos-separately t + "*If non-nil, one pseudo-article will be created for each file to be viewed. +If nil, all files that use the same viewing command will be given as a +list of parameters to that command." + :group 'gnus-extract-view + :type 'boolean) + +(defcustom gnus-insert-pseudo-articles t + "*If non-nil, insert pseudo-articles when decoding articles." + :group 'gnus-extract-view + :type 'boolean) + +(defcustom gnus-summary-dummy-line-format + "* %(: :%) %S\n" + "*The format specification for the dummy roots in the summary buffer. +It works along the same lines as a normal formatting string, +with some simple extensions. + +%S The subject" + :group 'gnus-threading + :type 'string) + +(defcustom gnus-summary-mode-line-format "Gnus: %%b [%A] %Z" + "*The format specification for the summary mode line. +It works along the same lines as a normal formatting string, +with some simple extensions: + +%G Group name +%p Unprefixed group name +%A Current article number +%V Gnus version +%U Number of unread articles in the group +%e Number of unselected articles in the group +%Z A string with unread/unselected article counts +%g Shortish group name +%S Subject of the current article +%u User-defined spec +%s Current score file name +%d Number of dormant articles +%r Number of articles that have been marked as read in this session +%E Number of articles expunged by the score files" + :group 'gnus-summary-format + :type 'string) + +(defcustom gnus-summary-mark-below 0 + "*Mark all articles with a score below this variable as read. +This variable is local to each summary buffer and usually set by the +score file." + :group 'gnus-score + :type 'integer) + +(defcustom gnus-article-sort-functions '(gnus-article-sort-by-number) + "*List of functions used for sorting articles in the summary buffer. +This variable is only used when not using a threaded display." + :group 'gnus-summary-sort + :type '(repeat (choice (function-item gnus-article-sort-by-number) + (function-item gnus-article-sort-by-author) + (function-item gnus-article-sort-by-subject) + (function-item gnus-article-sort-by-date) + (function-item gnus-article-sort-by-score) + (function :tag "other")))) + +(defcustom gnus-thread-sort-functions '(gnus-thread-sort-by-number) + "*List of functions used for sorting threads in the summary buffer. +By default, threads are sorted by article number. + +Each function takes two threads and return non-nil if the first thread +should be sorted before the other. If you use more than one function, +the primary sort function should be the last. You should probably +always include `gnus-thread-sort-by-number' in the list of sorting +functions -- preferably first. + +Ready-made functions include `gnus-thread-sort-by-number', +`gnus-thread-sort-by-author', `gnus-thread-sort-by-subject', +`gnus-thread-sort-by-date', `gnus-thread-sort-by-score' and +`gnus-thread-sort-by-total-score' (see `gnus-thread-score-function')." + :group 'gnus-summary-sort + :type '(repeat (choice (function-item gnus-thread-sort-by-number) + (function-item gnus-thread-sort-by-author) + (function-item gnus-thread-sort-by-subject) + (function-item gnus-thread-sort-by-date) + (function-item gnus-thread-sort-by-score) + (function-item gnus-thread-sort-by-total-score) + (function :tag "other")))) + +(defcustom gnus-thread-score-function '+ + "*Function used for calculating the total score of a thread. + +The function is called with the scores of the article and each +subthread and should then return the score of the thread. + +Some functions you can use are `+', `max', or `min'." + :group 'gnus-summary-sort + :type 'function) + +(defcustom gnus-summary-expunge-below nil + "All articles that have a score less than this variable will be expunged." + :group 'gnus-score + :type '(choice (const :tag "off" nil) + integer)) + +(defcustom gnus-thread-expunge-below nil + "All threads that have a total score less than this variable will be expunged. +See `gnus-thread-score-function' for en explanation of what a +\"thread score\" is." + :group 'gnus-treading + :group 'gnus-score + :type '(choice (const :tag "off" nil) + integer)) + +(defcustom gnus-summary-mode-hook nil + "*A hook for Gnus summary mode. +This hook is run before any variables are set in the summary buffer." + :group 'gnus-summary-various + :type 'hook) + +(defcustom gnus-summary-menu-hook nil + "*Hook run after the creation of the summary mode menu." + :group 'gnus-summary-visual + :type 'hook) + +(defcustom gnus-summary-exit-hook nil + "*A hook called on exit from the summary buffer. +It will be called with point in the group buffer." + :group 'gnus-summary-exit + :type 'hook) + +(defcustom gnus-summary-prepare-hook nil + "*A hook called after the summary buffer has been generated. +If you want to modify the summary buffer, you can use this hook." + :group 'gnus-summary-various + :type 'hook) + +(defcustom gnus-summary-generate-hook nil + "*A hook run just before generating the summary buffer. +This hook is commonly used to customize threading variables and the +like." + :group 'gnus-summary-various + :type 'hook) + +(defcustom gnus-select-group-hook nil + "*A hook called when a newsgroup is selected. + +If you'd like to simplify subjects like the +`gnus-summary-next-same-subject' command does, you can use the +following hook: + + (setq gnus-select-group-hook + (list + (lambda () + (mapcar (lambda (header) + (mail-header-set-subject + header + (gnus-simplify-subject + (mail-header-subject header) 're-only))) + gnus-newsgroup-headers))))" + :group 'gnus-group-select + :type 'hook) + +(defcustom gnus-select-article-hook nil + "*A hook called when an article is selected." + :group 'gnus-summary-choose + :type 'hook) + +(defcustom gnus-visual-mark-article-hook + (list 'gnus-highlight-selected-summary) + "*Hook run after selecting an article in the summary buffer. +It is meant to be used for highlighting the article in some way. It +is not run if `gnus-visual' is nil." + :group 'gnus-summary-visual + :type 'hook) + +(defcustom gnus-parse-headers-hook + (list 'gnus-decode-rfc1522) + "*A hook called before parsing the headers." + :group 'gnus-various + :type 'hook) + +(defcustom gnus-exit-group-hook nil + "*A hook called when exiting (not quitting) summary mode." + :group 'gnus-various + :type 'hook) + +(defcustom gnus-summary-update-hook + (list 'gnus-summary-highlight-line) + "*A hook called when a summary line is changed. +The hook will not be called if `gnus-visual' is nil. + +The default function `gnus-summary-highlight-line' will +highlight the line according to the `gnus-summary-highlight' +variable." + :group 'gnus-summary-visual + :type 'hook) + +(defcustom gnus-mark-article-hook '(gnus-summary-mark-read-and-unread-as-read) + "*A hook called when an article is selected for the first time. +The hook is intended to mark an article as read (or unread) +automatically when it is selected." + :group 'gnus-summary-choose + :type 'hook) + +(defcustom gnus-group-no-more-groups-hook nil + "*A hook run when returning to group mode having no more (unread) groups." + :group 'gnus-group-select + :type 'hook) + +(defcustom gnus-summary-selected-face 'gnus-summary-selected-face + "Face used for highlighting the current article in the summary buffer." + :group 'gnus-summary-visual + :type 'face) + +(defcustom gnus-summary-highlight + '(((= mark gnus-canceled-mark) + . gnus-summary-cancelled-face) + ((and (> score default) + (or (= mark gnus-dormant-mark) + (= mark gnus-ticked-mark))) + . gnus-summary-high-ticked-face) + ((and (< score default) + (or (= mark gnus-dormant-mark) + (= mark gnus-ticked-mark))) + . gnus-summary-low-ticked-face) + ((or (= mark gnus-dormant-mark) + (= mark gnus-ticked-mark)) + . gnus-summary-normal-ticked-face) + ((and (> score default) (= mark gnus-ancient-mark)) + . gnus-summary-high-ancient-face) + ((and (< score default) (= mark gnus-ancient-mark)) + . gnus-summary-low-ancient-face) + ((= mark gnus-ancient-mark) + . gnus-summary-normal-ancient-face) + ((and (> score default) (= mark gnus-unread-mark)) + . gnus-summary-high-unread-face) + ((and (< score default) (= mark gnus-unread-mark)) + . gnus-summary-low-unread-face) + ((and (= mark gnus-unread-mark)) + . gnus-summary-normal-unread-face) + ((> score default) + . gnus-summary-high-read-face) + ((< score default) + . gnus-summary-low-read-face) + (t + . gnus-summary-normal-read-face)) + "Controls the highlighting of summary buffer lines. + +A list of (FORM . FACE) pairs. When deciding how a a particular +summary line should be displayed, each form is evaluated. The content +of the face field after the first true form is used. You can change +how those summary lines are displayed, by editing the face field. + +You can use the following variables in the FORM field. + +score: The articles score +default: The default article score. +below: The score below which articles are automatically marked as read. +mark: The articles mark." + :group 'gnus-summary-visual + :type '(repeat (cons (sexp :tag "Form" nil) + face))) + +;;; Internal variables + +(defvar gnus-scores-exclude-files nil) + +(defvar gnus-summary-display-table + ;; Change the display table. Odd characters have a tendency to mess + ;; up nicely formatted displays - we make all possible glyphs + ;; display only a single character. + + ;; We start from the standard display table, if any. + (let ((table (or (copy-sequence standard-display-table) + (make-display-table))) + ;; Nix out all the control chars... + (i 32)) + (while (>= (setq i (1- i)) 0) + (aset table i [??])) + ;; ... but not newline and cr, of course. (cr is necessary for the + ;; selective display). + (aset table ?\n nil) + (aset table ?\r nil) + ;; We nix out any glyphs over 126 that are not set already. + (let ((i 256)) + (while (>= (setq i (1- i)) 127) + ;; Only modify if the entry is nil. + (or (aref table i) + (aset table i [??])))) + table) + "Display table used in summary mode buffers.") + +(defvar gnus-original-article nil) +(defvar gnus-article-internal-prepare-hook nil) +(defvar gnus-newsgroup-process-stack nil) + +(defvar gnus-thread-indent-array nil) +(defvar gnus-thread-indent-array-level gnus-thread-indent-level) + +;; Avoid highlighting in kill files. +(defvar gnus-summary-inhibit-highlight nil) +(defvar gnus-newsgroup-selected-overlay nil) +(defvar gnus-inhibit-limiting nil) +(defvar gnus-newsgroup-adaptive-score-file nil) +(defvar gnus-current-score-file nil) +(defvar gnus-current-move-group nil) +(defvar gnus-current-copy-group nil) +(defvar gnus-current-crosspost-group nil) + +(defvar gnus-newsgroup-dependencies nil) +(defvar gnus-newsgroup-adaptive nil) +(defvar gnus-summary-display-article-function nil) +(defvar gnus-summary-highlight-line-function nil + "Function called after highlighting a summary line.") + +(defvar gnus-summary-line-format-alist + `((?N ,(macroexpand '(mail-header-number gnus-tmp-header)) ?d) + (?S ,(macroexpand '(mail-header-subject gnus-tmp-header)) ?s) + (?s gnus-tmp-subject-or-nil ?s) + (?n gnus-tmp-name ?s) + (?A (car (cdr (funcall gnus-extract-address-components gnus-tmp-from))) + ?s) + (?a (or (car (funcall gnus-extract-address-components gnus-tmp-from)) + gnus-tmp-from) ?s) + (?F gnus-tmp-from ?s) + (?x ,(macroexpand '(mail-header-xref gnus-tmp-header)) ?s) + (?D ,(macroexpand '(mail-header-date gnus-tmp-header)) ?s) + (?d (gnus-dd-mmm (mail-header-date gnus-tmp-header)) ?s) + (?o (gnus-date-iso8601 gnus-tmp-header) ?s) + (?M ,(macroexpand '(mail-header-id gnus-tmp-header)) ?s) + (?r ,(macroexpand '(mail-header-references gnus-tmp-header)) ?s) + (?c (or (mail-header-chars gnus-tmp-header) 0) ?d) + (?L gnus-tmp-lines ?d) + (?I gnus-tmp-indentation ?s) + (?T (if (= gnus-tmp-level 0) "" (make-string (frame-width) ? )) ?s) + (?R gnus-tmp-replied ?c) + (?\[ gnus-tmp-opening-bracket ?c) + (?\] gnus-tmp-closing-bracket ?c) + (?\> (make-string gnus-tmp-level ? ) ?s) + (?\< (make-string (max 0 (- 20 gnus-tmp-level)) ? ) ?s) + (?i gnus-tmp-score ?d) + (?z gnus-tmp-score-char ?c) + (?l (bbb-grouplens-score gnus-tmp-header) ?s) + (?V (gnus-thread-total-score (and (boundp 'thread) (car thread))) ?d) + (?U gnus-tmp-unread ?c) + (?t (gnus-summary-number-of-articles-in-thread + (and (boundp 'thread) (car thread)) gnus-tmp-level) + ?d) + (?e (gnus-summary-number-of-articles-in-thread + (and (boundp 'thread) (car thread)) gnus-tmp-level t) + ?c) + (?u gnus-tmp-user-defined ?s) + (?P (gnus-pick-line-number) ?d)) + "An alist of format specifications that can appear in summary lines, +and what variables they correspond with, along with the type of the +variable (string, integer, character, etc).") + +(defvar gnus-summary-dummy-line-format-alist + `((?S gnus-tmp-subject ?s) + (?N gnus-tmp-number ?d) + (?u gnus-tmp-user-defined ?s))) + +(defvar gnus-summary-mode-line-format-alist + `((?G gnus-tmp-group-name ?s) + (?g (gnus-short-group-name gnus-tmp-group-name) ?s) + (?p (gnus-group-real-name gnus-tmp-group-name) ?s) + (?A gnus-tmp-article-number ?d) + (?Z gnus-tmp-unread-and-unselected ?s) + (?V gnus-version ?s) + (?U gnus-tmp-unread-and-unticked ?d) + (?S gnus-tmp-subject ?s) + (?e gnus-tmp-unselected ?d) + (?u gnus-tmp-user-defined ?s) + (?d (length gnus-newsgroup-dormant) ?d) + (?t (length gnus-newsgroup-marked) ?d) + (?r (length gnus-newsgroup-reads) ?d) + (?E gnus-newsgroup-expunged-tally ?d) + (?s (gnus-current-score-file-nondirectory) ?s))) + +(defvar gnus-last-search-regexp nil + "Default regexp for article search command.") + +(defvar gnus-last-shell-command nil + "Default shell command on article.") + +(defvar gnus-newsgroup-begin nil) +(defvar gnus-newsgroup-end nil) +(defvar gnus-newsgroup-last-rmail nil) +(defvar gnus-newsgroup-last-mail nil) +(defvar gnus-newsgroup-last-folder nil) +(defvar gnus-newsgroup-last-file nil) +(defvar gnus-newsgroup-auto-expire nil) +(defvar gnus-newsgroup-active nil) + +(defvar gnus-newsgroup-data nil) +(defvar gnus-newsgroup-data-reverse nil) +(defvar gnus-newsgroup-limit nil) +(defvar gnus-newsgroup-limits nil) + +(defvar gnus-newsgroup-unreads nil + "List of unread articles in the current newsgroup.") + +(defvar gnus-newsgroup-unselected nil + "List of unselected unread articles in the current newsgroup.") + +(defvar gnus-newsgroup-reads nil + "Alist of read articles and article marks in the current newsgroup.") + +(defvar gnus-newsgroup-expunged-tally nil) + +(defvar gnus-newsgroup-marked nil + "List of ticked articles in the current newsgroup (a subset of unread art).") + +(defvar gnus-newsgroup-killed nil + "List of ranges of articles that have been through the scoring process.") + +(defvar gnus-newsgroup-cached nil + "List of articles that come from the article cache.") + +(defvar gnus-newsgroup-saved nil + "List of articles that have been saved.") + +(defvar gnus-newsgroup-kill-headers nil) + +(defvar gnus-newsgroup-replied nil + "List of articles that have been replied to in the current newsgroup.") + +(defvar gnus-newsgroup-expirable nil + "List of articles in the current newsgroup that can be expired.") + +(defvar gnus-newsgroup-processable nil + "List of articles in the current newsgroup that can be processed.") + +(defvar gnus-newsgroup-bookmarks nil + "List of articles in the current newsgroup that have bookmarks.") + +(defvar gnus-newsgroup-dormant nil + "List of dormant articles in the current newsgroup.") + +(defvar gnus-newsgroup-scored nil + "List of scored articles in the current newsgroup.") + +(defvar gnus-newsgroup-headers nil + "List of article headers in the current newsgroup.") + +(defvar gnus-newsgroup-threads nil) + +(defvar gnus-newsgroup-prepared nil + "Whether the current group has been prepared properly.") + +(defvar gnus-newsgroup-ancient nil + "List of `gnus-fetch-old-headers' articles in the current newsgroup.") + +(defvar gnus-newsgroup-sparse nil) + +(defvar gnus-current-article nil) +(defvar gnus-article-current nil) +(defvar gnus-current-headers nil) +(defvar gnus-have-all-headers nil) +(defvar gnus-last-article nil) +(defvar gnus-newsgroup-history nil) + +(defconst gnus-summary-local-variables + '(gnus-newsgroup-name + gnus-newsgroup-begin gnus-newsgroup-end + gnus-newsgroup-last-rmail gnus-newsgroup-last-mail + gnus-newsgroup-last-folder gnus-newsgroup-last-file + gnus-newsgroup-auto-expire gnus-newsgroup-unreads + gnus-newsgroup-unselected gnus-newsgroup-marked + gnus-newsgroup-reads gnus-newsgroup-saved + gnus-newsgroup-replied gnus-newsgroup-expirable + gnus-newsgroup-processable gnus-newsgroup-killed + gnus-newsgroup-bookmarks gnus-newsgroup-dormant + gnus-newsgroup-headers gnus-newsgroup-threads + gnus-newsgroup-prepared gnus-summary-highlight-line-function + gnus-current-article gnus-current-headers gnus-have-all-headers + gnus-last-article gnus-article-internal-prepare-hook + gnus-newsgroup-dependencies gnus-newsgroup-selected-overlay + gnus-newsgroup-scored gnus-newsgroup-kill-headers + gnus-thread-expunge-below + gnus-score-alist gnus-current-score-file gnus-summary-expunge-below + (gnus-summary-mark-below . global) + gnus-newsgroup-active gnus-scores-exclude-files + gnus-newsgroup-history gnus-newsgroup-ancient + gnus-newsgroup-sparse gnus-newsgroup-process-stack + (gnus-newsgroup-adaptive . gnus-use-adaptive-scoring) + gnus-newsgroup-adaptive-score-file (gnus-reffed-article-number . -1) + (gnus-newsgroup-expunged-tally . 0) + gnus-cache-removable-articles gnus-newsgroup-cached + gnus-newsgroup-data gnus-newsgroup-data-reverse + gnus-newsgroup-limit gnus-newsgroup-limits) + "Variables that are buffer-local to the summary buffers.") + +;; Byte-compiler warning. +(defvar gnus-article-mode-map) + +;; Subject simplification. + +(defsubst gnus-simplify-subject-re (subject) + "Remove \"Re:\" from subject lines." + (if (string-match "^[Rr][Ee]: *" subject) + (substring subject (match-end 0)) + subject)) + +(defun gnus-simplify-subject (subject &optional re-only) + "Remove `Re:' and words in parentheses. +If RE-ONLY is non-nil, strip leading `Re:'s only." + (let ((case-fold-search t)) ;Ignore case. + ;; Remove `Re:', `Re^N:', `Re(n)', and `Re[n]:'. + (when (string-match "\\`\\(re\\([[(^][0-9]+[])]?\\)?:[ \t]*\\)+" subject) + (setq subject (substring subject (match-end 0)))) + ;; Remove uninteresting prefixes. + (when (and (not re-only) + gnus-simplify-ignored-prefixes + (string-match gnus-simplify-ignored-prefixes subject)) + (setq subject (substring subject (match-end 0)))) + ;; Remove words in parentheses from end. + (unless re-only + (while (string-match "[ \t\n]*([^()]*)[ \t\n]*\\'" subject) + (setq subject (substring subject 0 (match-beginning 0))))) + ;; Return subject string. + subject)) + +;; Remove any leading "re:"s, any trailing paren phrases, and simplify +;; all whitespace. +(defsubst gnus-simplify-buffer-fuzzy-step (regexp &optional newtext) + (goto-char (point-min)) + (while (re-search-forward regexp nil t) + (replace-match (or newtext "")))) + +(defun gnus-simplify-buffer-fuzzy () + "Simplify string in the buffer fuzzily. +The string in the accessible portion of the current buffer is simplified. +It is assumed to be a single-line subject. +Whitespace is generally cleaned up, and miscellaneous leading/trailing +matter is removed. Additional things can be deleted by setting +gnus-simplify-subject-fuzzy-regexp." + (let ((case-fold-search t) + (modified-tick)) + (gnus-simplify-buffer-fuzzy-step "\t" " ") + + (while (not (eq modified-tick (buffer-modified-tick))) + (setq modified-tick (buffer-modified-tick)) + (cond + ((listp gnus-simplify-subject-fuzzy-regexp) + (mapcar 'gnus-simplify-buffer-fuzzy-step + gnus-simplify-subject-fuzzy-regexp)) + (gnus-simplify-subject-fuzzy-regexp + (gnus-simplify-buffer-fuzzy-step gnus-simplify-subject-fuzzy-regexp))) + (gnus-simplify-buffer-fuzzy-step "^ *\\[[-+?*!][-+?*!]\\] *") + (gnus-simplify-buffer-fuzzy-step + "^ *\\(re\\|fw\\|fwd\\)[[{(^0-9]*[])}]?[:;] *") + (gnus-simplify-buffer-fuzzy-step "^[[].*:\\( .*\\)[]]$" "\\1")) + + (gnus-simplify-buffer-fuzzy-step " *[[{(][^()\n]*[]})] *$") + (gnus-simplify-buffer-fuzzy-step " +" " ") + (gnus-simplify-buffer-fuzzy-step " $") + (gnus-simplify-buffer-fuzzy-step "^ +"))) + +(defun gnus-simplify-subject-fuzzy (subject) + "Simplify a subject string fuzzily. +See gnus-simplify-buffer-fuzzy for details." + (save-excursion + (gnus-set-work-buffer) + (let ((case-fold-search t)) + (insert subject) + (inline (gnus-simplify-buffer-fuzzy)) + (buffer-string)))) + +(defsubst gnus-simplify-subject-fully (subject) + "Simplify a subject string according to gnus-summary-gather-subject-limit." + (cond + ((null gnus-summary-gather-subject-limit) + (gnus-simplify-subject-re subject)) + ((eq gnus-summary-gather-subject-limit 'fuzzy) + (gnus-simplify-subject-fuzzy subject)) + ((numberp gnus-summary-gather-subject-limit) + (gnus-limit-string (gnus-simplify-subject-re subject) + gnus-summary-gather-subject-limit)) + (t + subject))) + +(defsubst gnus-subject-equal (s1 s2 &optional simple-first) + "Check whether two subjects are equal. If optional argument +simple-first is t, first argument is already simplified." + (cond + ((null simple-first) + (equal (gnus-simplify-subject-fully s1) + (gnus-simplify-subject-fully s2))) + (t + (equal s1 + (gnus-simplify-subject-fully s2))))) + +(defun gnus-offer-save-summaries () + "Offer to save all active summary buffers." + (save-excursion + (let ((buflist (buffer-list)) + buffers bufname) + ;; Go through all buffers and find all summaries. + (while buflist + (and (setq bufname (buffer-name (car buflist))) + (string-match "Summary" bufname) + (save-excursion + (set-buffer bufname) + ;; We check that this is, indeed, a summary buffer. + (and (eq major-mode 'gnus-summary-mode) + ;; Also make sure this isn't bogus. + gnus-newsgroup-prepared)) + (push bufname buffers)) + (setq buflist (cdr buflist))) + ;; Go through all these summary buffers and offer to save them. + (when buffers + (map-y-or-n-p + "Update summary buffer %s? " + (lambda (buf) (set-buffer buf) (gnus-summary-exit)) + buffers))))) + +(defun gnus-summary-bubble-group () + "Increase the score of the current group. +This is a handy function to add to `gnus-summary-exit-hook' to +increase the score of each group you read." + (gnus-group-add-score gnus-newsgroup-name)) + + +;;; +;;; Gnus summary mode +;;; + +(put 'gnus-summary-mode 'mode-class 'special) + +(when t + ;; Non-orthogonal keys + + (gnus-define-keys gnus-summary-mode-map + " " gnus-summary-next-page + "\177" gnus-summary-prev-page + [delete] gnus-summary-prev-page + "\r" gnus-summary-scroll-up + "n" gnus-summary-next-unread-article + "p" gnus-summary-prev-unread-article + "N" gnus-summary-next-article + "P" gnus-summary-prev-article + "\M-\C-n" gnus-summary-next-same-subject + "\M-\C-p" gnus-summary-prev-same-subject + "\M-n" gnus-summary-next-unread-subject + "\M-p" gnus-summary-prev-unread-subject + "." gnus-summary-first-unread-article + "," gnus-summary-best-unread-article + "\M-s" gnus-summary-search-article-forward + "\M-r" gnus-summary-search-article-backward + "<" gnus-summary-beginning-of-article + ">" gnus-summary-end-of-article + "j" gnus-summary-goto-article + "^" gnus-summary-refer-parent-article + "\M-^" gnus-summary-refer-article + "u" gnus-summary-tick-article-forward + "!" gnus-summary-tick-article-forward + "U" gnus-summary-tick-article-backward + "d" gnus-summary-mark-as-read-forward + "D" gnus-summary-mark-as-read-backward + "E" gnus-summary-mark-as-expirable + "\M-u" gnus-summary-clear-mark-forward + "\M-U" gnus-summary-clear-mark-backward + "k" gnus-summary-kill-same-subject-and-select + "\C-k" gnus-summary-kill-same-subject + "\M-\C-k" gnus-summary-kill-thread + "\M-\C-l" gnus-summary-lower-thread + "e" gnus-summary-edit-article + "#" gnus-summary-mark-as-processable + "\M-#" gnus-summary-unmark-as-processable + "\M-\C-t" gnus-summary-toggle-threads + "\M-\C-s" gnus-summary-show-thread + "\M-\C-h" gnus-summary-hide-thread + "\M-\C-f" gnus-summary-next-thread + "\M-\C-b" gnus-summary-prev-thread + "\M-\C-u" gnus-summary-up-thread + "\M-\C-d" gnus-summary-down-thread + "&" gnus-summary-execute-command + "c" gnus-summary-catchup-and-exit + "\C-w" gnus-summary-mark-region-as-read + "\C-t" gnus-summary-toggle-truncation + "?" gnus-summary-mark-as-dormant + "\C-c\M-\C-s" gnus-summary-limit-include-expunged + "\C-c\C-s\C-n" gnus-summary-sort-by-number + "\C-c\C-s\C-l" gnus-summary-sort-by-lines + "\C-c\C-s\C-a" gnus-summary-sort-by-author + "\C-c\C-s\C-s" gnus-summary-sort-by-subject + "\C-c\C-s\C-d" gnus-summary-sort-by-date + "\C-c\C-s\C-i" gnus-summary-sort-by-score + "=" 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 + "\M-t" gnus-summary-toggle-mime + "f" gnus-summary-followup + "F" gnus-summary-followup-with-original + "C" gnus-summary-cancel-article + "r" gnus-summary-reply + "R" gnus-summary-reply-with-original + "\C-c\C-f" gnus-summary-mail-forward + "o" gnus-summary-save-article + "\C-o" gnus-summary-save-article-mail + "|" gnus-summary-pipe-output + "\M-k" gnus-summary-edit-local-kill + "\M-K" gnus-summary-edit-global-kill + ;; "V" gnus-version + "\C-c\C-d" gnus-summary-describe-group + "q" gnus-summary-exit + "Q" gnus-summary-exit-no-update + "\C-c\C-i" gnus-info-find-node + gnus-mouse-2 gnus-mouse-pick-article + "m" gnus-summary-mail-other-window + "a" gnus-summary-post-news + "x" gnus-summary-limit-to-unread + "s" gnus-summary-isearch-article + "t" gnus-article-hide-headers + "g" gnus-summary-show-article + "l" gnus-summary-goto-last-article + "\C-c\C-v\C-v" gnus-uu-decode-uu-view + "\C-d" gnus-summary-enter-digest-group + "\M-\C-d" gnus-summary-read-document + "\C-c\C-b" gnus-bug + "*" gnus-cache-enter-article + "\M-*" gnus-cache-remove-article + "\M-&" gnus-summary-universal-argument + "\C-l" gnus-recenter + "I" gnus-summary-increase-score + "L" gnus-summary-lower-score + + "V" gnus-summary-score-map + "X" gnus-uu-extract-map + "S" gnus-summary-send-map) + + ;; Sort of orthogonal keymap + (gnus-define-keys (gnus-summary-mark-map "M" gnus-summary-mode-map) + "t" gnus-summary-tick-article-forward + "!" gnus-summary-tick-article-forward + "d" gnus-summary-mark-as-read-forward + "r" gnus-summary-mark-as-read-forward + "c" gnus-summary-clear-mark-forward + " " gnus-summary-clear-mark-forward + "e" gnus-summary-mark-as-expirable + "x" gnus-summary-mark-as-expirable + "?" gnus-summary-mark-as-dormant + "b" gnus-summary-set-bookmark + "B" gnus-summary-remove-bookmark + "#" gnus-summary-mark-as-processable + "\M-#" gnus-summary-unmark-as-processable + "S" gnus-summary-limit-include-expunged + "C" gnus-summary-catchup + "H" gnus-summary-catchup-to-here + "\C-c" gnus-summary-catchup-all + "k" gnus-summary-kill-same-subject-and-select + "K" gnus-summary-kill-same-subject + "P" gnus-uu-mark-map) + + (gnus-define-keys (gnus-summary-mscore-map "V" gnus-summary-mark-map) + "c" gnus-summary-clear-above + "u" gnus-summary-tick-above + "m" gnus-summary-mark-above + "k" gnus-summary-kill-below) + + (gnus-define-keys (gnus-summary-limit-map "/" gnus-summary-mode-map) + "/" gnus-summary-limit-to-subject + "n" gnus-summary-limit-to-articles + "w" gnus-summary-pop-limit + "s" gnus-summary-limit-to-subject + "a" gnus-summary-limit-to-author + "u" gnus-summary-limit-to-unread + "m" gnus-summary-limit-to-marks + "v" gnus-summary-limit-to-score + "D" gnus-summary-limit-include-dormant + "d" gnus-summary-limit-exclude-dormant + "t" gnus-summary-limit-to-age + "E" gnus-summary-limit-include-expunged + "c" gnus-summary-limit-exclude-childless-dormant + "C" gnus-summary-limit-mark-excluded-as-read) + + (gnus-define-keys (gnus-summary-goto-map "G" gnus-summary-mode-map) + "n" gnus-summary-next-unread-article + "p" gnus-summary-prev-unread-article + "N" gnus-summary-next-article + "P" gnus-summary-prev-article + "\C-n" gnus-summary-next-same-subject + "\C-p" gnus-summary-prev-same-subject + "\M-n" gnus-summary-next-unread-subject + "\M-p" gnus-summary-prev-unread-subject + "f" gnus-summary-first-unread-article + "b" gnus-summary-best-unread-article + "j" gnus-summary-goto-article + "g" gnus-summary-goto-subject + "l" gnus-summary-goto-last-article + "p" gnus-summary-pop-article) + + (gnus-define-keys (gnus-summary-thread-map "T" gnus-summary-mode-map) + "k" gnus-summary-kill-thread + "l" gnus-summary-lower-thread + "i" gnus-summary-raise-thread + "T" gnus-summary-toggle-threads + "t" gnus-summary-rethread-current + "^" gnus-summary-reparent-thread + "s" gnus-summary-show-thread + "S" gnus-summary-show-all-threads + "h" gnus-summary-hide-thread + "H" gnus-summary-hide-all-threads + "n" gnus-summary-next-thread + "p" gnus-summary-prev-thread + "u" gnus-summary-up-thread + "o" gnus-summary-top-thread + "d" gnus-summary-down-thread + "#" gnus-uu-mark-thread + "\M-#" gnus-uu-unmark-thread) + + (gnus-define-keys (gnus-summary-buffer-map "Y" gnus-summary-mode-map) + "g" gnus-summary-prepare + "c" gnus-summary-insert-cached-articles) + + (gnus-define-keys (gnus-summary-exit-map "Z" gnus-summary-mode-map) + "c" gnus-summary-catchup-and-exit + "C" gnus-summary-catchup-all-and-exit + "E" gnus-summary-exit-no-update + "Q" gnus-summary-exit + "Z" gnus-summary-exit + "n" gnus-summary-catchup-and-goto-next-group + "R" gnus-summary-reselect-current-group + "G" gnus-summary-rescan-group + "N" gnus-summary-next-group + "s" gnus-summary-save-newsrc + "P" gnus-summary-prev-group) + + (gnus-define-keys (gnus-summary-article-map "A" gnus-summary-mode-map) + " " gnus-summary-next-page + "n" gnus-summary-next-page + "\177" gnus-summary-prev-page + [delete] gnus-summary-prev-page + "p" gnus-summary-prev-page + "\r" gnus-summary-scroll-up + "<" gnus-summary-beginning-of-article + ">" gnus-summary-end-of-article + "b" gnus-summary-beginning-of-article + "e" gnus-summary-end-of-article + "^" gnus-summary-refer-parent-article + "r" gnus-summary-refer-parent-article + "R" gnus-summary-refer-references + "g" gnus-summary-show-article + "s" gnus-summary-isearch-article + "P" gnus-summary-print-article) + + (gnus-define-keys (gnus-summary-wash-map "W" gnus-summary-mode-map) + "b" gnus-article-add-buttons + "B" gnus-article-add-buttons-to-head + "o" gnus-article-treat-overstrike + "e" gnus-article-emphasize + "w" gnus-article-fill-cited-article + "c" gnus-article-remove-cr + "q" gnus-article-de-quoted-unreadable + "f" gnus-article-display-x-face + "l" gnus-summary-stop-page-breaking + "r" gnus-summary-caesar-message + "t" gnus-article-hide-headers + "v" gnus-summary-verbose-headers + "m" gnus-summary-toggle-mime) + + (gnus-define-keys (gnus-summary-wash-hide-map "W" gnus-summary-wash-map) + "a" gnus-article-hide + "h" gnus-article-hide-headers + "b" gnus-article-hide-boring-headers + "s" gnus-article-hide-signature + "c" gnus-article-hide-citation + "p" gnus-article-hide-pgp + "P" gnus-article-hide-pem + "\C-c" gnus-article-hide-citation-maybe) + + (gnus-define-keys (gnus-summary-wash-highlight-map "H" gnus-summary-wash-map) + "a" gnus-article-highlight + "h" gnus-article-highlight-headers + "c" gnus-article-highlight-citation + "s" gnus-article-highlight-signature) + + (gnus-define-keys (gnus-summary-wash-time-map "T" gnus-summary-wash-map) + "z" gnus-article-date-ut + "u" gnus-article-date-ut + "l" gnus-article-date-local + "e" gnus-article-date-lapsed + "o" gnus-article-date-original + "s" gnus-article-date-user) + + (gnus-define-keys (gnus-summary-wash-empty-map "E" gnus-summary-wash-map) + "t" gnus-article-remove-trailing-blank-lines + "l" gnus-article-strip-leading-blank-lines + "m" gnus-article-strip-multiple-blank-lines + "a" gnus-article-strip-blank-lines) + + (gnus-define-keys (gnus-summary-help-map "H" gnus-summary-mode-map) + "v" gnus-version + "f" gnus-summary-fetch-faq + "d" gnus-summary-describe-group + "h" gnus-summary-describe-briefly + "i" gnus-info-find-node) + + (gnus-define-keys (gnus-summary-backend-map "B" gnus-summary-mode-map) + "e" gnus-summary-expire-articles + "\M-\C-e" gnus-summary-expire-articles-now + "\177" gnus-summary-delete-article + [delete] gnus-summary-delete-article + "m" gnus-summary-move-article + "r" gnus-summary-respool-article + "w" gnus-summary-edit-article + "c" gnus-summary-copy-article + "B" gnus-summary-crosspost-article + "q" gnus-summary-respool-query + "i" gnus-summary-import-article + "p" gnus-summary-article-posted-p) + + (gnus-define-keys (gnus-summary-save-map "O" gnus-summary-mode-map) + "o" gnus-summary-save-article + "m" gnus-summary-save-article-mail + "F" gnus-summary-write-article-file + "r" gnus-summary-save-article-rmail + "f" gnus-summary-save-article-file + "b" gnus-summary-save-article-body-file + "h" gnus-summary-save-article-folder + "v" gnus-summary-save-article-vm + "p" gnus-summary-pipe-output + "s" gnus-soup-add-article)) + +(defun gnus-summary-make-menu-bar () + (gnus-turn-off-edit-menu 'summary) + + (unless (boundp 'gnus-summary-misc-menu) + + (easy-menu-define + gnus-summary-kill-menu gnus-summary-mode-map "" + (cons + "Score" + (nconc + (list + ["Enter score..." gnus-summary-score-entry t] + ["Customize" gnus-score-customize t]) + (gnus-make-score-map 'increase) + (gnus-make-score-map 'lower) + '(("Mark" + ["Kill below" gnus-summary-kill-below t] + ["Mark above" gnus-summary-mark-above t] + ["Tick above" gnus-summary-tick-above t] + ["Clear above" gnus-summary-clear-above t]) + ["Current score" gnus-summary-current-score t] + ["Set score" gnus-summary-set-score t] + ["Switch current score file..." gnus-score-change-score-file t] + ["Set mark below..." gnus-score-set-mark-below t] + ["Set expunge below..." gnus-score-set-expunge-below t] + ["Edit current score file" gnus-score-edit-current-scores t] + ["Edit score file" gnus-score-edit-file t] + ["Trace score" gnus-score-find-trace t] + ["Find words" gnus-score-find-favourite-words t] + ["Rescore buffer" gnus-summary-rescore t] + ["Increase score..." gnus-summary-increase-score t] + ["Lower score..." gnus-summary-lower-score t])))) + + '(("Default header" + ["Ask" (gnus-score-set-default 'gnus-score-default-header nil) + :style radio + :selected (null gnus-score-default-header)] + ["From" (gnus-score-set-default 'gnus-score-default-header 'a) + :style radio + :selected (eq gnus-score-default-header 'a)] + ["Subject" (gnus-score-set-default 'gnus-score-default-header 's) + :style radio + :selected (eq gnus-score-default-header 's)] + ["Article body" + (gnus-score-set-default 'gnus-score-default-header 'b) + :style radio + :selected (eq gnus-score-default-header 'b )] + ["All headers" + (gnus-score-set-default 'gnus-score-default-header 'h) + :style radio + :selected (eq gnus-score-default-header 'h )] + ["Message-ID" (gnus-score-set-default 'gnus-score-default-header 'i) + :style radio + :selected (eq gnus-score-default-header 'i )] + ["Thread" (gnus-score-set-default 'gnus-score-default-header 't) + :style radio + :selected (eq gnus-score-default-header 't )] + ["Crossposting" + (gnus-score-set-default 'gnus-score-default-header 'x) + :style radio + :selected (eq gnus-score-default-header 'x )] + ["Lines" (gnus-score-set-default 'gnus-score-default-header 'l) + :style radio + :selected (eq gnus-score-default-header 'l )] + ["Date" (gnus-score-set-default 'gnus-score-default-header 'd) + :style radio + :selected (eq gnus-score-default-header 'd )] + ["Followups to author" + (gnus-score-set-default 'gnus-score-default-header 'f) + :style radio + :selected (eq gnus-score-default-header 'f )]) + ("Default type" + ["Ask" (gnus-score-set-default 'gnus-score-default-type nil) + :style radio + :selected (null gnus-score-default-type)] + ;; The `:active' key is commented out in the following, + ;; because the GNU Emacs hack to support radio buttons use + ;; active to indicate which button is selected. + ["Substring" (gnus-score-set-default 'gnus-score-default-type 's) + :style radio + ;; :active (not (memq gnus-score-default-header '(l d))) + :selected (eq gnus-score-default-type 's)] + ["Regexp" (gnus-score-set-default 'gnus-score-default-type 'r) + :style radio + ;; :active (not (memq gnus-score-default-header '(l d))) + :selected (eq gnus-score-default-type 'r)] + ["Exact" (gnus-score-set-default 'gnus-score-default-type 'e) + :style radio + ;; :active (not (memq gnus-score-default-header '(l d))) + :selected (eq gnus-score-default-type 'e)] + ["Fuzzy" (gnus-score-set-default 'gnus-score-default-type 'f) + :style radio + ;; :active (not (memq gnus-score-default-header '(l d))) + :selected (eq gnus-score-default-type 'f)] + ["Before date" (gnus-score-set-default 'gnus-score-default-type 'b) + :style radio + ;; :active (eq (gnus-score-default-header 'd)) + :selected (eq gnus-score-default-type 'b)] + ["At date" (gnus-score-set-default 'gnus-score-default-type 'n) + :style radio + ;; :active (eq (gnus-score-default-header 'd)) + :selected (eq gnus-score-default-type 'n)] + ["After date" (gnus-score-set-default 'gnus-score-default-type 'a) + :style radio + ;; :active (eq (gnus-score-default-header 'd)) + :selected (eq gnus-score-default-type 'a)] + ["Less than number" + (gnus-score-set-default 'gnus-score-default-type '<) + :style radio + ;; :active (eq (gnus-score-default-header 'l)) + :selected (eq gnus-score-default-type '<)] + ["Equal to number" + (gnus-score-set-default 'gnus-score-default-type '=) + :style radio + ;; :active (eq (gnus-score-default-header 'l)) + :selected (eq gnus-score-default-type '=)] + ["Greater than number" + (gnus-score-set-default 'gnus-score-default-type '>) + :style radio + ;; :active (eq (gnus-score-default-header 'l)) + :selected (eq gnus-score-default-type '>)]) + ["Default fold" gnus-score-default-fold-toggle + :style toggle + :selected gnus-score-default-fold] + ("Default duration" + ["Ask" (gnus-score-set-default 'gnus-score-default-duration nil) + :style radio + :selected (null gnus-score-default-duration)] + ["Permanent" + (gnus-score-set-default 'gnus-score-default-duration 'p) + :style radio + :selected (eq gnus-score-default-duration 'p)] + ["Temporary" + (gnus-score-set-default 'gnus-score-default-duration 't) + :style radio + :selected (eq gnus-score-default-duration 't)] + ["Immediate" + (gnus-score-set-default 'gnus-score-default-duration 'i) + :style radio + :selected (eq gnus-score-default-duration 'i)])) + + (easy-menu-define + gnus-summary-article-menu gnus-summary-mode-map "" + '("Article" + ("Hide" + ["All" gnus-article-hide t] + ["Headers" gnus-article-hide-headers t] + ["Signature" gnus-article-hide-signature t] + ["Citation" gnus-article-hide-citation t] + ["PGP" gnus-article-hide-pgp t] + ["Boring headers" gnus-article-hide-boring-headers t]) + ("Highlight" + ["All" gnus-article-highlight t] + ["Headers" gnus-article-highlight-headers t] + ["Signature" gnus-article-highlight-signature t] + ["Citation" gnus-article-highlight-citation t]) + ("Date" + ["Local" gnus-article-date-local t] + ["UT" gnus-article-date-ut t] + ["Original" gnus-article-date-original t] + ["Lapsed" gnus-article-date-lapsed t] + ["User-defined" gnus-article-date-user t]) + ("Washing" + ("Remove Blanks" + ["Leading" gnus-article-strip-leading-blank-lines t] + ["Multiple" gnus-article-strip-multiple-blank-lines t] + ["Trailing" gnus-article-remove-trailing-blank-lines t] + ["All of the above" gnus-article-strip-blank-lines t]) + ["Overstrike" gnus-article-treat-overstrike t] + ["Emphasis" gnus-article-emphasize t] + ["Word wrap" gnus-article-fill-cited-article t] + ["CR" gnus-article-remove-cr t] + ["Show X-Face" gnus-article-display-x-face t] + ["Quoted-Printable" gnus-article-de-quoted-unreadable t] + ["Rot 13" gnus-summary-caesar-message t] + ["Unix pipe" gnus-summary-pipe-message t] + ["Add buttons" gnus-article-add-buttons t] + ["Add buttons to head" gnus-article-add-buttons-to-head t] + ["Stop page breaking" gnus-summary-stop-page-breaking t] + ["Toggle MIME" gnus-summary-toggle-mime t] + ["Verbose header" gnus-summary-verbose-headers t] + ["Toggle header" gnus-summary-toggle-header t]) + ("Output" + ["Save in default format" gnus-summary-save-article t] + ["Save in file" gnus-summary-save-article-file t] + ["Save in Unix mail format" gnus-summary-save-article-mail t] + ["Write to file" gnus-summary-write-article-mail t] + ["Save in MH folder" gnus-summary-save-article-folder t] + ["Save in VM folder" gnus-summary-save-article-vm t] + ["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" gnus-summary-print-article t]) + ("Backend" + ["Respool article..." gnus-summary-respool-article t] + ["Move article..." gnus-summary-move-article + (gnus-check-backend-function + 'request-move-article gnus-newsgroup-name)] + ["Copy article..." gnus-summary-copy-article t] + ["Crosspost article..." gnus-summary-crosspost-article + (gnus-check-backend-function + 'request-replace-article gnus-newsgroup-name)] + ["Import file..." gnus-summary-import-article t] + ["Check if posted" gnus-summary-article-posted-p t] + ["Edit article" gnus-summary-edit-article + (not (gnus-group-read-only-p))] + ["Delete article" gnus-summary-delete-article + (gnus-check-backend-function + 'request-expire-articles gnus-newsgroup-name)] + ["Query respool" gnus-summary-respool-query t] + ["Delete expirable articles" gnus-summary-expire-articles-now + (gnus-check-backend-function + 'request-expire-articles gnus-newsgroup-name)]) + ("Extract" + ["Uudecode" gnus-uu-decode-uu t] + ["Uudecode and save" gnus-uu-decode-uu-and-save t] + ["Unshar" gnus-uu-decode-unshar t] + ["Unshar and save" gnus-uu-decode-unshar-and-save t] + ["Save" gnus-uu-decode-save t] + ["Binhex" gnus-uu-decode-binhex t] + ["Postscript" gnus-uu-decode-postscript t]) + ("Cache" + ["Enter article" gnus-cache-enter-article t] + ["Remove article" gnus-cache-remove-article t]) + ["Enter digest buffer" gnus-summary-enter-digest-group t] + ["Isearch article..." gnus-summary-isearch-article t] + ["Search articles forward..." gnus-summary-search-article-forward t] + ["Search articles backward..." gnus-summary-search-article-backward t] + ["Beginning of the article" gnus-summary-beginning-of-article t] + ["End of the article" gnus-summary-end-of-article t] + ["Fetch parent of article" gnus-summary-refer-parent-article t] + ["Fetch referenced articles" gnus-summary-refer-references t] + ["Fetch article with id..." gnus-summary-refer-article t] + ["Redisplay" gnus-summary-show-article t])) + + (easy-menu-define + gnus-summary-thread-menu gnus-summary-mode-map "" + '("Threads" + ["Toggle threading" gnus-summary-toggle-threads t] + ["Hide threads" gnus-summary-hide-all-threads t] + ["Show threads" gnus-summary-show-all-threads t] + ["Hide thread" gnus-summary-hide-thread t] + ["Show thread" gnus-summary-show-thread t] + ["Go to next thread" gnus-summary-next-thread t] + ["Go to previous thread" gnus-summary-prev-thread t] + ["Go down thread" gnus-summary-down-thread t] + ["Go up thread" gnus-summary-up-thread t] + ["Top of thread" gnus-summary-top-thread t] + ["Mark thread as read" gnus-summary-kill-thread t] + ["Lower thread score" gnus-summary-lower-thread t] + ["Raise thread score" gnus-summary-raise-thread t] + ["Rethread current" gnus-summary-rethread-current t] + )) + + (easy-menu-define + gnus-summary-post-menu gnus-summary-mode-map "" + '("Post" + ["Post an article" gnus-summary-post-news t] + ["Followup" gnus-summary-followup t] + ["Followup and yank" gnus-summary-followup-with-original t] + ["Supersede article" gnus-summary-supersede-article t] + ["Cancel article" gnus-summary-cancel-article t] + ["Reply" gnus-summary-reply t] + ["Reply and yank" gnus-summary-reply-with-original t] + ["Wide reply" gnus-summary-wide-reply t] + ["Wide reply and yank" gnus-summary-wide-reply-with-original t] + ["Mail forward" gnus-summary-mail-forward t] + ["Post forward" gnus-summary-post-forward t] + ["Digest and mail" gnus-uu-digest-mail-forward t] + ["Digest and post" gnus-uu-digest-post-forward t] + ["Resend message" gnus-summary-resend-message t] + ["Send bounced mail" gnus-summary-resend-bounced-mail t] + ["Send a mail" gnus-summary-mail-other-window t] + ["Uuencode and post" gnus-uu-post-news t] + ["Followup via news" gnus-summary-followup-to-mail t] + ["Followup via news and yank" + gnus-summary-followup-to-mail-with-original t] + ;;("Draft" + ;;["Send" gnus-summary-send-draft t] + ;;["Send bounced" gnus-resend-bounced-mail t]) + )) + + (easy-menu-define + gnus-summary-misc-menu gnus-summary-mode-map "" + '("Misc" + ("Mark Read" + ["Mark as read" gnus-summary-mark-as-read-forward t] + ["Mark same subject and select" + gnus-summary-kill-same-subject-and-select t] + ["Mark same subject" gnus-summary-kill-same-subject t] + ["Catchup" gnus-summary-catchup t] + ["Catchup all" gnus-summary-catchup-all t] + ["Catchup to here" gnus-summary-catchup-to-here t] + ["Catchup region" gnus-summary-mark-region-as-read t] + ["Mark excluded" gnus-summary-limit-mark-excluded-as-read t]) + ("Mark Various" + ["Tick" gnus-summary-tick-article-forward t] + ["Mark as dormant" gnus-summary-mark-as-dormant t] + ["Remove marks" gnus-summary-clear-mark-forward t] + ["Set expirable mark" gnus-summary-mark-as-expirable t] + ["Set bookmark" gnus-summary-set-bookmark t] + ["Remove bookmark" gnus-summary-remove-bookmark t]) + ("Mark Limit" + ["Marks..." gnus-summary-limit-to-marks t] + ["Subject..." gnus-summary-limit-to-subject t] + ["Author..." gnus-summary-limit-to-author t] + ["Age..." gnus-summary-limit-to-age t] + ["Score" gnus-summary-limit-to-score t] + ["Unread" gnus-summary-limit-to-unread t] + ["Non-dormant" gnus-summary-limit-exclude-dormant t] + ["Articles" gnus-summary-limit-to-articles t] + ["Pop limit" gnus-summary-pop-limit t] + ["Show dormant" gnus-summary-limit-include-dormant t] + ["Hide childless dormant" + gnus-summary-limit-exclude-childless-dormant t] + ;;["Hide thread" gnus-summary-limit-exclude-thread t] + ["Show expunged" gnus-summary-show-all-expunged t]) + ("Process Mark" + ["Set mark" gnus-summary-mark-as-processable t] + ["Remove mark" gnus-summary-unmark-as-processable t] + ["Remove all marks" gnus-summary-unmark-all-processable t] + ["Mark above" gnus-uu-mark-over t] + ["Mark series" gnus-uu-mark-series t] + ["Mark region" gnus-uu-mark-region t] + ["Mark by regexp..." gnus-uu-mark-by-regexp t] + ["Mark all" gnus-uu-mark-all t] + ["Mark buffer" gnus-uu-mark-buffer t] + ["Mark sparse" gnus-uu-mark-sparse t] + ["Mark thread" gnus-uu-mark-thread t] + ["Unmark thread" gnus-uu-unmark-thread t] + ("Process Mark Sets" + ["Kill" gnus-summary-kill-process-mark t] + ["Yank" gnus-summary-yank-process-mark + gnus-newsgroup-process-stack] + ["Save" gnus-summary-save-process-mark t])) + ("Scroll article" + ["Page forward" gnus-summary-next-page t] + ["Page backward" gnus-summary-prev-page t] + ["Line forward" gnus-summary-scroll-up t]) + ("Move" + ["Next unread article" gnus-summary-next-unread-article t] + ["Previous unread article" gnus-summary-prev-unread-article t] + ["Next article" gnus-summary-next-article t] + ["Previous article" gnus-summary-prev-article t] + ["Next unread subject" gnus-summary-next-unread-subject t] + ["Previous unread subject" gnus-summary-prev-unread-subject t] + ["Next article same subject" gnus-summary-next-same-subject t] + ["Previous article same subject" gnus-summary-prev-same-subject t] + ["First unread article" gnus-summary-first-unread-article t] + ["Best unread article" gnus-summary-best-unread-article t] + ["Go to subject number..." gnus-summary-goto-subject t] + ["Go to article number..." gnus-summary-goto-article t] + ["Go to the last article" gnus-summary-goto-last-article t] + ["Pop article off history" gnus-summary-pop-article t]) + ("Sort" + ["Sort by number" gnus-summary-sort-by-number t] + ["Sort by author" gnus-summary-sort-by-author t] + ["Sort by subject" gnus-summary-sort-by-subject t] + ["Sort by date" gnus-summary-sort-by-date t] + ["Sort by score" gnus-summary-sort-by-score t] + ["Sort by lines" gnus-summary-sort-by-lines t]) + ("Help" + ["Fetch group FAQ" gnus-summary-fetch-faq t] + ["Describe group" gnus-summary-describe-group t] + ["Read manual" gnus-info-find-node t]) + ("Modes" + ["Pick and read" gnus-pick-mode t] + ["Binary" gnus-binary-mode t]) + ("Regeneration" + ["Regenerate" gnus-summary-prepare t] + ["Insert cached articles" gnus-summary-insert-cached-articles t] + ["Toggle threading" gnus-summary-toggle-threads t]) + ["Filter articles..." gnus-summary-execute-command t] + ["Run command on subjects..." gnus-summary-universal-argument t] + ["Toggle line truncation" gnus-summary-toggle-truncation t] + ["Expand window" gnus-summary-expand-window t] + ["Expire expirable articles" gnus-summary-expire-articles + (gnus-check-backend-function + 'request-expire-articles gnus-newsgroup-name)] + ["Edit local kill file" gnus-summary-edit-local-kill t] + ["Edit main kill file" gnus-summary-edit-global-kill t] + ("Exit" + ["Catchup and exit" gnus-summary-catchup-and-exit t] + ["Catchup all and exit" gnus-summary-catchup-and-exit t] + ["Catchup and goto next" gnus-summary-catchup-and-goto-next-group t] + ["Exit group" gnus-summary-exit t] + ["Exit group without updating" gnus-summary-exit-no-update t] + ["Exit and goto next group" gnus-summary-next-group t] + ["Exit and goto prev group" gnus-summary-prev-group t] + ["Reselect group" gnus-summary-reselect-current-group t] + ["Rescan group" gnus-summary-rescan-group t] + ["Update dribble" gnus-summary-save-newsrc t]))) + + (run-hooks 'gnus-summary-menu-hook))) + +(defun gnus-score-set-default (var value) + "A version of set that updates the GNU Emacs menu-bar." + (set var value) + ;; It is the message that forces the active status to be updated. + (message "")) + +(defun gnus-make-score-map (type) + "Make a summary score map of type TYPE." + (if t + nil + (let ((headers '(("author" "from" string) + ("subject" "subject" string) + ("article body" "body" string) + ("article head" "head" string) + ("xref" "xref" string) + ("lines" "lines" number) + ("followups to author" "followup" string))) + (types '((number ("less than" <) + ("greater than" >) + ("equal" =)) + (string ("substring" s) + ("exact string" e) + ("fuzzy string" f) + ("regexp" r)))) + (perms '(("temporary" (current-time-string)) + ("permanent" nil) + ("immediate" now))) + header) + (list + (apply + 'nconc + (list + (if (eq type 'lower) + "Lower score" + "Increase score")) + (let (outh) + (while headers + (setq header (car headers)) + (setq outh + (cons + (apply + 'nconc + (list (car header)) + (let ((ts (cdr (assoc (nth 2 header) types))) + outt) + (while ts + (setq outt + (cons + (apply + 'nconc + (list (caar ts)) + (let ((ps perms) + outp) + (while ps + (setq outp + (cons + (vector + (caar ps) + (list + 'gnus-summary-score-entry + (nth 1 header) + (if (or (string= (nth 1 header) + "head") + (string= (nth 1 header) + "body")) + "" + (list 'gnus-summary-header + (nth 1 header))) + (list 'quote (nth 1 (car ts))) + (list 'gnus-score-default nil) + (nth 1 (car ps)) + t) + t) + outp)) + (setq ps (cdr ps))) + (list (nreverse outp)))) + outt)) + (setq ts (cdr ts))) + (list (nreverse outt)))) + outh)) + (setq headers (cdr headers))) + (list (nreverse outh)))))))) + + + +(defun gnus-summary-mode (&optional group) + "Major mode for reading articles. + +All normal editing commands are switched off. +\\ +Each line in this buffer represents one article. To read an +article, you can, for instance, type `\\[gnus-summary-next-page]'. To move forwards +and backwards while displaying articles, type `\\[gnus-summary-next-unread-article]' and `\\[gnus-summary-prev-unread-article]', +respectively. + +You can also post articles and send mail from this buffer. To +follow up an article, type `\\[gnus-summary-followup]'. To mail a reply to the author +of an article, type `\\[gnus-summary-reply]'. + +There are approx. one gazillion commands you can execute in this +buffer; read the info pages for more information (`\\[gnus-info-find-node]'). + +The following commands are available: + +\\{gnus-summary-mode-map}" + (interactive) + (when (gnus-visual-p 'summary-menu 'menu) + (gnus-summary-make-menu-bar)) + (kill-all-local-variables) + (gnus-summary-make-local-variables) + (gnus-make-thread-indent-array) + (gnus-simplify-mode-line) + (setq major-mode 'gnus-summary-mode) + (setq mode-name "Summary") + (make-local-variable 'minor-mode-alist) + (use-local-map gnus-summary-mode-map) + (buffer-disable-undo (current-buffer)) + (setq buffer-read-only t) ;Disable modification + (setq truncate-lines t) + (setq selective-display t) + (setq selective-display-ellipses t) ;Display `...' + (setq buffer-display-table gnus-summary-display-table) + (gnus-set-default-directory) + (setq gnus-newsgroup-name group) + (make-local-variable 'gnus-summary-line-format) + (make-local-variable 'gnus-summary-line-format-spec) + (make-local-variable 'gnus-summary-mark-positions) + (gnus-make-local-hook 'post-command-hook) + (gnus-add-hook 'post-command-hook 'gnus-clear-inboxes-moved nil t) + (run-hooks 'gnus-summary-mode-hook) + (gnus-update-format-specifications nil 'summary 'summary-mode 'summary-dummy) + (gnus-update-summary-mark-positions)) + +(defun gnus-summary-make-local-variables () + "Make all the local summary buffer variables." + (let ((locals gnus-summary-local-variables) + global local) + (while (setq local (pop locals)) + (if (consp local) + (progn + (if (eq (cdr local) 'global) + ;; Copy the global value of the variable. + (setq global (symbol-value (car local))) + ;; Use the value from the list. + (setq global (eval (cdr local)))) + (make-local-variable (car local)) + (set (car local) global)) + ;; Simple nil-valued local variable. + (make-local-variable local) + (set local nil))))) + +(defun gnus-summary-clear-local-variables () + (let ((locals gnus-summary-local-variables)) + (while locals + (if (consp (car locals)) + (and (vectorp (caar locals)) + (set (caar locals) nil)) + (and (vectorp (car locals)) + (set (car locals) nil))) + (setq locals (cdr locals))))) + +;; Summary data functions. + +(defmacro gnus-data-number (data) + `(car ,data)) + +(defmacro gnus-data-set-number (data number) + `(setcar ,data ,number)) + +(defmacro gnus-data-mark (data) + `(nth 1 ,data)) + +(defmacro gnus-data-set-mark (data mark) + `(setcar (nthcdr 1 ,data) ,mark)) + +(defmacro gnus-data-pos (data) + `(nth 2 ,data)) + +(defmacro gnus-data-set-pos (data pos) + `(setcar (nthcdr 2 ,data) ,pos)) + +(defmacro gnus-data-header (data) + `(nth 3 ,data)) + +(defmacro gnus-data-level (data) + `(nth 4 ,data)) + +(defmacro gnus-data-unread-p (data) + `(= (nth 1 ,data) gnus-unread-mark)) + +(defmacro gnus-data-read-p (data) + `(/= (nth 1 ,data) gnus-unread-mark)) + +(defmacro gnus-data-pseudo-p (data) + `(consp (nth 3 ,data))) + +(defmacro gnus-data-find (number) + `(assq ,number gnus-newsgroup-data)) + +(defmacro gnus-data-find-list (number &optional data) + `(let ((bdata ,(or data 'gnus-newsgroup-data))) + (memq (assq ,number bdata) + bdata))) + +(defmacro gnus-data-make (number mark pos header level) + `(list ,number ,mark ,pos ,header ,level)) + +(defun gnus-data-enter (after-article number mark pos header level offset) + (let ((data (gnus-data-find-list after-article))) + (unless data + (error "No such article: %d" after-article)) + (setcdr data (cons (gnus-data-make number mark pos header level) + (cdr data))) + (setq gnus-newsgroup-data-reverse nil) + (gnus-data-update-list (cddr data) offset))) + +(defun gnus-data-enter-list (after-article list &optional offset) + (when list + (let ((data (and after-article (gnus-data-find-list after-article))) + (ilist list)) + (or data (not after-article) (error "No such article: %d" after-article)) + ;; Find the last element in the list to be spliced into the main + ;; list. + (while (cdr list) + (setq list (cdr list))) + (if (not data) + (progn + (setcdr list gnus-newsgroup-data) + (setq gnus-newsgroup-data ilist) + (when offset + (gnus-data-update-list (cdr list) offset))) + (setcdr list (cdr data)) + (setcdr data ilist) + (when offset + (gnus-data-update-list (cdr list) offset))) + (setq gnus-newsgroup-data-reverse nil)))) + +(defun gnus-data-remove (article &optional offset) + (let ((data gnus-newsgroup-data)) + (if (= (gnus-data-number (car data)) article) + (progn + (setq gnus-newsgroup-data (cdr gnus-newsgroup-data) + gnus-newsgroup-data-reverse nil) + (when offset + (gnus-data-update-list gnus-newsgroup-data offset))) + (while (cdr data) + (when (= (gnus-data-number (cadr data)) article) + (setcdr data (cddr data)) + (when offset + (gnus-data-update-list (cdr data) offset)) + (setq data nil + gnus-newsgroup-data-reverse nil)) + (setq data (cdr data)))))) + +(defmacro gnus-data-list (backward) + `(if ,backward + (or gnus-newsgroup-data-reverse + (setq gnus-newsgroup-data-reverse + (reverse gnus-newsgroup-data))) + gnus-newsgroup-data)) + +(defun gnus-data-update-list (data offset) + "Add OFFSET to the POS of all data entries in DATA." + (while data + (setcar (nthcdr 2 (car data)) (+ offset (nth 2 (car data)))) + (setq data (cdr data)))) + +(defun gnus-data-compute-positions () + "Compute the positions of all articles." + (let ((data gnus-newsgroup-data) + pos) + (while data + (when (setq pos (text-property-any + (point-min) (point-max) + 'gnus-number (gnus-data-number (car data)))) + (gnus-data-set-pos (car data) (+ pos 3))) + (setq data (cdr data))))) + +(defun gnus-summary-article-pseudo-p (article) + "Say whether this article is a pseudo article or not." + (not (vectorp (gnus-data-header (gnus-data-find article))))) + +(defmacro gnus-summary-article-sparse-p (article) + "Say whether this article is a sparse article or not." + ` (memq ,article gnus-newsgroup-sparse)) + +(defmacro gnus-summary-article-ancient-p (article) + "Say whether this article is a sparse article or not." + `(memq ,article gnus-newsgroup-ancient)) + +(defun gnus-article-parent-p (number) + "Say whether this article is a parent or not." + (let ((data (gnus-data-find-list number))) + (and (cdr data) ; There has to be an article after... + (< (gnus-data-level (car data)) ; And it has to have a higher level. + (gnus-data-level (nth 1 data)))))) + +(defun gnus-article-children (number) + "Return a list of all children to NUMBER." + (let* ((data (gnus-data-find-list number)) + (level (gnus-data-level (car data))) + children) + (setq data (cdr data)) + (while (and data + (= (gnus-data-level (car data)) (1+ level))) + (push (gnus-data-number (car data)) children) + (setq data (cdr data))) + children)) + +(defmacro gnus-summary-skip-intangible () + "If the current article is intangible, then jump to a different article." + '(let ((to (get-text-property (point) 'gnus-intangible))) + (and to (gnus-summary-goto-subject to)))) + +(defmacro gnus-summary-article-intangible-p () + "Say whether this article is intangible or not." + '(get-text-property (point) 'gnus-intangible)) + +(defun gnus-article-read-p (article) + "Say whether ARTICLE is read or not." + (not (or (memq article gnus-newsgroup-marked) + (memq article gnus-newsgroup-unreads) + (memq article gnus-newsgroup-unselected) + (memq article gnus-newsgroup-dormant)))) + +;; Some summary mode macros. + +(defmacro gnus-summary-article-number () + "The article number of the article on the current line. +If there isn's an article number here, then we return the current +article number." + '(progn + (gnus-summary-skip-intangible) + (or (get-text-property (point) 'gnus-number) + (gnus-summary-last-subject)))) + +(defmacro gnus-summary-article-header (&optional number) + `(gnus-data-header (gnus-data-find + ,(or number '(gnus-summary-article-number))))) + +(defmacro gnus-summary-thread-level (&optional number) + `(if (and (eq gnus-summary-make-false-root 'dummy) + (get-text-property (point) 'gnus-intangible)) + 0 + (gnus-data-level (gnus-data-find + ,(or number '(gnus-summary-article-number)))))) + +(defmacro gnus-summary-article-mark (&optional number) + `(gnus-data-mark (gnus-data-find + ,(or number '(gnus-summary-article-number))))) + +(defmacro gnus-summary-article-pos (&optional number) + `(gnus-data-pos (gnus-data-find + ,(or number '(gnus-summary-article-number))))) + +(defalias 'gnus-summary-subject-string 'gnus-summary-article-subject) +(defmacro gnus-summary-article-subject (&optional number) + "Return current subject string or nil if nothing." + `(let ((headers + ,(if number + `(gnus-data-header (assq ,number gnus-newsgroup-data)) + '(gnus-data-header (assq (gnus-summary-article-number) + gnus-newsgroup-data))))) + (and headers + (vectorp headers) + (mail-header-subject headers)))) + +(defmacro gnus-summary-article-score (&optional number) + "Return current article score." + `(or (cdr (assq ,(or number '(gnus-summary-article-number)) + gnus-newsgroup-scored)) + gnus-summary-default-score 0)) + +(defun gnus-summary-article-children (&optional number) + (let* ((data (gnus-data-find-list (or number (gnus-summary-article-number)))) + (level (gnus-data-level (car data))) + l children) + (while (and (setq data (cdr data)) + (> (setq l (gnus-data-level (car data))) level)) + (and (= (1+ level) l) + (push (gnus-data-number (car data)) + children))) + (nreverse children))) + +(defun gnus-summary-article-parent (&optional number) + (let* ((data (gnus-data-find-list (or number (gnus-summary-article-number)) + (gnus-data-list t))) + (level (gnus-data-level (car data)))) + (if (zerop level) + () ; This is a root. + ;; We search until we find an article with a level less than + ;; this one. That function has to be the parent. + (while (and (setq data (cdr data)) + (not (< (gnus-data-level (car data)) level)))) + (and data (gnus-data-number (car data)))))) + +(defun gnus-unread-mark-p (mark) + "Say whether MARK is the unread mark." + (= mark gnus-unread-mark)) + +(defun gnus-read-mark-p (mark) + "Say whether MARK is one of the marks that mark as read. +This is all marks except unread, ticked, dormant, and expirable." + (not (or (= mark gnus-unread-mark) + (= mark gnus-ticked-mark) + (= mark gnus-dormant-mark) + (= mark gnus-expirable-mark)))) + +(defmacro gnus-article-mark (number) + `(cond + ((memq ,number gnus-newsgroup-unreads) gnus-unread-mark) + ((memq ,number gnus-newsgroup-marked) gnus-ticked-mark) + ((memq ,number gnus-newsgroup-dormant) gnus-dormant-mark) + ((memq ,number gnus-newsgroup-expirable) gnus-expirable-mark) + (t (or (cdr (assq ,number gnus-newsgroup-reads)) + gnus-ancient-mark)))) + +;; Saving hidden threads. + +(put 'gnus-save-hidden-threads 'lisp-indent-function 0) +(put 'gnus-save-hidden-threads 'edebug-form-spec '(body)) + +(defmacro gnus-save-hidden-threads (&rest forms) + "Save hidden threads, eval FORMS, and restore the hidden threads." + (let ((config (make-symbol "config"))) + `(let ((,config (gnus-hidden-threads-configuration))) + (unwind-protect + (save-excursion + ,@forms) + (gnus-restore-hidden-threads-configuration ,config))))) + +(defun gnus-hidden-threads-configuration () + "Return the current hidden threads configuration." + (save-excursion + (let (config) + (goto-char (point-min)) + (while (search-forward "\r" nil t) + (push (1- (point)) config)) + config))) + +(defun gnus-restore-hidden-threads-configuration (config) + "Restore hidden threads configuration from CONFIG." + (let (point buffer-read-only) + (while (setq point (pop config)) + (when (and (< point (point-max)) + (goto-char point) + (= (following-char) ?\n)) + (subst-char-in-region point (1+ point) ?\n ?\r))))) + +;; Various summary mode internalish functions. + +(defun gnus-mouse-pick-article (e) + (interactive "e") + (mouse-set-point e) + (gnus-summary-next-page nil t)) + +(defun gnus-summary-setup-buffer (group) + "Initialize summary buffer." + (let ((buffer (concat "*Summary " group "*"))) + (if (get-buffer buffer) + (progn + (set-buffer buffer) + (setq gnus-summary-buffer (current-buffer)) + (not gnus-newsgroup-prepared)) + ;; Fix by Sudish Joseph + (setq gnus-summary-buffer (set-buffer (get-buffer-create buffer))) + (gnus-add-current-to-buffer-list) + (gnus-summary-mode group) + (when gnus-carpal + (gnus-carpal-setup-buffer 'summary)) + (unless gnus-single-article-buffer + (make-local-variable 'gnus-article-buffer) + (make-local-variable 'gnus-article-current) + (make-local-variable 'gnus-original-article-buffer)) + (setq gnus-newsgroup-name group) + t))) + +(defun gnus-set-global-variables () + ;; Set the global equivalents of the summary buffer-local variables + ;; to the latest values they had. These reflect the summary buffer + ;; that was in action when the last article was fetched. + (when (eq major-mode 'gnus-summary-mode) + (setq gnus-summary-buffer (current-buffer)) + (let ((name gnus-newsgroup-name) + (marked gnus-newsgroup-marked) + (unread gnus-newsgroup-unreads) + (headers gnus-current-headers) + (data gnus-newsgroup-data) + (summary gnus-summary-buffer) + (article-buffer gnus-article-buffer) + (original gnus-original-article-buffer) + (gac gnus-article-current) + (reffed gnus-reffed-article-number) + (score-file gnus-current-score-file)) + (save-excursion + (set-buffer gnus-group-buffer) + (setq gnus-newsgroup-name name) + (setq gnus-newsgroup-marked marked) + (setq gnus-newsgroup-unreads unread) + (setq gnus-current-headers headers) + (setq gnus-newsgroup-data data) + (setq gnus-article-current gac) + (setq gnus-summary-buffer summary) + (setq gnus-article-buffer article-buffer) + (setq gnus-original-article-buffer original) + (setq gnus-reffed-article-number reffed) + (setq gnus-current-score-file score-file) + ;; The article buffer also has local variables. + (when (gnus-buffer-live-p gnus-article-buffer) + (set-buffer gnus-article-buffer) + (setq gnus-summary-buffer summary)))))) + +(defun gnus-summary-article-unread-p (article) + "Say whether ARTICLE is unread or not." + (memq article gnus-newsgroup-unreads)) + +(defun gnus-summary-first-article-p (&optional article) + "Return whether ARTICLE is the first article in the buffer." + (if (not (setq article (or article (gnus-summary-article-number)))) + nil + (eq article (caar gnus-newsgroup-data)))) + +(defun gnus-summary-last-article-p (&optional article) + "Return whether ARTICLE is the last article in the buffer." + (if (not (setq article (or article (gnus-summary-article-number)))) + t ; All non-existent numbers are the last article. :-) + (not (cdr (gnus-data-find-list article))))) + +(defun gnus-make-thread-indent-array () + (let ((n 200)) + (unless (and gnus-thread-indent-array + (= gnus-thread-indent-level gnus-thread-indent-array-level)) + (setq gnus-thread-indent-array (make-vector 201 "") + gnus-thread-indent-array-level gnus-thread-indent-level) + (while (>= n 0) + (aset gnus-thread-indent-array n + (make-string (* n gnus-thread-indent-level) ? )) + (setq n (1- n)))))) + +(defun gnus-update-summary-mark-positions () + "Compute where the summary marks are to go." + (save-excursion + (when (and gnus-summary-buffer + (get-buffer gnus-summary-buffer) + (buffer-name (get-buffer gnus-summary-buffer))) + (set-buffer gnus-summary-buffer)) + (let ((gnus-replied-mark 129) + (gnus-score-below-mark 130) + (gnus-score-over-mark 130) + (spec gnus-summary-line-format-spec) + thread gnus-visual pos) + (save-excursion + (gnus-set-work-buffer) + (let ((gnus-summary-line-format-spec spec)) + (gnus-summary-insert-line + [0 "" "" "" "" "" 0 0 ""] 0 nil 128 t nil "" nil 1) + (goto-char (point-min)) + (setq pos (list (cons 'unread (and (search-forward "\200" nil t) + (- (point) 2))))) + (goto-char (point-min)) + (push (cons 'replied (and (search-forward "\201" nil t) + (- (point) 2))) + pos) + (goto-char (point-min)) + (push (cons 'score (and (search-forward "\202" nil t) (- (point) 2))) + pos))) + (setq gnus-summary-mark-positions pos)))) + +(defun gnus-summary-insert-dummy-line (gnus-tmp-subject gnus-tmp-number) + "Insert a dummy root in the summary buffer." + (beginning-of-line) + (gnus-add-text-properties + (point) (progn (eval gnus-summary-dummy-line-format-spec) (point)) + (list 'gnus-number gnus-tmp-number 'gnus-intangible gnus-tmp-number))) + +(defun gnus-summary-insert-line (gnus-tmp-header + gnus-tmp-level gnus-tmp-current + gnus-tmp-unread gnus-tmp-replied + gnus-tmp-expirable gnus-tmp-subject-or-nil + &optional gnus-tmp-dummy gnus-tmp-score + gnus-tmp-process) + (let* ((gnus-tmp-indentation (aref gnus-thread-indent-array gnus-tmp-level)) + (gnus-tmp-lines (mail-header-lines gnus-tmp-header)) + (gnus-tmp-score (or gnus-tmp-score gnus-summary-default-score 0)) + (gnus-tmp-score-char + (if (or (null gnus-summary-default-score) + (<= (abs (- gnus-tmp-score gnus-summary-default-score)) + gnus-summary-zcore-fuzz)) + ? + (if (< gnus-tmp-score gnus-summary-default-score) + gnus-score-below-mark gnus-score-over-mark))) + (gnus-tmp-replied + (cond (gnus-tmp-process gnus-process-mark) + ((memq gnus-tmp-current gnus-newsgroup-cached) + gnus-cached-mark) + (gnus-tmp-replied gnus-replied-mark) + ((memq gnus-tmp-current gnus-newsgroup-saved) + gnus-saved-mark) + (t gnus-unread-mark))) + (gnus-tmp-from (mail-header-from gnus-tmp-header)) + (gnus-tmp-name + (cond + ((string-match "<[^>]+> *$" gnus-tmp-from) + (let ((beg (match-beginning 0))) + (or (and (string-match "^\"[^\"]*\"" gnus-tmp-from) + (substring gnus-tmp-from (1+ (match-beginning 0)) + (1- (match-end 0)))) + (substring gnus-tmp-from 0 beg)))) + ((string-match "(.+)" gnus-tmp-from) + (substring gnus-tmp-from + (1+ (match-beginning 0)) (1- (match-end 0)))) + (t gnus-tmp-from))) + (gnus-tmp-subject (mail-header-subject gnus-tmp-header)) + (gnus-tmp-number (mail-header-number gnus-tmp-header)) + (gnus-tmp-opening-bracket (if gnus-tmp-dummy ?\< ?\[)) + (gnus-tmp-closing-bracket (if gnus-tmp-dummy ?\> ?\])) + (buffer-read-only nil)) + (when (string= gnus-tmp-name "") + (setq gnus-tmp-name gnus-tmp-from)) + (unless (numberp gnus-tmp-lines) + (setq gnus-tmp-lines 0)) + (gnus-put-text-property + (point) + (progn (eval gnus-summary-line-format-spec) (point)) + 'gnus-number gnus-tmp-number) + (when (gnus-visual-p 'summary-highlight 'highlight) + (forward-line -1) + (run-hooks 'gnus-summary-update-hook) + (forward-line 1)))) + +(defun gnus-summary-update-line (&optional dont-update) + ;; Update summary line after change. + (when (and gnus-summary-default-score + (not gnus-summary-inhibit-highlight)) + (let* ((gnus-summary-inhibit-highlight t) ; Prevent recursion. + (article (gnus-summary-article-number)) + (score (gnus-summary-article-score article))) + (unless dont-update + (if (and gnus-summary-mark-below + (< (gnus-summary-article-score) + gnus-summary-mark-below)) + ;; This article has a low score, so we mark it as read. + (when (memq article gnus-newsgroup-unreads) + (gnus-summary-mark-article-as-read gnus-low-score-mark)) + (when (eq (gnus-summary-article-mark) gnus-low-score-mark) + ;; This article was previously marked as read on account + ;; of a low score, but now it has risen, so we mark it as + ;; unread. + (gnus-summary-mark-article-as-unread gnus-unread-mark))) + (gnus-summary-update-mark + (if (or (null gnus-summary-default-score) + (<= (abs (- score gnus-summary-default-score)) + gnus-summary-zcore-fuzz)) + ? + (if (< score gnus-summary-default-score) + gnus-score-below-mark gnus-score-over-mark)) + 'score)) + ;; Do visual highlighting. + (when (gnus-visual-p 'summary-highlight 'highlight) + (run-hooks 'gnus-summary-update-hook))))) + +(defvar gnus-tmp-new-adopts nil) + +(defun gnus-summary-number-of-articles-in-thread (thread &optional level char) + "Return the number of articles in THREAD. +This may be 0 in some cases -- if none of the articles in +the thread are to be displayed." + (let* ((number + ;; Fix by Luc Van Eycken . + (cond + ((not (listp thread)) + 1) + ((and (consp thread) (cdr thread)) + (apply + '+ 1 (mapcar + 'gnus-summary-number-of-articles-in-thread (cdr thread)))) + ((null thread) + 1) + ((memq (mail-header-number (car thread)) gnus-newsgroup-limit) + 1) + (t 0)))) + (when (and level (zerop level) gnus-tmp-new-adopts) + (incf number + (apply '+ (mapcar + 'gnus-summary-number-of-articles-in-thread + gnus-tmp-new-adopts)))) + (if char + (if (> number 1) gnus-not-empty-thread-mark + gnus-empty-thread-mark) + number))) + +(defun gnus-summary-set-local-parameters (group) + "Go through the local params of GROUP and set all variable specs in that list." + (let ((params (gnus-group-find-parameter group)) + elem) + (while params + (setq elem (car params) + params (cdr params)) + (and (consp elem) ; Has to be a cons. + (consp (cdr elem)) ; The cdr has to be a list. + (symbolp (car elem)) ; Has to be a symbol in there. + (not (memq (car elem) + '(quit-config to-address to-list to-group))) + (progn ; So we set it. + (make-local-variable (car elem)) + (set (car elem) (eval (nth 1 elem)))))))) + +(defun gnus-summary-read-group (group &optional show-all no-article + kill-buffer no-display) + "Start reading news in newsgroup GROUP. +If SHOW-ALL is non-nil, already read articles are also listed. +If NO-ARTICLE is non-nil, no article is selected initially. +If NO-DISPLAY, don't generate a summary buffer." + ;; Killed foreign groups can't be entered. + (when (and (not (gnus-group-native-p group)) + (not (gnus-gethash group gnus-newsrc-hashtb))) + (error "Dead non-native groups can't be entered")) + (gnus-message 5 "Retrieving newsgroup: %s..." group) + (let* ((new-group (gnus-summary-setup-buffer group)) + (quit-config (gnus-group-quit-config group)) + (did-select (and new-group (gnus-select-newsgroup group show-all)))) + (cond + ;; This summary buffer exists already, so we just select it. + ((not new-group) + (gnus-set-global-variables) + (when kill-buffer + (gnus-kill-or-deaden-summary kill-buffer)) + (gnus-configure-windows 'summary 'force) + (gnus-set-mode-line 'summary) + (gnus-summary-position-point) + (message "") + t) + ;; We couldn't select this group. + ((null did-select) + (when (and (eq major-mode 'gnus-summary-mode) + (not (equal (current-buffer) kill-buffer))) + (kill-buffer (current-buffer)) + (if (not quit-config) + (progn + (set-buffer gnus-group-buffer) + (gnus-group-jump-to-group group) + (gnus-group-next-unread-group 1)) + (gnus-handle-ephemeral-exit quit-config))) + (gnus-message 3 "Can't select group") + nil) + ;; The user did a `C-g' while prompting for number of articles, + ;; so we exit this group. + ((eq did-select 'quit) + (and (eq major-mode 'gnus-summary-mode) + (not (equal (current-buffer) kill-buffer)) + (kill-buffer (current-buffer))) + (when kill-buffer + (gnus-kill-or-deaden-summary kill-buffer)) + (if (not quit-config) + (progn + (set-buffer gnus-group-buffer) + (gnus-group-jump-to-group group) + (gnus-group-next-unread-group 1) + (gnus-configure-windows 'group 'force)) + (gnus-handle-ephemeral-exit quit-config)) + ;; Finally signal the quit. + (signal 'quit nil)) + ;; The group was successfully selected. + (t + (gnus-set-global-variables) + ;; Save the active value in effect when the group was entered. + (setq gnus-newsgroup-active + (gnus-copy-sequence + (gnus-active gnus-newsgroup-name))) + ;; You can change the summary buffer in some way with this hook. + (run-hooks 'gnus-select-group-hook) + ;; Set any local variables in the group parameters. + (gnus-summary-set-local-parameters gnus-newsgroup-name) + (gnus-update-format-specifications + nil 'summary 'summary-mode 'summary-dummy) + ;; Do score processing. + (when gnus-use-scoring + (gnus-possibly-score-headers)) + ;; Check whether to fill in the gaps in the threads. + (when gnus-build-sparse-threads + (gnus-build-sparse-threads)) + ;; Find the initial limit. + (if gnus-show-threads + (if show-all + (let ((gnus-newsgroup-dormant nil)) + (gnus-summary-initial-limit show-all)) + (gnus-summary-initial-limit show-all)) + (setq gnus-newsgroup-limit + (mapcar + (lambda (header) (mail-header-number header)) + gnus-newsgroup-headers))) + ;; Generate the summary buffer. + (unless no-display + (gnus-summary-prepare)) + (when gnus-use-trees + (gnus-tree-open group) + (setq gnus-summary-highlight-line-function + 'gnus-tree-highlight-article)) + ;; If the summary buffer is empty, but there are some low-scored + ;; articles or some excluded dormants, we include these in the + ;; buffer. + (when (and (zerop (buffer-size)) + (not no-display)) + (cond (gnus-newsgroup-dormant + (gnus-summary-limit-include-dormant)) + ((and gnus-newsgroup-scored show-all) + (gnus-summary-limit-include-expunged t)))) + ;; Function `gnus-apply-kill-file' must be called in this hook. + (run-hooks 'gnus-apply-kill-hook) + (if (and (zerop (buffer-size)) + (not no-display)) + (progn + ;; This newsgroup is empty. + (gnus-summary-catchup-and-exit nil t) ;Without confirmations. + (gnus-message 6 "No unread news") + (when kill-buffer + (gnus-kill-or-deaden-summary kill-buffer)) + ;; Return nil from this function. + nil) + ;; Hide conversation thread subtrees. We cannot do this in + ;; gnus-summary-prepare-hook since kill processing may not + ;; work with hidden articles. + (and gnus-show-threads + gnus-thread-hide-subtree + (gnus-summary-hide-all-threads)) + ;; Show first unread article if requested. + (if (and (not no-article) + (not no-display) + gnus-newsgroup-unreads + gnus-auto-select-first) + (unless (if (eq gnus-auto-select-first 'best) + (gnus-summary-best-unread-article) + (gnus-summary-first-unread-article)) + (gnus-configure-windows 'summary)) + ;; Don't select any articles, just move point to the first + ;; article in the group. + (goto-char (point-min)) + (gnus-summary-position-point) + (gnus-set-mode-line 'summary) + (gnus-configure-windows 'summary 'force)) + (when kill-buffer + (gnus-kill-or-deaden-summary kill-buffer)) + (when (get-buffer-window gnus-group-buffer t) + ;; Gotta use windows, because recenter does weird stuff if + ;; the current buffer ain't the displayed window. + (let ((owin (selected-window))) + (select-window (get-buffer-window gnus-group-buffer t)) + (when (gnus-group-goto-group group) + (recenter)) + (select-window owin)))) + ;; Mark this buffer as "prepared". + (setq gnus-newsgroup-prepared t) + t)))) + +(defun gnus-summary-prepare () + "Generate the summary buffer." + (interactive) + (let ((buffer-read-only nil)) + (erase-buffer) + (setq gnus-newsgroup-data nil + gnus-newsgroup-data-reverse nil) + (run-hooks 'gnus-summary-generate-hook) + ;; Generate the buffer, either with threads or without. + (when gnus-newsgroup-headers + (gnus-summary-prepare-threads + (if gnus-show-threads + (gnus-sort-gathered-threads + (funcall gnus-summary-thread-gathering-function + (gnus-sort-threads + (gnus-cut-threads (gnus-make-threads))))) + ;; Unthreaded display. + (gnus-sort-articles gnus-newsgroup-headers)))) + (setq gnus-newsgroup-data (nreverse gnus-newsgroup-data)) + ;; Call hooks for modifying summary buffer. + (goto-char (point-min)) + (run-hooks 'gnus-summary-prepare-hook))) + +(defsubst gnus-general-simplify-subject (subject) + "Simply subject by the same rules as gnus-gather-threads-by-subject." + (setq subject + (cond + ;; Truncate the subject. + ((numberp gnus-summary-gather-subject-limit) + (setq subject (gnus-simplify-subject-re subject)) + (if (> (length subject) gnus-summary-gather-subject-limit) + (substring subject 0 gnus-summary-gather-subject-limit) + subject)) + ;; Fuzzily simplify it. + ((eq 'fuzzy gnus-summary-gather-subject-limit) + (gnus-simplify-subject-fuzzy subject)) + ;; Just remove the leading "Re:". + (t + (gnus-simplify-subject-re subject)))) + + (if (and gnus-summary-gather-exclude-subject + (string-match gnus-summary-gather-exclude-subject subject)) + nil ; This article shouldn't be gathered + subject)) + +(defun gnus-summary-simplify-subject-query () + "Query where the respool algorithm would put this article." + (interactive) + (gnus-set-global-variables) + (gnus-summary-select-article) + (message (gnus-general-simplify-subject (gnus-summary-article-subject)))) + +(defun gnus-gather-threads-by-subject (threads) + "Gather threads by looking at Subject headers." + (if (not gnus-summary-make-false-root) + threads + (let ((hashtb (gnus-make-hashtable 1024)) + (prev threads) + (result threads) + subject hthread whole-subject) + (while threads + (setq subject (gnus-general-simplify-subject + (setq whole-subject (mail-header-subject + (caar threads))))) + (when subject + (if (setq hthread (gnus-gethash subject hashtb)) + (progn + ;; We enter a dummy root into the thread, if we + ;; haven't done that already. + (unless (stringp (caar hthread)) + (setcar hthread (list whole-subject (car hthread)))) + ;; We add this new gathered thread to this gathered + ;; thread. + (setcdr (car hthread) + (nconc (cdar hthread) (list (car threads)))) + ;; Remove it from the list of threads. + (setcdr prev (cdr threads)) + (setq threads prev)) + ;; Enter this thread into the hash table. + (gnus-sethash subject threads hashtb))) + (setq prev threads) + (setq threads (cdr threads))) + result))) + +(defun gnus-gather-threads-by-references (threads) + "Gather threads by looking at References headers." + (let ((idhashtb (gnus-make-hashtable 1024)) + (thhashtb (gnus-make-hashtable 1024)) + (prev threads) + (result threads) + ids references id gthread gid entered ref) + (while threads + (when (setq references (mail-header-references (caar threads))) + (setq id (mail-header-id (caar threads)) + ids (gnus-split-references references) + entered nil) + (while (setq ref (pop ids)) + (setq ids (delete ref ids)) + (if (not (setq gid (gnus-gethash ref idhashtb))) + (progn + (gnus-sethash ref id idhashtb) + (gnus-sethash id threads thhashtb)) + (setq gthread (gnus-gethash gid thhashtb)) + (unless entered + ;; We enter a dummy root into the thread, if we + ;; haven't done that already. + (unless (stringp (caar gthread)) + (setcar gthread (list (mail-header-subject (caar gthread)) + (car gthread)))) + ;; We add this new gathered thread to this gathered + ;; thread. + (setcdr (car gthread) + (nconc (cdar gthread) (list (car threads))))) + ;; Add it into the thread hash table. + (gnus-sethash id gthread thhashtb) + (setq entered t) + ;; Remove it from the list of threads. + (setcdr prev (cdr threads)) + (setq threads prev)))) + (setq prev threads) + (setq threads (cdr threads))) + result)) + +(defun gnus-sort-gathered-threads (threads) + "Sort subtreads inside each gathered thread by article number." + (let ((result threads)) + (while threads + (when (stringp (caar threads)) + (setcdr (car threads) + (sort (cdar threads) 'gnus-thread-sort-by-number))) + (setq threads (cdr threads))) + result)) + +(defun gnus-thread-loop-p (root thread) + "Say whether ROOT is in THREAD." + (let ((th (cdr thread))) + (while (and th + (not (eq (caar th) root))) + (pop th)) + (if th + ;; We have found a loop. + (let (ref-dep) + (setcdr thread (delq (car th) (cdr thread))) + (if (boundp (setq ref-dep (intern "none" + gnus-newsgroup-dependencies))) + (setcdr (symbol-value ref-dep) + (nconc (cdr (symbol-value ref-dep)) + (list (car th)))) + (set ref-dep (list nil (car th)))) + 1) + ;; Recurse down into the sub-threads and look for loops. + (apply '+ + (mapcar + (lambda (thread) (gnus-thread-loop-p root thread)) + (cdr thread)))))) + +(defun gnus-make-threads () + "Go through the dependency hashtb and find the roots. Return all threads." + (let (threads) + (while (catch 'infloop + (mapatoms + (lambda (refs) + ;; Deal with self-referencing References loops. + (when (and (car (symbol-value refs)) + (not (zerop + (apply + '+ + (mapcar + (lambda (thread) + (gnus-thread-loop-p + (car (symbol-value refs)) thread)) + (cdr (symbol-value refs))))))) + (setq threads nil) + (throw 'infloop t)) + (unless (car (symbol-value refs)) + ;; These threads do not refer back to any other articles, + ;; so they're roots. + (setq threads (append (cdr (symbol-value refs)) threads)))) + gnus-newsgroup-dependencies))) + threads)) + +(defun gnus-build-sparse-threads () + (let ((headers gnus-newsgroup-headers) + (deps gnus-newsgroup-dependencies) + header references generation relations + cthread subject child end pthread relation) + ;; First we create an alist of generations/relations, where + ;; generations is how much we trust the relation, and the relation + ;; is parent/child. + (gnus-message 7 "Making sparse threads...") + (save-excursion + (nnheader-set-temp-buffer " *gnus sparse threads*") + (while (setq header (pop headers)) + (when (and (setq references (mail-header-references header)) + (not (string= references ""))) + (insert references) + (setq child (mail-header-id header) + subject (mail-header-subject header)) + (setq generation 0) + (while (search-backward ">" nil t) + (setq end (1+ (point))) + (when (search-backward "<" nil t) + (push (list (incf generation) + child (setq child (buffer-substring (point) end)) + subject) + relations))) + (push (list (1+ generation) child nil subject) relations) + (erase-buffer))) + (kill-buffer (current-buffer))) + ;; Sort over trustworthiness. + (setq relations (sort relations (lambda (r1 r2) (< (car r1) (car r2))))) + (while (setq relation (pop relations)) + (when (if (boundp (setq cthread (intern (cadr relation) deps))) + (unless (car (symbol-value cthread)) + ;; Make this article the parent of these threads. + (setcar (symbol-value cthread) + (vector gnus-reffed-article-number + (cadddr relation) + "" "" + (cadr relation) + (or (caddr relation) "") 0 0 ""))) + (set cthread (list (vector gnus-reffed-article-number + (cadddr relation) + "" "" (cadr relation) + (or (caddr relation) "") 0 0 "")))) + (push gnus-reffed-article-number gnus-newsgroup-limit) + (push gnus-reffed-article-number gnus-newsgroup-sparse) + (push (cons gnus-reffed-article-number gnus-sparse-mark) + gnus-newsgroup-reads) + (decf gnus-reffed-article-number) + ;; Make this new thread the child of its parent. + (if (boundp (setq pthread (intern (or (caddr relation) "none") deps))) + (setcdr (symbol-value pthread) + (nconc (cdr (symbol-value pthread)) + (list (symbol-value cthread)))) + (set pthread (list nil (symbol-value cthread)))))) + (gnus-message 7 "Making sparse threads...done"))) + +(defun gnus-build-old-threads () + ;; Look at all the articles that refer back to old articles, and + ;; fetch the headers for the articles that aren't there. This will + ;; build complete threads - if the roots haven't been expired by the + ;; server, that is. + (let (id heads) + (mapatoms + (lambda (refs) + (when (not (car (symbol-value refs))) + (setq heads (cdr (symbol-value refs))) + (while heads + (if (memq (mail-header-number (caar heads)) + gnus-newsgroup-dormant) + (setq heads (cdr heads)) + (setq id (symbol-name refs)) + (while (and (setq id (gnus-build-get-header id)) + (not (car (gnus-gethash + id gnus-newsgroup-dependencies))))) + (setq heads nil))))) + gnus-newsgroup-dependencies))) + +(defun gnus-build-get-header (id) + ;; Look through the buffer of NOV lines and find the header to + ;; ID. Enter this line into the dependencies hash table, and return + ;; the id of the parent article (if any). + (let ((deps gnus-newsgroup-dependencies) + found header) + (prog1 + (save-excursion + (set-buffer nntp-server-buffer) + (goto-char (point-min)) + (while (and (not found) (search-forward id nil t)) + (beginning-of-line) + (setq found (looking-at + (format "^[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t%s" + (regexp-quote id)))) + (or found (beginning-of-line 2))) + (when found + (beginning-of-line) + (and + (setq header (gnus-nov-parse-line + (read (current-buffer)) deps)) + (gnus-parent-id (mail-header-references header))))) + (when header + (let ((number (mail-header-number header))) + (push number gnus-newsgroup-limit) + (push header gnus-newsgroup-headers) + (if (memq number gnus-newsgroup-unselected) + (progn + (push number gnus-newsgroup-unreads) + (setq gnus-newsgroup-unselected + (delq number gnus-newsgroup-unselected))) + (push number gnus-newsgroup-ancient))))))) + +(defun gnus-summary-update-article-line (article header) + "Update the line for ARTICLE using HEADERS." + (let* ((id (mail-header-id header)) + (thread (gnus-id-to-thread id))) + (unless thread + (error "Article in no thread")) + ;; Update the thread. + (setcar thread header) + (gnus-summary-goto-subject article) + (let* ((datal (gnus-data-find-list article)) + (data (car datal)) + (length (when (cdr datal) + (- (gnus-data-pos data) + (gnus-data-pos (cadr datal))))) + (buffer-read-only nil) + (level (gnus-summary-thread-level))) + (gnus-delete-line) + (gnus-summary-insert-line + header level nil (gnus-article-mark article) + (memq article gnus-newsgroup-replied) + (memq article gnus-newsgroup-expirable) + (mail-header-subject header) + nil (cdr (assq article gnus-newsgroup-scored)) + (memq article gnus-newsgroup-processable)) + (when length + (gnus-data-update-list + (cdr datal) (- length (- (gnus-data-pos data) (point)))))))) + +(defun gnus-summary-update-article (article &optional iheader) + "Update ARTICLE in the summary buffer." + (set-buffer gnus-summary-buffer) + (let* ((header (or iheader (gnus-summary-article-header article))) + (id (mail-header-id header)) + (data (gnus-data-find article)) + (thread (gnus-id-to-thread id)) + (references (mail-header-references header)) + (parent + (gnus-id-to-thread + (or (gnus-parent-id + (when (and references + (not (equal "" references))) + references)) + "none"))) + (buffer-read-only nil) + (old (car thread)) + (number (mail-header-number header)) + pos) + (when thread + ;; !!! Should this be in or not? + (unless iheader + (setcar thread nil)) + (when parent + (delq thread parent)) + (if (gnus-summary-insert-subject id header iheader) + ;; Set the (possibly) new article number in the data structure. + (gnus-data-set-number data (gnus-id-to-article id)) + (setcar thread old) + nil)))) + +(defun gnus-rebuild-thread (id) + "Rebuild the thread containing ID." + (let ((buffer-read-only nil) + old-pos current thread data) + (if (not gnus-show-threads) + (setq thread (list (car (gnus-id-to-thread id)))) + ;; Get the thread this article is part of. + (setq thread (gnus-remove-thread id))) + (setq old-pos (point-at-bol)) + (setq current (save-excursion + (and (zerop (forward-line -1)) + (gnus-summary-article-number)))) + ;; If this is a gathered thread, we have to go some re-gathering. + (when (stringp (car thread)) + (let ((subject (car thread)) + roots thr) + (setq thread (cdr thread)) + (while thread + (unless (memq (setq thr (gnus-id-to-thread + (gnus-root-id + (mail-header-id (caar thread))))) + roots) + (push thr roots)) + (setq thread (cdr thread))) + ;; We now have all (unique) roots. + (if (= (length roots) 1) + ;; All the loose roots are now one solid root. + (setq thread (car roots)) + (setq thread (cons subject (gnus-sort-threads roots)))))) + (let (threads) + ;; We then insert this thread into the summary buffer. + (let (gnus-newsgroup-data gnus-newsgroup-threads) + (if gnus-show-threads + (gnus-summary-prepare-threads (gnus-cut-threads (list thread))) + (gnus-summary-prepare-unthreaded thread)) + (setq data (nreverse gnus-newsgroup-data)) + (setq threads gnus-newsgroup-threads)) + ;; We splice the new data into the data structure. + (gnus-data-enter-list current data (- (point) old-pos)) + (setq gnus-newsgroup-threads (nconc threads gnus-newsgroup-threads))))) + +(defun gnus-number-to-header (number) + "Return the header for article NUMBER." + (let ((headers gnus-newsgroup-headers)) + (while (and headers + (not (= number (mail-header-number (car headers))))) + (pop headers)) + (when headers + (car headers)))) + +(defun gnus-parent-headers (headers &optional generation) + "Return the headers of the GENERATIONeth parent of HEADERS." + (unless generation + (setq generation 1)) + (let (references parent) + (while (and headers (not (zerop generation))) + (setq references (mail-header-references headers)) + (when (and references + (setq parent (gnus-parent-id references)) + (setq headers (car (gnus-id-to-thread parent)))) + (decf generation))) + headers)) + +(defun gnus-id-to-thread (id) + "Return the (sub-)thread where ID appears." + (gnus-gethash id gnus-newsgroup-dependencies)) + +(defun gnus-id-to-article (id) + "Return the article number of ID." + (let ((thread (gnus-id-to-thread id))) + (when (and thread + (car thread)) + (mail-header-number (car thread))))) + +(defun gnus-id-to-header (id) + "Return the article headers of ID." + (car (gnus-id-to-thread id))) + +(defun gnus-article-displayed-root-p (article) + "Say whether ARTICLE is a root(ish) article." + (let ((level (gnus-summary-thread-level article)) + (refs (mail-header-references (gnus-summary-article-header article))) + particle) + (cond + ((null level) nil) + ((zerop level) t) + ((null refs) t) + ((null (gnus-parent-id refs)) t) + ((and (= 1 level) + (null (setq particle (gnus-id-to-article + (gnus-parent-id refs)))) + (null (gnus-summary-thread-level particle))))))) + +(defun gnus-root-id (id) + "Return the id of the root of the thread where ID appears." + (let (last-id prev) + (while (and id (setq prev (car (gnus-gethash + id gnus-newsgroup-dependencies)))) + (setq last-id id + id (gnus-parent-id (mail-header-references prev)))) + last-id)) + +(defun gnus-remove-thread (id &optional dont-remove) + "Remove the thread that has ID in it." + (let ((dep gnus-newsgroup-dependencies) + headers thread last-id) + ;; First go up in this thread until we find the root. + (setq last-id (gnus-root-id id)) + (setq headers (list (car (gnus-id-to-thread last-id)) + (caadr (gnus-id-to-thread last-id)))) + ;; We have now found the real root of this thread. It might have + ;; been gathered into some loose thread, so we have to search + ;; through the threads to find the thread we wanted. + (let ((threads gnus-newsgroup-threads) + sub) + (while threads + (setq sub (car threads)) + (if (stringp (car sub)) + ;; This is a gathered thread, so we look at the roots + ;; below it to find whether this article is in this + ;; gathered root. + (progn + (setq sub (cdr sub)) + (while sub + (when (member (caar sub) headers) + (setq thread (car threads) + threads nil + sub nil)) + (setq sub (cdr sub)))) + ;; It's an ordinary thread, so we check it. + (when (eq (car sub) (car headers)) + (setq thread sub + threads nil))) + (setq threads (cdr threads))) + ;; If this article is in no thread, then it's a root. + (if thread + (unless dont-remove + (setq gnus-newsgroup-threads (delq thread gnus-newsgroup-threads))) + (setq thread (gnus-gethash last-id dep))) + (when thread + (prog1 + thread ; We return this thread. + (unless dont-remove + (if (stringp (car thread)) + (progn + ;; If we use dummy roots, then we have to remove the + ;; dummy root as well. + (when (eq gnus-summary-make-false-root 'dummy) + (gnus-delete-line) + (gnus-data-compute-positions)) + (setq thread (cdr thread)) + (while thread + (gnus-remove-thread-1 (car thread)) + (setq thread (cdr thread)))) + (gnus-remove-thread-1 thread)))))))) + +(defun gnus-remove-thread-1 (thread) + "Remove the thread THREAD recursively." + (let ((number (mail-header-number (pop thread))) + d) + (setq thread (reverse thread)) + (while thread + (gnus-remove-thread-1 (pop thread))) + (when (setq d (gnus-data-find number)) + (goto-char (gnus-data-pos d)) + (gnus-data-remove + number + (- (point-at-bol) + (prog1 + (1+ (point-at-eol)) + (gnus-delete-line))))))) + +(defun gnus-sort-threads (threads) + "Sort THREADS." + (if (not gnus-thread-sort-functions) + threads + (gnus-message 7 "Sorting threads...") + (prog1 + (sort threads (gnus-make-sort-function gnus-thread-sort-functions)) + (gnus-message 7 "Sorting threads...done")))) + +(defun gnus-sort-articles (articles) + "Sort ARTICLES." + (when gnus-article-sort-functions + (gnus-message 7 "Sorting articles...") + (prog1 + (setq gnus-newsgroup-headers + (sort articles (gnus-make-sort-function + gnus-article-sort-functions))) + (gnus-message 7 "Sorting articles...done")))) + +;; Written by Hallvard B Furuseth . +(defmacro gnus-thread-header (thread) + ;; Return header of first article in THREAD. + ;; Note that THREAD must never, ever be anything else than a variable - + ;; using some other form will lead to serious barfage. + (or (symbolp thread) (signal 'wrong-type-argument '(symbolp thread))) + ;; (8% speedup to gnus-summary-prepare, just for fun :-) + (list 'byte-code "\10\211:\203\17\0\211@;\203\16\0A@@\207" ; + (vector thread) 2)) + +(defsubst gnus-article-sort-by-number (h1 h2) + "Sort articles by article number." + (< (mail-header-number h1) + (mail-header-number h2))) + +(defun gnus-thread-sort-by-number (h1 h2) + "Sort threads by root article number." + (gnus-article-sort-by-number + (gnus-thread-header h1) (gnus-thread-header h2))) + +(defsubst gnus-article-sort-by-lines (h1 h2) + "Sort articles by article Lines header." + (< (mail-header-lines h1) + (mail-header-lines h2))) + +(defun gnus-thread-sort-by-lines (h1 h2) + "Sort threads by root article Lines header." + (gnus-article-sort-by-lines + (gnus-thread-header h1) (gnus-thread-header h2))) + +(defsubst gnus-article-sort-by-author (h1 h2) + "Sort articles by root author." + (string-lessp + (let ((extract (funcall + gnus-extract-address-components + (mail-header-from h1)))) + (or (car extract) (cdr extract))) + (let ((extract (funcall + gnus-extract-address-components + (mail-header-from h2)))) + (or (car extract) (cdr extract))))) + +(defun gnus-thread-sort-by-author (h1 h2) + "Sort threads by root author." + (gnus-article-sort-by-author + (gnus-thread-header h1) (gnus-thread-header h2))) + +(defsubst gnus-article-sort-by-subject (h1 h2) + "Sort articles by root subject." + (string-lessp + (downcase (gnus-simplify-subject-re (mail-header-subject h1))) + (downcase (gnus-simplify-subject-re (mail-header-subject h2))))) + +(defun gnus-thread-sort-by-subject (h1 h2) + "Sort threads by root subject." + (gnus-article-sort-by-subject + (gnus-thread-header h1) (gnus-thread-header h2))) + +(defsubst gnus-article-sort-by-date (h1 h2) + "Sort articles by root article date." + (gnus-time-less + (gnus-date-get-time (mail-header-date h1)) + (gnus-date-get-time (mail-header-date h2)))) + +(defun gnus-thread-sort-by-date (h1 h2) + "Sort threads by root article date." + (gnus-article-sort-by-date + (gnus-thread-header h1) (gnus-thread-header h2))) + +(defsubst gnus-article-sort-by-score (h1 h2) + "Sort articles by root article score. +Unscored articles will be counted as having a score of zero." + (> (or (cdr (assq (mail-header-number h1) + gnus-newsgroup-scored)) + gnus-summary-default-score 0) + (or (cdr (assq (mail-header-number h2) + gnus-newsgroup-scored)) + gnus-summary-default-score 0))) + +(defun gnus-thread-sort-by-score (h1 h2) + "Sort threads by root article score." + (gnus-article-sort-by-score + (gnus-thread-header h1) (gnus-thread-header h2))) + +(defun gnus-thread-sort-by-total-score (h1 h2) + "Sort threads by the sum of all scores in the thread. +Unscored articles will be counted as having a score of zero." + (> (gnus-thread-total-score h1) (gnus-thread-total-score h2))) + +(defun gnus-thread-total-score (thread) + ;; This function find the total score of THREAD. + (cond ((null thread) + 0) + ((consp thread) + (if (stringp (car thread)) + (apply gnus-thread-score-function 0 + (mapcar 'gnus-thread-total-score-1 (cdr thread))) + (gnus-thread-total-score-1 thread))) + (t + (gnus-thread-total-score-1 (list thread))))) + +(defun gnus-thread-total-score-1 (root) + ;; This function find the total score of the thread below ROOT. + (setq root (car root)) + (apply gnus-thread-score-function + (or (append + (mapcar 'gnus-thread-total-score + (cdr (gnus-gethash (mail-header-id root) + gnus-newsgroup-dependencies))) + (when (> (mail-header-number root) 0) + (list (or (cdr (assq (mail-header-number root) + gnus-newsgroup-scored)) + gnus-summary-default-score 0)))) + (list gnus-summary-default-score) + '(0)))) + +;; Added by Per Abrahamsen . +(defvar gnus-tmp-prev-subject nil) +(defvar gnus-tmp-false-parent nil) +(defvar gnus-tmp-root-expunged nil) +(defvar gnus-tmp-dummy-line nil) + +(defun gnus-summary-prepare-threads (threads) + "Prepare summary buffer from THREADS and indentation LEVEL. +THREADS is either a list of `(PARENT [(CHILD1 [(GRANDCHILD ...]...) ...])' +or a straight list of headers." + (gnus-message 7 "Generating summary...") + + (setq gnus-newsgroup-threads threads) + (beginning-of-line) + + (let ((gnus-tmp-level 0) + (default-score (or gnus-summary-default-score 0)) + (gnus-visual-p (gnus-visual-p 'summary-highlight 'highlight)) + thread number subject stack state gnus-tmp-gathered beg-match + new-roots gnus-tmp-new-adopts thread-end + gnus-tmp-header gnus-tmp-unread + gnus-tmp-replied gnus-tmp-subject-or-nil + gnus-tmp-dummy gnus-tmp-indentation gnus-tmp-lines gnus-tmp-score + gnus-tmp-score-char gnus-tmp-from gnus-tmp-name + gnus-tmp-number gnus-tmp-opening-bracket gnus-tmp-closing-bracket) + + (setq gnus-tmp-prev-subject nil) + + (if (vectorp (car threads)) + ;; If this is a straight (sic) list of headers, then a + ;; threaded summary display isn't required, so we just create + ;; an unthreaded one. + (gnus-summary-prepare-unthreaded threads) + + ;; Do the threaded display. + + (while (or threads stack gnus-tmp-new-adopts new-roots) + + (if (and (= gnus-tmp-level 0) + (not (setq gnus-tmp-dummy-line nil)) + (or (not stack) + (= (caar stack) 0)) + (not gnus-tmp-false-parent) + (or gnus-tmp-new-adopts new-roots)) + (if gnus-tmp-new-adopts + (setq gnus-tmp-level (if gnus-tmp-root-expunged 0 1) + thread (list (car gnus-tmp-new-adopts)) + gnus-tmp-header (caar thread) + gnus-tmp-new-adopts (cdr gnus-tmp-new-adopts)) + (when new-roots + (setq thread (list (car new-roots)) + gnus-tmp-header (caar thread) + new-roots (cdr new-roots)))) + + (if threads + ;; If there are some threads, we do them before the + ;; threads on the stack. + (setq thread threads + gnus-tmp-header (caar thread)) + ;; There were no current threads, so we pop something off + ;; the stack. + (setq state (car stack) + gnus-tmp-level (car state) + thread (cdr state) + stack (cdr stack) + gnus-tmp-header (caar thread)))) + + (setq gnus-tmp-false-parent nil) + (setq gnus-tmp-root-expunged nil) + (setq thread-end nil) + + (if (stringp gnus-tmp-header) + ;; The header is a dummy root. + (cond + ((eq gnus-summary-make-false-root 'adopt) + ;; We let the first article adopt the rest. + (setq gnus-tmp-new-adopts (nconc gnus-tmp-new-adopts + (cddar thread))) + (setq gnus-tmp-gathered + (nconc (mapcar + (lambda (h) (mail-header-number (car h))) + (cddar thread)) + gnus-tmp-gathered)) + (setq thread (cons (list (caar thread) + (cadar thread)) + (cdr thread))) + (setq gnus-tmp-level -1 + gnus-tmp-false-parent t)) + ((eq gnus-summary-make-false-root 'empty) + ;; We print adopted articles with empty subject fields. + (setq gnus-tmp-gathered + (nconc (mapcar + (lambda (h) (mail-header-number (car h))) + (cddar thread)) + gnus-tmp-gathered)) + (setq gnus-tmp-level -1)) + ((eq gnus-summary-make-false-root 'dummy) + ;; We remember that we probably want to output a dummy + ;; root. + (setq gnus-tmp-dummy-line gnus-tmp-header) + (setq gnus-tmp-prev-subject gnus-tmp-header)) + (t + ;; We do not make a root for the gathered + ;; sub-threads at all. + (setq gnus-tmp-level -1))) + + (setq number (mail-header-number gnus-tmp-header) + subject (mail-header-subject gnus-tmp-header)) + + (cond + ;; If the thread has changed subject, we might want to make + ;; this subthread into a root. + ((and (null gnus-thread-ignore-subject) + (not (zerop gnus-tmp-level)) + gnus-tmp-prev-subject + (not (inline + (gnus-subject-equal gnus-tmp-prev-subject subject)))) + (setq new-roots (nconc new-roots (list (car thread))) + thread-end t + gnus-tmp-header nil)) + ;; If the article lies outside the current limit, + ;; then we do not display it. + ((not (memq number gnus-newsgroup-limit)) + (setq gnus-tmp-gathered + (nconc (mapcar + (lambda (h) (mail-header-number (car h))) + (cdar thread)) + gnus-tmp-gathered)) + (setq gnus-tmp-new-adopts (if (cdar thread) + (append gnus-tmp-new-adopts + (cdar thread)) + gnus-tmp-new-adopts) + thread-end t + gnus-tmp-header nil) + (when (zerop gnus-tmp-level) + (setq gnus-tmp-root-expunged t))) + ;; Perhaps this article is to be marked as read? + ((and gnus-summary-mark-below + (< (or (cdr (assq number gnus-newsgroup-scored)) + default-score) + gnus-summary-mark-below) + ;; Don't touch sparse articles. + (not (gnus-summary-article-sparse-p number)) + (not (gnus-summary-article-ancient-p number))) + (setq gnus-newsgroup-unreads + (delq number gnus-newsgroup-unreads)) + (if gnus-newsgroup-auto-expire + (push number gnus-newsgroup-expirable) + (push (cons number gnus-low-score-mark) + gnus-newsgroup-reads)))) + + (when gnus-tmp-header + ;; We may have an old dummy line to output before this + ;; article. + (when gnus-tmp-dummy-line + (gnus-summary-insert-dummy-line + gnus-tmp-dummy-line (mail-header-number gnus-tmp-header)) + (setq gnus-tmp-dummy-line nil)) + + ;; Compute the mark. + (setq gnus-tmp-unread (gnus-article-mark number)) + + (push (gnus-data-make number gnus-tmp-unread (1+ (point)) + gnus-tmp-header gnus-tmp-level) + gnus-newsgroup-data) + + ;; Actually insert the line. + (setq + gnus-tmp-subject-or-nil + (cond + ((and gnus-thread-ignore-subject + gnus-tmp-prev-subject + (not (inline (gnus-subject-equal + gnus-tmp-prev-subject subject)))) + subject) + ((zerop gnus-tmp-level) + (if (and (eq gnus-summary-make-false-root 'empty) + (memq number gnus-tmp-gathered) + gnus-tmp-prev-subject + (inline (gnus-subject-equal + gnus-tmp-prev-subject subject))) + gnus-summary-same-subject + subject)) + (t gnus-summary-same-subject))) + (if (and (eq gnus-summary-make-false-root 'adopt) + (= gnus-tmp-level 1) + (memq number gnus-tmp-gathered)) + (setq gnus-tmp-opening-bracket ?\< + gnus-tmp-closing-bracket ?\>) + (setq gnus-tmp-opening-bracket ?\[ + gnus-tmp-closing-bracket ?\])) + (setq + gnus-tmp-indentation + (aref gnus-thread-indent-array gnus-tmp-level) + gnus-tmp-lines (mail-header-lines gnus-tmp-header) + gnus-tmp-score (or (cdr (assq number gnus-newsgroup-scored)) + gnus-summary-default-score 0) + gnus-tmp-score-char + (if (or (null gnus-summary-default-score) + (<= (abs (- gnus-tmp-score gnus-summary-default-score)) + gnus-summary-zcore-fuzz)) + ? + (if (< gnus-tmp-score gnus-summary-default-score) + gnus-score-below-mark gnus-score-over-mark)) + gnus-tmp-replied + (cond ((memq number gnus-newsgroup-processable) + gnus-process-mark) + ((memq number gnus-newsgroup-cached) + gnus-cached-mark) + ((memq number gnus-newsgroup-replied) + gnus-replied-mark) + ((memq number gnus-newsgroup-saved) + gnus-saved-mark) + (t gnus-unread-mark)) + gnus-tmp-from (mail-header-from gnus-tmp-header) + gnus-tmp-name + (cond + ((string-match "<[^>]+> *$" gnus-tmp-from) + (setq beg-match (match-beginning 0)) + (or (and (string-match "^\"[^\"]*\"" gnus-tmp-from) + (substring gnus-tmp-from (1+ (match-beginning 0)) + (1- (match-end 0)))) + (substring gnus-tmp-from 0 beg-match))) + ((string-match "(.+)" gnus-tmp-from) + (substring gnus-tmp-from + (1+ (match-beginning 0)) (1- (match-end 0)))) + (t gnus-tmp-from))) + (when (string= gnus-tmp-name "") + (setq gnus-tmp-name gnus-tmp-from)) + (unless (numberp gnus-tmp-lines) + (setq gnus-tmp-lines 0)) + (gnus-put-text-property + (point) + (progn (eval gnus-summary-line-format-spec) (point)) + 'gnus-number number) + (when gnus-visual-p + (forward-line -1) + (run-hooks 'gnus-summary-update-hook) + (forward-line 1)) + + (setq gnus-tmp-prev-subject subject))) + + (when (nth 1 thread) + (push (cons (max 0 gnus-tmp-level) (nthcdr 1 thread)) stack)) + (incf gnus-tmp-level) + (setq threads (if thread-end nil (cdar thread))) + (unless threads + (setq gnus-tmp-level 0))))) + (gnus-message 7 "Generating summary...done")) + +(defun gnus-summary-prepare-unthreaded (headers) + "Generate an unthreaded summary buffer based on HEADERS." + (let (header number mark) + + (while headers + ;; We may have to root out some bad articles... + (when (memq (setq number (mail-header-number + (setq header (pop headers)))) + gnus-newsgroup-limit) + ;; Mark article as read when it has a low score. + (when (and gnus-summary-mark-below + (< (or (cdr (assq number gnus-newsgroup-scored)) + gnus-summary-default-score 0) + gnus-summary-mark-below) + (not (gnus-summary-article-ancient-p number))) + (setq gnus-newsgroup-unreads + (delq number gnus-newsgroup-unreads)) + (if gnus-newsgroup-auto-expire + (push number gnus-newsgroup-expirable) + (push (cons number gnus-low-score-mark) + gnus-newsgroup-reads))) + + (setq mark (gnus-article-mark number)) + (push (gnus-data-make number mark (1+ (point)) header 0) + gnus-newsgroup-data) + (gnus-summary-insert-line + header 0 number + mark (memq number gnus-newsgroup-replied) + (memq number gnus-newsgroup-expirable) + (mail-header-subject header) nil + (cdr (assq number gnus-newsgroup-scored)) + (memq number gnus-newsgroup-processable)))))) + +(defun gnus-select-newsgroup (group &optional read-all) + "Select newsgroup GROUP. +If READ-ALL is non-nil, all articles in the group are selected." + (let* ((entry (gnus-gethash group gnus-newsrc-hashtb)) + (info (nth 2 entry)) + articles fetched-articles cached) + + (unless (gnus-check-server + (setq gnus-current-select-method + (gnus-find-method-for-group group))) + (error "Couldn't open server")) + + (or (and entry (not (eq (car entry) t))) ; Either it's active... + (gnus-activate-group group) ; Or we can activate it... + (progn ; Or we bug out. + (when (equal major-mode 'gnus-summary-mode) + (kill-buffer (current-buffer))) + (error "Couldn't request group %s: %s" + group (gnus-status-message group)))) + + (unless (gnus-request-group group t) + (when (equal major-mode 'gnus-summary-mode) + (kill-buffer (current-buffer))) + (error "Couldn't request group %s: %s" + group (gnus-status-message group))) + + (setq gnus-newsgroup-name group) + (setq gnus-newsgroup-unselected nil) + (setq gnus-newsgroup-unreads (gnus-list-of-unread-articles group)) + + ;; Adjust and set lists of article marks. + (when info + (gnus-adjust-marked-articles info)) + + ;; Kludge to avoid having cached articles nixed out in virtual groups. + (when (gnus-virtual-group-p group) + (setq cached gnus-newsgroup-cached)) + + (setq gnus-newsgroup-unreads + (gnus-set-difference + (gnus-set-difference gnus-newsgroup-unreads gnus-newsgroup-marked) + gnus-newsgroup-dormant)) + + (setq gnus-newsgroup-processable nil) + + (setq articles (gnus-articles-to-read group read-all)) + + (cond + ((null articles) + ;;(gnus-message 3 "Couldn't select newsgroup -- no articles to display") + 'quit) + ((eq articles 0) nil) + (t + ;; Init the dependencies hash table. + (setq gnus-newsgroup-dependencies + (gnus-make-hashtable (length articles))) + ;; Retrieve the headers and read them in. + (gnus-message 5 "Fetching headers for %s..." gnus-newsgroup-name) + (setq gnus-newsgroup-headers + (if (eq 'nov + (setq gnus-headers-retrieved-by + (gnus-retrieve-headers + articles gnus-newsgroup-name + ;; We might want to fetch old headers, but + ;; not if there is only 1 article. + (and gnus-fetch-old-headers + (or (and + (not (eq gnus-fetch-old-headers 'some)) + (not (numberp gnus-fetch-old-headers))) + (> (length articles) 1)))))) + (gnus-get-newsgroup-headers-xover + articles nil nil gnus-newsgroup-name t) + (gnus-get-newsgroup-headers))) + (gnus-message 5 "Fetching headers for %s...done" gnus-newsgroup-name) + + ;; Kludge to avoid having cached articles nixed out in virtual groups. + (when cached + (setq gnus-newsgroup-cached cached)) + + ;; Suppress duplicates? + (when gnus-suppress-duplicates + (gnus-dup-suppress-articles)) + + ;; Set the initial limit. + (setq gnus-newsgroup-limit (copy-sequence articles)) + ;; Remove canceled articles from the list of unread articles. + (setq gnus-newsgroup-unreads + (gnus-set-sorted-intersection + gnus-newsgroup-unreads + (setq fetched-articles + (mapcar (lambda (headers) (mail-header-number headers)) + gnus-newsgroup-headers)))) + ;; Removed marked articles that do not exist. + (gnus-update-missing-marks + (gnus-sorted-complement fetched-articles articles)) + ;; We might want to build some more threads first. + (and gnus-fetch-old-headers + (eq gnus-headers-retrieved-by 'nov) + (gnus-build-old-threads)) + ;; Check whether auto-expire is to be done in this group. + (setq gnus-newsgroup-auto-expire + (gnus-group-auto-expirable-p group)) + ;; Set up the article buffer now, if necessary. + (unless gnus-single-article-buffer + (gnus-article-setup-buffer)) + ;; First and last article in this newsgroup. + (when gnus-newsgroup-headers + (setq gnus-newsgroup-begin + (mail-header-number (car gnus-newsgroup-headers)) + gnus-newsgroup-end + (mail-header-number + (gnus-last-element gnus-newsgroup-headers)))) + ;; GROUP is successfully selected. + (or gnus-newsgroup-headers t))))) + +(defun gnus-articles-to-read (group &optional read-all) + ;; Find out what articles the user wants to read. + (let* ((articles + ;; Select all articles if `read-all' is non-nil, or if there + ;; are no unread articles. + (if (or read-all + (and (zerop (length gnus-newsgroup-marked)) + (zerop (length gnus-newsgroup-unreads))) + (eq (gnus-group-find-parameter group 'display) + 'all)) + (gnus-uncompress-range (gnus-active group)) + (sort (append gnus-newsgroup-dormant gnus-newsgroup-marked + (copy-sequence gnus-newsgroup-unreads)) + '<))) + (scored-list (gnus-killed-articles gnus-newsgroup-killed articles)) + (scored (length scored-list)) + (number (length articles)) + (marked (+ (length gnus-newsgroup-marked) + (length gnus-newsgroup-dormant))) + (select + (cond + ((numberp read-all) + read-all) + (t + (condition-case () + (cond + ((and (or (<= scored marked) (= scored number)) + (numberp gnus-large-newsgroup) + (> number gnus-large-newsgroup)) + (let ((input + (read-string + (format + "How many articles from %s (default %d): " + (gnus-limit-string gnus-newsgroup-name 35) + number)))) + (if (string-match "^[ \t]*$" input) number input))) + ((and (> scored marked) (< scored number) + (> (- scored number) 20)) + (let ((input + (read-string + (format "%s %s (%d scored, %d total): " + "How many articles from" + group scored number)))) + (if (string-match "^[ \t]*$" input) + number input))) + (t number)) + (quit nil)))))) + (setq select (if (stringp select) (string-to-number select) select)) + (if (or (null select) (zerop select)) + select + (if (and (not (zerop scored)) (<= (abs select) scored)) + (progn + (setq articles (sort scored-list '<)) + (setq number (length articles))) + (setq articles (copy-sequence articles))) + + (when (< (abs select) number) + (if (< select 0) + ;; Select the N oldest articles. + (setcdr (nthcdr (1- (abs select)) articles) nil) + ;; Select the N most recent articles. + (setq articles (nthcdr (- number select) articles)))) + (setq gnus-newsgroup-unselected + (gnus-sorted-intersection + gnus-newsgroup-unreads + (gnus-sorted-complement gnus-newsgroup-unreads articles))) + articles))) + +(defun gnus-killed-articles (killed articles) + (let (out) + (while articles + (when (inline (gnus-member-of-range (car articles) killed)) + (push (car articles) out)) + (setq articles (cdr articles))) + out)) + +(defun gnus-uncompress-marks (marks) + "Uncompress the mark ranges in MARKS." + (let ((uncompressed '(score bookmark)) + out) + (while marks + (if (memq (caar marks) uncompressed) + (push (car marks) out) + (push (cons (caar marks) (gnus-uncompress-range (cdar marks))) out)) + (setq marks (cdr marks))) + out)) + +(defun gnus-adjust-marked-articles (info) + "Set all article lists and remove all marks that are no longer legal." + (let* ((marked-lists (gnus-info-marks info)) + (active (gnus-active (gnus-info-group info))) + (min (car active)) + (max (cdr active)) + (types gnus-article-mark-lists) + (uncompressed '(score bookmark killed)) + marks var articles article mark) + + (while marked-lists + (setq marks (pop marked-lists)) + (set (setq var (intern (format "gnus-newsgroup-%s" + (car (rassq (setq mark (car marks)) + types))))) + (if (memq (car marks) uncompressed) (cdr marks) + (gnus-uncompress-range (cdr marks)))) + + (setq articles (symbol-value var)) + + ;; All articles have to be subsets of the active articles. + (cond + ;; Adjust "simple" lists. + ((memq mark '(tick dormant expirable reply save)) + (while articles + (when (or (< (setq article (pop articles)) min) (> article max)) + (set var (delq article (symbol-value var)))))) + ;; Adjust assocs. + ((memq mark uncompressed) + (while articles + (when (or (not (consp (setq article (pop articles)))) + (< (car article) min) + (> (car article) max)) + (set var (delq article (symbol-value var)))))))))) + +(defun gnus-update-missing-marks (missing) + "Go through the list of MISSING articles and remove them mark lists." + (when missing + (let ((types gnus-article-mark-lists) + var m) + ;; Go through all types. + (while types + (setq var (intern (format "gnus-newsgroup-%s" (car (pop types))))) + (when (symbol-value var) + ;; This list has articles. So we delete all missing articles + ;; from it. + (setq m missing) + (while m + (set var (delq (pop m) (symbol-value var))))))))) + +(defun gnus-update-marks () + "Enter the various lists of marked articles into the newsgroup info list." + (let ((types gnus-article-mark-lists) + (info (gnus-get-info gnus-newsgroup-name)) + (uncompressed '(score bookmark killed)) + type list newmarked symbol) + (when info + ;; Add all marks lists that are non-nil to the list of marks lists. + (while types + (setq type (pop types)) + (when (setq list (symbol-value + (setq symbol + (intern (format "gnus-newsgroup-%s" + (car type)))))) + (push (cons (cdr type) + (if (memq (cdr type) uncompressed) list + (gnus-compress-sequence + (set symbol (sort list '<)) t))) + newmarked))) + + ;; Enter these new marks into the info of the group. + (if (nthcdr 3 info) + (setcar (nthcdr 3 info) newmarked) + ;; Add the marks lists to the end of the info. + (when newmarked + (setcdr (nthcdr 2 info) (list newmarked)))) + + ;; Cut off the end of the info if there's nothing else there. + (let ((i 5)) + (while (and (> i 2) + (not (nth i info))) + (when (nthcdr (decf i) info) + (setcdr (nthcdr i info) nil))))))) + +(defun gnus-set-mode-line (where) + "This function sets the mode line of the article or summary buffers. +If WHERE is `summary', the summary mode line format will be used." + ;; Is this mode line one we keep updated? + (when (memq where gnus-updated-mode-lines) + (let (mode-string) + (save-excursion + ;; We evaluate this in the summary buffer since these + ;; variables are buffer-local to that buffer. + (set-buffer gnus-summary-buffer) + ;; We bind all these variables that are used in the `eval' form + ;; below. + (let* ((mformat (symbol-value + (intern + (format "gnus-%s-mode-line-format-spec" where)))) + (gnus-tmp-group-name gnus-newsgroup-name) + (gnus-tmp-article-number (or gnus-current-article 0)) + (gnus-tmp-unread gnus-newsgroup-unreads) + (gnus-tmp-unread-and-unticked (length gnus-newsgroup-unreads)) + (gnus-tmp-unselected (length gnus-newsgroup-unselected)) + (gnus-tmp-unread-and-unselected + (cond ((and (zerop gnus-tmp-unread-and-unticked) + (zerop gnus-tmp-unselected)) + "") + ((zerop gnus-tmp-unselected) + (format "{%d more}" gnus-tmp-unread-and-unticked)) + (t (format "{%d(+%d) more}" + gnus-tmp-unread-and-unticked + gnus-tmp-unselected)))) + (gnus-tmp-subject + (if (and gnus-current-headers + (vectorp gnus-current-headers)) + (gnus-mode-string-quote + (mail-header-subject gnus-current-headers)) + "")) + max-len + gnus-tmp-header);; passed as argument to any user-format-funcs + (setq mode-string (eval mformat)) + (setq max-len (max 4 (if gnus-mode-non-string-length + (- (window-width) + gnus-mode-non-string-length) + (length mode-string)))) + ;; We might have to chop a bit of the string off... + (when (> (length mode-string) max-len) + (setq mode-string + (concat (gnus-truncate-string 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))) + (set-buffer-modified-p t)))) + +(defun gnus-create-xref-hashtb (from-newsgroup headers unreads) + "Go through the HEADERS list and add all Xrefs to a hash table. +The resulting hash table is returned, or nil if no Xrefs were found." + (let* ((virtual (gnus-virtual-group-p from-newsgroup)) + (prefix (if virtual "" (gnus-group-real-prefix from-newsgroup))) + (xref-hashtb (gnus-make-hashtable)) + start group entry number xrefs header) + (while headers + (setq header (pop headers)) + (when (and (setq xrefs (mail-header-xref header)) + (not (memq (setq number (mail-header-number header)) + unreads))) + (setq start 0) + (while (string-match "\\([^ ]+\\)[:/]\\([0-9]+\\)" xrefs start) + (setq start (match-end 0)) + (setq group (if prefix + (concat prefix (substring xrefs (match-beginning 1) + (match-end 1))) + (substring xrefs (match-beginning 1) (match-end 1)))) + (setq number + (string-to-int (substring xrefs (match-beginning 2) + (match-end 2)))) + (if (setq entry (gnus-gethash group xref-hashtb)) + (setcdr entry (cons number (cdr entry))) + (gnus-sethash group (cons number nil) xref-hashtb))))) + (and start xref-hashtb))) + +(defun gnus-mark-xrefs-as-read (from-newsgroup headers unreads) + "Look through all the headers and mark the Xrefs as read." + (let ((virtual (gnus-virtual-group-p from-newsgroup)) + name entry info xref-hashtb idlist method nth4) + (save-excursion + (set-buffer gnus-group-buffer) + (when (setq xref-hashtb + (gnus-create-xref-hashtb from-newsgroup headers unreads)) + (mapatoms + (lambda (group) + (unless (string= from-newsgroup (setq name (symbol-name group))) + (setq idlist (symbol-value group)) + ;; Dead groups are not updated. + (and (prog1 + (setq entry (gnus-gethash name gnus-newsrc-hashtb) + info (nth 2 entry)) + (when (stringp (setq nth4 (gnus-info-method info))) + (setq nth4 (gnus-server-to-method nth4)))) + ;; Only do the xrefs if the group has the same + ;; select method as the group we have just read. + (or (gnus-methods-equal-p + nth4 (gnus-find-method-for-group from-newsgroup)) + virtual + (equal nth4 (setq method (gnus-find-method-for-group + from-newsgroup))) + (and (equal (car nth4) (car method)) + (equal (nth 1 nth4) (nth 1 method)))) + gnus-use-cross-reference + (or (not (eq gnus-use-cross-reference t)) + virtual + ;; Only do cross-references on subscribed + ;; groups, if that is what is wanted. + (<= (gnus-info-level info) gnus-level-subscribed)) + (gnus-group-make-articles-read name idlist)))) + xref-hashtb))))) + +(defun gnus-group-make-articles-read (group articles) + "Update the info of GROUP to say that only ARTICLES are unread." + (let* ((num 0) + (entry (gnus-gethash group gnus-newsrc-hashtb)) + (info (nth 2 entry)) + (active (gnus-active group)) + range) + ;; First peel off all illegal article numbers. + (when active + (let ((ids articles) + id first) + (while (setq id (pop ids)) + (when (and first (> id (cdr active))) + ;; We'll end up in this situation in one particular + ;; obscure situation. If you re-scan a group and get + ;; a new article that is cross-posted to a different + ;; group that has not been re-scanned, you might get + ;; crossposted article that has a higher number than + ;; Gnus believes possible. So we re-activate this + ;; group as well. This might mean doing the + ;; crossposting thingy will *increase* the number + ;; of articles in some groups. Tsk, tsk. + (setq active (or (gnus-activate-group group) active))) + (when (or (> id (cdr active)) + (< id (car active))) + (setq articles (delq id articles)))))) + (save-excursion + (set-buffer gnus-group-buffer) + (gnus-undo-register + `(progn + (gnus-info-set-marks ',info ',(gnus-info-marks info) t) + (gnus-info-set-read ',info ',(gnus-info-read info)) + (gnus-get-unread-articles-in-group ',info (gnus-active ,group)) + (gnus-group-update-group ,group t)))) + ;; If the read list is nil, we init it. + (and active + (null (gnus-info-read info)) + (> (car active) 1) + (gnus-info-set-read info (cons 1 (1- (car active))))) + ;; Then we add the read articles to the range. + (gnus-info-set-read + info + (setq range + (gnus-add-to-range + (gnus-info-read info) (setq articles (sort articles '<))))) + ;; Then we have to re-compute how many unread + ;; articles there are in this group. + (when active + (cond + ((not range) + (setq num (- (1+ (cdr active)) (car active)))) + ((not (listp (cdr range))) + (setq num (- (cdr active) (- (1+ (cdr range)) + (car range))))) + (t + (while range + (if (numberp (car range)) + (setq num (1+ num)) + (setq num (+ num (- (1+ (cdar range)) (caar range))))) + (setq range (cdr range))) + (setq num (- (cdr active) num)))) + ;; Update the number of unread articles. + (setcar entry num) + ;; Update the group buffer. + (gnus-group-update-group group t)))) + +(defun gnus-methods-equal-p (m1 m2) + (let ((m1 (or m1 gnus-select-method)) + (m2 (or m2 gnus-select-method))) + (or (equal m1 m2) + (and (eq (car m1) (car m2)) + (or (not (memq 'address (assoc (symbol-name (car m1)) + gnus-valid-select-methods))) + (equal (nth 1 m1) (nth 1 m2))))))) + +(defvar gnus-newsgroup-none-id 0) + +(defun gnus-get-newsgroup-headers (&optional dependencies force-new) + (let ((cur nntp-server-buffer) + (dependencies + (or dependencies + (save-excursion (set-buffer gnus-summary-buffer) + gnus-newsgroup-dependencies))) + headers id id-dep ref-dep end ref) + (save-excursion + (set-buffer nntp-server-buffer) + ;; Translate all TAB characters into SPACE characters. + (subst-char-in-region (point-min) (point-max) ?\t ? t) + (run-hooks 'gnus-parse-headers-hook) + (let ((case-fold-search t) + in-reply-to header p lines) + (goto-char (point-min)) + ;; Search to the beginning of the next header. Error messages + ;; do not begin with 2 or 3. + (while (re-search-forward "^[23][0-9]+ " nil t) + (setq id nil + ref nil) + ;; This implementation of this function, with nine + ;; search-forwards instead of the one re-search-forward and + ;; a case (which basically was the old function) is actually + ;; about twice as fast, even though it looks messier. You + ;; can't have everything, I guess. Speed and elegance + ;; doesn't always go hand in hand. + (setq + header + (vector + ;; Number. + (prog1 + (read cur) + (end-of-line) + (setq p (point)) + (narrow-to-region (point) + (or (and (search-forward "\n.\n" nil t) + (- (point) 2)) + (point)))) + ;; Subject. + (progn + (goto-char p) + (if (search-forward "\nsubject: " nil t) + (nnheader-header-value) "(none)")) + ;; From. + (progn + (goto-char p) + (if (search-forward "\nfrom: " nil t) + (nnheader-header-value) "(nobody)")) + ;; Date. + (progn + (goto-char p) + (if (search-forward "\ndate: " nil t) + (nnheader-header-value) "")) + ;; Message-ID. + (progn + (goto-char p) + (setq id (if (search-forward "\nmessage-id: " nil t) + (nnheader-header-value) + ;; If there was no message-id, we just fake one + ;; to make subsequent routines simpler. + (nnheader-generate-fake-message-id)))) + ;; References. + (progn + (goto-char p) + (if (search-forward "\nreferences: " nil t) + (progn + (setq end (point)) + (prog1 + (nnheader-header-value) + (setq ref + (buffer-substring + (progn + (end-of-line) + (search-backward ">" end t) + (1+ (point))) + (progn + (search-backward "<" end t) + (point)))))) + ;; Get the references from the in-reply-to header if there + ;; were no references and the in-reply-to header looks + ;; promising. + (if (and (search-forward "\nin-reply-to: " nil t) + (setq in-reply-to (nnheader-header-value)) + (string-match "<[^>]+>" in-reply-to)) + (setq ref (substring in-reply-to (match-beginning 0) + (match-end 0))) + (setq ref nil)))) + ;; Chars. + 0 + ;; Lines. + (progn + (goto-char p) + (if (search-forward "\nlines: " nil t) + (if (numberp (setq lines (read cur))) + lines 0) + 0)) + ;; Xref. + (progn + (goto-char p) + (and (search-forward "\nxref: " nil t) + (nnheader-header-value))))) + (when (equal id ref) + (setq ref nil)) + ;; We do the threading while we read the headers. The + ;; message-id and the last reference are both entered into + ;; the same hash table. Some tippy-toeing around has to be + ;; done in case an article has arrived before the article + ;; which it refers to. + (if (boundp (setq id-dep (intern id dependencies))) + (if (and (car (symbol-value id-dep)) + (not force-new)) + ;; An article with this Message-ID has already + ;; been seen, so we ignore this one, except we add + ;; any additional Xrefs (in case the two articles + ;; came from different servers). + (progn + (mail-header-set-xref + (car (symbol-value id-dep)) + (concat (or (mail-header-xref + (car (symbol-value id-dep))) + "") + (or (mail-header-xref header) ""))) + (setq header nil)) + (setcar (symbol-value id-dep) header)) + (set id-dep (list header))) + (when header + (if (boundp (setq ref-dep (intern (or ref "none") dependencies))) + (setcdr (symbol-value ref-dep) + (nconc (cdr (symbol-value ref-dep)) + (list (symbol-value id-dep)))) + (set ref-dep (list nil (symbol-value id-dep)))) + (push header headers)) + (goto-char (point-max)) + (widen)) + (nreverse headers))))) + +;; The following macros and functions were written by Felix Lee +;; . + +(defmacro gnus-nov-read-integer () + '(prog1 + (if (= (following-char) ?\t) + 0 + (let ((num (ignore-errors (read buffer)))) + (if (numberp num) num 0))) + (unless (eobp) + (forward-char 1)))) + +(defmacro gnus-nov-skip-field () + '(search-forward "\t" eol 'move)) + +(defmacro gnus-nov-field () + '(buffer-substring (point) (if (gnus-nov-skip-field) (1- (point)) eol))) + +;; (defvar gnus-nov-none-counter 0) + +;; This function has to be called with point after the article number +;; on the beginning of the line. +(defun gnus-nov-parse-line (number dependencies &optional force-new) + (let ((eol (point-at-eol)) + (buffer (current-buffer)) + header ref id id-dep ref-dep) + + ;; overview: [num subject from date id refs chars lines misc] + (unwind-protect + (progn + (narrow-to-region (point) eol) + (unless (eobp) + (forward-char)) + + (setq header + (vector + number ; number + (gnus-nov-field) ; subject + (gnus-nov-field) ; from + (gnus-nov-field) ; date + (setq id (or (gnus-nov-field) + (nnheader-generate-fake-message-id))) ; id + (progn + (let ((beg (point))) + (search-forward "\t" eol) + (if (search-backward ">" beg t) + (setq ref + (buffer-substring + (1+ (point)) + (search-backward "<" beg t))) + (setq ref nil)) + (goto-char beg)) + (gnus-nov-field)) ; refs + (gnus-nov-read-integer) ; chars + (gnus-nov-read-integer) ; lines + (if (= (following-char) ?\n) + nil + (gnus-nov-field)) ; misc + ))) + + (widen)) + + ;; We build the thread tree. + (when (equal id ref) + ;; This article refers back to itself. Naughty, naughty. + (setq ref nil)) + (if (boundp (setq id-dep (intern id dependencies))) + (if (and (car (symbol-value id-dep)) + (not force-new)) + ;; An article with this Message-ID has already been seen, + ;; so we ignore this one, except we add any additional + ;; Xrefs (in case the two articles came from different + ;; servers. + (progn + (mail-header-set-xref + (car (symbol-value id-dep)) + (concat (or (mail-header-xref + (car (symbol-value id-dep))) + "") + (or (mail-header-xref header) ""))) + (setq header nil)) + (setcar (symbol-value id-dep) header)) + (set id-dep (list header))) + (when header + (if (boundp (setq ref-dep (intern (or ref "none") dependencies))) + (setcdr (symbol-value ref-dep) + (nconc (cdr (symbol-value ref-dep)) + (list (symbol-value id-dep)))) + (set ref-dep (list nil (symbol-value id-dep))))) + header)) + +;; Goes through the xover lines and returns a list of vectors +(defun gnus-get-newsgroup-headers-xover (sequence &optional + force-new dependencies + group also-fetch-heads) + "Parse the news overview data in the server buffer, and return a +list of headers that match SEQUENCE (see `nntp-retrieve-headers')." + ;; Get the Xref when the users reads the articles since most/some + ;; NNTP servers do not include Xrefs when using XOVER. + (setq gnus-article-internal-prepare-hook '(gnus-article-get-xrefs)) + (let ((cur nntp-server-buffer) + (dependencies (or dependencies gnus-newsgroup-dependencies)) + number headers header) + (save-excursion + (set-buffer nntp-server-buffer) + ;; Allow the user to mangle the headers before parsing them. + (run-hooks 'gnus-parse-headers-hook) + (goto-char (point-min)) + (while (not (eobp)) + (condition-case () + (while (and sequence (not (eobp))) + (setq number (read cur)) + (while (and sequence + (< (car sequence) number)) + (setq sequence (cdr sequence))) + (and sequence + (eq number (car sequence)) + (progn + (setq sequence (cdr sequence)) + (setq header (inline + (gnus-nov-parse-line + number dependencies force-new)))) + (push header headers)) + (forward-line 1)) + (error + (gnus-error 4 "Strange nov line (%d)" + (count-lines (point-min) (point))))) + (forward-line 1)) + ;; A common bug in inn is that if you have posted an article and + ;; then retrieves the active file, it will answer correctly -- + ;; the new article is included. However, a NOV entry for the + ;; article may not have been generated yet, so this may fail. + ;; We work around this problem by retrieving the last few + ;; headers using HEAD. + (if (or (not also-fetch-heads) + (not sequence)) + (nreverse headers) + (let ((gnus-nov-is-evil t) + (nntp-nov-is-evil t)) + (nconc + (nreverse headers) + (when (gnus-retrieve-headers sequence group) + (gnus-get-newsgroup-headers)))))))) + +(defun gnus-article-get-xrefs () + "Fill in the Xref value in `gnus-current-headers', if necessary. +This is meant to be called in `gnus-article-internal-prepare-hook'." + (let ((headers (save-excursion (set-buffer gnus-summary-buffer) + gnus-current-headers))) + (or (not gnus-use-cross-reference) + (not headers) + (and (mail-header-xref headers) + (not (string= (mail-header-xref headers) ""))) + (let ((case-fold-search t) + xref) + (save-restriction + (nnheader-narrow-to-headers) + (goto-char (point-min)) + (when (or (and (eq (downcase (following-char)) ?x) + (looking-at "Xref:")) + (search-forward "\nXref:" nil t)) + (goto-char (1+ (match-end 0))) + (setq xref (buffer-substring (point) + (progn (end-of-line) (point)))) + (mail-header-set-xref headers xref))))))) + +(defun gnus-summary-insert-subject (id &optional old-header use-old-header) + "Find article ID and insert the summary line for that article." + (let ((header (if (and old-header use-old-header) + old-header (gnus-read-header id))) + (number (and (numberp id) id)) + pos d) + (when header + ;; Rebuild the thread that this article is part of and go to the + ;; article we have fetched. + (when (and (not gnus-show-threads) + old-header) + (when (setq d (gnus-data-find (mail-header-number old-header))) + (goto-char (gnus-data-pos d)) + (gnus-data-remove + number + (- (point-at-bol) + (prog1 + (1+ (point-at-eol)) + (gnus-delete-line)))))) + (when old-header + (mail-header-set-number header (mail-header-number old-header))) + (setq gnus-newsgroup-sparse + (delq (setq number (mail-header-number header)) + gnus-newsgroup-sparse)) + (setq gnus-newsgroup-ancient (delq number gnus-newsgroup-ancient)) + (gnus-rebuild-thread (mail-header-id header)) + (gnus-summary-goto-subject number nil t)) + (when (and (numberp number) + (> number 0)) + ;; We have to update the boundaries even if we can't fetch the + ;; article if ID is a number -- so that the next `P' or `N' + ;; command will fetch the previous (or next) article even + ;; if the one we tried to fetch this time has been canceled. + (when (> number gnus-newsgroup-end) + (setq gnus-newsgroup-end number)) + (when (< number gnus-newsgroup-begin) + (setq gnus-newsgroup-begin number)) + (setq gnus-newsgroup-unselected + (delq number gnus-newsgroup-unselected))) + ;; Report back a success? + (and header (mail-header-number header)))) + +;;; Process/prefix in the summary buffer + +(defun gnus-summary-work-articles (n) + "Return a list of articles to be worked upon. The prefix argument, +the list of process marked articles, and the current article will be +taken into consideration." + (cond + (n + ;; A numerical prefix has been given. + (setq n (prefix-numeric-value n)) + (let ((backward (< n 0)) + (n (abs (prefix-numeric-value n))) + articles article) + (save-excursion + (while + (and (> n 0) + (push (setq article (gnus-summary-article-number)) + articles) + (if backward + (gnus-summary-find-prev nil article) + (gnus-summary-find-next nil article))) + (decf n))) + (nreverse articles))) + ((and (boundp 'transient-mark-mode) + transient-mark-mode + (boundp 'mark-active) + mark-active) + ;; Work on the region between point and mark. + (let ((max (max (point) (mark))) + articles article) + (save-excursion + (goto-char (min (point) (mark))) + (while + (and + (push (setq article (gnus-summary-article-number)) articles) + (gnus-summary-find-next nil article) + (< (point) max))) + (nreverse articles)))) + (gnus-newsgroup-processable + ;; There are process-marked articles present. + ;; Save current state. + (gnus-summary-save-process-mark) + ;; Return the list. + (reverse gnus-newsgroup-processable)) + (t + ;; Just return the current article. + (list (gnus-summary-article-number))))) + +(defun gnus-summary-save-process-mark () + "Push the current set of process marked articles on the stack." + (interactive) + (push (copy-sequence gnus-newsgroup-processable) + gnus-newsgroup-process-stack)) + +(defun gnus-summary-kill-process-mark () + "Push the current set of process marked articles on the stack and unmark." + (interactive) + (gnus-summary-save-process-mark) + (gnus-summary-unmark-all-processable)) + +(defun gnus-summary-yank-process-mark () + "Pop the last process mark state off the stack and restore it." + (interactive) + (unless gnus-newsgroup-process-stack + (error "Empty mark stack")) + (gnus-summary-process-mark-set (pop gnus-newsgroup-process-stack))) + +(defun gnus-summary-process-mark-set (set) + "Make SET into the current process marked articles." + (gnus-summary-unmark-all-processable) + (while set + (gnus-summary-set-process-mark (pop set)))) + +;;; Searching and stuff + +(defun gnus-summary-search-group (&optional backward use-level) + "Search for next unread newsgroup. +If optional argument BACKWARD is non-nil, search backward instead." + (save-excursion + (set-buffer gnus-group-buffer) + (when (gnus-group-search-forward + backward nil (if use-level (gnus-group-group-level) nil)) + (gnus-group-group-name)))) + +(defun gnus-summary-best-group (&optional exclude-group) + "Find the name of the best unread group. +If EXCLUDE-GROUP, do not go to this group." + (save-excursion + (set-buffer gnus-group-buffer) + (save-excursion + (gnus-group-best-unread-group exclude-group)))) + +(defun gnus-summary-find-next (&optional unread article backward) + (if backward (gnus-summary-find-prev) + (let* ((dummy (gnus-summary-article-intangible-p)) + (article (or article (gnus-summary-article-number))) + (arts (gnus-data-find-list article)) + result) + (when (and (not dummy) + (or (not gnus-summary-check-current) + (not unread) + (not (gnus-data-unread-p (car arts))))) + (setq arts (cdr arts))) + (when (setq result + (if unread + (progn + (while arts + (when (gnus-data-unread-p (car arts)) + (setq result (car arts) + arts nil)) + (setq arts (cdr arts))) + result) + (car arts))) + (goto-char (gnus-data-pos result)) + (gnus-data-number result))))) + +(defun gnus-summary-find-prev (&optional unread article) + (let* ((eobp (eobp)) + (article (or article (gnus-summary-article-number))) + (arts (gnus-data-find-list article (gnus-data-list 'rev))) + result) + (when (and (not eobp) + (or (not gnus-summary-check-current) + (not unread) + (not (gnus-data-unread-p (car arts))))) + (setq arts (cdr arts))) + (when (setq result + (if unread + (progn + (while arts + (when (gnus-data-unread-p (car arts)) + (setq result (car arts) + arts nil)) + (setq arts (cdr arts))) + result) + (car arts))) + (goto-char (gnus-data-pos result)) + (gnus-data-number result)))) + +(defun gnus-summary-find-subject (subject &optional unread backward article) + (let* ((simp-subject (gnus-simplify-subject-fully subject)) + (article (or article (gnus-summary-article-number))) + (articles (gnus-data-list backward)) + (arts (gnus-data-find-list article articles)) + result) + (when (or (not gnus-summary-check-current) + (not unread) + (not (gnus-data-unread-p (car arts)))) + (setq arts (cdr arts))) + (while arts + (and (or (not unread) + (gnus-data-unread-p (car arts))) + (vectorp (gnus-data-header (car arts))) + (gnus-subject-equal + simp-subject (mail-header-subject (gnus-data-header (car arts))) t) + (setq result (car arts) + arts nil)) + (setq arts (cdr arts))) + (and result + (goto-char (gnus-data-pos result)) + (gnus-data-number result)))) + +(defun gnus-summary-search-forward (&optional unread subject backward) + "Search forward for an article. +If UNREAD, look for unread articles. If SUBJECT, look for +articles with that subject. If BACKWARD, search backward instead." + (cond (subject (gnus-summary-find-subject subject unread backward)) + (backward (gnus-summary-find-prev unread)) + (t (gnus-summary-find-next unread)))) + +(defun gnus-recenter (&optional n) + "Center point in window and redisplay frame. +Also do horizontal recentering." + (interactive "P") + (when (and gnus-auto-center-summary + (not (eq gnus-auto-center-summary 'vertical))) + (gnus-horizontal-recenter)) + (recenter n)) + +(defun gnus-summary-recenter () + "Center point in the summary window. +If `gnus-auto-center-summary' is nil, or the article buffer isn't +displayed, no centering will be performed." + ;; Suggested by earle@mahendo.JPL.NASA.GOV (Greg Earle). + ;; Recenter only when requested. Suggested by popovich@park.cs.columbia.edu. + (let* ((top (cond ((< (window-height) 4) 0) + ((< (window-height) 7) 1) + (t 2))) + (height (1- (window-height))) + (bottom (save-excursion (goto-char (point-max)) + (forward-line (- height)) + (point))) + (window (get-buffer-window (current-buffer)))) + ;; The user has to want it. + (when gnus-auto-center-summary + (when (get-buffer-window gnus-article-buffer) + ;; Only do recentering when the article buffer is displayed, + ;; Set the window start to either `bottom', which is the biggest + ;; possible valid number, or the second line from the top, + ;; whichever is the least. + (set-window-start + window (min bottom (save-excursion + (forward-line (- top)) (point))))) + ;; Do horizontal recentering while we're at it. + (when (and (get-buffer-window (current-buffer) t) + (not (eq gnus-auto-center-summary 'vertical))) + (let ((selected (selected-window))) + (select-window (get-buffer-window (current-buffer) t)) + (gnus-summary-position-point) + (gnus-horizontal-recenter) + (select-window selected)))))) + +(defun gnus-summary-jump-to-group (newsgroup) + "Move point to NEWSGROUP in group mode buffer." + ;; Keep update point of group mode buffer if visible. + (if (eq (current-buffer) (get-buffer gnus-group-buffer)) + (save-window-excursion + ;; Take care of tree window mode. + (when (get-buffer-window gnus-group-buffer) + (pop-to-buffer gnus-group-buffer)) + (gnus-group-jump-to-group newsgroup)) + (save-excursion + ;; Take care of tree window mode. + (if (get-buffer-window gnus-group-buffer) + (pop-to-buffer gnus-group-buffer) + (set-buffer gnus-group-buffer)) + (gnus-group-jump-to-group newsgroup)))) + +;; This function returns a list of article numbers based on the +;; difference between the ranges of read articles in this group and +;; the range of active articles. +(defun gnus-list-of-unread-articles (group) + (let* ((read (gnus-info-read (gnus-get-info group))) + (active (or (gnus-active group) (gnus-activate-group group))) + (last (cdr active)) + first nlast unread) + ;; If none are read, then all are unread. + (if (not read) + (setq first (car active)) + ;; If the range of read articles is a single range, then the + ;; first unread article is the article after the last read + ;; article. Sounds logical, doesn't it? + (if (not (listp (cdr read))) + (setq first (1+ (cdr read))) + ;; `read' is a list of ranges. + (when (/= (setq nlast (or (and (numberp (car read)) (car read)) + (caar read))) + 1) + (setq first 1)) + (while read + (when first + (while (< first nlast) + (push first unread) + (setq first (1+ first)))) + (setq first (1+ (if (atom (car read)) (car read) (cdar read)))) + (setq nlast (if (atom (cadr read)) (cadr read) (caadr read))) + (setq read (cdr read))))) + ;; And add the last unread articles. + (while (<= first last) + (push first unread) + (setq first (1+ first))) + ;; Return the list of unread articles. + (nreverse unread))) + +(defun gnus-list-of-read-articles (group) + "Return a list of unread, unticked and non-dormant articles." + (let* ((info (gnus-get-info group)) + (marked (gnus-info-marks info)) + (active (gnus-active group))) + (and info active + (gnus-set-difference + (gnus-sorted-complement + (gnus-uncompress-range active) + (gnus-list-of-unread-articles group)) + (append + (gnus-uncompress-range (cdr (assq 'dormant marked))) + (gnus-uncompress-range (cdr (assq 'tick marked)))))))) + +;; Various summary commands + +(defun gnus-summary-universal-argument (arg) + "Perform any operation on all articles that are process/prefixed." + (interactive "P") + (gnus-set-global-variables) + (let ((articles (gnus-summary-work-articles arg)) + func article) + (if (eq + (setq + func + (key-binding + (read-key-sequence + (substitute-command-keys + "\\\\[gnus-summary-universal-argument]" + )))) + 'undefined) + (gnus-error 1 "Undefined key") + (save-excursion + (while articles + (gnus-summary-goto-subject (setq article (pop articles))) + (let (gnus-newsgroup-processable) + (command-execute func)) + (gnus-summary-remove-process-mark article))))) + (gnus-summary-position-point)) + +(defun gnus-summary-toggle-truncation (&optional arg) + "Toggle truncation of summary lines. +With arg, turn line truncation on iff arg is positive." + (interactive "P") + (setq truncate-lines + (if (null arg) (not truncate-lines) + (> (prefix-numeric-value arg) 0))) + (redraw-display)) + +(defun gnus-summary-reselect-current-group (&optional all rescan) + "Exit and then reselect the current newsgroup. +The prefix argument ALL means to select all articles." + (interactive "P") + (gnus-set-global-variables) + (when (gnus-ephemeral-group-p gnus-newsgroup-name) + (error "Ephemeral groups can't be reselected")) + (let ((current-subject (gnus-summary-article-number)) + (group gnus-newsgroup-name)) + (setq gnus-newsgroup-begin nil) + (gnus-summary-exit) + ;; We have to adjust the point of group mode buffer because + ;; point was moved to the next unread newsgroup by exiting. + (gnus-summary-jump-to-group group) + (when rescan + (save-excursion + (gnus-group-get-new-news-this-group 1))) + (gnus-group-read-group all t) + (gnus-summary-goto-subject current-subject nil t))) + +(defun gnus-summary-rescan-group (&optional all) + "Exit the newsgroup, ask for new articles, and select the newsgroup." + (interactive "P") + (gnus-summary-reselect-current-group all t)) + +(defun gnus-summary-update-info (&optional non-destructive) + (save-excursion + (let ((group gnus-newsgroup-name)) + (when gnus-newsgroup-kill-headers + (setq gnus-newsgroup-killed + (gnus-compress-sequence + (nconc + (gnus-set-sorted-intersection + (gnus-uncompress-range gnus-newsgroup-killed) + (setq gnus-newsgroup-unselected + (sort gnus-newsgroup-unselected '<))) + (setq gnus-newsgroup-unreads + (sort gnus-newsgroup-unreads '<))) + t))) + (unless (listp (cdr gnus-newsgroup-killed)) + (setq gnus-newsgroup-killed (list gnus-newsgroup-killed))) + (let ((headers gnus-newsgroup-headers)) + (when (and (not gnus-save-score) + (not non-destructive)) + (setq gnus-newsgroup-scored nil)) + ;; Set the new ranges of read articles. + (gnus-update-read-articles + group (append gnus-newsgroup-unreads gnus-newsgroup-unselected)) + ;; Set the current article marks. + (gnus-update-marks) + ;; Do the cross-ref thing. + (when gnus-use-cross-reference + (gnus-mark-xrefs-as-read group headers gnus-newsgroup-unreads)) + ;; Do adaptive scoring, and possibly save score files. + (when gnus-newsgroup-adaptive + (gnus-score-adaptive)) + (when gnus-use-scoring + (gnus-score-save)) + ;; Do not switch windows but change the buffer to work. + (set-buffer gnus-group-buffer) + (unless (gnus-ephemeral-group-p gnus-newsgroup-name) + (gnus-group-update-group group)))))) + +(defun gnus-summary-save-newsrc (&optional force) + "Save the current number of read/marked articles in the dribble buffer. +The dribble buffer will then be saved. +If FORCE (the prefix), also save the .newsrc file(s)." + (interactive "P") + (gnus-summary-update-info t) + (if force + (gnus-save-newsrc-file) + (gnus-dribble-save))) + +(defun gnus-summary-exit (&optional temporary) + "Exit reading current newsgroup, and then return to group selection mode. +gnus-exit-group-hook is called with no arguments if that value is non-nil." + (interactive) + (gnus-set-global-variables) + (gnus-kill-save-kill-buffer) + (let* ((group gnus-newsgroup-name) + (quit-config (gnus-group-quit-config gnus-newsgroup-name)) + (mode major-mode) + (buf (current-buffer))) + (run-hooks 'gnus-summary-prepare-exit-hook) + ;; If we have several article buffers, we kill them at exit. + (unless gnus-single-article-buffer + (gnus-kill-buffer gnus-original-article-buffer) + (setq gnus-article-current nil)) + (when gnus-use-cache + (gnus-cache-possibly-remove-articles) + (gnus-cache-save-buffers)) + (gnus-async-prefetch-remove-group group) + (when gnus-suppress-duplicates + (gnus-dup-enter-articles)) + (when gnus-use-trees + (gnus-tree-close group)) + ;; Make all changes in this group permanent. + (unless quit-config + (run-hooks 'gnus-exit-group-hook) + (gnus-summary-update-info)) + (gnus-close-group group) + ;; Make sure where I was, and go to next newsgroup. + (set-buffer gnus-group-buffer) + (unless quit-config + (gnus-group-jump-to-group group)) + (run-hooks 'gnus-summary-exit-hook) + (unless quit-config + (gnus-group-next-unread-group 1)) + (if temporary + nil ;Nothing to do. + ;; If we have several article buffers, we kill them at exit. + (unless gnus-single-article-buffer + (gnus-kill-buffer gnus-article-buffer) + (gnus-kill-buffer gnus-original-article-buffer) + (setq gnus-article-current nil)) + (set-buffer buf) + (if (not gnus-kill-summary-on-exit) + (gnus-deaden-summary) + ;; We set all buffer-local variables to nil. It is unclear why + ;; this is needed, but if we don't, buffer-local variables are + ;; not garbage-collected, it seems. This would the lead to en + ;; ever-growing Emacs. + (gnus-summary-clear-local-variables) + (when (get-buffer gnus-article-buffer) + (bury-buffer gnus-article-buffer)) + ;; We clear the global counterparts of the buffer-local + ;; variables as well, just to be on the safe side. + (set-buffer gnus-group-buffer) + (gnus-summary-clear-local-variables) + ;; Return to group mode buffer. + (when (eq mode 'gnus-summary-mode) + (gnus-kill-buffer buf))) + (setq gnus-current-select-method gnus-select-method) + (pop-to-buffer gnus-group-buffer) + ;; Clear the current group name. + (if (not quit-config) + (progn + (gnus-group-jump-to-group group) + (gnus-group-next-unread-group 1) + (gnus-configure-windows 'group 'force)) + (gnus-handle-ephemeral-exit quit-config)) + (unless quit-config + (setq gnus-newsgroup-name nil))))) + +(defalias 'gnus-summary-quit 'gnus-summary-exit-no-update) +(defun gnus-summary-exit-no-update (&optional no-questions) + "Quit reading current newsgroup without updating read article info." + (interactive) + (gnus-set-global-variables) + (let* ((group gnus-newsgroup-name) + (quit-config (gnus-group-quit-config group))) + (when (or no-questions + gnus-expert-user + (gnus-y-or-n-p "Discard changes to this group and exit? ")) + ;; If we have several article buffers, we kill them at exit. + (unless gnus-single-article-buffer + (gnus-kill-buffer gnus-article-buffer) + (gnus-kill-buffer gnus-original-article-buffer) + (setq gnus-article-current nil)) + (if (not gnus-kill-summary-on-exit) + (gnus-deaden-summary) + (gnus-close-group group) + (gnus-summary-clear-local-variables) + (set-buffer gnus-group-buffer) + (gnus-summary-clear-local-variables) + (when (get-buffer gnus-summary-buffer) + (kill-buffer gnus-summary-buffer))) + (unless gnus-single-article-buffer + (setq gnus-article-current nil)) + (when gnus-use-trees + (gnus-tree-close group)) + (gnus-async-prefetch-remove-group group) + (when (get-buffer gnus-article-buffer) + (bury-buffer gnus-article-buffer)) + ;; Return to the group buffer. + (gnus-configure-windows 'group 'force) + ;; Clear the current group name. + (setq gnus-newsgroup-name nil) + (when (equal (gnus-group-group-name) group) + (gnus-group-next-unread-group 1)) + (when quit-config + (gnus-handle-ephemeral-exit quit-config))))) + +(defun gnus-handle-ephemeral-exit (quit-config) + "Handle movement when leaving an ephemeral group. The state +which existed when entering the ephemeral is reset." + (if (not (buffer-name (car quit-config))) + (gnus-configure-windows 'group 'force) + (set-buffer (car quit-config)) + (cond ((eq major-mode 'gnus-summary-mode) + (gnus-set-global-variables)) + ((eq major-mode 'gnus-article-mode) + (save-excursion + ;; The `gnus-summary-buffer' variable may point + ;; to the old summary buffer when using a single + ;; article buffer. + (unless (gnus-buffer-live-p gnus-summary-buffer) + (set-buffer gnus-group-buffer)) + (set-buffer gnus-summary-buffer) + (gnus-set-global-variables)))) + (if (or (eq (cdr quit-config) 'article) + (eq (cdr quit-config) 'pick)) + (progn + ;; The current article may be from the ephemeral group + ;; thus it is best that we reload this article + (gnus-summary-show-article) + (if (and (boundp 'gnus-pick-mode) (symbol-value 'gnus-pick-mode)) + (gnus-configure-windows 'pick 'force) + (gnus-configure-windows (cdr quit-config) 'force))) + (gnus-configure-windows (cdr quit-config) 'force)) + (when (eq major-mode 'gnus-summary-mode) + (gnus-summary-next-subject 1 nil t) + (gnus-summary-recenter) + (gnus-summary-position-point)))) + +;;; Dead summaries. + +(defvar gnus-dead-summary-mode-map nil) + +(unless gnus-dead-summary-mode-map + (setq gnus-dead-summary-mode-map (make-keymap)) + (suppress-keymap gnus-dead-summary-mode-map) + (substitute-key-definition + 'undefined 'gnus-summary-wake-up-the-dead gnus-dead-summary-mode-map) + (let ((keys '("\C-d" "\r" "\177"))) + (while keys + (define-key gnus-dead-summary-mode-map + (pop keys) 'gnus-summary-wake-up-the-dead)))) + +(defvar gnus-dead-summary-mode nil + "Minor mode for Gnus summary buffers.") + +(defun gnus-dead-summary-mode (&optional arg) + "Minor mode for Gnus summary buffers." + (interactive "P") + (when (eq major-mode 'gnus-summary-mode) + (make-local-variable 'gnus-dead-summary-mode) + (setq gnus-dead-summary-mode + (if (null arg) (not gnus-dead-summary-mode) + (> (prefix-numeric-value arg) 0))) + (when gnus-dead-summary-mode + (unless (assq 'gnus-dead-summary-mode minor-mode-alist) + (push '(gnus-dead-summary-mode " Dead") minor-mode-alist)) + (unless (assq 'gnus-dead-summary-mode minor-mode-map-alist) + (push (cons 'gnus-dead-summary-mode gnus-dead-summary-mode-map) + minor-mode-map-alist))))) + +(defun gnus-deaden-summary () + "Make the current summary buffer into a dead summary buffer." + ;; Kill any previous dead summary buffer. + (when (and gnus-dead-summary + (buffer-name gnus-dead-summary)) + (save-excursion + (set-buffer gnus-dead-summary) + (when gnus-dead-summary-mode + (kill-buffer (current-buffer))))) + ;; Make this the current dead summary. + (setq gnus-dead-summary (current-buffer)) + (gnus-dead-summary-mode 1) + (let ((name (buffer-name))) + (when (string-match "Summary" name) + (rename-buffer + (concat (substring name 0 (match-beginning 0)) "Dead " + (substring name (match-beginning 0))) + t)))) + +(defun gnus-kill-or-deaden-summary (buffer) + "Kill or deaden the summary BUFFER." + (when (and (buffer-name buffer) + (not gnus-single-article-buffer)) + (save-excursion + (set-buffer buffer) + (gnus-kill-buffer gnus-article-buffer) + (gnus-kill-buffer gnus-original-article-buffer))) + (cond (gnus-kill-summary-on-exit + (when (and gnus-use-trees + (and (get-buffer buffer) + (buffer-name (get-buffer buffer)))) + (save-excursion + (set-buffer (get-buffer buffer)) + (gnus-tree-close gnus-newsgroup-name))) + (gnus-kill-buffer buffer)) + ((and (get-buffer buffer) + (buffer-name (get-buffer buffer))) + (save-excursion + (set-buffer buffer) + (gnus-deaden-summary))))) + +(defun gnus-summary-wake-up-the-dead (&rest args) + "Wake up the dead summary buffer." + (interactive) + (gnus-dead-summary-mode -1) + (let ((name (buffer-name))) + (when (string-match "Dead " name) + (rename-buffer + (concat (substring name 0 (match-beginning 0)) + (substring name (match-end 0))) + t))) + (gnus-message 3 "This dead summary is now alive again")) + +;; Suggested by Andrew Eskilsson . +(defun gnus-summary-fetch-faq (&optional faq-dir) + "Fetch the FAQ for the current group. +If FAQ-DIR (the prefix), prompt for a directory to search for the faq +in." + (interactive + (list + (when current-prefix-arg + (completing-read + "Faq dir: " (and (listp gnus-group-faq-directory) + gnus-group-faq-directory))))) + (let (gnus-faq-buffer) + (when (setq gnus-faq-buffer + (gnus-group-fetch-faq gnus-newsgroup-name faq-dir)) + (gnus-configure-windows 'summary-faq)))) + +;; Suggested by Per Abrahamsen . +(defun gnus-summary-describe-group (&optional force) + "Describe the current newsgroup." + (interactive "P") + (gnus-group-describe-group force gnus-newsgroup-name)) + +(defun gnus-summary-describe-briefly () + "Describe summary mode commands briefly." + (interactive) + (gnus-message 6 + (substitute-command-keys "\\\\[gnus-summary-next-page]:Select \\[gnus-summary-next-unread-article]:Forward \\[gnus-summary-prev-unread-article]:Backward \\[gnus-summary-exit]:Exit \\[gnus-info-find-node]:Run Info \\[gnus-summary-describe-briefly]:This help"))) + +;; Walking around group mode buffer from summary mode. + +(defun gnus-summary-next-group (&optional no-article target-group backward) + "Exit current newsgroup and then select next unread newsgroup. +If prefix argument NO-ARTICLE is non-nil, no article is selected +initially. If NEXT-GROUP, go to this group. If BACKWARD, go to +previous group instead." + (interactive "P") + (gnus-set-global-variables) + ;; Stop pre-fetching. + (gnus-async-halt-prefetch) + (let ((current-group gnus-newsgroup-name) + (current-buffer (current-buffer)) + entered) + ;; First we semi-exit this group to update Xrefs and all variables. + ;; We can't do a real exit, because the window conf must remain + ;; the same in case the user is prompted for info, and we don't + ;; want the window conf to change before that... + (gnus-summary-exit t) + (while (not entered) + ;; Then we find what group we are supposed to enter. + (set-buffer gnus-group-buffer) + (gnus-group-jump-to-group current-group) + (setq target-group + (or target-group + (if (eq gnus-keep-same-level 'best) + (gnus-summary-best-group gnus-newsgroup-name) + (gnus-summary-search-group backward gnus-keep-same-level)))) + (if (not target-group) + ;; There are no further groups, so we return to the group + ;; buffer. + (progn + (gnus-message 5 "Returning to the group buffer") + (setq entered t) + (set-buffer current-buffer) + (gnus-summary-exit) + (run-hooks 'gnus-group-no-more-groups-hook)) + ;; We try to enter the target group. + (gnus-group-jump-to-group target-group) + (let ((unreads (gnus-group-group-unread))) + (if (and (or (eq t unreads) + (and unreads (not (zerop unreads)))) + (gnus-summary-read-group + target-group nil no-article current-buffer)) + (setq entered t) + (setq current-group target-group + target-group nil))))))) + +(defun gnus-summary-prev-group (&optional no-article) + "Exit current newsgroup and then select previous unread newsgroup. +If prefix argument NO-ARTICLE is non-nil, no article is selected initially." + (interactive "P") + (gnus-summary-next-group no-article nil t)) + +;; Walking around summary lines. + +(defun gnus-summary-first-subject (&optional unread) + "Go to the first unread subject. +If UNREAD is non-nil, go to the first unread article. +Returns the article selected or nil if there are no unread articles." + (interactive "P") + (prog1 + (cond + ;; Empty summary. + ((null gnus-newsgroup-data) + (gnus-message 3 "No articles in the group") + nil) + ;; Pick the first article. + ((not unread) + (goto-char (gnus-data-pos (car gnus-newsgroup-data))) + (gnus-data-number (car gnus-newsgroup-data))) + ;; No unread articles. + ((null gnus-newsgroup-unreads) + (gnus-message 3 "No more unread articles") + nil) + ;; Find the first unread article. + (t + (let ((data gnus-newsgroup-data)) + (while (and data + (not (gnus-data-unread-p (car data)))) + (setq data (cdr data))) + (when data + (goto-char (gnus-data-pos (car data))) + (gnus-data-number (car data)))))) + (gnus-summary-position-point))) + +(defun gnus-summary-next-subject (n &optional unread dont-display) + "Go to next N'th summary line. +If N is negative, go to the previous N'th subject line. +If UNREAD is non-nil, only unread articles are selected. +The difference between N and the actual number of steps taken is +returned." + (interactive "p") + (let ((backward (< n 0)) + (n (abs n))) + (while (and (> n 0) + (if backward + (gnus-summary-find-prev unread) + (gnus-summary-find-next unread))) + (setq n (1- n))) + (when (/= 0 n) + (gnus-message 7 "No more%s articles" + (if unread " unread" ""))) + (unless dont-display + (gnus-summary-recenter) + (gnus-summary-position-point)) + n)) + +(defun gnus-summary-next-unread-subject (n) + "Go to next N'th unread summary line." + (interactive "p") + (gnus-summary-next-subject n t)) + +(defun gnus-summary-prev-subject (n &optional unread) + "Go to previous N'th summary line. +If optional argument UNREAD is non-nil, only unread article is selected." + (interactive "p") + (gnus-summary-next-subject (- n) unread)) + +(defun gnus-summary-prev-unread-subject (n) + "Go to previous N'th unread summary line." + (interactive "p") + (gnus-summary-next-subject (- n) t)) + +(defun gnus-summary-goto-subject (article &optional force silent) + "Go the subject line of ARTICLE. +If FORCE, also allow jumping to articles not currently shown." + (interactive "nArticle number: ") + (let ((b (point)) + (data (gnus-data-find article))) + ;; We read in the article if we have to. + (and (not data) + force + (gnus-summary-insert-subject article (and (vectorp force) force) t) + (setq data (gnus-data-find article))) + (goto-char b) + (if (not data) + (progn + (unless silent + (gnus-message 3 "Can't find article %d" article)) + nil) + (goto-char (gnus-data-pos data)) + article))) + +;; Walking around summary lines with displaying articles. + +(defun gnus-summary-expand-window (&optional arg) + "Make the summary buffer take up the entire Emacs frame. +Given a prefix, will force an `article' buffer configuration." + (interactive "P") + (gnus-set-global-variables) + (if arg + (gnus-configure-windows 'article 'force) + (gnus-configure-windows 'summary 'force))) + +(defun gnus-summary-display-article (article &optional all-header) + "Display ARTICLE in article buffer." + (gnus-set-global-variables) + (if (null article) + nil + (prog1 + (if gnus-summary-display-article-function + (funcall gnus-summary-display-article-function article all-header) + (gnus-article-prepare article all-header)) + (run-hooks 'gnus-select-article-hook) + (when (and gnus-current-article + (not (zerop gnus-current-article))) + (gnus-summary-goto-subject gnus-current-article)) + (gnus-summary-recenter) + (when (and gnus-use-trees gnus-show-threads) + (gnus-possibly-generate-tree article) + (gnus-highlight-selected-tree article)) + ;; Successfully display article. + (gnus-article-set-window-start + (cdr (assq article gnus-newsgroup-bookmarks)))))) + +(defun gnus-summary-select-article (&optional all-headers force pseudo article) + "Select the current article. +If ALL-HEADERS is non-nil, show all header fields. If FORCE is +non-nil, the article will be re-fetched even if it already present in +the article buffer. If PSEUDO is non-nil, pseudo-articles will also +be displayed." + ;; Make sure we are in the summary buffer to work around bbdb bug. + (unless (eq major-mode 'gnus-summary-mode) + (set-buffer gnus-summary-buffer)) + (let ((article (or article (gnus-summary-article-number))) + (all-headers (not (not all-headers))) ;Must be T or NIL. + gnus-summary-display-article-function + did) + (and (not pseudo) + (gnus-summary-article-pseudo-p article) + (error "This is a pseudo-article.")) + (prog1 + (save-excursion + (set-buffer gnus-summary-buffer) + (if (or (and gnus-single-article-buffer + (or (null gnus-current-article) + (null gnus-article-current) + (null (get-buffer gnus-article-buffer)) + (not (eq article (cdr gnus-article-current))) + (not (equal (car gnus-article-current) + gnus-newsgroup-name)))) + (and (not gnus-single-article-buffer) + (or (null gnus-current-article) + (not (eq gnus-current-article article)))) + force) + ;; The requested article is different from the current article. + (prog1 + (gnus-summary-display-article article all-headers) + (setq did article)) + (when (or all-headers gnus-show-all-headers) + (gnus-article-show-all-headers)) + 'old)) + (when did + (gnus-article-set-window-start + (cdr (assq article gnus-newsgroup-bookmarks))))))) + +(defun gnus-summary-set-current-mark (&optional current-mark) + "Obsolete function." + nil) + +(defun gnus-summary-next-article (&optional unread subject backward push) + "Select the next article. +If UNREAD, only unread articles are selected. +If SUBJECT, only articles with SUBJECT are selected. +If BACKWARD, the previous article is selected instead of the next." + (interactive "P") + (gnus-set-global-variables) + (cond + ;; Is there such an article? + ((and (gnus-summary-search-forward unread subject backward) + (or (gnus-summary-display-article (gnus-summary-article-number)) + (eq (gnus-summary-article-mark) gnus-canceled-mark))) + (gnus-summary-position-point)) + ;; If not, we try the first unread, if that is wanted. + ((and subject + gnus-auto-select-same + (gnus-summary-first-unread-article)) + (gnus-summary-position-point) + (gnus-message 6 "Wrapped")) + ;; Try to get next/previous article not displayed in this group. + ((and gnus-auto-extend-newsgroup + (not unread) (not subject)) + (gnus-summary-goto-article + (if backward (1- gnus-newsgroup-begin) (1+ gnus-newsgroup-end)) + nil t)) + ;; Go to next/previous group. + (t + (unless (gnus-ephemeral-group-p gnus-newsgroup-name) + (gnus-summary-jump-to-group gnus-newsgroup-name)) + (let ((cmd last-command-char) + (group + (if (eq gnus-keep-same-level 'best) + (gnus-summary-best-group gnus-newsgroup-name) + (gnus-summary-search-group backward gnus-keep-same-level)))) + ;; For some reason, the group window gets selected. We change + ;; it back. + (select-window (get-buffer-window (current-buffer))) + ;; Select next unread newsgroup automagically. + (cond + ((or (not gnus-auto-select-next) + (not cmd)) + (gnus-message 7 "No more%s articles" (if unread " unread" ""))) + ((or (eq gnus-auto-select-next 'quietly) + (and (eq gnus-auto-select-next 'slightly-quietly) + push) + (and (eq gnus-auto-select-next 'almost-quietly) + (gnus-summary-last-article-p))) + ;; Select quietly. + (if (gnus-ephemeral-group-p gnus-newsgroup-name) + (gnus-summary-exit) + (gnus-message 7 "No more%s articles (%s)..." + (if unread " unread" "") + (if group (concat "selecting " group) + "exiting")) + (gnus-summary-next-group nil group backward))) + (t + (when (gnus-key-press-event-p last-input-event) + (gnus-summary-walk-group-buffer + gnus-newsgroup-name cmd unread backward)))))))) + +(defun gnus-summary-walk-group-buffer (from-group cmd unread backward) + (let ((keystrokes '((?\C-n (gnus-group-next-unread-group 1)) + (?\C-p (gnus-group-prev-unread-group 1)))) + (cursor-in-echo-area t) + keve key group ended) + (save-excursion + (set-buffer gnus-group-buffer) + (gnus-summary-jump-to-group from-group) + (setq group + (if (eq gnus-keep-same-level 'best) + (gnus-summary-best-group gnus-newsgroup-name) + (gnus-summary-search-group backward gnus-keep-same-level)))) + (while (not ended) + (gnus-message + 5 "No more%s articles%s" (if unread " unread" "") + (if (and group + (not (gnus-ephemeral-group-p gnus-newsgroup-name))) + (format " (Type %s for %s [%s])" + (single-key-description cmd) group + (car (gnus-gethash group gnus-newsrc-hashtb))) + (format " (Type %s to exit %s)" + (single-key-description cmd) + gnus-newsgroup-name))) + ;; Confirm auto selection. + (setq key (car (setq keve (gnus-read-event-char)))) + (setq ended t) + (cond + ((assq key keystrokes) + (let ((obuf (current-buffer))) + (switch-to-buffer gnus-group-buffer) + (when group + (gnus-group-jump-to-group group)) + (eval (cadr (assq key keystrokes))) + (setq group (gnus-group-group-name)) + (switch-to-buffer obuf)) + (setq ended nil)) + ((equal key cmd) + (if (or (not group) + (gnus-ephemeral-group-p gnus-newsgroup-name)) + (gnus-summary-exit) + (gnus-summary-next-group nil group backward))) + (t + (push (cdr keve) unread-command-events)))))) + +(defun gnus-summary-next-unread-article () + "Select unread article after current one." + (interactive) + (gnus-summary-next-article + (or (not (eq gnus-summary-goto-unread 'never)) + (gnus-summary-last-article-p (gnus-summary-article-number))) + (and gnus-auto-select-same + (gnus-summary-article-subject)))) + +(defun gnus-summary-prev-article (&optional unread subject) + "Select the article after the current one. +If UNREAD is non-nil, only unread articles are selected." + (interactive "P") + (gnus-summary-next-article unread subject t)) + +(defun gnus-summary-prev-unread-article () + "Select unread article before current one." + (interactive) + (gnus-summary-prev-article + (or (not (eq gnus-summary-goto-unread 'never)) + (gnus-summary-first-article-p (gnus-summary-article-number))) + (and gnus-auto-select-same + (gnus-summary-article-subject)))) + +(defun gnus-summary-next-page (&optional lines circular) + "Show next page of the selected article. +If at the end of the current article, select the next article. +LINES says how many lines should be scrolled up. + +If CIRCULAR is non-nil, go to the start of the article instead of +selecting the next article when reaching the end of the current +article." + (interactive "P") + (setq gnus-summary-buffer (current-buffer)) + (gnus-set-global-variables) + (let ((article (gnus-summary-article-number)) + (article-window (get-buffer-window gnus-article-buffer)) + (endp nil)) + (gnus-configure-windows 'article) + (if (eq (cdr (assq article gnus-newsgroup-reads)) gnus-canceled-mark) + (if (and (eq gnus-summary-goto-unread 'never) + (not (gnus-summary-last-article-p article))) + (gnus-summary-next-article) + (gnus-summary-next-unread-article)) + (if (or (null gnus-current-article) + (null gnus-article-current) + (/= article (cdr gnus-article-current)) + (not (equal (car gnus-article-current) gnus-newsgroup-name))) + ;; Selected subject is different from current article's. + (gnus-summary-display-article article) + (when article-window + (gnus-eval-in-buffer-window gnus-article-buffer + (setq endp (gnus-article-next-page lines))) + (when endp + (cond (circular + (gnus-summary-beginning-of-article)) + (lines + (gnus-message 3 "End of message")) + ((null lines) + (if (and (eq gnus-summary-goto-unread 'never) + (not (gnus-summary-last-article-p article))) + (gnus-summary-next-article) + (gnus-summary-next-unread-article)))))))) + (gnus-summary-recenter) + (gnus-summary-position-point))) + +(defun gnus-summary-prev-page (&optional lines) + "Show previous page of selected article. +Argument LINES specifies lines to be scrolled down." + (interactive "P") + (gnus-set-global-variables) + (let ((article (gnus-summary-article-number))) + (gnus-configure-windows 'article) + (if (or (null gnus-current-article) + (null gnus-article-current) + (/= article (cdr gnus-article-current)) + (not (equal (car gnus-article-current) gnus-newsgroup-name))) + ;; Selected subject is different from current article's. + (gnus-summary-display-article article) + (gnus-summary-recenter) + (gnus-eval-in-buffer-window gnus-article-buffer + (gnus-article-prev-page lines)))) + (gnus-summary-position-point)) + +(defun gnus-summary-scroll-up (lines) + "Scroll up (or down) one line current article. +Argument LINES specifies lines to be scrolled up (or down if negative)." + (interactive "p") + (gnus-set-global-variables) + (gnus-configure-windows 'article) + (gnus-summary-show-thread) + (when (eq (gnus-summary-select-article nil nil 'pseudo) 'old) + (gnus-eval-in-buffer-window gnus-article-buffer + (cond ((> lines 0) + (when (gnus-article-next-page lines) + (gnus-message 3 "End of message"))) + ((< lines 0) + (gnus-article-prev-page (- lines)))))) + (gnus-summary-recenter) + (gnus-summary-position-point)) + +(defun gnus-summary-next-same-subject () + "Select next article which has the same subject as current one." + (interactive) + (gnus-set-global-variables) + (gnus-summary-next-article nil (gnus-summary-article-subject))) + +(defun gnus-summary-prev-same-subject () + "Select previous article which has the same subject as current one." + (interactive) + (gnus-set-global-variables) + (gnus-summary-prev-article nil (gnus-summary-article-subject))) + +(defun gnus-summary-next-unread-same-subject () + "Select next unread article which has the same subject as current one." + (interactive) + (gnus-set-global-variables) + (gnus-summary-next-article t (gnus-summary-article-subject))) + +(defun gnus-summary-prev-unread-same-subject () + "Select previous unread article which has the same subject as current one." + (interactive) + (gnus-set-global-variables) + (gnus-summary-prev-article t (gnus-summary-article-subject))) + +(defun gnus-summary-first-unread-article () + "Select the first unread article. +Return nil if there are no unread articles." + (interactive) + (gnus-set-global-variables) + (prog1 + (when (gnus-summary-first-subject t) + (gnus-summary-show-thread) + (gnus-summary-first-subject t) + (gnus-summary-display-article (gnus-summary-article-number))) + (gnus-summary-position-point))) + +(defun gnus-summary-first-article () + "Select the first article. +Return nil if there are no articles." + (interactive) + (gnus-set-global-variables) + (prog1 + (when (gnus-summary-first-subject) + (gnus-summary-show-thread) + (gnus-summary-first-subject) + (gnus-summary-display-article (gnus-summary-article-number))) + (gnus-summary-position-point))) + +(defun gnus-summary-best-unread-article () + "Select the unread article with the highest score." + (interactive) + (gnus-set-global-variables) + (let ((best -1000000) + (data gnus-newsgroup-data) + article score) + (while data + (and (gnus-data-unread-p (car data)) + (> (setq score + (gnus-summary-article-score (gnus-data-number (car data)))) + best) + (setq best score + article (gnus-data-number (car data)))) + (setq data (cdr data))) + (prog1 + (if article + (gnus-summary-goto-article article) + (error "No unread articles")) + (gnus-summary-position-point)))) + +(defun gnus-summary-last-subject () + "Go to the last displayed subject line in the group." + (let ((article (gnus-data-number (car (gnus-data-list t))))) + (when article + (gnus-summary-goto-subject article)))) + +(defun gnus-summary-goto-article (article &optional all-headers force) + "Fetch ARTICLE and display it if it exists. +If ALL-HEADERS is non-nil, no header lines are hidden." + (interactive + (list + (string-to-int + (completing-read + "Article number: " + (mapcar (lambda (number) (list (int-to-string number))) + gnus-newsgroup-limit))) + current-prefix-arg + t)) + (prog1 + (if (gnus-summary-goto-subject article force) + (gnus-summary-display-article article all-headers) + (gnus-message 4 "Couldn't go to article %s" article) nil) + (gnus-summary-position-point))) + +(defun gnus-summary-goto-last-article () + "Go to the previously read article." + (interactive) + (prog1 + (when gnus-last-article + (gnus-summary-goto-article gnus-last-article)) + (gnus-summary-position-point))) + +(defun gnus-summary-pop-article (number) + "Pop one article off the history and go to the previous. +NUMBER articles will be popped off." + (interactive "p") + (let (to) + (setq gnus-newsgroup-history + (cdr (setq to (nthcdr number gnus-newsgroup-history)))) + (if to + (gnus-summary-goto-article (car to)) + (error "Article history empty"))) + (gnus-summary-position-point)) + +;; Summary commands and functions for limiting the summary buffer. + +(defun gnus-summary-limit-to-articles (n) + "Limit the summary buffer to the next N articles. +If not given a prefix, use the process marked articles instead." + (interactive "P") + (gnus-set-global-variables) + (prog1 + (let ((articles (gnus-summary-work-articles n))) + (setq gnus-newsgroup-processable nil) + (gnus-summary-limit articles)) + (gnus-summary-position-point))) + +(defun gnus-summary-pop-limit (&optional total) + "Restore the previous limit. +If given a prefix, remove all limits." + (interactive "P") + (gnus-set-global-variables) + (when total + (setq gnus-newsgroup-limits + (list (mapcar (lambda (h) (mail-header-number h)) + gnus-newsgroup-headers)))) + (unless gnus-newsgroup-limits + (error "No limit to pop")) + (prog1 + (gnus-summary-limit nil 'pop) + (gnus-summary-position-point))) + +(defun gnus-summary-limit-to-subject (subject &optional header) + "Limit the summary buffer to articles that have subjects that match a regexp." + (interactive "sLimit to subject (regexp): ") + (unless header + (setq header "subject")) + (when (not (equal "" subject)) + (prog1 + (let ((articles (gnus-summary-find-matching + (or header "subject") subject 'all))) + (unless articles + (error "Found no matches for \"%s\"" subject)) + (gnus-summary-limit articles)) + (gnus-summary-position-point)))) + +(defun gnus-summary-limit-to-author (from) + "Limit the summary buffer to articles that have authors that match a regexp." + (interactive "sLimit to author (regexp): ") + (gnus-summary-limit-to-subject from "from")) + +(defun gnus-summary-limit-to-age (age &optional younger-p) + "Limit the summary buffer to articles that are older than (or equal) AGE days. +If YOUNGER-P (the prefix) is non-nil, limit the summary buffer to +articles that are younger than AGE days." + (interactive "nTime in days: \nP") + (prog1 + (let ((data gnus-newsgroup-data) + (cutoff (nnmail-days-to-time age)) + articles d date is-younger) + (while (setq d (pop data)) + (when (and (vectorp (gnus-data-header d)) + (setq date (mail-header-date (gnus-data-header d)))) + (setq is-younger (nnmail-time-less + (nnmail-time-since (nnmail-date-to-time date)) + cutoff)) + (when (if younger-p is-younger (not is-younger)) + (push (gnus-data-number d) articles)))) + (gnus-summary-limit (nreverse articles))) + (gnus-summary-position-point))) + +(defalias 'gnus-summary-delete-marked-as-read 'gnus-summary-limit-to-unread) +(make-obsolete + 'gnus-summary-delete-marked-as-read 'gnus-summary-limit-to-unread) + +(defun gnus-summary-limit-to-unread (&optional all) + "Limit the summary buffer to articles that are not marked as read. +If ALL is non-nil, limit strictly to unread articles." + (interactive "P") + (if all + (gnus-summary-limit-to-marks (char-to-string gnus-unread-mark)) + (gnus-summary-limit-to-marks + ;; Concat all the marks that say that an article is read and have + ;; those removed. + (list gnus-del-mark gnus-read-mark gnus-ancient-mark + gnus-killed-mark gnus-kill-file-mark + gnus-low-score-mark gnus-expirable-mark + gnus-canceled-mark gnus-catchup-mark gnus-sparse-mark + gnus-duplicate-mark) + 'reverse))) + +(defalias 'gnus-summary-delete-marked-with 'gnus-summary-limit-exclude-marks) +(make-obsolete 'gnus-summary-delete-marked-with + 'gnus-summary-limit-exlude-marks) + +(defun gnus-summary-limit-exclude-marks (marks &optional reverse) + "Exclude articles that are marked with MARKS (e.g. \"DK\"). +If REVERSE, limit the summary buffer to articles that are marked +with MARKS. MARKS can either be a string of marks or a list of marks. +Returns how many articles were removed." + (interactive "sMarks: ") + (gnus-summary-limit-to-marks marks t)) + +(defun gnus-summary-limit-to-marks (marks &optional reverse) + "Limit the summary buffer to articles that are marked with MARKS (e.g. \"DK\"). +If REVERSE (the prefix), limit the summary buffer to articles that are +not marked with MARKS. MARKS can either be a string of marks or a +list of marks. +Returns how many articles were removed." + (interactive (list (read-string "Marks: ") current-prefix-arg)) + (gnus-set-global-variables) + (prog1 + (let ((data gnus-newsgroup-data) + (marks (if (listp marks) marks + (append marks nil))) ; Transform to list. + articles) + (while data + (when (if reverse (not (memq (gnus-data-mark (car data)) marks)) + (memq (gnus-data-mark (car data)) marks)) + (push (gnus-data-number (car data)) articles)) + (setq data (cdr data))) + (gnus-summary-limit articles)) + (gnus-summary-position-point))) + +(defun gnus-summary-limit-to-score (&optional score) + "Limit to articles with score at or above SCORE." + (interactive "P") + (gnus-set-global-variables) + (setq score (if score + (prefix-numeric-value score) + (or gnus-summary-default-score 0))) + (let ((data gnus-newsgroup-data) + articles) + (while data + (when (>= (gnus-summary-article-score (gnus-data-number (car data))) + score) + (push (gnus-data-number (car data)) articles)) + (setq data (cdr data))) + (prog1 + (gnus-summary-limit articles) + (gnus-summary-position-point)))) + +(defun gnus-summary-limit-include-dormant () + "Display all the hidden articles that are marked as dormant." + (interactive) + (gnus-set-global-variables) + (unless gnus-newsgroup-dormant + (error "There are no dormant articles in this group")) + (prog1 + (gnus-summary-limit (append gnus-newsgroup-dormant gnus-newsgroup-limit)) + (gnus-summary-position-point))) + +(defun gnus-summary-limit-exclude-dormant () + "Hide all dormant articles." + (interactive) + (gnus-set-global-variables) + (prog1 + (gnus-summary-limit-to-marks (list gnus-dormant-mark) 'reverse) + (gnus-summary-position-point))) + +(defun gnus-summary-limit-exclude-childless-dormant () + "Hide all dormant articles that have no children." + (interactive) + (gnus-set-global-variables) + (let ((data (gnus-data-list t)) + articles d children) + ;; Find all articles that are either not dormant or have + ;; children. + (while (setq d (pop data)) + (when (or (not (= (gnus-data-mark d) gnus-dormant-mark)) + (and (setq children + (gnus-article-children (gnus-data-number d))) + (let (found) + (while children + (when (memq (car children) articles) + (setq children nil + found t)) + (pop children)) + found))) + (push (gnus-data-number d) articles))) + ;; Do the limiting. + (prog1 + (gnus-summary-limit articles) + (gnus-summary-position-point)))) + +(defun gnus-summary-limit-mark-excluded-as-read (&optional all) + "Mark all unread excluded articles as read. +If ALL, mark even excluded ticked and dormants as read." + (interactive "P") + (let ((articles (gnus-sorted-complement + (sort + (mapcar (lambda (h) (mail-header-number h)) + gnus-newsgroup-headers) + '<) + (sort gnus-newsgroup-limit '<))) + article) + (setq gnus-newsgroup-unreads nil) + (if all + (setq gnus-newsgroup-dormant nil + gnus-newsgroup-marked nil + gnus-newsgroup-reads + (nconc + (mapcar (lambda (n) (cons n gnus-catchup-mark)) articles) + gnus-newsgroup-reads)) + (while (setq article (pop articles)) + (unless (or (memq article gnus-newsgroup-dormant) + (memq article gnus-newsgroup-marked)) + (push (cons article gnus-catchup-mark) gnus-newsgroup-reads)))))) + +(defun gnus-summary-limit (articles &optional pop) + (if pop + ;; We pop the previous limit off the stack and use that. + (setq articles (car gnus-newsgroup-limits) + gnus-newsgroup-limits (cdr gnus-newsgroup-limits)) + ;; We use the new limit, so we push the old limit on the stack. + (push gnus-newsgroup-limit gnus-newsgroup-limits)) + ;; Set the limit. + (setq gnus-newsgroup-limit articles) + (let ((total (length gnus-newsgroup-data)) + (data (gnus-data-find-list (gnus-summary-article-number))) + (gnus-summary-mark-below nil) ; Inhibit this. + found) + ;; This will do all the work of generating the new summary buffer + ;; according to the new limit. + (gnus-summary-prepare) + ;; Hide any threads, possibly. + (and gnus-show-threads + gnus-thread-hide-subtree + (gnus-summary-hide-all-threads)) + ;; Try to return to the article you were at, or one in the + ;; neighborhood. + (when data + ;; We try to find some article after the current one. + (while data + (when (gnus-summary-goto-subject (gnus-data-number (car data)) nil t) + (setq data nil + found t)) + (setq data (cdr data)))) + (unless found + ;; If there is no data, that means that we were after the last + ;; article. The same goes when we can't find any articles + ;; after the current one. + (goto-char (point-max)) + (gnus-summary-find-prev)) + ;; We return how many articles were removed from the summary + ;; buffer as a result of the new limit. + (- total (length gnus-newsgroup-data)))) + +(defsubst gnus-invisible-cut-children (threads) + (let ((num 0)) + (while threads + (when (memq (mail-header-number (caar threads)) gnus-newsgroup-limit) + (incf num)) + (pop threads)) + (< num 2))) + +(defsubst gnus-cut-thread (thread) + "Go forwards in the thread until we find an article that we want to display." + (when (or (eq gnus-fetch-old-headers 'some) + (eq gnus-build-sparse-threads 'some) + (eq gnus-build-sparse-threads 'more)) + ;; Deal with old-fetched headers and sparse threads. + (while (and + thread + (or + (gnus-summary-article-sparse-p (mail-header-number (car thread))) + (gnus-summary-article-ancient-p + (mail-header-number (car thread)))) + (progn + (if (<= (length (cdr thread)) 1) + (setq thread (cadr thread)) + (when (gnus-invisible-cut-children (cdr thread)) + (let ((th (cdr thread))) + (while th + (if (memq (mail-header-number (caar th)) + gnus-newsgroup-limit) + (setq thread (car th) + th nil) + (setq th (cdr th))))))))) + )) + thread) + +(defun gnus-cut-threads (threads) + "Cut off all uninteresting articles from the beginning of threads." + (when (or (eq gnus-fetch-old-headers 'some) + (eq gnus-build-sparse-threads 'some) + (eq gnus-build-sparse-threads 'more)) + (let ((th threads)) + (while th + (setcar th (gnus-cut-thread (car th))) + (setq th (cdr th))))) + ;; Remove nixed out threads. + (delq nil threads)) + +(defun gnus-summary-initial-limit (&optional show-if-empty) + "Figure out what the initial limit is supposed to be on group entry. +This entails weeding out unwanted dormants, low-scored articles, +fetch-old-headers verbiage, and so on." + ;; Most groups have nothing to remove. + (if (or gnus-inhibit-limiting + (and (null gnus-newsgroup-dormant) + (not (eq gnus-fetch-old-headers 'some)) + (null gnus-summary-expunge-below) + (not (eq gnus-build-sparse-threads 'some)) + (not (eq gnus-build-sparse-threads 'more)) + (null gnus-thread-expunge-below) + (not gnus-use-nocem))) + () ; Do nothing. + (push gnus-newsgroup-limit gnus-newsgroup-limits) + (setq gnus-newsgroup-limit nil) + (mapatoms + (lambda (node) + (unless (car (symbol-value node)) + ;; These threads have no parents -- they are roots. + (let ((nodes (cdr (symbol-value node))) + thread) + (while nodes + (if (and gnus-thread-expunge-below + (< (gnus-thread-total-score (car nodes)) + gnus-thread-expunge-below)) + (gnus-expunge-thread (pop nodes)) + (setq thread (pop nodes)) + (gnus-summary-limit-children thread)))))) + gnus-newsgroup-dependencies) + ;; If this limitation resulted in an empty group, we might + ;; pop the previous limit and use it instead. + (when (and (not gnus-newsgroup-limit) + show-if-empty) + (setq gnus-newsgroup-limit (pop gnus-newsgroup-limits))) + gnus-newsgroup-limit)) + +(defun gnus-summary-limit-children (thread) + "Return 1 if this subthread is visible and 0 if it is not." + ;; First we get the number of visible children to this thread. This + ;; is done by recursing down the thread using this function, so this + ;; will really go down to a leaf article first, before slowly + ;; working its way up towards the root. + (when thread + (let ((children + (if (cdr thread) + (apply '+ (mapcar 'gnus-summary-limit-children + (cdr thread))) + 0)) + (number (mail-header-number (car thread))) + score) + (if (and + (not (memq number gnus-newsgroup-marked)) + (or + ;; If this article is dormant and has absolutely no visible + ;; children, then this article isn't visible. + (and (memq number gnus-newsgroup-dormant) + (zerop children)) + ;; If this is "fetch-old-headered" and there is no + ;; visible children, then we don't want this article. + (and (eq gnus-fetch-old-headers 'some) + (gnus-summary-article-ancient-p number) + (zerop children)) + ;; If this is a sparsely inserted article with no children, + ;; we don't want it. + (and (eq gnus-build-sparse-threads 'some) + (gnus-summary-article-sparse-p number) + (zerop children)) + ;; If we use expunging, and this article is really + ;; low-scored, then we don't want this article. + (when (and gnus-summary-expunge-below + (< (setq score + (or (cdr (assq number gnus-newsgroup-scored)) + gnus-summary-default-score)) + gnus-summary-expunge-below)) + ;; We increase the expunge-tally here, but that has + ;; nothing to do with the limits, really. + (incf gnus-newsgroup-expunged-tally) + ;; We also mark as read here, if that's wanted. + (when (and gnus-summary-mark-below + (< score gnus-summary-mark-below)) + (setq gnus-newsgroup-unreads + (delq number gnus-newsgroup-unreads)) + (if gnus-newsgroup-auto-expire + (push number gnus-newsgroup-expirable) + (push (cons number gnus-low-score-mark) + gnus-newsgroup-reads))) + t) + ;; Check NoCeM things. + (if (and gnus-use-nocem + (gnus-nocem-unwanted-article-p + (mail-header-id (car thread)))) + (progn + (setq gnus-newsgroup-reads + (delq number gnus-newsgroup-unreads)) + t)))) + ;; Nope, invisible article. + 0 + ;; Ok, this article is to be visible, so we add it to the limit + ;; and return 1. + (push number gnus-newsgroup-limit) + 1)))) + +(defun gnus-expunge-thread (thread) + "Mark all articles in THREAD as read." + (let* ((number (mail-header-number (car thread)))) + (incf gnus-newsgroup-expunged-tally) + ;; We also mark as read here, if that's wanted. + (setq gnus-newsgroup-unreads + (delq number gnus-newsgroup-unreads)) + (if gnus-newsgroup-auto-expire + (push number gnus-newsgroup-expirable) + (push (cons number gnus-low-score-mark) + gnus-newsgroup-reads))) + ;; Go recursively through all subthreads. + (mapcar 'gnus-expunge-thread (cdr thread))) + +;; Summary article oriented commands + +(defun gnus-summary-refer-parent-article (n) + "Refer parent article N times. +If N is negative, go to ancestor -N instead. +The difference between N and the number of articles fetched is returned." + (interactive "p") + (gnus-set-global-variables) + (let ((skip 1) + error header ref) + (when (not (natnump n)) + (setq skip (abs n) + n 1)) + (while (and (> n 0) + (not error)) + (setq header (gnus-summary-article-header)) + (if (and (eq (mail-header-number header) + (cdr gnus-article-current)) + (equal gnus-newsgroup-name + (car gnus-article-current))) + ;; If we try to find the parent of the currently + ;; displayed article, then we take a look at the actual + ;; References header, since this is slightly more + ;; reliable than the References field we got from the + ;; server. + (save-excursion + (set-buffer gnus-original-article-buffer) + (nnheader-narrow-to-headers) + (unless (setq ref (message-fetch-field "references")) + (setq ref (message-fetch-field "in-reply-to"))) + (widen)) + (setq ref + ;; It's not the current article, so we take a bet on + ;; the value we got from the server. + (mail-header-references header))) + (if (and ref + (not (equal ref ""))) + (unless (gnus-summary-refer-article (gnus-parent-id ref skip)) + (gnus-message 1 "Couldn't find parent")) + (gnus-message 1 "No references in article %d" + (gnus-summary-article-number)) + (setq error t)) + (decf n)) + (gnus-summary-position-point) + n)) + +(defun gnus-summary-refer-references () + "Fetch all articles mentioned in the References header. +Return how many articles were fetched." + (interactive) + (gnus-set-global-variables) + (let ((ref (mail-header-references (gnus-summary-article-header))) + (current (gnus-summary-article-number)) + (n 0)) + (if (or (not ref) + (equal ref "")) + (error "No References in the current article") + ;; For each Message-ID in the References header... + (while (string-match "<[^>]*>" ref) + (incf n) + ;; ... fetch that article. + (gnus-summary-refer-article + (prog1 (match-string 0 ref) + (setq ref (substring ref (match-end 0)))))) + (gnus-summary-goto-subject current) + (gnus-summary-position-point) + n))) + +(defun gnus-summary-refer-article (message-id) + "Fetch an article specified by MESSAGE-ID." + (interactive "sMessage-ID: ") + (when (and (stringp message-id) + (not (zerop (length message-id)))) + ;; Construct the correct Message-ID if necessary. + ;; Suggested by tale@pawl.rpi.edu. + (unless (string-match "^<" message-id) + (setq message-id (concat "<" message-id))) + (unless (string-match ">$" message-id) + (setq message-id (concat message-id ">"))) + (let* ((header (gnus-id-to-header message-id)) + (sparse (and header + (gnus-summary-article-sparse-p + (mail-header-number header))))) + (if header + (prog1 + ;; The article is present in the buffer, to we just go to it. + (gnus-summary-goto-article + (mail-header-number header) nil header) + (when sparse + (gnus-summary-update-article (mail-header-number header)))) + ;; We fetch the article + (let ((gnus-override-method + (and (gnus-news-group-p gnus-newsgroup-name) + gnus-refer-article-method)) + number) + ;; Start the special refer-article method, if necessary. + (when (and gnus-refer-article-method + (gnus-news-group-p gnus-newsgroup-name)) + (gnus-check-server gnus-refer-article-method)) + ;; Fetch the header, and display the article. + (if (setq number (gnus-summary-insert-subject message-id)) + (gnus-summary-select-article nil nil nil number) + (gnus-message 3 "Couldn't fetch article %s" message-id))))))) + +(defun gnus-summary-enter-digest-group (&optional force) + "Enter an nndoc group based on the current article. +If FORCE, force a digest interpretation. If not, try +to guess what the document format is." + (interactive "P") + (gnus-set-global-variables) + (let ((conf gnus-current-window-configuration)) + (save-excursion + (gnus-summary-select-article)) + (setq gnus-current-window-configuration conf) + (let* ((name (format "%s-%d" + (gnus-group-prefixed-name + gnus-newsgroup-name (list 'nndoc "")) + (save-excursion + (set-buffer gnus-summary-buffer) + gnus-current-article))) + (ogroup gnus-newsgroup-name) + (params (append (gnus-info-params (gnus-get-info ogroup)) + (list (cons 'to-group ogroup)))) + (case-fold-search t) + (buf (current-buffer)) + dig) + (save-excursion + (setq dig (nnheader-set-temp-buffer " *gnus digest buffer*")) + (insert-buffer-substring gnus-original-article-buffer) + ;; Remove lines that may lead nndoc to misinterpret the + ;; document type. + (narrow-to-region + (goto-char (point-min)) + (or (search-forward "\n\n" nil t) (point))) + (goto-char (point-min)) + (delete-matching-lines "^\\(Path\\):\\|^From ") + (widen)) + (unwind-protect + (if (gnus-group-read-ephemeral-group + name `(nndoc ,name (nndoc-address ,(get-buffer dig)) + (nndoc-article-type + ,(if force 'digest 'guess))) t) + ;; Make all postings to this group go to the parent group. + (nconc (gnus-info-params (gnus-get-info name)) + params) + ;; Couldn't select this doc group. + (switch-to-buffer buf) + (gnus-set-global-variables) + (gnus-configure-windows 'summary) + (gnus-message 3 "Article couldn't be entered?")) + (kill-buffer dig))))) + +(defun gnus-summary-read-document (n) + "Open a new group based on the current article(s). +This will allow you to read digests and other similar +documents as newsgroups. +Obeys the standard process/prefix convention." + (interactive "P") + (let* ((articles (gnus-summary-work-articles n)) + (ogroup gnus-newsgroup-name) + (params (append (gnus-info-params (gnus-get-info ogroup)) + (list (cons 'to-group ogroup)))) + article group egroup groups vgroup) + (while (setq article (pop articles)) + (setq group (format "%s-%d" gnus-newsgroup-name article)) + (gnus-summary-remove-process-mark article) + (when (gnus-summary-display-article article) + (save-excursion + (nnheader-temp-write nil + (insert-buffer-substring gnus-original-article-buffer) + ;; Remove some headers that may lead nndoc to make + ;; the wrong guess. + (message-narrow-to-head) + (goto-char (point-min)) + (delete-matching-lines "^\\(Path\\):\\|^From ") + (widen) + (if (setq egroup + (gnus-group-read-ephemeral-group + group `(nndoc ,group (nndoc-address ,(current-buffer)) + (nndoc-article-type guess)) + t nil t)) + (progn + ;; Make all postings to this group go to the parent group. + (nconc (gnus-info-params (gnus-get-info egroup)) + params) + (push egroup groups)) + ;; Couldn't select this doc group. + (gnus-error 3 "Article couldn't be entered")))))) + ;; Now we have selected all the documents. + (cond + ((not groups) + (error "None of the articles could be interpreted as documents")) + ((gnus-group-read-ephemeral-group + (setq vgroup (format + "nnvirtual:%s-%s" gnus-newsgroup-name + (format-time-string "%Y%m%dT%H%M%S" (current-time)))) + `(nnvirtual ,vgroup (nnvirtual-component-groups ,groups)) + t + (cons (current-buffer) 'summary))) + (t + (error "Couldn't select virtual nndoc group"))))) + +(defun gnus-summary-isearch-article (&optional regexp-p) + "Do incremental search forward on the current article. +If REGEXP-P (the prefix) is non-nil, do regexp isearch." + (interactive "P") + (gnus-set-global-variables) + (gnus-summary-select-article) + (gnus-configure-windows 'article) + (gnus-eval-in-buffer-window gnus-article-buffer + ;;(goto-char (point-min)) + (isearch-forward regexp-p))) + +(defun gnus-summary-search-article-forward (regexp &optional backward) + "Search for an article containing REGEXP forward. +If BACKWARD, search backward instead." + (interactive + (list (read-string + (format "Search article %s (regexp%s): " + (if current-prefix-arg "backward" "forward") + (if gnus-last-search-regexp + (concat ", default " gnus-last-search-regexp) + ""))) + current-prefix-arg)) + (gnus-set-global-variables) + (if (string-equal regexp "") + (setq regexp (or gnus-last-search-regexp "")) + (setq gnus-last-search-regexp regexp)) + (if (gnus-summary-search-article regexp backward) + (gnus-summary-show-thread) + (error "Search failed: \"%s\"" regexp))) + +(defun gnus-summary-search-article-backward (regexp) + "Search for an article containing REGEXP backward." + (interactive + (list (read-string + (format "Search article backward (regexp%s): " + (if gnus-last-search-regexp + (concat ", default " gnus-last-search-regexp) + ""))))) + (gnus-summary-search-article-forward regexp 'backward)) + +(defun gnus-summary-search-article (regexp &optional backward) + "Search for an article containing REGEXP. +Optional argument BACKWARD means do search for backward. +`gnus-select-article-hook' is not called during the search." + (let ((gnus-select-article-hook nil) ;Disable hook. + (gnus-article-display-hook nil) + (gnus-mark-article-hook nil) ;Inhibit marking as read. + (gnus-use-article-prefetch nil) + (gnus-xmas-force-redisplay nil) ;Inhibit XEmacs redisplay. + (sum (current-buffer)) + (found nil) + point) + (gnus-save-hidden-threads + (gnus-summary-select-article) + (set-buffer gnus-article-buffer) + (when backward + (forward-line -1)) + (while (not found) + (gnus-message 7 "Searching article: %d..." (cdr gnus-article-current)) + (if (if backward + (re-search-backward regexp nil t) + (re-search-forward regexp nil t)) + ;; We found the regexp. + (progn + (setq found 'found) + (beginning-of-line) + (set-window-start + (get-buffer-window (current-buffer)) + (point)) + (forward-line 1) + (set-buffer sum) + (setq point (point))) + ;; We didn't find it, so we go to the next article. + (set-buffer sum) + (setq found 'not) + (while (eq found 'not) + (if (not (if backward (gnus-summary-find-prev) + (gnus-summary-find-next))) + ;; No more articles. + (setq found t) + ;; Select the next article and adjust point. + (unless (gnus-summary-article-sparse-p + (gnus-summary-article-number)) + (setq found nil) + (gnus-summary-select-article) + (set-buffer gnus-article-buffer) + (widen) + (goto-char (if backward (point-max) (point-min)))))))) + (gnus-message 7 "")) + ;; Return whether we found the regexp. + (when (eq found 'found) + (goto-char point) + (gnus-summary-show-thread) + (gnus-summary-goto-subject gnus-current-article) + (gnus-summary-position-point) + t))) + +(defun gnus-summary-find-matching (header regexp &optional backward unread + not-case-fold) + "Return a list of all articles that match REGEXP on HEADER. +The search stars on the current article and goes forwards unless +BACKWARD is non-nil. If BACKWARD is `all', do all articles. +If UNREAD is non-nil, only unread articles will +be taken into consideration. If NOT-CASE-FOLD, case won't be folded +in the comparisons." + (let ((data (if (eq backward 'all) gnus-newsgroup-data + (gnus-data-find-list + (gnus-summary-article-number) (gnus-data-list backward)))) + (func `(lambda (h) (,(intern (concat "mail-header-" header)) h))) + (case-fold-search (not not-case-fold)) + articles d) + (unless (fboundp (intern (concat "mail-header-" header))) + (error "%s is not a valid header" header)) + (while data + (setq d (car data)) + (and (or (not unread) ; We want all articles... + (gnus-data-unread-p d)) ; Or just unreads. + (vectorp (gnus-data-header d)) ; It's not a pseudo. + (string-match regexp (funcall func (gnus-data-header d))) ; Match. + (push (gnus-data-number d) articles)) ; Success! + (setq data (cdr data))) + (nreverse articles))) + +(defun gnus-summary-execute-command (header regexp command &optional backward) + "Search forward for an article whose HEADER matches REGEXP and execute COMMAND. +If HEADER is an empty string (or nil), the match is done on the entire +article. If BACKWARD (the prefix) is non-nil, search backward instead." + (interactive + (list (let ((completion-ignore-case t)) + (completing-read + "Header name: " + (mapcar (lambda (string) (list string)) + '("Number" "Subject" "From" "Lines" "Date" + "Message-ID" "Xref" "References" "Body")) + nil 'require-match)) + (read-string "Regexp: ") + (read-key-sequence "Command: ") + current-prefix-arg)) + (when (equal header "Body") + (setq header "")) + (gnus-set-global-variables) + ;; Hidden thread subtrees must be searched as well. + (gnus-summary-show-all-threads) + ;; We don't want to change current point nor window configuration. + (save-excursion + (save-window-excursion + (gnus-message 6 "Executing %s..." (key-description command)) + ;; We'd like to execute COMMAND interactively so as to give arguments. + (gnus-execute header regexp + `(call-interactively ',(key-binding command)) + backward) + (gnus-message 6 "Executing %s...done" (key-description command))))) + +(defun gnus-summary-beginning-of-article () + "Scroll the article back to the beginning." + (interactive) + (gnus-set-global-variables) + (gnus-summary-select-article) + (gnus-configure-windows 'article) + (gnus-eval-in-buffer-window gnus-article-buffer + (widen) + (goto-char (point-min)) + (when gnus-break-pages + (gnus-narrow-to-page)))) + +(defun gnus-summary-end-of-article () + "Scroll to the end of the article." + (interactive) + (gnus-set-global-variables) + (gnus-summary-select-article) + (gnus-configure-windows 'article) + (gnus-eval-in-buffer-window gnus-article-buffer + (widen) + (goto-char (point-max)) + (recenter -3) + (when gnus-break-pages + (gnus-narrow-to-page)))) + +(defun gnus-summary-print-article (&optional filename) + "Generate and print a PostScript image of the article buffer. + +If the optional argument FILENAME is nil, send the image to the printer. +If FILENAME is a string, save the PostScript image in a file with that +name. If FILENAME is a number, prompt the user for the name of the file +to save in." + (interactive (list (ps-print-preprint current-prefix-arg))) + (gnus-summary-select-article) + (gnus-eval-in-buffer-window gnus-article-buffer + (let ((buffer (generate-new-buffer " *print*"))) + (unwind-protect + (progn + (copy-to-buffer buffer (point-min) (point-max)) + (set-buffer buffer) + (gnus-article-delete-invisible-text) + (ps-print-buffer-with-faces filename)) + (kill-buffer buffer))))) + +(defun gnus-summary-show-article (&optional arg) + "Force re-fetching of the current article. +If ARG (the prefix) is non-nil, show the raw article without any +article massaging functions being run." + (interactive "P") + (gnus-set-global-variables) + (if (not arg) + ;; Select the article the normal way. + (gnus-summary-select-article nil 'force) + ;; Bind the article treatment functions to nil. + (let ((gnus-have-all-headers t) + gnus-article-display-hook + gnus-article-prepare-hook + gnus-break-pages + gnus-visual) + (gnus-summary-select-article nil 'force))) + (gnus-summary-goto-subject gnus-current-article) + ; (gnus-configure-windows 'article) + (gnus-summary-position-point)) + +(defun gnus-summary-verbose-headers (&optional arg) + "Toggle permanent full header display. +If ARG is a positive number, turn header display on. +If ARG is a negative number, turn header display off." + (interactive "P") + (gnus-set-global-variables) + (setq gnus-show-all-headers + (cond ((or (not (numberp arg)) + (zerop arg)) + (not gnus-show-all-headers)) + ((natnump arg) + t))) + (gnus-summary-show-article)) + +(defun gnus-summary-toggle-header (&optional arg) + "Show the headers if they are hidden, or hide them if they are shown. +If ARG is a positive number, show the entire header. +If ARG is a negative number, hide the unwanted header lines." + (interactive "P") + (gnus-set-global-variables) + (save-excursion + (set-buffer gnus-article-buffer) + (let* ((buffer-read-only nil) + (inhibit-point-motion-hooks t) + (hidden (text-property-any + (goto-char (point-min)) (search-forward "\n\n") + 'invisible t)) + e) + (goto-char (point-min)) + (when (search-forward "\n\n" nil t) + (delete-region (point-min) (1- (point)))) + (goto-char (point-min)) + (save-excursion + (set-buffer gnus-original-article-buffer) + (goto-char (point-min)) + (setq e (1- (or (search-forward "\n\n" nil t) (point-max))))) + (insert-buffer-substring gnus-original-article-buffer 1 e) + (let ((article-inhibit-hiding t)) + (run-hooks 'gnus-article-display-hook)) + (when (or (not hidden) (and (numberp arg) (< arg 0))) + (gnus-article-hide-headers))))) + +(defun gnus-summary-show-all-headers () + "Make all header lines visible." + (interactive) + (gnus-set-global-variables) + (gnus-article-show-all-headers)) + +(defun gnus-summary-toggle-mime (&optional arg) + "Toggle MIME processing. +If ARG is a positive number, turn MIME processing on." + (interactive "P") + (gnus-set-global-variables) + (setq gnus-show-mime + (if (null arg) (not gnus-show-mime) + (> (prefix-numeric-value arg) 0))) + (gnus-summary-select-article t 'force)) + +(defun gnus-summary-caesar-message (&optional arg) + "Caesar rotate the current article by 13. +The numerical prefix specifies how many places to rotate each letter +forward." + (interactive "P") + (gnus-set-global-variables) + (gnus-summary-select-article) + (let ((mail-header-separator "")) + (gnus-eval-in-buffer-window gnus-article-buffer + (save-restriction + (widen) + (let ((start (window-start)) + buffer-read-only) + (message-caesar-buffer-body arg) + (set-window-start (get-buffer-window (current-buffer)) start)))))) + +(defun gnus-summary-stop-page-breaking () + "Stop page breaking in the current article." + (interactive) + (gnus-set-global-variables) + (gnus-summary-select-article) + (gnus-eval-in-buffer-window gnus-article-buffer + (widen) + (when (gnus-visual-p 'page-marker) + (let ((buffer-read-only nil)) + (gnus-remove-text-with-property 'gnus-prev) + (gnus-remove-text-with-property 'gnus-next))))) + +(defun gnus-summary-move-article (&optional n to-newsgroup + select-method action) + "Move the current article to a different newsgroup. +If N is a positive number, move the N next articles. +If N is a negative number, move the N previous articles. +If N is nil and any articles have been marked with the process mark, +move those articles instead. +If TO-NEWSGROUP is string, do not prompt for a newsgroup to move to. +If SELECT-METHOD is non-nil, do not move to a specific newsgroup, but +re-spool using this method. + +For this function to work, both the current newsgroup and the +newsgroup that you want to move to have to support the `request-move' +and `request-accept' functions." + (interactive "P") + (unless action + (setq action 'move)) + (gnus-set-global-variables) + ;; Disable marking as read. + (let (gnus-mark-article-hook) + (save-window-excursion + (gnus-summary-select-article))) + ;; Check whether the source group supports the required functions. + (cond ((and (eq action 'move) + (not (gnus-check-backend-function + 'request-move-article gnus-newsgroup-name))) + (error "The current group does not support article moving")) + ((and (eq action 'crosspost) + (not (gnus-check-backend-function + 'request-replace-article gnus-newsgroup-name))) + (error "The current group does not support article editing"))) + (let ((articles (gnus-summary-work-articles n)) + (prefix (gnus-group-real-prefix gnus-newsgroup-name)) + (names '((move "Move" "Moving") + (copy "Copy" "Copying") + (crosspost "Crosspost" "Crossposting"))) + (copy-buf (save-excursion + (nnheader-set-temp-buffer " *copy article*"))) + art-group to-method new-xref article to-groups) + (unless (assq action names) + (error "Unknown action %s" action)) + ;; Read the newsgroup name. + (when (and (not to-newsgroup) + (not select-method)) + (setq to-newsgroup + (gnus-read-move-group-name + (cadr (assq action names)) + (symbol-value (intern (format "gnus-current-%s-group" action))) + articles prefix)) + (set (intern (format "gnus-current-%s-group" action)) to-newsgroup)) + (setq to-method (or select-method + (gnus-group-name-to-method to-newsgroup))) + ;; Check the method we are to move this article to... + (unless (gnus-check-backend-function + 'request-accept-article (car to-method)) + (error "%s does not support article copying" (car to-method))) + (unless (gnus-check-server to-method) + (error "Can't open server %s" (car to-method))) + (gnus-message 6 "%s to %s: %s..." + (caddr (assq action names)) + (or (car select-method) to-newsgroup) articles) + (while articles + (setq article (pop articles)) + (setq + art-group + (cond + ;; Move the article. + ((eq action 'move) + (gnus-request-move-article + article ; Article to move + gnus-newsgroup-name ; From newsgroup + (nth 1 (gnus-find-method-for-group + gnus-newsgroup-name)) ; Server + (list 'gnus-request-accept-article + to-newsgroup (list 'quote select-method) + (not articles)) ; Accept form + (not articles))) ; Only save nov last time + ;; Copy the article. + ((eq action 'copy) + (save-excursion + (set-buffer copy-buf) + (gnus-request-article-this-buffer article gnus-newsgroup-name) + (gnus-request-accept-article + to-newsgroup select-method (not articles)))) + ;; Crosspost the article. + ((eq action 'crosspost) + (let ((xref (message-tokenize-header + (mail-header-xref (gnus-summary-article-header article)) + " "))) + (setq new-xref (concat (gnus-group-real-name gnus-newsgroup-name) + ":" article)) + (unless xref + (setq xref (list (system-name)))) + (setq new-xref + (concat + (mapconcat 'identity + (delete "Xref:" (delete new-xref xref)) + " ") + new-xref)) + (save-excursion + (set-buffer copy-buf) + (gnus-request-article-this-buffer article gnus-newsgroup-name) + (nnheader-replace-header "xref" new-xref) + (gnus-request-accept-article + to-newsgroup select-method (not articles))))))) + (if (not art-group) + (gnus-message 1 "Couldn't %s article %s" + (cadr (assq action names)) article) + (let* ((entry + (or + (gnus-gethash (car art-group) gnus-newsrc-hashtb) + (gnus-gethash + (gnus-group-prefixed-name + (car art-group) + (or select-method + (gnus-find-method-for-group to-newsgroup))) + gnus-newsrc-hashtb))) + (info (nth 2 entry)) + (to-group (gnus-info-group info))) + ;; Update the group that has been moved to. + (when (and info + (memq action '(move copy))) + (unless (member to-group to-groups) + (push to-group to-groups)) + + (unless (memq article gnus-newsgroup-unreads) + (gnus-info-set-read + info (gnus-add-to-range (gnus-info-read info) + (list (cdr art-group))))) + + ;; Copy any marks over to the new group. + (let ((marks gnus-article-mark-lists) + (to-article (cdr art-group))) + + ;; See whether the article is to be put in the cache. + (when gnus-use-cache + (gnus-cache-possibly-enter-article + to-group to-article + (let ((header (copy-sequence + (gnus-summary-article-header article)))) + (mail-header-set-number header to-article) + header) + (memq article gnus-newsgroup-marked) + (memq article gnus-newsgroup-dormant) + (memq article gnus-newsgroup-unreads))) + + (while marks + (when (memq article (symbol-value + (intern (format "gnus-newsgroup-%s" + (caar marks))))) + ;; If the other group is the same as this group, + ;; then we have to add the mark to the list. + (when (equal to-group gnus-newsgroup-name) + (set (intern (format "gnus-newsgroup-%s" (caar marks))) + (cons to-article + (symbol-value + (intern (format "gnus-newsgroup-%s" + (caar marks))))))) + ;; Copy mark to other group. + (gnus-add-marked-articles + to-group (cdar marks) (list to-article) info)) + (setq marks (cdr marks))))) + + ;; Update the Xref header in this article to point to + ;; the new crossposted article we have just created. + (when (eq action 'crosspost) + (save-excursion + (set-buffer copy-buf) + (gnus-request-article-this-buffer article gnus-newsgroup-name) + (nnheader-replace-header + "xref" (concat new-xref " " (car art-group) + ":" (cdr art-group))) + (gnus-request-replace-article + article gnus-newsgroup-name (current-buffer))))) + + (gnus-summary-goto-subject article) + (when (eq action 'move) + (gnus-summary-mark-article article gnus-canceled-mark))) + (gnus-summary-remove-process-mark article)) + ;; Re-activate all groups that have been moved to. + (while to-groups + (gnus-activate-group (pop to-groups))) + + (gnus-kill-buffer copy-buf) + (gnus-summary-position-point) + (gnus-set-mode-line 'summary))) + +(defun gnus-summary-copy-article (&optional n to-newsgroup select-method) + "Move the current article to a different newsgroup. +If TO-NEWSGROUP is string, do not prompt for a newsgroup to move to. +If SELECT-METHOD is non-nil, do not move to a specific newsgroup, but +re-spool using this method." + (interactive "P") + (gnus-summary-move-article n nil select-method 'copy)) + +(defun gnus-summary-crosspost-article (&optional n) + "Crosspost the current article to some other group." + (interactive "P") + (gnus-summary-move-article n nil nil 'crosspost)) + +(defcustom gnus-summary-respool-default-method nil + "Default method for respooling an article. +If nil, use to the current newsgroup method." + :type 'gnus-select-method-name + :group 'gnus-summary-mail) + +(defun gnus-summary-respool-article (&optional n method) + "Respool the current article. +The article will be squeezed through the mail spooling process again, +which means that it will be put in some mail newsgroup or other +depending on `nnmail-split-methods'. +If N is a positive number, respool the N next articles. +If N is a negative number, respool the N previous articles. +If N is nil and any articles have been marked with the process mark, +respool those articles instead. + +Respooling can be done both from mail groups and \"real\" newsgroups. +In the former case, the articles in question will be moved from the +current group into whatever groups they are destined to. In the +latter case, they will be copied into the relevant groups." + (interactive + (list current-prefix-arg + (let* ((methods (gnus-methods-using 'respool)) + (methname + (symbol-name (or gnus-summary-respool-default-method + (car (gnus-find-method-for-group + gnus-newsgroup-name))))) + (method + (gnus-completing-read + methname "What backend do you want to use when respooling?" + methods nil t nil 'gnus-mail-method-history)) + ms) + (cond + ((zerop (length (setq ms (gnus-servers-using-backend + (intern method))))) + (list (intern method) "")) + ((= 1 (length ms)) + (car ms)) + (t + (let ((ms-alist (mapcar (lambda (m) (cons (cadr m) m)) ms))) + (cdr (assoc (completing-read "Server name: " ms-alist nil t) + ms-alist)))))))) + (gnus-set-global-variables) + (unless method + (error "No method given for respooling")) + (if (assoc (symbol-name + (car (gnus-find-method-for-group gnus-newsgroup-name))) + (gnus-methods-using 'respool)) + (gnus-summary-move-article n nil method) + (gnus-summary-copy-article n nil method))) + +(defun gnus-summary-import-article (file) + "Import a random file into a mail newsgroup." + (interactive "fImport file: ") + (gnus-set-global-variables) + (let ((group gnus-newsgroup-name) + (now (current-time)) + atts lines) + (unless (gnus-check-backend-function 'request-accept-article group) + (error "%s does not support article importing" group)) + (or (file-readable-p file) + (not (file-regular-p file)) + (error "Can't read %s" file)) + (save-excursion + (set-buffer (get-buffer-create " *import file*")) + (buffer-disable-undo (current-buffer)) + (erase-buffer) + (insert-file-contents file) + (goto-char (point-min)) + (unless (nnheader-article-p) + ;; This doesn't look like an article, so we fudge some headers. + (setq atts (file-attributes file) + lines (count-lines (point-min) (point-max))) + (insert "From: " (read-string "From: ") "\n" + "Subject: " (read-string "Subject: ") "\n" + "Date: " (timezone-make-date-arpa-standard + (current-time-string (nth 5 atts)) + (current-time-zone now) + (current-time-zone now)) + "\n" + "Message-ID: " (message-make-message-id) "\n" + "Lines: " (int-to-string lines) "\n" + "Chars: " (int-to-string (nth 7 atts)) "\n\n")) + (gnus-request-accept-article group nil t) + (kill-buffer (current-buffer))))) + +(defun gnus-summary-article-posted-p () + "Say whether the current (mail) article is available from `gnus-select-method' as well. +This will be the case if the article has both been mailed and posted." + (interactive) + (let ((id (mail-header-references (gnus-summary-article-header))) + (gnus-override-method + (or gnus-refer-article-method gnus-select-method))) + (if (gnus-request-head id "") + (gnus-message 2 "The current message was found on %s" + gnus-override-method) + (gnus-message 2 "The current message couldn't be found on %s" + gnus-override-method) + nil))) + +(defun gnus-summary-expire-articles (&optional now) + "Expire all articles that are marked as expirable in the current group." + (interactive) + (gnus-set-global-variables) + (when (gnus-check-backend-function + 'request-expire-articles gnus-newsgroup-name) + ;; This backend supports expiry. + (let* ((total (gnus-group-total-expirable-p gnus-newsgroup-name)) + (expirable (if total + (progn + ;; We need to update the info for + ;; this group for `gnus-list-of-read-articles' + ;; to give us the right answer. + (run-hooks 'gnus-exit-group-hook) + (gnus-summary-update-info) + (gnus-list-of-read-articles gnus-newsgroup-name)) + (setq gnus-newsgroup-expirable + (sort gnus-newsgroup-expirable '<)))) + (expiry-wait (if now 'immediate + (gnus-group-find-parameter + gnus-newsgroup-name 'expiry-wait))) + es) + (when expirable + ;; There are expirable articles in this group, so we run them + ;; through the expiry process. + (gnus-message 6 "Expiring articles...") + ;; The list of articles that weren't expired is returned. + (if expiry-wait + (let ((nnmail-expiry-wait-function nil) + (nnmail-expiry-wait expiry-wait)) + (setq es (gnus-request-expire-articles + expirable gnus-newsgroup-name))) + (setq es (gnus-request-expire-articles + expirable gnus-newsgroup-name))) + (unless total + (setq gnus-newsgroup-expirable es)) + ;; We go through the old list of expirable, and mark all + ;; really expired articles as nonexistent. + (unless (eq es expirable) ;If nothing was expired, we don't mark. + (let ((gnus-use-cache nil)) + (while expirable + (unless (memq (car expirable) es) + (when (gnus-data-find (car expirable)) + (gnus-summary-mark-article + (car expirable) gnus-canceled-mark))) + (setq expirable (cdr expirable))))) + (gnus-message 6 "Expiring articles...done"))))) + +(defun gnus-summary-expire-articles-now () + "Expunge all expirable articles in the current group. +This means that *all* articles that are marked as expirable will be +deleted forever, right now." + (interactive) + (gnus-set-global-variables) + (or gnus-expert-user + (gnus-yes-or-no-p + "Are you really, really, really sure you want to delete all these messages? ") + (error "Phew!")) + (gnus-summary-expire-articles t)) + +;; Suggested by Jack Vinson . +(defun gnus-summary-delete-article (&optional n) + "Delete the N next (mail) articles. +This command actually deletes articles. This is not a marking +command. The article will disappear forever from your life, never to +return. +If N is negative, delete backwards. +If N is nil and articles have been marked with the process mark, +delete these instead." + (interactive "P") + (gnus-set-global-variables) + (unless (gnus-check-backend-function 'request-expire-articles + gnus-newsgroup-name) + (error "The current newsgroup does not support article deletion.")) + ;; Compute the list of articles to delete. + (let ((articles (gnus-summary-work-articles n)) + not-deleted) + (if (and gnus-novice-user + (not (gnus-yes-or-no-p + (format "Do you really want to delete %s forever? " + (if (> (length articles) 1) + (format "these %s articles" (length articles)) + "this article"))))) + () + ;; Delete the articles. + (setq not-deleted (gnus-request-expire-articles + articles gnus-newsgroup-name 'force)) + (while articles + (gnus-summary-remove-process-mark (car articles)) + ;; The backend might not have been able to delete the article + ;; after all. + (unless (memq (car articles) not-deleted) + (gnus-summary-mark-article (car articles) gnus-canceled-mark)) + (setq articles (cdr articles)))) + (gnus-summary-position-point) + (gnus-set-mode-line 'summary) + not-deleted)) + +(defun gnus-summary-edit-article (&optional force) + "Edit the current article. +This will have permanent effect only in mail groups. +If FORCE is non-nil, allow editing of articles even in read-only +groups." + (interactive "P") + (save-excursion + (set-buffer gnus-summary-buffer) + (gnus-set-global-variables) + (when (and (not force) + (gnus-group-read-only-p)) + (error "The current newsgroup does not support article editing.")) + ;; Select article if needed. + (unless (eq (gnus-summary-article-number) + gnus-current-article) + (gnus-summary-select-article t)) + (gnus-article-edit-article + `(lambda () + (gnus-summary-edit-article-done + ,(or (mail-header-references gnus-current-headers) "") + ,(gnus-group-read-only-p) ,gnus-summary-buffer))))) + +(defalias 'gnus-summary-edit-article-postpone 'gnus-article-edit-exit) + +(defun gnus-summary-edit-article-done (&optional references read-only buffer) + "Make edits to the current article permanent." + (interactive) + ;; Replace the article. + (if (and (not read-only) + (not (gnus-request-replace-article + (cdr gnus-article-current) (car gnus-article-current) + (current-buffer)))) + (error "Couldn't replace article.") + ;; Update the summary buffer. + (if (and references + (equal (message-tokenize-header references " ") + (message-tokenize-header + (or (message-fetch-field "references") "") " "))) + ;; We only have to update this line. + (save-excursion + (save-restriction + (message-narrow-to-head) + (let ((header (nnheader-parse-head t))) + (set-buffer buffer) + (mail-header-set-number header (cdr gnus-article-current)) + (gnus-summary-update-article-line + (cdr gnus-article-current) header)))) + ;; Update threads. + (set-buffer (or buffer gnus-summary-buffer)) + (gnus-summary-update-article (cdr gnus-article-current))) + ;; Prettify the article buffer again. + (save-excursion + (set-buffer gnus-article-buffer) + (run-hooks 'gnus-article-display-hook)) + ;; Prettify the summary buffer line. + (when (gnus-visual-p 'summary-highlight 'highlight) + (run-hooks 'gnus-visual-mark-article-hook)))) + +(defun gnus-summary-edit-wash (key) + "Perform editing command in the article buffer." + (interactive + (list + (progn + (message "%s" (concat (this-command-keys) "- ")) + (read-char)))) + (message "") + (gnus-summary-edit-article) + (execute-kbd-macro (concat (this-command-keys) key)) + (gnus-article-edit-done)) + +;;; Respooling + +(defun gnus-summary-respool-query () + "Query where the respool algorithm would put this article." + (interactive) + (gnus-set-global-variables) + (let (gnus-mark-article-hook) + (gnus-summary-select-article) + (save-excursion + (set-buffer gnus-article-buffer) + (save-restriction + (goto-char (point-min)) + (search-forward "\n\n") + (narrow-to-region (point-min) (point)) + (message "This message would go to %s" + (mapconcat 'car (nnmail-article-group 'identity) ", ")))))) + +;; Summary marking commands. + +(defun gnus-summary-kill-same-subject-and-select (&optional unmark) + "Mark articles which has the same subject as read, and then select the next. +If UNMARK is positive, remove any kind of mark. +If UNMARK is negative, tick articles." + (interactive "P") + (gnus-set-global-variables) + (when unmark + (setq unmark (prefix-numeric-value unmark))) + (let ((count + (gnus-summary-mark-same-subject + (gnus-summary-article-subject) unmark))) + ;; Select next unread article. If auto-select-same mode, should + ;; select the first unread article. + (gnus-summary-next-article t (and gnus-auto-select-same + (gnus-summary-article-subject))) + (gnus-message 7 "%d article%s marked as %s" + count (if (= count 1) " is" "s are") + (if unmark "unread" "read")))) + +(defun gnus-summary-kill-same-subject (&optional unmark) + "Mark articles which has the same subject as read. +If UNMARK is positive, remove any kind of mark. +If UNMARK is negative, tick articles." + (interactive "P") + (gnus-set-global-variables) + (when unmark + (setq unmark (prefix-numeric-value unmark))) + (let ((count + (gnus-summary-mark-same-subject + (gnus-summary-article-subject) unmark))) + ;; If marked as read, go to next unread subject. + (when (null unmark) + ;; Go to next unread subject. + (gnus-summary-next-subject 1 t)) + (gnus-message 7 "%d articles are marked as %s" + count (if unmark "unread" "read")))) + +(defun gnus-summary-mark-same-subject (subject &optional unmark) + "Mark articles with same SUBJECT as read, and return marked number. +If optional argument UNMARK is positive, remove any kinds of marks. +If optional argument UNMARK is negative, mark articles as unread instead." + (let ((count 1)) + (save-excursion + (cond + ((null unmark) ; Mark as read. + (while (and + (progn + (gnus-summary-mark-article-as-read gnus-killed-mark) + (gnus-summary-show-thread) t) + (gnus-summary-find-subject subject)) + (setq count (1+ count)))) + ((> unmark 0) ; Tick. + (while (and + (progn + (gnus-summary-mark-article-as-unread gnus-ticked-mark) + (gnus-summary-show-thread) t) + (gnus-summary-find-subject subject)) + (setq count (1+ count)))) + (t ; Mark as unread. + (while (and + (progn + (gnus-summary-mark-article-as-unread gnus-unread-mark) + (gnus-summary-show-thread) t) + (gnus-summary-find-subject subject)) + (setq count (1+ count))))) + (gnus-set-mode-line 'summary) + ;; Return the number of marked articles. + count))) + +(defun gnus-summary-mark-as-processable (n &optional unmark) + "Set the process mark on the next N articles. +If N is negative, mark backward instead. If UNMARK is non-nil, remove +the process mark instead. The difference between N and the actual +number of articles marked is returned." + (interactive "p") + (gnus-set-global-variables) + (let ((backward (< n 0)) + (n (abs n))) + (while (and + (> n 0) + (if unmark + (gnus-summary-remove-process-mark + (gnus-summary-article-number)) + (gnus-summary-set-process-mark (gnus-summary-article-number))) + (zerop (gnus-summary-next-subject (if backward -1 1) nil t))) + (setq n (1- n))) + (when (/= 0 n) + (gnus-message 7 "No more articles")) + (gnus-summary-recenter) + (gnus-summary-position-point) + n)) + +(defun gnus-summary-unmark-as-processable (n) + "Remove the process mark from the next N articles. +If N is negative, mark backward instead. The difference between N and +the actual number of articles marked is returned." + (interactive "p") + (gnus-set-global-variables) + (gnus-summary-mark-as-processable n t)) + +(defun gnus-summary-unmark-all-processable () + "Remove the process mark from all articles." + (interactive) + (gnus-set-global-variables) + (save-excursion + (while gnus-newsgroup-processable + (gnus-summary-remove-process-mark (car gnus-newsgroup-processable)))) + (gnus-summary-position-point)) + +(defun gnus-summary-mark-as-expirable (n) + "Mark N articles forward as expirable. +If N is negative, mark backward instead. The difference between N and +the actual number of articles marked is returned." + (interactive "p") + (gnus-set-global-variables) + (gnus-summary-mark-forward n gnus-expirable-mark)) + +(defun gnus-summary-mark-article-as-replied (article) + "Mark ARTICLE replied and update the summary line." + (push article gnus-newsgroup-replied) + (let ((buffer-read-only nil)) + (when (gnus-summary-goto-subject article) + (gnus-summary-update-secondary-mark article)))) + +(defun gnus-summary-set-bookmark (article) + "Set a bookmark in current article." + (interactive (list (gnus-summary-article-number))) + (gnus-set-global-variables) + (when (or (not (get-buffer gnus-article-buffer)) + (not gnus-current-article) + (not gnus-article-current) + (not (equal gnus-newsgroup-name (car gnus-article-current)))) + (error "No current article selected")) + ;; Remove old bookmark, if one exists. + (let ((old (assq article gnus-newsgroup-bookmarks))) + (when old + (setq gnus-newsgroup-bookmarks + (delq old gnus-newsgroup-bookmarks)))) + ;; Set the new bookmark, which is on the form + ;; (article-number . line-number-in-body). + (push + (cons article + (save-excursion + (set-buffer gnus-article-buffer) + (count-lines + (min (point) + (save-excursion + (goto-char (point-min)) + (search-forward "\n\n" nil t) + (point))) + (point)))) + gnus-newsgroup-bookmarks) + (gnus-message 6 "A bookmark has been added to the current article.")) + +(defun gnus-summary-remove-bookmark (article) + "Remove the bookmark from the current article." + (interactive (list (gnus-summary-article-number))) + (gnus-set-global-variables) + ;; Remove old bookmark, if one exists. + (let ((old (assq article gnus-newsgroup-bookmarks))) + (if old + (progn + (setq gnus-newsgroup-bookmarks + (delq old gnus-newsgroup-bookmarks)) + (gnus-message 6 "Removed bookmark.")) + (gnus-message 6 "No bookmark in current article.")))) + +;; Suggested by Daniel Quinlan . +(defun gnus-summary-mark-as-dormant (n) + "Mark N articles forward as dormant. +If N is negative, mark backward instead. The difference between N and +the actual number of articles marked is returned." + (interactive "p") + (gnus-set-global-variables) + (gnus-summary-mark-forward n gnus-dormant-mark)) + +(defun gnus-summary-set-process-mark (article) + "Set the process mark on ARTICLE and update the summary line." + (setq gnus-newsgroup-processable + (cons article + (delq article gnus-newsgroup-processable))) + (when (gnus-summary-goto-subject article) + (gnus-summary-show-thread) + (gnus-summary-update-secondary-mark article))) + +(defun gnus-summary-remove-process-mark (article) + "Remove the process mark from ARTICLE and update the summary line." + (setq gnus-newsgroup-processable (delq article gnus-newsgroup-processable)) + (when (gnus-summary-goto-subject article) + (gnus-summary-show-thread) + (gnus-summary-update-secondary-mark article))) + +(defun gnus-summary-set-saved-mark (article) + "Set the process mark on ARTICLE and update the summary line." + (push article gnus-newsgroup-saved) + (when (gnus-summary-goto-subject article) + (gnus-summary-update-secondary-mark article))) + +(defun gnus-summary-mark-forward (n &optional mark no-expire) + "Mark N articles as read forwards. +If N is negative, mark backwards instead. Mark with MARK, ?r by default. +The difference between N and the actual number of articles marked is +returned." + (interactive "p") + (gnus-set-global-variables) + (let ((backward (< n 0)) + (gnus-summary-goto-unread + (and gnus-summary-goto-unread + (not (eq gnus-summary-goto-unread 'never)) + (not (memq mark (list gnus-unread-mark + gnus-ticked-mark gnus-dormant-mark))))) + (n (abs n)) + (mark (or mark gnus-del-mark))) + (while (and (> n 0) + (gnus-summary-mark-article nil mark no-expire) + (zerop (gnus-summary-next-subject + (if backward -1 1) + (and gnus-summary-goto-unread + (not (eq gnus-summary-goto-unread 'never))) + t))) + (setq n (1- n))) + (when (/= 0 n) + (gnus-message 7 "No more %sarticles" (if mark "" "unread "))) + (gnus-summary-recenter) + (gnus-summary-position-point) + (gnus-set-mode-line 'summary) + n)) + +(defun gnus-summary-mark-article-as-read (mark) + "Mark the current article quickly as read with MARK." + (let ((article (gnus-summary-article-number))) + (setq gnus-newsgroup-unreads (delq article gnus-newsgroup-unreads)) + (setq gnus-newsgroup-marked (delq article gnus-newsgroup-marked)) + (setq gnus-newsgroup-dormant (delq article gnus-newsgroup-dormant)) + (push (cons article mark) gnus-newsgroup-reads) + ;; Possibly remove from cache, if that is used. + (when gnus-use-cache + (gnus-cache-enter-remove-article article)) + ;; Allow the backend to change the mark. + (setq mark (gnus-request-update-mark gnus-newsgroup-name article mark)) + ;; Check for auto-expiry. + (when (and gnus-newsgroup-auto-expire + (or (= mark gnus-killed-mark) (= mark gnus-del-mark) + (= mark gnus-catchup-mark) (= mark gnus-low-score-mark) + (= mark gnus-ancient-mark) + (= mark gnus-read-mark) (= mark gnus-souped-mark) + (= mark gnus-duplicate-mark))) + (setq mark gnus-expirable-mark) + (push article gnus-newsgroup-expirable)) + ;; Set the mark in the buffer. + (gnus-summary-update-mark mark 'unread) + t)) + +(defun gnus-summary-mark-article-as-unread (mark) + "Mark the current article quickly as unread with MARK." + (let ((article (gnus-summary-article-number))) + (if (< article 0) + (gnus-error 1 "Unmarkable article") + (setq gnus-newsgroup-marked (delq article gnus-newsgroup-marked)) + (setq gnus-newsgroup-dormant (delq article gnus-newsgroup-dormant)) + (setq gnus-newsgroup-expirable (delq article gnus-newsgroup-expirable)) + (setq gnus-newsgroup-reads (delq article gnus-newsgroup-reads)) + (cond ((= mark gnus-ticked-mark) + (push article gnus-newsgroup-marked)) + ((= mark gnus-dormant-mark) + (push article gnus-newsgroup-dormant)) + (t + (push article gnus-newsgroup-unreads))) + (setq gnus-newsgroup-reads + (delq (assq article gnus-newsgroup-reads) + gnus-newsgroup-reads)) + + ;; See whether the article is to be put in the cache. + (and gnus-use-cache + (vectorp (gnus-summary-article-header article)) + (save-excursion + (gnus-cache-possibly-enter-article + gnus-newsgroup-name article + (gnus-summary-article-header article) + (= mark gnus-ticked-mark) + (= mark gnus-dormant-mark) (= mark gnus-unread-mark)))) + + ;; Fix the mark. + (gnus-summary-update-mark mark 'unread)) + t)) + +(defun gnus-summary-mark-article (&optional article mark no-expire) + "Mark ARTICLE with MARK. MARK can be any character. +Four MARK strings are reserved: `? ' (unread), `?!' (ticked), +`??' (dormant) and `?E' (expirable). +If MARK is nil, then the default character `?D' is used. +If ARTICLE is nil, then the article on the current line will be +marked." + ;; The mark might be a string. + (when (stringp mark) + (setq mark (aref mark 0))) + ;; If no mark is given, then we check auto-expiring. + (and (not no-expire) + gnus-newsgroup-auto-expire + (or (not mark) + (and (gnus-characterp mark) + (or (= mark gnus-killed-mark) (= mark gnus-del-mark) + (= mark gnus-catchup-mark) (= mark gnus-low-score-mark) + (= mark gnus-read-mark) (= mark gnus-souped-mark) + (= mark gnus-duplicate-mark)))) + (setq mark gnus-expirable-mark)) + (let* ((mark (or mark gnus-del-mark)) + (article (or article (gnus-summary-article-number)))) + (unless article + (error "No article on current line")) + (if (or (= mark gnus-unread-mark) + (= mark gnus-ticked-mark) + (= mark gnus-dormant-mark)) + (gnus-mark-article-as-unread article mark) + (gnus-mark-article-as-read article mark)) + + ;; See whether the article is to be put in the cache. + (and gnus-use-cache + (not (= mark gnus-canceled-mark)) + (vectorp (gnus-summary-article-header article)) + (save-excursion + (gnus-cache-possibly-enter-article + gnus-newsgroup-name article + (gnus-summary-article-header article) + (= mark gnus-ticked-mark) + (= mark gnus-dormant-mark) (= mark gnus-unread-mark)))) + + (when (gnus-summary-goto-subject article nil t) + (let ((buffer-read-only nil)) + (gnus-summary-show-thread) + ;; Fix the mark. + (gnus-summary-update-mark mark 'unread) + t)))) + +(defun gnus-summary-update-secondary-mark (article) + "Update the secondary (read, process, cache) mark." + (gnus-summary-update-mark + (cond ((memq article gnus-newsgroup-processable) + gnus-process-mark) + ((memq article gnus-newsgroup-cached) + gnus-cached-mark) + ((memq article gnus-newsgroup-replied) + gnus-replied-mark) + ((memq article gnus-newsgroup-saved) + gnus-saved-mark) + (t gnus-unread-mark)) + 'replied) + (when (gnus-visual-p 'summary-highlight 'highlight) + (run-hooks 'gnus-summary-update-hook)) + t) + +(defun gnus-summary-update-mark (mark type) + (let ((forward (cdr (assq type gnus-summary-mark-positions))) + (buffer-read-only nil)) + (re-search-backward "[\n\r]" (point-at-bol) 'move-to-limit) + (when (looking-at "\r") + (incf forward)) + (when (and forward + (<= (+ forward (point)) (point-max))) + ;; Go to the right position on the line. + (goto-char (+ forward (point))) + ;; Replace the old mark with the new mark. + (subst-char-in-region (point) (1+ (point)) (following-char) mark) + ;; Optionally update the marks by some user rule. + (when (eq type 'unread) + (gnus-data-set-mark + (gnus-data-find (gnus-summary-article-number)) mark) + (gnus-summary-update-line (eq mark gnus-unread-mark)))))) + +(defun gnus-mark-article-as-read (article &optional mark) + "Enter ARTICLE in the pertinent lists and remove it from others." + ;; Make the article expirable. + (let ((mark (or mark gnus-del-mark))) + (if (= mark gnus-expirable-mark) + (push article gnus-newsgroup-expirable) + (setq gnus-newsgroup-expirable (delq article gnus-newsgroup-expirable))) + ;; Remove from unread and marked lists. + (setq gnus-newsgroup-unreads (delq article gnus-newsgroup-unreads)) + (setq gnus-newsgroup-marked (delq article gnus-newsgroup-marked)) + (setq gnus-newsgroup-dormant (delq article gnus-newsgroup-dormant)) + (push (cons article mark) gnus-newsgroup-reads) + ;; Possibly remove from cache, if that is used. + (when gnus-use-cache + (gnus-cache-enter-remove-article article)))) + +(defun gnus-mark-article-as-unread (article &optional mark) + "Enter ARTICLE in the pertinent lists and remove it from others." + (let ((mark (or mark gnus-ticked-mark))) + (setq gnus-newsgroup-marked (delq article gnus-newsgroup-marked) + gnus-newsgroup-dormant (delq article gnus-newsgroup-dormant) + gnus-newsgroup-expirable (delq article gnus-newsgroup-expirable) + gnus-newsgroup-unreads (delq article gnus-newsgroup-unreads)) + + ;; Unsuppress duplicates? + (when gnus-suppress-duplicates + (gnus-dup-unsuppress-article article)) + + (cond ((= mark gnus-ticked-mark) + (push article gnus-newsgroup-marked)) + ((= mark gnus-dormant-mark) + (push article gnus-newsgroup-dormant)) + (t + (push article gnus-newsgroup-unreads))) + (setq gnus-newsgroup-reads + (delq (assq article gnus-newsgroup-reads) + gnus-newsgroup-reads)))) + +(defalias 'gnus-summary-mark-as-unread-forward + 'gnus-summary-tick-article-forward) +(make-obsolete 'gnus-summary-mark-as-unread-forward + 'gnus-summary-tick-article-forward) +(defun gnus-summary-tick-article-forward (n) + "Tick N articles forwards. +If N is negative, tick backwards instead. +The difference between N and the number of articles ticked is returned." + (interactive "p") + (gnus-summary-mark-forward n gnus-ticked-mark)) + +(defalias 'gnus-summary-mark-as-unread-backward + 'gnus-summary-tick-article-backward) +(make-obsolete 'gnus-summary-mark-as-unread-backward + 'gnus-summary-tick-article-backward) +(defun gnus-summary-tick-article-backward (n) + "Tick N articles backwards. +The difference between N and the number of articles ticked is returned." + (interactive "p") + (gnus-summary-mark-forward (- n) gnus-ticked-mark)) + +(defalias 'gnus-summary-mark-as-unread 'gnus-summary-tick-article) +(make-obsolete 'gnus-summary-mark-as-unread 'gnus-summary-tick-article) +(defun gnus-summary-tick-article (&optional article clear-mark) + "Mark current article as unread. +Optional 1st argument ARTICLE specifies article number to be marked as unread. +Optional 2nd argument CLEAR-MARK remove any kinds of mark." + (interactive) + (gnus-summary-mark-article article (if clear-mark gnus-unread-mark + gnus-ticked-mark))) + +(defun gnus-summary-mark-as-read-forward (n) + "Mark N articles as read forwards. +If N is negative, mark backwards instead. +The difference between N and the actual number of articles marked is +returned." + (interactive "p") + (gnus-summary-mark-forward n gnus-del-mark t)) + +(defun gnus-summary-mark-as-read-backward (n) + "Mark the N articles as read backwards. +The difference between N and the actual number of articles marked is +returned." + (interactive "p") + (gnus-summary-mark-forward (- n) gnus-del-mark t)) + +(defun gnus-summary-mark-as-read (&optional article mark) + "Mark current article as read. +ARTICLE specifies the article to be marked as read. +MARK specifies a string to be inserted at the beginning of the line." + (gnus-summary-mark-article article mark)) + +(defun gnus-summary-clear-mark-forward (n) + "Clear marks from N articles forward. +If N is negative, clear backward instead. +The difference between N and the number of marks cleared is returned." + (interactive "p") + (gnus-summary-mark-forward n gnus-unread-mark)) + +(defun gnus-summary-clear-mark-backward (n) + "Clear marks from N articles backward. +The difference between N and the number of marks cleared is returned." + (interactive "p") + (gnus-summary-mark-forward (- n) gnus-unread-mark)) + +(defun gnus-summary-mark-unread-as-read () + "Intended to be used by `gnus-summary-mark-article-hook'." + (when (memq gnus-current-article gnus-newsgroup-unreads) + (gnus-summary-mark-article gnus-current-article gnus-read-mark))) + +(defun gnus-summary-mark-read-and-unread-as-read () + "Intended to be used by `gnus-summary-mark-article-hook'." + (let ((mark (gnus-summary-article-mark))) + (when (or (gnus-unread-mark-p mark) + (gnus-read-mark-p mark)) + (gnus-summary-mark-article gnus-current-article gnus-read-mark)))) + +(defun gnus-summary-mark-region-as-read (point mark all) + "Mark all unread articles between point and mark as read. +If given a prefix, mark all articles between point and mark as read, +even ticked and dormant ones." + (interactive "r\nP") + (save-excursion + (let (article) + (goto-char point) + (beginning-of-line) + (while (and + (< (point) mark) + (progn + (when (or all + (memq (setq article (gnus-summary-article-number)) + gnus-newsgroup-unreads)) + (gnus-summary-mark-article article gnus-del-mark)) + t) + (gnus-summary-find-next)))))) + +(defun gnus-summary-mark-below (score mark) + "Mark articles with score less than SCORE with MARK." + (interactive "P\ncMark: ") + (gnus-set-global-variables) + (setq score (if score + (prefix-numeric-value score) + (or gnus-summary-default-score 0))) + (save-excursion + (set-buffer gnus-summary-buffer) + (goto-char (point-min)) + (while + (progn + (and (< (gnus-summary-article-score) score) + (gnus-summary-mark-article nil mark)) + (gnus-summary-find-next))))) + +(defun gnus-summary-kill-below (&optional score) + "Mark articles with score below SCORE as read." + (interactive "P") + (gnus-set-global-variables) + (gnus-summary-mark-below score gnus-killed-mark)) + +(defun gnus-summary-clear-above (&optional score) + "Clear all marks from articles with score above SCORE." + (interactive "P") + (gnus-set-global-variables) + (gnus-summary-mark-above score gnus-unread-mark)) + +(defun gnus-summary-tick-above (&optional score) + "Tick all articles with score above SCORE." + (interactive "P") + (gnus-set-global-variables) + (gnus-summary-mark-above score gnus-ticked-mark)) + +(defun gnus-summary-mark-above (score mark) + "Mark articles with score over SCORE with MARK." + (interactive "P\ncMark: ") + (gnus-set-global-variables) + (setq score (if score + (prefix-numeric-value score) + (or gnus-summary-default-score 0))) + (save-excursion + (set-buffer gnus-summary-buffer) + (goto-char (point-min)) + (while (and (progn + (when (> (gnus-summary-article-score) score) + (gnus-summary-mark-article nil mark)) + t) + (gnus-summary-find-next))))) + +;; Suggested by Daniel Quinlan . +(defalias 'gnus-summary-show-all-expunged 'gnus-summary-limit-include-expunged) +(defun gnus-summary-limit-include-expunged (&optional no-error) + "Display all the hidden articles that were expunged for low scores." + (interactive) + (gnus-set-global-variables) + (let ((buffer-read-only nil)) + (let ((scored gnus-newsgroup-scored) + headers h) + (while scored + (unless (gnus-summary-goto-subject (caar scored)) + (and (setq h (gnus-summary-article-header (caar scored))) + (< (cdar scored) gnus-summary-expunge-below) + (push h headers))) + (setq scored (cdr scored))) + (if (not headers) + (when (not no-error) + (error "No expunged articles hidden.")) + (goto-char (point-min)) + (gnus-summary-prepare-unthreaded (nreverse headers)) + (goto-char (point-min)) + (gnus-summary-position-point) + t)))) + +(defun gnus-summary-catchup (&optional all quietly to-here not-mark) + "Mark all unread articles in this newsgroup as read. +If prefix argument ALL is non-nil, ticked and dormant articles will +also be marked as read. +If QUIETLY is non-nil, no questions will be asked. +If TO-HERE is non-nil, it should be a point in the buffer. All +articles before this point will be marked as read. +Note that this function will only catch up the unread article +in the current summary buffer limitation. +The number of articles marked as read is returned." + (interactive "P") + (gnus-set-global-variables) + (prog1 + (save-excursion + (when (or quietly + (not gnus-interactive-catchup) ;Without confirmation? + gnus-expert-user + (gnus-y-or-n-p + (if all + "Mark absolutely all articles as read? " + "Mark all unread articles as read? "))) + (if (and not-mark + (not gnus-newsgroup-adaptive) + (not gnus-newsgroup-auto-expire) + (not gnus-suppress-duplicates)) + (progn + (when all + (setq gnus-newsgroup-marked nil + gnus-newsgroup-dormant nil)) + (setq gnus-newsgroup-unreads nil)) + ;; We actually mark all articles as canceled, which we + ;; have to do when using auto-expiry or adaptive scoring. + (gnus-summary-show-all-threads) + (when (gnus-summary-first-subject (not all)) + (while (and + (if to-here (< (point) to-here) t) + (gnus-summary-mark-article-as-read gnus-catchup-mark) + (gnus-summary-find-next (not all))))) + (gnus-set-mode-line 'summary)) + t)) + (gnus-summary-position-point))) + +(defun gnus-summary-catchup-to-here (&optional all) + "Mark all unticked articles before the current one as read. +If ALL is non-nil, also mark ticked and dormant articles as read." + (interactive "P") + (gnus-set-global-variables) + (save-excursion + (gnus-save-hidden-threads + (let ((beg (point))) + ;; We check that there are unread articles. + (when (or all (gnus-summary-find-prev)) + (gnus-summary-catchup all t beg))))) + (gnus-summary-position-point)) + +(defun gnus-summary-catchup-all (&optional quietly) + "Mark all articles in this newsgroup as read." + (interactive "P") + (gnus-set-global-variables) + (gnus-summary-catchup t quietly)) + +(defun gnus-summary-catchup-and-exit (&optional all quietly) + "Mark all articles not marked as unread in this newsgroup as read, then exit. +If prefix argument ALL is non-nil, all articles are marked as read." + (interactive "P") + (gnus-set-global-variables) + (when (gnus-summary-catchup all quietly nil 'fast) + ;; Select next newsgroup or exit. + (if (eq gnus-auto-select-next 'quietly) + (gnus-summary-next-group nil) + (gnus-summary-exit)))) + +(defun gnus-summary-catchup-all-and-exit (&optional quietly) + "Mark all articles in this newsgroup as read, and then exit." + (interactive "P") + (gnus-set-global-variables) + (gnus-summary-catchup-and-exit t quietly)) + +;; Suggested by "Arne Eofsson" . +(defun gnus-summary-catchup-and-goto-next-group (&optional all) + "Mark all articles in this group as read and select the next group. +If given a prefix, mark all articles, unread as well as ticked, as +read." + (interactive "P") + (gnus-set-global-variables) + (save-excursion + (gnus-summary-catchup all)) + (gnus-summary-next-article t nil nil t)) + +;; Thread-based commands. + +(defun gnus-summary-articles-in-thread (&optional article) + "Return a list of all articles in the current thread. +If ARTICLE is non-nil, return all articles in the thread that starts +with that article." + (let* ((article (or article (gnus-summary-article-number))) + (data (gnus-data-find-list article)) + (top-level (gnus-data-level (car data))) + (top-subject + (cond ((null gnus-thread-operation-ignore-subject) + (gnus-simplify-subject-re + (mail-header-subject (gnus-data-header (car data))))) + ((eq gnus-thread-operation-ignore-subject 'fuzzy) + (gnus-simplify-subject-fuzzy + (mail-header-subject (gnus-data-header (car data))))) + (t nil))) + (end-point (save-excursion + (if (gnus-summary-go-to-next-thread) + (point) (point-max)))) + articles) + (while (and data + (< (gnus-data-pos (car data)) end-point)) + (when (or (not top-subject) + (string= top-subject + (if (eq gnus-thread-operation-ignore-subject 'fuzzy) + (gnus-simplify-subject-fuzzy + (mail-header-subject + (gnus-data-header (car data)))) + (gnus-simplify-subject-re + (mail-header-subject + (gnus-data-header (car data))))))) + (push (gnus-data-number (car data)) articles)) + (unless (and (setq data (cdr data)) + (> (gnus-data-level (car data)) top-level)) + (setq data nil))) + ;; Return the list of articles. + (nreverse articles))) + +(defun gnus-summary-rethread-current () + "Rethread the thread the current article is part of." + (interactive) + (gnus-set-global-variables) + (let* ((gnus-show-threads t) + (article (gnus-summary-article-number)) + (id (mail-header-id (gnus-summary-article-header))) + (gnus-newsgroup-threads (list (gnus-id-to-thread (gnus-root-id id))))) + (unless id + (error "No article on the current line")) + (gnus-rebuild-thread id) + (gnus-summary-goto-subject article))) + +(defun gnus-summary-reparent-thread () + "Make current article child of the marked (or previous) article. + +Note that the re-threading will only work if `gnus-thread-ignore-subject' +is non-nil or the Subject: of both articles are the same." + (interactive) + (unless (not (gnus-group-read-only-p)) + (error "The current newsgroup does not support article editing.")) + (unless (<= (length gnus-newsgroup-processable) 1) + (error "No more than one article may be marked.")) + (save-window-excursion + (let ((gnus-article-buffer " *reparent*") + (current-article (gnus-summary-article-number)) + ; first grab the marked article, otherwise one line up. + (parent-article (if (not (null gnus-newsgroup-processable)) + (car gnus-newsgroup-processable) + (save-excursion + (if (eq (forward-line -1) 0) + (gnus-summary-article-number) + (error "Beginning of summary buffer.")))))) + (unless (not (eq current-article parent-article)) + (error "An article may not be self-referential.")) + (let ((message-id (mail-header-id + (gnus-summary-article-header parent-article)))) + (unless (and message-id (not (equal message-id ""))) + (error "No message-id in desired parent.")) + (gnus-summary-select-article t t nil current-article) + (set-buffer gnus-article-buffer) + (setq buffer-read-only nil) + (let ((buf (format "%s" (buffer-string)))) + (erase-buffer) + (insert buf)) + (goto-char (point-min)) + (if (search-forward-regexp "^References: " nil t) + (insert message-id " " ) + (insert "References: " message-id "\n")) + (unless (gnus-request-replace-article current-article + (car gnus-article-current) + gnus-article-buffer) + (error "Couldn't replace article.")) + (set-buffer gnus-summary-buffer) + (gnus-summary-unmark-all-processable) + (gnus-summary-rethread-current) + (gnus-message 3 "Article %d is now the child of article %d." + current-article parent-article))))) + +(defun gnus-summary-toggle-threads (&optional arg) + "Toggle showing conversation threads. +If ARG is positive number, turn showing conversation threads on." + (interactive "P") + (gnus-set-global-variables) + (let ((current (or (gnus-summary-article-number) gnus-newsgroup-end))) + (setq gnus-show-threads + (if (null arg) (not gnus-show-threads) + (> (prefix-numeric-value arg) 0))) + (gnus-summary-prepare) + (gnus-summary-goto-subject current) + (gnus-message 6 "Threading is now %s" (if gnus-show-threads "on" "off")) + (gnus-summary-position-point))) + +(defun gnus-summary-show-all-threads () + "Show all threads." + (interactive) + (gnus-set-global-variables) + (save-excursion + (let ((buffer-read-only nil)) + (subst-char-in-region (point-min) (point-max) ?\^M ?\n t))) + (gnus-summary-position-point)) + +(defun gnus-summary-show-thread () + "Show thread subtrees. +Returns nil if no thread was there to be shown." + (interactive) + (gnus-set-global-variables) + (let ((buffer-read-only nil) + (orig (point)) + ;; first goto end then to beg, to have point at beg after let + (end (progn (end-of-line) (point))) + (beg (progn (beginning-of-line) (point)))) + (prog1 + ;; Any hidden lines here? + (search-forward "\r" end t) + (subst-char-in-region beg end ?\^M ?\n t) + (goto-char orig) + (gnus-summary-position-point)))) + +(defun gnus-summary-hide-all-threads () + "Hide all thread subtrees." + (interactive) + (gnus-set-global-variables) + (save-excursion + (goto-char (point-min)) + (gnus-summary-hide-thread) + (while (zerop (gnus-summary-next-thread 1 t)) + (gnus-summary-hide-thread))) + (gnus-summary-position-point)) + +(defun gnus-summary-hide-thread () + "Hide thread subtrees. +Returns nil if no threads were there to be hidden." + (interactive) + (gnus-set-global-variables) + (let ((buffer-read-only nil) + (start (point)) + (article (gnus-summary-article-number))) + (goto-char start) + ;; Go forward until either the buffer ends or the subthread + ;; ends. + (when (and (not (eobp)) + (or (zerop (gnus-summary-next-thread 1 t)) + (goto-char (point-max)))) + (prog1 + (if (and (> (point) start) + (search-backward "\n" start t)) + (progn + (subst-char-in-region start (point) ?\n ?\^M) + (gnus-summary-goto-subject article)) + (goto-char start) + nil) + ;;(gnus-summary-position-point) + )))) + +(defun gnus-summary-go-to-next-thread (&optional previous) + "Go to the same level (or less) next thread. +If PREVIOUS is non-nil, go to previous thread instead. +Return the article number moved to, or nil if moving was impossible." + (let ((level (gnus-summary-thread-level)) + (way (if previous -1 1)) + (beg (point))) + (forward-line way) + (while (and (not (eobp)) + (< level (gnus-summary-thread-level))) + (forward-line way)) + (if (eobp) + (progn + (goto-char beg) + nil) + (setq beg (point)) + (prog1 + (gnus-summary-article-number) + (goto-char beg))))) + +(defun gnus-summary-next-thread (n &optional silent) + "Go to the same level next N'th thread. +If N is negative, search backward instead. +Returns the difference between N and the number of skips actually +done. + +If SILENT, don't output messages." + (interactive "p") + (gnus-set-global-variables) + (let ((backward (< n 0)) + (n (abs n))) + (while (and (> n 0) + (gnus-summary-go-to-next-thread backward)) + (decf n)) + (unless silent + (gnus-summary-position-point)) + (when (and (not silent) (/= 0 n)) + (gnus-message 7 "No more threads")) + n)) + +(defun gnus-summary-prev-thread (n) + "Go to the same level previous N'th thread. +Returns the difference between N and the number of skips actually +done." + (interactive "p") + (gnus-set-global-variables) + (gnus-summary-next-thread (- n))) + +(defun gnus-summary-go-down-thread () + "Go down one level in the current thread." + (let ((children (gnus-summary-article-children))) + (when children + (gnus-summary-goto-subject (car children))))) + +(defun gnus-summary-go-up-thread () + "Go up one level in the current thread." + (let ((parent (gnus-summary-article-parent))) + (when parent + (gnus-summary-goto-subject parent)))) + +(defun gnus-summary-down-thread (n) + "Go down thread N steps. +If N is negative, go up instead. +Returns the difference between N and how many steps down that were +taken." + (interactive "p") + (gnus-set-global-variables) + (let ((up (< n 0)) + (n (abs n))) + (while (and (> n 0) + (if up (gnus-summary-go-up-thread) + (gnus-summary-go-down-thread))) + (setq n (1- n))) + (gnus-summary-position-point) + (when (/= 0 n) + (gnus-message 7 "Can't go further")) + n)) + +(defun gnus-summary-up-thread (n) + "Go up thread N steps. +If N is negative, go up instead. +Returns the difference between N and how many steps down that were +taken." + (interactive "p") + (gnus-set-global-variables) + (gnus-summary-down-thread (- n))) + +(defun gnus-summary-top-thread () + "Go to the top of the thread." + (interactive) + (gnus-set-global-variables) + (while (gnus-summary-go-up-thread)) + (gnus-summary-article-number)) + +(defun gnus-summary-kill-thread (&optional unmark) + "Mark articles under current thread as read. +If the prefix argument is positive, remove any kinds of marks. +If the prefix argument is negative, tick articles instead." + (interactive "P") + (gnus-set-global-variables) + (when unmark + (setq unmark (prefix-numeric-value unmark))) + (let ((articles (gnus-summary-articles-in-thread))) + (save-excursion + ;; Expand the thread. + (gnus-summary-show-thread) + ;; Mark all the articles. + (while articles + (gnus-summary-goto-subject (car articles)) + (cond ((null unmark) + (gnus-summary-mark-article-as-read gnus-killed-mark)) + ((> unmark 0) + (gnus-summary-mark-article-as-unread gnus-unread-mark)) + (t + (gnus-summary-mark-article-as-unread gnus-ticked-mark))) + (setq articles (cdr articles)))) + ;; Hide killed subtrees. + (and (null unmark) + gnus-thread-hide-killed + (gnus-summary-hide-thread)) + ;; If marked as read, go to next unread subject. + (when (null unmark) + ;; Go to next unread subject. + (gnus-summary-next-subject 1 t))) + (gnus-set-mode-line 'summary)) + +;; Summary sorting commands + +(defun gnus-summary-sort-by-number (&optional reverse) + "Sort the summary buffer by article number. +Argument REVERSE means reverse order." + (interactive "P") + (gnus-summary-sort 'number reverse)) + +(defun gnus-summary-sort-by-author (&optional reverse) + "Sort the summary buffer by author name alphabetically. +If case-fold-search is non-nil, case of letters is ignored. +Argument REVERSE means reverse order." + (interactive "P") + (gnus-summary-sort 'author reverse)) + +(defun gnus-summary-sort-by-subject (&optional reverse) + "Sort the summary buffer by subject alphabetically. `Re:'s are ignored. +If case-fold-search is non-nil, case of letters is ignored. +Argument REVERSE means reverse order." + (interactive "P") + (gnus-summary-sort 'subject reverse)) + +(defun gnus-summary-sort-by-date (&optional reverse) + "Sort the summary buffer by date. +Argument REVERSE means reverse order." + (interactive "P") + (gnus-summary-sort 'date reverse)) + +(defun gnus-summary-sort-by-score (&optional reverse) + "Sort the summary buffer by score. +Argument REVERSE means reverse order." + (interactive "P") + (gnus-summary-sort 'score reverse)) + +(defun gnus-summary-sort-by-lines (&optional reverse) + "Sort the summary buffer by article length. +Argument REVERSE means reverse order." + (interactive "P") + (gnus-summary-sort 'lines reverse)) + +(defun gnus-summary-sort (predicate reverse) + "Sort summary buffer by PREDICATE. REVERSE means reverse order." + (gnus-set-global-variables) + (let* ((thread (intern (format "gnus-thread-sort-by-%s" predicate))) + (article (intern (format "gnus-article-sort-by-%s" predicate))) + (gnus-thread-sort-functions + (list + (if (not reverse) + thread + `(lambda (t1 t2) + (,thread t2 t1))))) + (gnus-article-sort-functions + (list + (if (not reverse) + article + `(lambda (t1 t2) + (,article t2 t1))))) + (buffer-read-only) + (gnus-summary-prepare-hook nil)) + ;; We do the sorting by regenerating the threads. + (gnus-summary-prepare) + ;; Hide subthreads if needed. + (when (and gnus-show-threads gnus-thread-hide-subtree) + (gnus-summary-hide-all-threads)))) + +;; Summary saving commands. + +(defun gnus-summary-save-article (&optional n not-saved) + "Save the current article using the default saver function. +If N is a positive number, save the N next articles. +If N is a negative number, save the N previous articles. +If N is nil and any articles have been marked with the process mark, +save those articles instead. +The variable `gnus-default-article-saver' specifies the saver function." + (interactive "P") + (gnus-set-global-variables) + (let* ((articles (gnus-summary-work-articles n)) + (save-buffer (save-excursion + (nnheader-set-temp-buffer " *Gnus Save*"))) + (num (length articles)) + header article file) + (while articles + (setq header (gnus-summary-article-header + (setq article (pop articles)))) + (if (not (vectorp header)) + ;; This is a pseudo-article. + (if (assq 'name header) + (gnus-copy-file (cdr (assq 'name header))) + (gnus-message 1 "Article %d is unsaveable" article)) + ;; This is a real article. + (save-window-excursion + (gnus-summary-select-article t nil nil article)) + (save-excursion + (set-buffer save-buffer) + (erase-buffer) + (insert-buffer-substring gnus-original-article-buffer)) + (setq file (gnus-article-save save-buffer file num)) + (gnus-summary-remove-process-mark article) + (unless not-saved + (gnus-summary-set-saved-mark article)))) + (gnus-kill-buffer save-buffer) + (gnus-summary-position-point) + (gnus-set-mode-line 'summary) + n)) + +(defun gnus-summary-pipe-output (&optional arg) + "Pipe the current article to a subprocess. +If N is a positive number, pipe the N next articles. +If N is a negative number, pipe the N previous articles. +If N is nil and any articles have been marked with the process mark, +pipe those articles instead." + (interactive "P") + (gnus-set-global-variables) + (let ((gnus-default-article-saver 'gnus-summary-save-in-pipe)) + (gnus-summary-save-article arg t)) + (gnus-configure-windows 'pipe)) + +(defun gnus-summary-save-article-mail (&optional arg) + "Append the current article to an mail file. +If N is a positive number, save the N next articles. +If N is a negative number, save the N previous articles. +If N is nil and any articles have been marked with the process mark, +save those articles instead." + (interactive "P") + (gnus-set-global-variables) + (let ((gnus-default-article-saver 'gnus-summary-save-in-mail)) + (gnus-summary-save-article arg))) + +(defun gnus-summary-save-article-rmail (&optional arg) + "Append the current article to an rmail file. +If N is a positive number, save the N next articles. +If N is a negative number, save the N previous articles. +If N is nil and any articles have been marked with the process mark, +save those articles instead." + (interactive "P") + (gnus-set-global-variables) + (let ((gnus-default-article-saver 'gnus-summary-save-in-rmail)) + (gnus-summary-save-article arg))) + +(defun gnus-summary-save-article-file (&optional arg) + "Append the current article to a file. +If N is a positive number, save the N next articles. +If N is a negative number, save the N previous articles. +If N is nil and any articles have been marked with the process mark, +save those articles instead." + (interactive "P") + (gnus-set-global-variables) + (let ((gnus-default-article-saver 'gnus-summary-save-in-file)) + (gnus-summary-save-article arg))) + +(defun gnus-summary-write-article-file (&optional arg) + "Write the current article to a file, deleting the previous file. +If N is a positive number, save the N next articles. +If N is a negative number, save the N previous articles. +If N is nil and any articles have been marked with the process mark, +save those articles instead." + (interactive "P") + (gnus-set-global-variables) + (let ((gnus-default-article-saver 'gnus-summary-write-to-file)) + (gnus-summary-save-article arg))) + +(defun gnus-summary-save-article-body-file (&optional arg) + "Append the current article body to a file. +If N is a positive number, save the N next articles. +If N is a negative number, save the N previous articles. +If N is nil and any articles have been marked with the process mark, +save those articles instead." + (interactive "P") + (gnus-set-global-variables) + (let ((gnus-default-article-saver 'gnus-summary-save-body-in-file)) + (gnus-summary-save-article arg))) + +(defun gnus-summary-pipe-message (program) + "Pipe the current article through PROGRAM." + (interactive "sProgram: ") + (gnus-set-global-variables) + (gnus-summary-select-article) + (let ((mail-header-separator "") + (art-buf (get-buffer gnus-article-buffer))) + (gnus-eval-in-buffer-window gnus-article-buffer + (save-restriction + (widen) + (let ((start (window-start)) + buffer-read-only) + (message-pipe-buffer-body program) + (set-window-start (get-buffer-window (current-buffer)) start)))))) + +(defun gnus-get-split-value (methods) + "Return a value based on the split METHODS." + (let (split-name method result match) + (when methods + (save-excursion + (set-buffer gnus-original-article-buffer) + (save-restriction + (nnheader-narrow-to-headers) + (while methods + (goto-char (point-min)) + (setq method (pop methods)) + (setq match (car method)) + (when (cond + ((stringp match) + ;; Regular expression. + (ignore-errors + (re-search-forward match nil t))) + ((gnus-functionp match) + ;; Function. + (save-restriction + (widen) + (setq result (funcall match gnus-newsgroup-name)))) + ((consp match) + ;; Form. + (save-restriction + (widen) + (setq result (eval match))))) + (setq split-name (append (cdr method) split-name)) + (cond ((stringp result) + (push (expand-file-name + result gnus-article-save-directory) + split-name)) + ((consp result) + (setq split-name (append result split-name))))))))) + split-name)) + +(defun gnus-valid-move-group-p (group) + (and (boundp group) + (symbol-name group) + (memq 'respool + (assoc (symbol-name + (car (gnus-find-method-for-group + (symbol-name group)))) + gnus-valid-select-methods)))) + +(defun gnus-read-move-group-name (prompt default articles prefix) + "Read a group name." + (let* ((split-name (gnus-get-split-value gnus-move-split-methods)) + (minibuffer-confirm-incomplete nil) ; XEmacs + (prom + (format "%s %s to:" + prompt + (if (> (length articles) 1) + (format "these %d articles" (length articles)) + "this article"))) + (to-newsgroup + (cond + ((null split-name) + (gnus-completing-read default prom + gnus-active-hashtb + 'gnus-valid-move-group-p + nil prefix + 'gnus-group-history)) + ((= 1 (length split-name)) + (gnus-completing-read (car split-name) prom + gnus-active-hashtb + 'gnus-valid-move-group-p + nil nil + 'gnus-group-history)) + (t + (gnus-completing-read nil prom + (mapcar (lambda (el) (list el)) + (nreverse split-name)) + nil nil nil + 'gnus-group-history))))) + (when to-newsgroup + (if (or (string= to-newsgroup "") + (string= to-newsgroup prefix)) + (setq to-newsgroup (or default ""))) + (or (gnus-active to-newsgroup) + (gnus-activate-group to-newsgroup) + (if (gnus-y-or-n-p (format "No such group: %s. Create it? " + to-newsgroup)) + (or (and (gnus-request-create-group + to-newsgroup (gnus-group-name-to-method to-newsgroup)) + (gnus-activate-group to-newsgroup nil nil + (gnus-group-name-to-method + to-newsgroup))) + (error "Couldn't create group %s" to-newsgroup))) + (error "No such group: %s" to-newsgroup))) + to-newsgroup)) + +;; Summary extract commands + +(defun gnus-summary-insert-pseudos (pslist &optional not-view) + (let ((buffer-read-only nil) + (article (gnus-summary-article-number)) + after-article b e) + (unless (gnus-summary-goto-subject article) + (error "No such article: %d" article)) + (gnus-summary-position-point) + ;; If all commands are to be bunched up on one line, we collect + ;; them here. + (unless gnus-view-pseudos-separately + (let ((ps (setq pslist (sort pslist 'gnus-pseudos<))) + files action) + (while ps + (setq action (cdr (assq 'action (car ps)))) + (setq files (list (cdr (assq 'name (car ps))))) + (while (and ps (cdr ps) + (string= (or action "1") + (or (cdr (assq 'action (cadr ps))) "2"))) + (push (cdr (assq 'name (cadr ps))) files) + (setcdr ps (cddr ps))) + (when files + (when (not (string-match "%s" action)) + (push " " files)) + (push " " files) + (when (assq 'execute (car ps)) + (setcdr (assq 'execute (car ps)) + (funcall (if (string-match "%s" action) + 'format 'concat) + action + (mapconcat (lambda (f) f) files " "))))) + (setq ps (cdr ps))))) + (if (and gnus-view-pseudos (not not-view)) + (while pslist + (when (assq 'execute (car pslist)) + (gnus-execute-command (cdr (assq 'execute (car pslist))) + (eq gnus-view-pseudos 'not-confirm))) + (setq pslist (cdr pslist))) + (save-excursion + (while pslist + (setq after-article (or (cdr (assq 'article (car pslist))) + (gnus-summary-article-number))) + (gnus-summary-goto-subject after-article) + (forward-line 1) + (setq b (point)) + (insert " " (file-name-nondirectory + (cdr (assq 'name (car pslist)))) + ": " (or (cdr (assq 'execute (car pslist))) "") "\n") + (setq e (point)) + (forward-line -1) ; back to `b' + (gnus-add-text-properties + b (1- e) (list 'gnus-number gnus-reffed-article-number + gnus-mouse-face-prop gnus-mouse-face)) + (gnus-data-enter + after-article gnus-reffed-article-number + gnus-unread-mark b (car pslist) 0 (- e b)) + (push gnus-reffed-article-number gnus-newsgroup-unreads) + (setq gnus-reffed-article-number (1- gnus-reffed-article-number)) + (setq pslist (cdr pslist))))))) + +(defun gnus-pseudos< (p1 p2) + (let ((c1 (cdr (assq 'action p1))) + (c2 (cdr (assq 'action p2)))) + (and c1 c2 (string< c1 c2)))) + +(defun gnus-request-pseudo-article (props) + (cond ((assq 'execute props) + (gnus-execute-command (cdr (assq 'execute props))))) + (let ((gnus-current-article (gnus-summary-article-number))) + (run-hooks 'gnus-mark-article-hook))) + +(defun gnus-execute-command (command &optional automatic) + (save-excursion + (gnus-article-setup-buffer) + (set-buffer gnus-article-buffer) + (setq buffer-read-only nil) + (let ((command (if automatic command (read-string "Command: " command))) + ;; Just binding this here doesn't help, because there might + ;; be output from the process after exiting the scope of + ;; this `let'. + ;; (buffer-read-only nil) + ) + (erase-buffer) + (insert "$ " command "\n\n") + (if gnus-view-pseudo-asynchronously + (start-process "gnus-execute" nil shell-file-name + shell-command-switch command) + (call-process shell-file-name nil t nil + shell-command-switch command))))) + +;; Summary kill commands. + +(defun gnus-summary-edit-global-kill (article) + "Edit the \"global\" kill file." + (interactive (list (gnus-summary-article-number))) + (gnus-set-global-variables) + (gnus-group-edit-global-kill article)) + +(defun gnus-summary-edit-local-kill () + "Edit a local kill file applied to the current newsgroup." + (interactive) + (gnus-set-global-variables) + (setq gnus-current-headers (gnus-summary-article-header)) + (gnus-set-global-variables) + (gnus-group-edit-local-kill + (gnus-summary-article-number) gnus-newsgroup-name)) + +;;; Header reading. + +(defun gnus-read-header (id &optional header) + "Read the headers of article ID and enter them into the Gnus system." + (let ((group gnus-newsgroup-name) + (gnus-override-method + (and (gnus-news-group-p gnus-newsgroup-name) + gnus-refer-article-method)) + where) + ;; First we check to see whether the header in question is already + ;; fetched. + (if (stringp id) + ;; This is a Message-ID. + (setq header (or header (gnus-id-to-header id))) + ;; This is an article number. + (setq header (or header (gnus-summary-article-header id)))) + (if (and header + (not (gnus-summary-article-sparse-p (mail-header-number header)))) + ;; We have found the header. + header + ;; We have to really fetch the header to this article. + (save-excursion + (set-buffer nntp-server-buffer) + (when (setq where (gnus-request-head id group)) + (nnheader-fold-continuation-lines) + (goto-char (point-max)) + (insert ".\n") + (goto-char (point-min)) + (insert "211 ") + (princ (cond + ((numberp id) id) + ((cdr where) (cdr where)) + (header (mail-header-number header)) + (t gnus-reffed-article-number)) + (current-buffer)) + (insert " Article retrieved.\n")) + (if (not (setq header (car (gnus-get-newsgroup-headers nil t)))) + () ; Malformed head. + (unless (gnus-summary-article-sparse-p (mail-header-number header)) + (when (and (stringp id) + (not (string= (gnus-group-real-name group) + (car where)))) + ;; If we fetched by Message-ID and the article came + ;; from a different group, we fudge some bogus article + ;; numbers for this article. + (mail-header-set-number header gnus-reffed-article-number)) + (save-excursion + (set-buffer gnus-summary-buffer) + (decf gnus-reffed-article-number) + (gnus-remove-header (mail-header-number header)) + (push header gnus-newsgroup-headers) + (setq gnus-current-headers header) + (push (mail-header-number header) gnus-newsgroup-limit))) + header))))) + +(defun gnus-remove-header (number) + "Remove header NUMBER from `gnus-newsgroup-headers'." + (if (and gnus-newsgroup-headers + (= number (mail-header-number (car gnus-newsgroup-headers)))) + (pop gnus-newsgroup-headers) + (let ((headers gnus-newsgroup-headers)) + (while (and (cdr headers) + (not (= number (mail-header-number (cadr headers))))) + (pop headers)) + (when (cdr headers) + (setcdr headers (cddr headers)))))) + +;;; +;;; summary highlights +;;; + +(defun gnus-highlight-selected-summary () + ;; Added by Per Abrahamsen . + ;; Highlight selected article in summary buffer + (when gnus-summary-selected-face + (save-excursion + (let* ((beg (progn (beginning-of-line) (point))) + (end (progn (end-of-line) (point))) + ;; Fix by Mike Dugan . + (from (if (get-text-property beg gnus-mouse-face-prop) + beg + (or (next-single-property-change + beg gnus-mouse-face-prop nil end) + beg))) + (to + (if (= from end) + (- from 2) + (or (next-single-property-change + from gnus-mouse-face-prop nil end) + end)))) + ;; If no mouse-face prop on line we will have to = from = end, + ;; so we highlight the entire line instead. + (when (= (+ to 2) from) + (setq from beg) + (setq to end)) + (if gnus-newsgroup-selected-overlay + ;; Move old overlay. + (gnus-move-overlay + gnus-newsgroup-selected-overlay from to (current-buffer)) + ;; Create new overlay. + (gnus-overlay-put + (setq gnus-newsgroup-selected-overlay (gnus-make-overlay from to)) + 'face gnus-summary-selected-face)))))) + +;; New implementation by Christian Limpach . +(defun gnus-summary-highlight-line () + "Highlight current line according to `gnus-summary-highlight'." + (let* ((list gnus-summary-highlight) + (p (point)) + (end (progn (end-of-line) (point))) + ;; now find out where the line starts and leave point there. + (beg (progn (beginning-of-line) (point))) + (article (gnus-summary-article-number)) + (score (or (cdr (assq (or article gnus-current-article) + gnus-newsgroup-scored)) + gnus-summary-default-score 0)) + (mark (or (gnus-summary-article-mark) gnus-unread-mark)) + (inhibit-read-only t)) + ;; Eval the cars of the lists until we find a match. + (let ((default gnus-summary-default-score)) + (while (and list + (not (eval (caar list)))) + (setq list (cdr list)))) + (let ((face (cdar list))) + (unless (eq face (get-text-property beg 'face)) + (gnus-put-text-property + beg end 'face + (setq face (if (boundp face) (symbol-value face) face))) + (when gnus-summary-highlight-line-function + (funcall gnus-summary-highlight-line-function article face)))) + (goto-char p))) + +(defun gnus-update-read-articles (group unread) + "Update the list of read articles in GROUP." + (let* ((active (or gnus-newsgroup-active (gnus-active group))) + (entry (gnus-gethash group gnus-newsrc-hashtb)) + (info (nth 2 entry)) + (prev 1) + (unread (sort (copy-sequence unread) '<)) + read) + (if (or (not info) (not active)) + ;; There is no info on this group if it was, in fact, + ;; killed. Gnus stores no information on killed groups, so + ;; there's nothing to be done. + ;; One could store the information somewhere temporarily, + ;; perhaps... Hmmm... + () + ;; Remove any negative articles numbers. + (while (and unread (< (car unread) 0)) + (setq unread (cdr unread))) + ;; Remove any expired article numbers + (while (and unread (< (car unread) (car active))) + (setq unread (cdr unread))) + ;; Compute the ranges of read articles by looking at the list of + ;; unread articles. + (while unread + (when (/= (car unread) prev) + (push (if (= prev (1- (car unread))) prev + (cons prev (1- (car unread)))) + read)) + (setq prev (1+ (car unread))) + (setq unread (cdr unread))) + (when (<= prev (cdr active)) + (push (cons prev (cdr active)) read)) + (save-excursion + (set-buffer gnus-group-buffer) + (gnus-undo-register + `(progn + (gnus-info-set-marks ',info ',(gnus-info-marks info) t) + (gnus-info-set-read ',info ',(gnus-info-read info)) + (gnus-get-unread-articles-in-group ',info (gnus-active ,group)) + (gnus-group-update-group ,group t)))) + ;; Enter this list into the group info. + (gnus-info-set-read + info (if (> (length read) 1) (nreverse read) read)) + ;; Set the number of unread articles in gnus-newsrc-hashtb. + (gnus-get-unread-articles-in-group info (gnus-active group)) + t))) + +(provide 'gnus-sum) + +(run-hooks 'gnus-sum-load-hook) + +;;; gnus-sum.el ends here diff -r ad457d5f7d04 -r 0293115a14e9 lisp/gnus/gnus-topic.el --- a/lisp/gnus/gnus-topic.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/gnus/gnus-topic.el Mon Aug 13 08:49:20 2007 +0200 @@ -1,5 +1,5 @@ ;;; gnus-topic.el --- a folding minor mode for Gnus group buffers -;; Copyright (C) 1995,96 Free Software Foundation, Inc. +;; Copyright (C) 1995,96,97 Free Software Foundation, Inc. ;; Author: Ilja Weis ;; Lars Magne Ingebrigtsen @@ -27,15 +27,22 @@ ;;; Code: (require 'gnus) -(eval-when-compile (require 'cl)) +(require 'gnus-group) +(require 'gnus-start) + +(defgroup gnus-topic nil + "Group topics." + :group 'gnus-group) (defvar gnus-topic-mode nil "Minor mode for Gnus group buffers.") -(defvar gnus-topic-mode-hook nil - "Hook run in topic mode buffers.") +(defcustom gnus-topic-mode-hook nil + "Hook run in topic mode buffers." + :type 'hook + :group 'gnus-topic) -(defvar gnus-topic-line-format "%i[ %(%{%n%}%) -- %A ]%v\n" +(defcustom gnus-topic-line-format "%i[ %(%{%n%}%) -- %A ]%v\n" "Format of topic lines. It works along the same lines as a normal formatting string, with some simple extensions. @@ -46,10 +53,19 @@ %g Number of groups in the topic. %a Number of unread articles in the groups in the topic. %A Number of unread articles in the groups in the topic and its subtopics. -") +" + :type 'string + :group 'gnus-topic) -(defvar gnus-topic-indent-level 2 - "*How much each subtopic should be indented.") +(defcustom gnus-topic-indent-level 2 + "*How much each subtopic should be indented." + :type 'integer + :group 'gnus-topic) + +(defcustom gnus-topic-display-empty-topics t + "*If non-nil, display the topic lines even of topics that have no unread articles." + :type 'boolean + :group 'gnus-topic) ;; Internal variables. @@ -74,20 +90,20 @@ (defvar gnus-topic-line-format-spec nil) -;; Functions. +;;; Utility functions (defun gnus-group-topic-name () "The name of the topic on the current line." - (let ((topic (get-text-property (gnus-point-at-bol) 'gnus-topic))) + (let ((topic (get-text-property (point-at-bol) 'gnus-topic))) (and topic (symbol-name topic)))) (defun gnus-group-topic-level () "The level of the topic on the current line." - (get-text-property (gnus-point-at-bol) 'gnus-topic-level)) + (get-text-property (point-at-bol) 'gnus-topic-level)) (defun gnus-group-topic-unread () "The number of unread articles in topic on the current line." - (get-text-property (gnus-point-at-bol) 'gnus-topic-unread)) + (get-text-property (point-at-bol) 'gnus-topic-unread)) (defun gnus-topic-unread (topic) "Return the number of unread articles in TOPIC." @@ -96,118 +112,73 @@ (gnus-group-topic-unread))) 0)) -(defun gnus-topic-init-alist () - "Initialize the topic structures." - (setq gnus-topic-topology - (cons (list "Gnus" 'visible) - (mapcar (lambda (topic) - (list (list (car topic) 'visible))) - '(("misc"))))) - (setq gnus-topic-alist - (list (cons "misc" - (mapcar (lambda (info) (gnus-info-group info)) - (cdr gnus-newsrc-alist))) - (list "Gnus"))) - (gnus-topic-enter-dribble)) +(defun gnus-group-topic-p () + "Return non-nil if the current line is a topic." + (gnus-group-topic-name)) -(defun gnus-group-prepare-topics (level &optional all lowest regexp list-topic topic-level) - "List all newsgroups with unread articles of level LEVEL or lower, and -use the `gnus-group-topics' to sort the groups. -If ALL is non-nil, list groups that have no unread articles. -If LOWEST is non-nil, list all newsgroups of level LOWEST or higher." - (set-buffer gnus-group-buffer) - (let ((buffer-read-only nil) - (lowest (or lowest 1))) - - (setq gnus-topic-tallied-groups nil) +(defun gnus-topic-visible-p () + "Return non-nil if the current topic is visible." + (get-text-property (point-at-bol) 'gnus-topic-visible)) - (when (or (not gnus-topic-alist) - (not gnus-topology-checked-p)) - (gnus-topic-check-topology)) +(defun gnus-topic-articles-in-topic (entries) + (let ((total 0) + number) + (while entries + (when (numberp (setq number (car (pop entries)))) + (incf total number))) + total)) - (unless list-topic - (erase-buffer)) - - ;; List dead groups? - (when (and (>= level gnus-level-zombie) (<= lowest gnus-level-zombie)) - (gnus-group-prepare-flat-list-dead - (setq gnus-zombie-list (sort gnus-zombie-list 'string<)) - gnus-level-zombie ?Z - regexp)) - - (when (and (>= level gnus-level-killed) (<= lowest gnus-level-killed)) - (gnus-group-prepare-flat-list-dead - (setq gnus-killed-list (sort gnus-killed-list 'string<)) - gnus-level-killed ?K - regexp)) - - ;; Use topics. - (when (< lowest gnus-level-zombie) - (if list-topic - (let ((top (gnus-topic-find-topology list-topic))) - (gnus-topic-prepare-topic (cdr top) (car top) - (or topic-level level) all)) - (gnus-topic-prepare-topic gnus-topic-topology 0 - (or topic-level level) all)))) +(defun gnus-group-topic (group) + "Return the topic GROUP is a member of." + (let ((alist gnus-topic-alist) + out) + (while alist + (when (member group (cdar alist)) + (setq out (caar alist) + alist nil)) + (setq alist (cdr alist))) + out)) - (gnus-group-set-mode-line) - (setq gnus-group-list-mode (cons level all)) - (run-hooks 'gnus-group-prepare-hook)) +(defun gnus-group-parent-topic (group) + "Return the topic GROUP is member of by looking at the group buffer." + (save-excursion + (set-buffer gnus-group-buffer) + (if (gnus-group-goto-group group) + (gnus-current-topic) + (gnus-group-topic group)))) + +(defun gnus-topic-goto-topic (topic) + "Go to TOPIC." + (when topic + (gnus-goto-char (text-property-any (point-min) (point-max) + 'gnus-topic (intern topic))))) -(defun gnus-topic-prepare-topic (topicl level &optional list-level all silent) - "Insert TOPIC into the group buffer. -If SILENT, don't insert anything. Return the number of unread -articles in the topic and its subtopics." - (let* ((type (pop topicl)) - (entries (gnus-topic-find-groups (car type) list-level all)) - (visiblep (and (eq (nth 1 type) 'visible) (not silent))) - (gnus-group-indentation - (make-string (* gnus-topic-indent-level level) ? )) - (beg (progn (beginning-of-line) (point))) - (topicl (reverse topicl)) - (all-entries entries) - (unread 0) - (topic (car type)) - info entry end active) - ;; Insert any sub-topics. - (while topicl - (incf unread - (gnus-topic-prepare-topic - (pop topicl) (1+ level) list-level all - (not visiblep)))) - (setq end (point)) - (goto-char beg) - ;; Insert all the groups that belong in this topic. - (while (setq entry (pop entries)) - (when visiblep - (if (stringp entry) - ;; Dead groups. - (gnus-group-insert-group-line - entry (if (member entry gnus-zombie-list) 8 9) - nil (- (1+ (cdr (setq active (gnus-active entry)))) - (car active)) nil) - ;; Living groups. - (when (setq info (nth 2 entry)) - (gnus-group-insert-group-line - (gnus-info-group info) - (gnus-info-level info) (gnus-info-marks info) - (car entry) (gnus-info-method info))))) - (when (and (listp entry) - (numberp (car entry)) - (not (member (gnus-info-group (setq info (nth 2 entry))) - gnus-topic-tallied-groups))) - (push (gnus-info-group info) gnus-topic-tallied-groups) - (incf unread (car entry)))) - (goto-char beg) - ;; Insert the topic line. - (unless silent - (gnus-extent-start-open (point)) - (gnus-topic-insert-topic-line - (car type) visiblep - (not (eq (nth 2 type) 'hidden)) - level all-entries unread)) - (goto-char end) - unread)) +(defun gnus-current-topic () + "Return the name of the current topic." + (let ((result + (or (get-text-property (point) 'gnus-topic) + (save-excursion + (and (gnus-goto-char (previous-single-property-change + (point) 'gnus-topic)) + (get-text-property (max (1- (point)) (point-min)) + 'gnus-topic)))))) + (when result + (symbol-name result)))) + +(defun gnus-current-topics () + "Return a list of all current topics, lowest in hierarchy first." + (let ((topic (gnus-current-topic)) + topics) + (while topic + (push topic topics) + (setq topic (gnus-topic-parent-topic topic))) + (nreverse topics))) + +(defun gnus-group-active-topic-p () + "Say whether the current topic comes from the active topics." + (save-excursion + (beginning-of-line) + (get-text-property (point) 'gnus-active))) (defun gnus-topic-find-groups (topic &optional level all) "Return entries for all visible groups in TOPIC." @@ -217,19 +188,20 @@ (setq level (or level 7)) ;; We go through the newsrc to look for matches. (while groups - (setq entry (gnus-gethash (setq group (pop groups)) gnus-newsrc-hashtb) - info (nth 2 entry) - params (gnus-info-params info) - active (gnus-active group) - unread (or (car entry) - (and (not (equal group "dummy.group")) - active - (- (1+ (cdr active)) (car active)))) - clevel (or (gnus-info-level info) - (if (member group gnus-zombie-list) 8 9))) + (when (setq group (pop groups)) + (setq entry (gnus-gethash group gnus-newsrc-hashtb) + info (nth 2 entry) + params (gnus-info-params info) + active (gnus-active group) + unread (or (car entry) + (and (not (equal group "dummy.group")) + active + (- (1+ (cdr active)) (car active)))) + clevel (or (gnus-info-level info) + (if (member group gnus-zombie-list) 8 9)))) (and unread ; nil means that the group is dead. - (<= clevel level) + (<= clevel level) (>= clevel lowest) ; Is inside the level we want. (or all (if (eq unread t) @@ -247,72 +219,6 @@ (push (or entry group) visible-groups))) (nreverse visible-groups))) -(defun gnus-topic-remove-topic (&optional insert total-remove hide in-level) - "Remove the current topic." - (let ((topic (gnus-group-topic-name)) - (level (gnus-group-topic-level)) - (beg (progn (beginning-of-line) (point))) - buffer-read-only) - (when topic - (while (and (zerop (forward-line 1)) - (> (or (gnus-group-topic-level) (1+ level)) level))) - (delete-region beg (point)) - (setcar (cdadr (gnus-topic-find-topology topic)) - (if insert 'visible 'invisible)) - (when hide - (setcdr (cdadr (gnus-topic-find-topology topic)) - (list hide))) - (unless total-remove - (gnus-topic-insert-topic topic in-level))))) - -(defun gnus-topic-insert-topic (topic &optional level) - "Insert TOPIC." - (gnus-group-prepare-topics - (car gnus-group-list-mode) (cdr gnus-group-list-mode) - nil nil topic level)) - -(defun gnus-topic-fold (&optional insert) - "Remove/insert the current topic." - (let ((topic (gnus-group-topic-name))) - (when topic - (save-excursion - (if (not (gnus-group-active-topic-p)) - (gnus-topic-remove-topic - (or insert (not (gnus-topic-visible-p)))) - (let ((gnus-topic-topology gnus-topic-active-topology) - (gnus-topic-alist gnus-topic-active-alist) - (gnus-group-list-mode (cons 5 t))) - (gnus-topic-remove-topic - (or insert (not (gnus-topic-visible-p))) nil nil 9))))))) - -(defun gnus-group-topic-p () - "Return non-nil if the current line is a topic." - (gnus-group-topic-name)) - -(defun gnus-topic-visible-p () - "Return non-nil if the current topic is visible." - (get-text-property (gnus-point-at-bol) 'gnus-topic-visible)) - -(defun gnus-topic-insert-topic-line (name visiblep shownp level entries - &optional unread) - (let* ((visible (if visiblep "" "...")) - (indentation (make-string (* gnus-topic-indent-level level) ? )) - (total-number-of-articles unread) - (number-of-groups (length entries)) - (active-topic (eq gnus-topic-alist gnus-topic-active-alist))) - (beginning-of-line) - ;; Insert the text. - (gnus-add-text-properties - (point) - (prog1 (1+ (point)) - (eval gnus-topic-line-format-spec) - (gnus-topic-remove-excess-properties)1) - (list 'gnus-topic (intern name) - 'gnus-topic-level level - 'gnus-topic-unread unread - 'gnus-active active-topic - 'gnus-topic-visible visiblep)))) - (defun gnus-topic-previous-topic (topic) "Return the previous topic on the same level as TOPIC." (let ((top (cddr (gnus-topic-find-topology @@ -337,8 +243,7 @@ (defun gnus-topic-next-topic (topic &optional previous) "Return the next sibling of TOPIC." - (let ((topology gnus-topic-topology) - (parentt (cddr (gnus-topic-find-topology + (let ((parentt (cddr (gnus-topic-find-topology (gnus-topic-parent-topic topic)))) prev) (while (and parentt @@ -369,6 +274,334 @@ (setq topology (cdr topology))) result))) +(defvar gnus-tmp-topics nil) +(defun gnus-topic-list (&optional topology) + "Return a list of all topics in the topology." + (unless topology + (setq topology gnus-topic-topology + gnus-tmp-topics nil)) + (push (caar topology) gnus-tmp-topics) + (mapcar 'gnus-topic-list (cdr topology)) + gnus-tmp-topics) + +;;; Topic parameter jazz + +(defun gnus-topic-parameters (topic) + "Return the parameters for TOPIC." + (let ((top (gnus-topic-find-topology topic))) + (when top + (nth 3 (cadr top))))) + +(defun gnus-topic-set-parameters (topic parameters) + "Set the topic parameters of TOPIC to PARAMETERS." + (let ((top (gnus-topic-find-topology topic))) + (unless top + (error "No such topic: %s" topic)) + ;; We may have to extend if there is no parameters here + ;; to begin with. + (unless (nthcdr 2 (cadr top)) + (nconc (cadr top) (list nil))) + (unless (nthcdr 3 (cadr top)) + (nconc (cadr top) (list nil))) + (setcar (nthcdr 3 (cadr top)) parameters) + (gnus-dribble-enter + (format "(gnus-topic-set-parameters %S '%S)" topic parameters)))) + +(defun gnus-group-topic-parameters (group) + "Compute the group parameters for GROUP taking into account inheritance from topics." + (let ((params-list (list (gnus-group-get-parameter group))) + topics params param out) + (save-excursion + (gnus-group-goto-group group) + (setq topics (gnus-current-topics)) + (while topics + (push (gnus-topic-parameters (pop topics)) params-list)) + ;; We probably have lots of nil elements here, so + ;; we remove them. Probably faster than doing this "properly". + (setq params-list (delq nil params-list)) + ;; Now we have all the parameters, so we go through them + ;; and do inheritance in the obvious way. + (while (setq params (pop params-list)) + (while (setq param (pop params)) + (when (atom param) + (setq param (cons param t))) + ;; Override any old versions of this param. + (setq out (delq (assq (car param) out) out)) + (push param out))) + ;; Return the resulting parameter list. + out))) + +;;; General utility functions + +(defun gnus-topic-enter-dribble () + (gnus-dribble-enter + (format "(setq gnus-topic-topology '%S)" gnus-topic-topology))) + +;;; Generating group buffers + +(defun gnus-group-prepare-topics (level &optional all lowest regexp list-topic topic-level) + "List all newsgroups with unread articles of level LEVEL or lower, and +use the `gnus-group-topics' to sort the groups. +If ALL is non-nil, list groups that have no unread articles. +If LOWEST is non-nil, list all newsgroups of level LOWEST or higher." + (set-buffer gnus-group-buffer) + (let ((buffer-read-only nil) + (lowest (or lowest 1))) + + (setq gnus-topic-tallied-groups nil) + + (when (or (not gnus-topic-alist) + (not gnus-topology-checked-p)) + (gnus-topic-check-topology)) + + (unless list-topic + (erase-buffer)) + + ;; List dead groups? + (when (and (>= level gnus-level-zombie) (<= lowest gnus-level-zombie)) + (gnus-group-prepare-flat-list-dead + (setq gnus-zombie-list (sort gnus-zombie-list 'string<)) + gnus-level-zombie ?Z + regexp)) + + (when (and (>= level gnus-level-killed) (<= lowest gnus-level-killed)) + (gnus-group-prepare-flat-list-dead + (setq gnus-killed-list (sort gnus-killed-list 'string<)) + gnus-level-killed ?K + regexp)) + + ;; Use topics. + (prog1 + (when (< lowest gnus-level-zombie) + (if list-topic + (let ((top (gnus-topic-find-topology list-topic))) + (gnus-topic-prepare-topic (cdr top) (car top) + (or topic-level level) all)) + (gnus-topic-prepare-topic gnus-topic-topology 0 + (or topic-level level) all))) + + (gnus-group-set-mode-line) + (setq gnus-group-list-mode (cons level all)) + (run-hooks 'gnus-group-prepare-hook)))) + +(defun gnus-topic-prepare-topic (topicl level &optional list-level all silent) + "Insert TOPIC into the group buffer. +If SILENT, don't insert anything. Return the number of unread +articles in the topic and its subtopics." + (let* ((type (pop topicl)) + (entries (gnus-topic-find-groups (car type) list-level all)) + (visiblep (and (eq (nth 1 type) 'visible) (not silent))) + (gnus-group-indentation + (make-string (* gnus-topic-indent-level level) ? )) + (beg (progn (beginning-of-line) (point))) + (topicl (reverse topicl)) + (all-entries entries) + (point-max (point-max)) + (unread 0) + (topic (car type)) + info entry end active) + ;; Insert any sub-topics. + (while topicl + (incf unread + (gnus-topic-prepare-topic + (pop topicl) (1+ level) list-level all + (not visiblep)))) + (setq end (point)) + (goto-char beg) + ;; Insert all the groups that belong in this topic. + (while (setq entry (pop entries)) + (when visiblep + (if (stringp entry) + ;; Dead groups. + (gnus-group-insert-group-line + entry (if (member entry gnus-zombie-list) 8 9) + nil (- (1+ (cdr (setq active (gnus-active entry)))) + (car active)) + nil) + ;; Living groups. + (when (setq info (nth 2 entry)) + (gnus-group-insert-group-line + (gnus-info-group info) + (gnus-info-level info) (gnus-info-marks info) + (car entry) (gnus-info-method info))))) + (when (and (listp entry) + (numberp (car entry)) + (not (member (gnus-info-group (setq info (nth 2 entry))) + gnus-topic-tallied-groups))) + (push (gnus-info-group info) gnus-topic-tallied-groups) + (incf unread (car entry)))) + (goto-char beg) + ;; Insert the topic line. + (when (and (not silent) + (or gnus-topic-display-empty-topics + (not (zerop unread)) + (/= point-max (point-max)))) + (gnus-extent-start-open (point)) + (gnus-topic-insert-topic-line + (car type) visiblep + (not (eq (nth 2 type) 'hidden)) + level all-entries unread)) + (goto-char end) + unread)) + +(defun gnus-topic-remove-topic (&optional insert total-remove hide in-level) + "Remove the current topic." + (let ((topic (gnus-group-topic-name)) + (level (gnus-group-topic-level)) + (beg (progn (beginning-of-line) (point))) + buffer-read-only) + (when topic + (while (and (zerop (forward-line 1)) + (> (or (gnus-group-topic-level) (1+ level)) level))) + (delete-region beg (point)) + ;; Do the change in this rather odd manner because it has been + ;; reported that some topics share parts of some lists, for some + ;; reason. I have been unable to determine why this is the + ;; case, but this hack seems to take care of things. + (let ((data (cadr (gnus-topic-find-topology topic)))) + (setcdr data + (list (if insert 'visible 'invisible) + (if hide 'hide nil) + (cadddr data)))) + (if total-remove + (setq gnus-topic-alist + (delq (assoc topic gnus-topic-alist) gnus-topic-alist)) + (gnus-topic-insert-topic topic in-level))))) + +(defun gnus-topic-insert-topic (topic &optional level) + "Insert TOPIC." + (gnus-group-prepare-topics + (car gnus-group-list-mode) (cdr gnus-group-list-mode) + nil nil topic level)) + +(defun gnus-topic-fold (&optional insert) + "Remove/insert the current topic." + (let ((topic (gnus-group-topic-name))) + (when topic + (save-excursion + (if (not (gnus-group-active-topic-p)) + (gnus-topic-remove-topic + (or insert (not (gnus-topic-visible-p)))) + (let ((gnus-topic-topology gnus-topic-active-topology) + (gnus-topic-alist gnus-topic-active-alist) + (gnus-group-list-mode (cons 5 t))) + (gnus-topic-remove-topic + (or insert (not (gnus-topic-visible-p))) nil nil 9))))))) + +(defun gnus-topic-insert-topic-line (name visiblep shownp level entries + &optional unread) + (let* ((visible (if visiblep "" "...")) + (indentation (make-string (* gnus-topic-indent-level level) ? )) + (total-number-of-articles unread) + (number-of-groups (length entries)) + (active-topic (eq gnus-topic-alist gnus-topic-active-alist))) + (beginning-of-line) + ;; Insert the text. + (gnus-add-text-properties + (point) + (prog1 (1+ (point)) + (eval gnus-topic-line-format-spec) + (gnus-topic-remove-excess-properties)1) + (list 'gnus-topic (intern name) + 'gnus-topic-level level + 'gnus-topic-unread unread + 'gnus-active active-topic + 'gnus-topic-visible visiblep)))) + +(defun gnus-topic-update-topics-containing-group (group) + "Update all topics that have GROUP as a member." + (when (and (eq major-mode 'gnus-group-mode) + gnus-topic-mode) + (save-excursion + (let ((alist gnus-topic-alist)) + ;; This is probably not entirely correct. If a topic + ;; isn't shown, then it's not updated. But the updating + ;; should be performed in any case, since the topic's + ;; parent should be updated. Pfft. + (while alist + (when (and (member group (cdar alist)) + (gnus-topic-goto-topic (caar alist))) + (gnus-topic-update-topic-line (caar alist))) + (pop alist)))))) + +(defun gnus-topic-update-topic () + "Update all parent topics to the current group." + (when (and (eq major-mode 'gnus-group-mode) + gnus-topic-mode) + (let ((group (gnus-group-group-name)) + (buffer-read-only nil)) + (when (and group + (gnus-get-info group) + (gnus-topic-goto-topic (gnus-current-topic))) + (gnus-topic-update-topic-line (gnus-group-topic-name)) + (gnus-group-goto-group group) + (gnus-group-position-point))))) + +(defun gnus-topic-goto-missing-group (group) + "Place point where GROUP is supposed to be inserted." + (let* ((topic (gnus-group-topic group)) + (groups (cdr (assoc topic gnus-topic-alist))) + (g (cdr (member group groups))) + (unfound t)) + ;; Try to jump to a visible group. + (while (and g (not (gnus-group-goto-group (car g) t))) + (pop g)) + ;; It wasn't visible, so we try to see where to insert it. + (when (not g) + (setq g (cdr (member group (reverse groups)))) + (while (and g unfound) + (when (gnus-group-goto-group (pop g) t) + (forward-line 1) + (setq unfound nil))) + (when unfound + (gnus-topic-goto-topic topic) + (forward-line 1))))) + +(defun gnus-topic-update-topic-line (topic-name &optional reads) + (let* ((top (gnus-topic-find-topology topic-name)) + (type (cadr top)) + (children (cddr top)) + (entries (gnus-topic-find-groups + (car type) (car gnus-group-list-mode) + (cdr gnus-group-list-mode))) + (parent (gnus-topic-parent-topic topic-name)) + (all-entries entries) + (unread 0) + old-unread entry) + (when (gnus-topic-goto-topic (car type)) + ;; Tally all the groups that belong in this topic. + (if reads + (setq unread (- (gnus-group-topic-unread) reads)) + (while children + (incf unread (gnus-topic-unread (caar (pop children))))) + (while (setq entry (pop entries)) + (when (numberp (car entry)) + (incf unread (car entry))))) + (setq old-unread (gnus-group-topic-unread)) + ;; Insert the topic line. + (gnus-topic-insert-topic-line + (car type) (gnus-topic-visible-p) + (not (eq (nth 2 type) 'hidden)) + (gnus-group-topic-level) all-entries unread) + (gnus-delete-line)) + (when parent + (forward-line -1) + (gnus-topic-update-topic-line + parent (- old-unread (gnus-group-topic-unread)))) + unread)) + +(defun gnus-topic-group-indentation () + (make-string + (* gnus-topic-indent-level + (or (save-excursion + (forward-line -1) + (gnus-topic-goto-topic (gnus-current-topic)) + (gnus-group-topic-level)) + 0)) + ? )) + +;;; Initialization + (gnus-add-shutdown 'gnus-topic-close 'gnus) (defun gnus-topic-close () @@ -378,8 +611,7 @@ gnus-topic-tallied-groups nil gnus-topology-checked-p nil)) - -(defun gnus-topic-check-topology () +(defun gnus-topic-check-topology () ;; The first time we set the topology to whatever we have ;; gotten here, which can be rather random. (unless gnus-topic-alist @@ -424,120 +656,122 @@ (setq topic (cdr topic)) (setcdr topic (cddr topic))))))) -(defvar gnus-tmp-topics nil) -(defun gnus-topic-list (&optional topology) - (unless topology - (setq topology gnus-topic-topology - gnus-tmp-topics nil)) - (push (caar topology) gnus-tmp-topics) - (mapcar 'gnus-topic-list (cdr topology)) - gnus-tmp-topics) +(defun gnus-topic-init-alist () + "Initialize the topic structures." + (setq gnus-topic-topology + (cons (list "Gnus" 'visible) + (mapcar (lambda (topic) + (list (list (car topic) 'visible))) + '(("misc"))))) + (setq gnus-topic-alist + (list (cons "misc" + (mapcar (lambda (info) (gnus-info-group info)) + (cdr gnus-newsrc-alist))) + (list "Gnus"))) + (gnus-topic-enter-dribble)) -(defun gnus-topic-enter-dribble () - (gnus-dribble-enter - (format "(setq gnus-topic-topology '%S)" gnus-topic-topology))) +;;; Maintenance -(defun gnus-topic-articles-in-topic (entries) - (let ((total 0) - number) - (while entries - (when (numberp (setq number (car (pop entries)))) - (incf total number))) - total)) - -(defun gnus-group-topic (group) - "Return the topic GROUP is a member of." - (let ((alist gnus-topic-alist) - out) - (while alist - (when (member group (cdar alist)) - (setq out (caar alist) - alist nil)) - (setq alist (cdr alist))) - out)) - -(defun gnus-topic-goto-topic (topic) - "Go to TOPIC." - (when topic - (gnus-goto-char (text-property-any (point-min) (point-max) - 'gnus-topic (intern topic))))) +(defun gnus-topic-clean-alist () + "Remove bogus groups from the topic alist." + (let ((topic-alist gnus-topic-alist) + result topic) + (unless gnus-killed-hashtb + (gnus-make-hashtable-from-killed)) + (while (setq topic (pop topic-alist)) + (let ((topic-name (pop topic)) + group filtered-topic) + (while (setq group (pop topic)) + (when (and (or (gnus-gethash group gnus-active-hashtb) + (gnus-info-method (gnus-get-info group))) + (not (gnus-gethash group gnus-killed-hashtb))) + (push group filtered-topic))) + (push (cons topic-name (nreverse filtered-topic)) result))) + (setq gnus-topic-alist (nreverse result)))) -(defun gnus-group-parent-topic () - "Return the name of the current topic." - (let ((result - (or (get-text-property (point) 'gnus-topic) - (save-excursion - (and (gnus-goto-char (previous-single-property-change - (point) 'gnus-topic)) - (get-text-property (max (1- (point)) (point-min)) - 'gnus-topic)))))) - (when result - (symbol-name result)))) - -(defun gnus-topic-update-topic () - "Update all parent topics to the current group." - (when (and (eq major-mode 'gnus-group-mode) - gnus-topic-mode) - (let ((group (gnus-group-group-name)) - (buffer-read-only nil)) - (when (and group (gnus-get-info group) - (gnus-topic-goto-topic (gnus-group-parent-topic))) - (gnus-topic-update-topic-line (gnus-group-topic-name)) - (gnus-group-goto-group group) - (gnus-group-position-point))))) +(defun gnus-topic-change-level (group level oldlevel) + "Run when changing levels to enter/remove groups from topics." + (save-excursion + (set-buffer gnus-group-buffer) + (when (and gnus-topic-mode + gnus-topic-alist + (not gnus-topic-inhibit-change-level)) + ;; Remove the group from the topics. + (when (and (< oldlevel gnus-level-zombie) + (>= level gnus-level-zombie)) + (let (alist) + (forward-line -1) + (when (setq alist (assoc (gnus-current-topic) gnus-topic-alist)) + (setcdr alist (gnus-delete-first group (cdr alist)))))) + ;; If the group is subscribed we enter it into the topics. + (when (and (< level gnus-level-zombie) + (>= oldlevel gnus-level-zombie)) + (let* ((prev (gnus-group-group-name)) + (gnus-topic-inhibit-change-level t) + (gnus-group-indentation + (make-string + (* gnus-topic-indent-level + (or (save-excursion + (gnus-topic-goto-topic (gnus-current-topic)) + (gnus-group-topic-level)) + 0)) + ? )) + (yanked (list group)) + alist talist end) + ;; Then we enter the yanked groups into the topics they belong + ;; to. + (when (setq alist (assoc (save-excursion + (forward-line -1) + (or + (gnus-current-topic) + (caar gnus-topic-topology))) + gnus-topic-alist)) + (setq talist alist) + (when (stringp yanked) + (setq yanked (list yanked))) + (if (not prev) + (nconc alist yanked) + (if (not (cdr alist)) + (setcdr alist (nconc yanked (cdr alist))) + (while (and (not end) (cdr alist)) + (when (equal (cadr alist) prev) + (setcdr alist (nconc yanked (cdr alist))) + (setq end t)) + (setq alist (cdr alist))) + (unless end + (nconc talist yanked)))))) + (gnus-topic-update-topic))))) -(defun gnus-topic-goto-missing-group (group) - "Place point where GROUP is supposed to be inserted." - (let* ((topic (gnus-group-topic group)) - (groups (cdr (assoc topic gnus-topic-alist))) - (g (cdr (member group groups))) - (unfound t)) - (while (and g unfound) - (when (gnus-group-goto-group (pop g)) - (beginning-of-line) - (setq unfound nil))) - (when unfound - (setq g (cdr (member group (reverse groups)))) - (while (and g unfound) - (when (gnus-group-goto-group (pop g)) - (forward-line 1) - (setq unfound nil))) - (when unfound - (gnus-topic-goto-topic topic) - (forward-line 1))))) +(defun gnus-topic-goto-next-group (group props) + "Go to group or the next group after group." + (if (not group) + (if (not (memq 'gnus-topic props)) + (goto-char (point-max)) + (gnus-topic-goto-topic (symbol-name (cadr (memq 'gnus-topic props))))) + (if (gnus-group-goto-group group) + t + ;; The group is no longer visible. + (let* ((list (assoc (gnus-group-topic group) gnus-topic-alist)) + (after (cdr (member group (cdr list))))) + ;; First try to put point on a group after the current one. + (while (and after + (not (gnus-group-goto-group (car after)))) + (setq after (cdr after))) + ;; Then try to put point on a group before point. + (unless after + (setq after (cdr (member group (reverse (cdr list))))) + (while (and after + (not (gnus-group-goto-group (car after)))) + (setq after (cdr after)))) + ;; Finally, just put point on the topic. + (if (not (car list)) + (goto-char (point-min)) + (unless after + (gnus-topic-goto-topic (car list)) + (setq after nil))) + t)))) -(defun gnus-topic-update-topic-line (topic-name &optional reads) - (let* ((top (gnus-topic-find-topology topic-name)) - (type (cadr top)) - (children (cddr top)) - (entries (gnus-topic-find-groups - (car type) (car gnus-group-list-mode) - (cdr gnus-group-list-mode))) - (parent (gnus-topic-parent-topic topic-name)) - (all-entries entries) - (unread 0) - old-unread entry) - (when (gnus-topic-goto-topic (car type)) - ;; Tally all the groups that belong in this topic. - (if reads - (setq unread (- (gnus-group-topic-unread) reads)) - (while children - (incf unread (gnus-topic-unread (caar (pop children))))) - (while (setq entry (pop entries)) - (when (numberp (car entry)) - (incf unread (car entry))))) - (setq old-unread (gnus-group-topic-unread)) - ;; Insert the topic line. - (gnus-topic-insert-topic-line - (car type) (gnus-topic-visible-p) - (not (eq (nth 2 type) 'hidden)) - (gnus-group-topic-level) all-entries unread) - (gnus-delete-line)) - (when parent - (forward-line -1) - (gnus-topic-update-topic-line - parent (- old-unread (gnus-group-topic-unread)))) - unread)) +;;; Topic-active functions (defun gnus-topic-grok-active (&optional force) "Parse all active groups and create topic structures for them." @@ -589,12 +823,6 @@ ;; to this topic. groups)) -(defun gnus-group-active-topic-p () - "Return whether the current active comes from the active topics." - (save-excursion - (beginning-of-line) - (get-text-property (point) 'gnus-active))) - ;;; Topic mode, commands and keymap. (defvar gnus-topic-mode-map nil) @@ -604,34 +832,44 @@ (setq gnus-topic-mode-map (make-sparse-keymap)) ;; Override certain group mode keys. - (gnus-define-keys - gnus-topic-mode-map - "=" gnus-topic-select-group - "\r" gnus-topic-select-group - " " gnus-topic-read-group - "\C-k" gnus-topic-kill-group - "\C-y" gnus-topic-yank-group - "\M-g" gnus-topic-get-new-news-this-topic - "AT" gnus-topic-list-active - gnus-mouse-2 gnus-mouse-pick-topic) + (gnus-define-keys gnus-topic-mode-map + "=" gnus-topic-select-group + "\r" gnus-topic-select-group + " " gnus-topic-read-group + "\C-k" gnus-topic-kill-group + "\C-y" gnus-topic-yank-group + "\M-g" gnus-topic-get-new-news-this-topic + "AT" gnus-topic-list-active + "Gp" gnus-topic-edit-parameters + "#" gnus-topic-mark-topic + "\M-#" gnus-topic-unmark-topic + gnus-mouse-2 gnus-mouse-pick-topic) ;; Define a new submap. - (gnus-define-keys - (gnus-group-topic-map "T" gnus-group-mode-map) - "#" gnus-topic-mark-topic - "\M-#" gnus-topic-unmark-topic - "n" gnus-topic-create-topic - "m" gnus-topic-move-group - "D" gnus-topic-remove-group - "c" gnus-topic-copy-group - "h" gnus-topic-hide-topic - "s" gnus-topic-show-topic - "M" gnus-topic-move-matching - "C" gnus-topic-copy-matching - "\C-i" gnus-topic-indent - [tab] gnus-topic-indent - "r" gnus-topic-rename - "\177" gnus-topic-delete)) + (gnus-define-keys (gnus-group-topic-map "T" gnus-group-mode-map) + "#" gnus-topic-mark-topic + "\M-#" gnus-topic-unmark-topic + "n" gnus-topic-create-topic + "m" gnus-topic-move-group + "D" gnus-topic-remove-group + "c" gnus-topic-copy-group + "h" gnus-topic-hide-topic + "s" gnus-topic-show-topic + "M" gnus-topic-move-matching + "C" gnus-topic-copy-matching + "\C-i" gnus-topic-indent + [tab] gnus-topic-indent + "r" gnus-topic-rename + "\177" gnus-topic-delete) + + (gnus-define-keys (gnus-topic-sort-map "S" gnus-group-topic-map) + "s" gnus-topic-sort-groups + "a" gnus-topic-sort-groups-by-alphabet + "u" gnus-topic-sort-groups-by-unread + "l" gnus-topic-sort-groups-by-level + "v" gnus-topic-sort-groups-by-score + "r" gnus-topic-sort-groups-by-rank + "m" gnus-topic-sort-groups-by-method)) (defun gnus-topic-make-menu-bar () (unless (boundp 'gnus-topic-menu) @@ -665,8 +903,7 @@ (> (prefix-numeric-value arg) 0))) ;; Infest Gnus with topics. (when gnus-topic-mode - (when (and menu-bar-mode - (gnus-visual-p 'topic-menu 'menu)) + (when (gnus-visual-p 'topic-menu 'menu) (gnus-topic-make-menu-bar)) (setq gnus-topic-line-format-spec (gnus-parse-format gnus-topic-line-format @@ -678,17 +915,20 @@ minor-mode-map-alist)) (add-hook 'gnus-summary-exit-hook 'gnus-topic-update-topic) (add-hook 'gnus-group-catchup-group-hook 'gnus-topic-update-topic) - (add-hook 'gnus-group-update-group-hook 'gnus-topic-update-topic) - (make-local-variable 'gnus-group-prepare-function) - (setq gnus-group-prepare-function 'gnus-group-prepare-topics) - (make-local-variable 'gnus-group-goto-next-group-function) - (setq gnus-group-goto-next-group-function - 'gnus-topic-goto-next-group) + (set (make-local-variable 'gnus-group-prepare-function) + 'gnus-group-prepare-topics) + (set (make-local-variable 'gnus-group-get-parameter-function) + 'gnus-group-topic-parameters) + (set (make-local-variable 'gnus-group-goto-next-group-function) + 'gnus-topic-goto-next-group) + (set (make-local-variable 'gnus-group-indentation-function) + 'gnus-topic-group-indentation) + (set (make-local-variable 'gnus-group-update-group-function) + 'gnus-topic-update-topics-containing-group) + (set (make-local-variable 'gnus-group-sort-alist-function) + 'gnus-group-sort-topic) (setq gnus-group-change-level-function 'gnus-topic-change-level) (setq gnus-goto-missing-group-function 'gnus-topic-goto-missing-group) - (make-local-variable 'gnus-group-indentation-function) - (setq gnus-group-indentation-function - 'gnus-topic-group-indentation) (gnus-make-local-hook 'gnus-check-bogus-groups-hook) (add-hook 'gnus-check-bogus-groups-hook 'gnus-topic-clean-alist) (setq gnus-topology-checked-p nil) @@ -702,7 +942,8 @@ (remove-hook 'gnus-group-change-level-function 'gnus-topic-change-level) (remove-hook 'gnus-check-bogus-groups-hook 'gnus-topic-clean-alist) - (setq gnus-group-prepare-function 'gnus-group-prepare-flat)) + (setq gnus-group-prepare-function 'gnus-group-prepare-flat) + (setq gnus-group-sort-alist-function 'gnus-group-sort-flat)) (when redisplay (gnus-group-list-groups)))) @@ -746,10 +987,10 @@ (interactive (list (read-string "New topic: ") - (gnus-group-parent-topic))) + (gnus-current-topic))) ;; Check whether this topic already exists. (when (gnus-topic-find-topology topic) - (error "Topic aleady exists")) + (error "Topic already exists")) (unless parent (setq parent (caar gnus-topic-topology))) (let ((top (cdr (gnus-topic-find-topology parent))) @@ -777,30 +1018,36 @@ (completing-read "Move to topic: " gnus-topic-alist nil t))) (let ((groups (gnus-group-process-prefix n)) (topicl (assoc topic gnus-topic-alist)) + (start-group (progn (forward-line 1) (gnus-group-group-name))) + (start-topic (gnus-group-topic-name)) entry) - (mapcar (lambda (g) - (gnus-group-remove-mark g) - (when (and - (setq entry (assoc (gnus-group-parent-topic) - gnus-topic-alist)) - (not copyp)) - (setcdr entry (gnus-delete-first g (cdr entry)))) - (nconc topicl (list g))) - groups) - (gnus-group-position-point)) - (gnus-topic-enter-dribble) - (gnus-group-list-groups)) + (mapcar + (lambda (g) + (gnus-group-remove-mark g) + (when (and + (setq entry (assoc (gnus-current-topic) gnus-topic-alist)) + (not copyp)) + (setcdr entry (gnus-delete-first g (cdr entry)))) + (nconc topicl (list g))) + groups) + (gnus-topic-enter-dribble) + (if start-group + (gnus-group-goto-group start-group) + (gnus-topic-goto-topic start-topic)) + (gnus-group-list-groups))) -(defun gnus-topic-remove-group () +(defun gnus-topic-remove-group (&optional arg) "Remove the current group from the topic." - (interactive) - (let ((topicl (assoc (gnus-group-parent-topic) gnus-topic-alist)) - (group (gnus-group-group-name)) - (buffer-read-only nil)) - (when (and topicl group) - (gnus-delete-line) - (gnus-delete-first group topicl)) - (gnus-group-position-point))) + (interactive "P") + (gnus-group-iterate arg + (lambda (group) + (let ((topicl (assoc (gnus-current-topic) gnus-topic-alist)) + (buffer-read-only nil)) + (when (and topicl group) + (gnus-delete-line) + (gnus-delete-first group topicl)) + (gnus-topic-update-topic) + (gnus-group-position-point))))) (defun gnus-topic-copy-group (n topic) "Copy the current group to a topic." @@ -809,113 +1056,18 @@ (completing-read "Copy to topic: " gnus-topic-alist nil t))) (gnus-topic-move-group n topic t)) -(defun gnus-topic-group-indentation () - (make-string - (* gnus-topic-indent-level - (or (save-excursion - (gnus-topic-goto-topic (gnus-group-parent-topic)) - (gnus-group-topic-level)) 0)) ? )) - -(defun gnus-topic-clean-alist () - "Remove bogus groups from the topic alist." - (let ((topic-alist gnus-topic-alist) - result topic) - (unless gnus-killed-hashtb - (gnus-make-hashtable-from-killed)) - (while (setq topic (pop topic-alist)) - (let ((topic-name (pop topic)) - group filtered-topic) - (while (setq group (pop topic)) - (if (and (gnus-gethash group gnus-active-hashtb) - (not (gnus-gethash group gnus-killed-hashtb))) - (push group filtered-topic))) - (push (cons topic-name (nreverse filtered-topic)) result))) - (setq gnus-topic-alist (nreverse result)))) - -(defun gnus-topic-change-level (group level oldlevel) - "Run when changing levels to enter/remove groups from topics." - (save-excursion - (set-buffer gnus-group-buffer) - (when (and gnus-topic-mode - gnus-topic-alist - (not gnus-topic-inhibit-change-level)) - ;; Remove the group from the topics. - (when (and (< oldlevel gnus-level-zombie) - (>= level gnus-level-zombie)) - (let (alist) - (forward-line -1) - (when (setq alist (assoc (gnus-group-parent-topic) gnus-topic-alist)) - (setcdr alist (gnus-delete-first group (cdr alist)))))) - ;; If the group is subscribed. then we enter it into the topics. - (when (and (< level gnus-level-zombie) - (>= oldlevel gnus-level-zombie)) - (let* ((prev (gnus-group-group-name)) - (gnus-topic-inhibit-change-level t) - (gnus-group-indentation - (make-string - (* gnus-topic-indent-level - (or (save-excursion - (gnus-topic-goto-topic (gnus-group-parent-topic)) - (gnus-group-topic-level)) 0)) ? )) - (yanked (list group)) - alist talist end) - ;; Then we enter the yanked groups into the topics they belong - ;; to. - (when (setq alist (assoc (save-excursion - (forward-line -1) - (or - (gnus-group-parent-topic) - (caar gnus-topic-topology))) - gnus-topic-alist)) - (setq talist alist) - (when (stringp yanked) - (setq yanked (list yanked))) - (if (not prev) - (nconc alist yanked) - (if (not (cdr alist)) - (setcdr alist (nconc yanked (cdr alist))) - (while (and (not end) (cdr alist)) - (when (equal (cadr alist) prev) - (setcdr alist (nconc yanked (cdr alist))) - (setq end t)) - (setq alist (cdr alist))) - (unless end - (nconc talist yanked)))))) - (gnus-topic-update-topic))))) - -(defun gnus-topic-goto-next-group (group props) - "Go to group or the next group after group." - (if (null group) - (gnus-topic-goto-topic (symbol-name (cadr (memq 'gnus-topic props)))) - (if (gnus-group-goto-group group) - t - ;; The group is no longer visible. - (let* ((list (assoc (gnus-group-parent-topic) gnus-topic-alist)) - (after (cdr (member group (cdr list))))) - ;; First try to put point on a group after the current one. - (while (and after - (not (gnus-group-goto-group (car after)))) - (setq after (cdr after))) - ;; Then try to put point on a group before point. - (unless after - (setq after (cdr (member group (reverse (cdr list))))) - (while (and after - (not (gnus-group-goto-group (car after)))) - (setq after (cdr after)))) - ;; Finally, just put point on the topic. - (unless after - (gnus-topic-goto-topic (car list)) - (setq after nil)) - t)))) - (defun gnus-topic-kill-group (&optional n discard) "Kill the next N groups." (interactive "P") (if (gnus-group-topic-p) (let ((topic (gnus-group-topic-name))) + (push (cons + (gnus-topic-find-topology topic) + (assoc topic gnus-topic-alist)) + gnus-topic-killed-topics) (gnus-topic-remove-topic nil t) - (push (gnus-topic-find-topology topic nil nil gnus-topic-topology) - gnus-topic-killed-topics)) + (gnus-topic-find-topology topic nil nil gnus-topic-topology) + (gnus-topic-enter-dribble)) (gnus-group-kill-group n discard) (gnus-topic-update-topic))) @@ -923,13 +1075,17 @@ "Yank the last topic." (interactive "p") (if gnus-topic-killed-topics - (let ((previous - (or (gnus-group-topic-name) - (gnus-topic-next-topic (gnus-group-parent-topic)))) - (item (cdr (pop gnus-topic-killed-topics)))) + (let* ((previous + (or (gnus-group-topic-name) + (gnus-topic-next-topic (gnus-current-topic)))) + (data (pop gnus-topic-killed-topics)) + (alist (cdr data)) + (item (cdar data))) + (push alist gnus-topic-alist) (gnus-topic-create-topic (caar item) (gnus-topic-parent-topic previous) previous item) + (gnus-topic-enter-dribble) (gnus-topic-goto-topic (caar item))) (let* ((prev (gnus-group-group-name)) (gnus-topic-inhibit-change-level t) @@ -937,8 +1093,10 @@ (make-string (* gnus-topic-indent-level (or (save-excursion - (gnus-topic-goto-topic (gnus-group-parent-topic)) - (gnus-group-topic-level)) 0)) ? )) + (gnus-topic-goto-topic (gnus-current-topic)) + (gnus-group-topic-level)) + 0)) + ? )) yanked alist) ;; We first yank the groups the normal way... (setq yanked (gnus-group-yank-group arg)) @@ -946,7 +1104,7 @@ ;; to. (setq alist (assoc (save-excursion (forward-line -1) - (gnus-group-parent-topic)) + (gnus-current-topic)) gnus-topic-alist)) (when (stringp yanked) (setq yanked (list yanked))) @@ -964,8 +1122,8 @@ (defun gnus-topic-hide-topic () "Hide the current topic." (interactive) - (when (gnus-group-parent-topic) - (gnus-topic-goto-topic (gnus-group-parent-topic)) + (when (gnus-current-topic) + (gnus-topic-goto-topic (gnus-current-topic)) (gnus-topic-remove-topic nil nil 'hidden))) (defun gnus-topic-show-topic () @@ -976,17 +1134,21 @@ (defun gnus-topic-mark-topic (topic &optional unmark) "Mark all groups in the topic with the process mark." - (interactive (list (gnus-group-parent-topic))) - (save-excursion - (let ((groups (gnus-topic-find-groups topic 9 t))) - (while groups - (funcall (if unmark 'gnus-group-remove-mark 'gnus-group-set-mark) - (gnus-info-group (nth 2 (pop groups)))))))) + (interactive (list (gnus-group-topic-name))) + (if (not topic) + (call-interactively 'gnus-group-mark-group) + (save-excursion + (let ((groups (gnus-topic-find-groups topic 9 t))) + (while groups + (funcall (if unmark 'gnus-group-remove-mark 'gnus-group-set-mark) + (gnus-info-group (nth 2 (pop groups))))))))) (defun gnus-topic-unmark-topic (topic &optional unmark) "Remove the process mark from all groups in the topic." - (interactive (list (gnus-group-parent-topic))) - (gnus-topic-mark-topic topic t)) + (interactive (list (gnus-group-topic-name))) + (if (not topic) + (call-interactively 'gnus-group-unmark-group) + (gnus-topic-mark-topic topic t))) (defun gnus-topic-get-new-news-this-topic (&optional n) "Check for new news in the current topic." @@ -1037,7 +1199,7 @@ (defun gnus-topic-rename (old-name new-name) "Rename a topic." (interactive - (let ((topic (gnus-group-parent-topic))) + (let ((topic (gnus-current-topic))) (list topic (read-string (format "Rename %s to: " topic))))) (let ((top (gnus-topic-find-topology old-name)) @@ -1047,6 +1209,7 @@ (when entry (setcar entry new-name)) (forward-line -1) + (gnus-dribble-touch) (gnus-group-list-groups))) (defun gnus-topic-indent (&optional unindent) @@ -1055,22 +1218,25 @@ (interactive "P") (if unindent (gnus-topic-unindent) - (let* ((topic (gnus-group-parent-topic)) - (parent (gnus-topic-previous-topic topic))) + (let* ((topic (gnus-current-topic)) + (parent (gnus-topic-previous-topic topic)) + (buffer-read-only nil)) (unless parent (error "Nothing to indent %s into" topic)) (when topic (gnus-topic-goto-topic topic) (gnus-topic-kill-group) + (push (cdar gnus-topic-killed-topics) gnus-topic-alist) (gnus-topic-create-topic - topic parent nil (cdr (pop gnus-topic-killed-topics))) + topic parent nil (cdaar gnus-topic-killed-topics)) + (pop gnus-topic-killed-topics) (or (gnus-topic-goto-topic topic) (gnus-topic-goto-topic parent)))))) (defun gnus-topic-unindent () "Unindent a topic." (interactive) - (let* ((topic (gnus-group-parent-topic)) + (let* ((topic (gnus-current-topic)) (parent (gnus-topic-parent-topic topic)) (grandparent (gnus-topic-parent-topic parent))) (unless grandparent @@ -1078,9 +1244,11 @@ (when topic (gnus-topic-goto-topic topic) (gnus-topic-kill-group) + (push (cdar gnus-topic-killed-topics) gnus-topic-alist) (gnus-topic-create-topic topic grandparent (gnus-topic-next-topic parent) - (cdr (pop gnus-topic-killed-topics))) + (cdaar gnus-topic-killed-topics)) + (pop gnus-topic-killed-topics) (gnus-topic-goto-topic topic)))) (defun gnus-topic-list-active (&optional force) @@ -1095,6 +1263,95 @@ gnus-killed-list gnus-zombie-list) (gnus-group-list-groups 9 nil 1))) +;;; Topic sorting functions + +(defun gnus-topic-edit-parameters (group) + "Edit the group parameters of GROUP. +If performed on a topic, edit the topic parameters instead." + (interactive (list (gnus-group-group-name))) + (if group + (gnus-group-edit-group-parameters group) + (if (not (gnus-group-topic-p)) + (error "Nothing to edit on the current line.") + (let ((topic (gnus-group-topic-name))) + (gnus-edit-form + (gnus-topic-parameters topic) + "Editing the topic parameters." + `(lambda (form) + (gnus-topic-set-parameters ,topic form))))))) + +(defun gnus-group-sort-topic (func reverse) + "Sort groups in the topics according to FUNC and REVERSE." + (let ((alist gnus-topic-alist)) + (while alist + ;; !!!Sometimes nil elements sneak into the alist, + ;; for some reason or other. + (setcar alist (delq nil (car alist))) + (gnus-topic-sort-topic (pop alist) func reverse)))) + +(defun gnus-topic-sort-topic (topic func reverse) + ;; Each topic only lists the name of the group, while + ;; the sort predicates expect group infos as inputs. + ;; So we first transform the group names into infos, + ;; then sort, and then transform back into group names. + (setcdr + topic + (mapcar + (lambda (info) (gnus-info-group info)) + (sort + (mapcar + (lambda (group) (gnus-get-info group)) + (cdr topic)) + func))) + ;; Do the reversal, if necessary. + (when reverse + (setcdr topic (nreverse (cdr topic))))) + +(defun gnus-topic-sort-groups (func &optional reverse) + "Sort the current topic according to FUNC. +If REVERSE, reverse the sorting order." + (interactive (list gnus-group-sort-function current-prefix-arg)) + (let ((topic (assoc (gnus-current-topic) gnus-topic-alist))) + (gnus-topic-sort-topic + topic (gnus-make-sort-function func) reverse) + (gnus-group-list-groups))) + +(defun gnus-topic-sort-groups-by-alphabet (&optional reverse) + "Sort the current topic alphabetically by group name. +If REVERSE, sort in reverse order." + (interactive "P") + (gnus-topic-sort-groups 'gnus-group-sort-by-alphabet reverse)) + +(defun gnus-topic-sort-groups-by-unread (&optional reverse) + "Sort the current topic by number of unread articles. +If REVERSE, sort in reverse order." + (interactive "P") + (gnus-topic-sort-groups 'gnus-group-sort-by-unread reverse)) + +(defun gnus-topic-sort-groups-by-level (&optional reverse) + "Sort the current topic by group level. +If REVERSE, sort in reverse order." + (interactive "P") + (gnus-topic-sort-groups 'gnus-group-sort-by-level reverse)) + +(defun gnus-topic-sort-groups-by-score (&optional reverse) + "Sort the current topic by group score. +If REVERSE, sort in reverse order." + (interactive "P") + (gnus-topic-sort-groups 'gnus-group-sort-by-score reverse)) + +(defun gnus-topic-sort-groups-by-rank (&optional reverse) + "Sort the current topic by group rank. +If REVERSE, sort in reverse order." + (interactive "P") + (gnus-topic-sort-groups 'gnus-group-sort-by-rank reverse)) + +(defun gnus-topic-sort-groups-by-method (&optional reverse) + "Sort the current topic alphabetically by backend name. +If REVERSE, sort in reverse order." + (interactive "P") + (gnus-topic-sort-groups 'gnus-group-sort-by-method reverse)) + (provide 'gnus-topic) ;;; gnus-topic.el ends here diff -r ad457d5f7d04 -r 0293115a14e9 lisp/gnus/gnus-undo.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus/gnus-undo.el Mon Aug 13 08:49:20 2007 +0200 @@ -0,0 +1,168 @@ +;;; gnus-undo.el --- minor mode for undoing in Gnus +;; Copyright (C) 1996,97 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen +;; Keywords: news + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; This package allows arbitrary undoing in Gnus buffers. As all the +;; Gnus buffers aren't very text-oriented (what is in the buffers is +;; just some random representation of the actual data), normal Emacs +;; undoing doesn't work at all for Gnus. +;; +;; This package works by letting Gnus register functions for reversing +;; actions, and then calling these functions when the user pushes the +;; `undo' key. As with normal `undo', there it is possible to set +;; undo boundaries and so on. +;; +;; Internally, the undo sequence is represented by the +;; `gnus-undo-actions' list, where each element is a list of functions +;; to be called, in sequence, to undo some action. (An "action" is a +;; collection of functions.) +;; +;; For instance, a function for killing a group will call +;; `gnus-undo-register' with a function that un-kills the group. This +;; package will put that function into an action. + +;;; Code: + +(require 'gnus-util) +(require 'gnus) + +(defvar gnus-undo-mode nil + "Minor mode for undoing in Gnus buffers.") + +(defvar gnus-undo-mode-hook nil + "Hook called in all `gnus-undo-mode' buffers.") + +;;; Internal variables. + +(defvar gnus-undo-actions nil) +(defvar gnus-undo-boundary t) +(defvar gnus-undo-last nil) +(defvar gnus-undo-boundary-inhibit nil) + +;;; Minor mode definition. + +(defvar gnus-undo-mode-map nil) + +(unless gnus-undo-mode-map + (setq gnus-undo-mode-map (make-sparse-keymap)) + + (gnus-define-keys gnus-undo-mode-map + "\M-\C-_" gnus-undo)) + +(defun gnus-undo-make-menu-bar () + (when nil + (define-key-after (current-local-map) [menu-bar file gnus-undo] + (cons "Undo" 'gnus-undo-actions) + [menu-bar file whatever]))) + +(defun gnus-undo-mode (&optional arg) + "Minor mode for providing `undo' in Gnus buffers. + +\\{gnus-undo-mode-map}" + (interactive "P") + (set (make-local-variable 'gnus-undo-mode) + (if (null arg) (not gnus-undo-mode) + (> (prefix-numeric-value arg) 0))) + (set (make-local-variable 'gnus-undo-actions) nil) + (set (make-local-variable 'gnus-undo-boundary) t) + (when gnus-undo-mode + ;; Set up the menu. + (when (gnus-visual-p 'undo-menu 'menu) + (gnus-undo-make-menu-bar)) + ;; Don't display anything in the mode line -- too annoying. + ;;(unless (assq 'gnus-undo-mode minor-mode-alist) + ;; (push '(gnus-undo-mode " Undo") minor-mode-alist)) + (unless (assq 'gnus-undo-mode minor-mode-map-alist) + (push (cons 'gnus-undo-mode gnus-undo-mode-map) + minor-mode-map-alist)) + (gnus-make-local-hook 'post-command-hook) + (gnus-add-hook 'post-command-hook 'gnus-undo-boundary nil t) + (add-hook 'gnus-summary-exit-hook 'gnus-undo-boundary) + (run-hooks 'gnus-undo-mode-hook))) + +;;; Interface functions. + +(defun gnus-disable-undo (&optional buffer) + "Disable undoing in the current buffer." + (interactive) + (save-excursion + (when buffer + (set-buffer buffer)) + (gnus-undo-mode -1))) + +(defun gnus-undo-boundary () + "Set Gnus undo boundary." + (if gnus-undo-boundary-inhibit + (setq gnus-undo-boundary-inhibit nil) + (setq gnus-undo-boundary t))) + +(defun gnus-undo-register (form) + "Register FORMS as something to be performed to undo a change. +FORMS may use backtick quote syntax." + (when gnus-undo-mode + (gnus-undo-register-1 + `(lambda () + ,form)))) + +(put 'gnus-undo-register 'lisp-indent-function 0) +(put 'gnus-undo-register 'edebug-form-spec '(body)) + +(defun gnus-undo-register-1 (function) + "Register FUNCTION as something to be performed to undo a change." + (when gnus-undo-mode + (cond + ;; We are on a boundary, so we create a new action. + (gnus-undo-boundary + (push (list function) gnus-undo-actions) + (setq gnus-undo-boundary nil)) + ;; Prepend the function to an old action. + (gnus-undo-actions + (setcar gnus-undo-actions (cons function (car gnus-undo-actions)))) + ;; Initialize list. + (t + (setq gnus-undo-actions (list (list function))))) + (setq gnus-undo-boundary-inhibit t))) + +(defun gnus-undo (n) + "Undo some previous changes in Gnus buffers. +Repeat this command to undo more changes. +A numeric argument serves as a repeat count." + (interactive "p") + (unless gnus-undo-mode + (error "Undoing is not enabled in this buffer")) + (message "%s" last-command) + (when (or (not (eq last-command 'gnus-undo)) + (not gnus-undo-last)) + (setq gnus-undo-last gnus-undo-actions)) + (let ((action (pop gnus-undo-last))) + (unless action + (error "Nothing further to undo")) + (setq gnus-undo-actions (delq action gnus-undo-actions)) + (setq gnus-undo-boundary t) + (while action + (funcall (pop action))))) + +(provide 'gnus-undo) + +;;; gnus-undo.el ends here diff -r ad457d5f7d04 -r 0293115a14e9 lisp/gnus/gnus-util.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus/gnus-util.el Mon Aug 13 08:49:20 2007 +0200 @@ -0,0 +1,806 @@ +;;; gnus-util.el --- utility functions for Gnus +;; Copyright (C) 1996,97 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen +;; Keywords: news + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; Nothing in this file depends on any other parts of Gnus -- all +;; functions and macros in this file are utility functions that are +;; used by Gnus and may be used by any other package without loading +;; Gnus first. + +;;; Code: + +;(if (fboundp 'point-at-bol) +; (fset 'gnus-point-at-bol 'point-at-bol) +; (defsubst gnus-point-at-bol () +; "Return point at the beginning of the line." +; (let ((p (point))) +; (beginning-of-line) +; (prog1 +; (point) +; (goto-char p))))) + +;(if (fboundp 'point-at-eol) +; (fset 'gnus-point-at-eol 'point-at-eol) +; (defsubst gnus-point-at-eol () +; "Return point at the end of the line." +; (let ((p (point))) +; (end-of-line) +; (prog1 +; (point) +; (goto-char p))))) + +(require 'custom) +(require 'cl) +(require 'nnheader) +(require 'timezone) +(require 'message) + +(defun gnus-boundp (variable) + "Return non-nil if VARIABLE is bound and non-nil." + (and (boundp variable) + (symbol-value variable))) + +(defmacro gnus-eval-in-buffer-window (buffer &rest forms) + "Pop to BUFFER, evaluate FORMS, and then return to the original window." + (let ((tempvar (make-symbol "GnusStartBufferWindow")) + (w (make-symbol "w")) + (buf (make-symbol "buf"))) + `(let* ((,tempvar (selected-window)) + (,buf ,buffer) + (,w (get-buffer-window ,buf 'visible))) + (unwind-protect + (progn + (if ,w + (progn + (select-window ,w) + (set-buffer (window-buffer ,w))) + (pop-to-buffer ,buf)) + ,@forms) + (select-window ,tempvar))))) + +(put 'gnus-eval-in-buffer-window 'lisp-indent-function 1) +(put 'gnus-eval-in-buffer-window 'edebug-form-spec '(form body)) + +(defmacro gnus-intern-safe (string hashtable) + "Set hash value. Arguments are STRING, VALUE, and HASHTABLE." + `(let ((symbol (intern ,string ,hashtable))) + (or (boundp symbol) + (set symbol nil)) + symbol)) + +;; modified by MORIOKA Tomohiko +;; function `substring' might cut on a middle of multi-octet +;; character. +(defun gnus-truncate-string (str width) + (substring str 0 width)) + +;; Added by Geoffrey T. Dairiki . A safe way +;; to limit the length of a string. This function is necessary since +;; `(substr "abc" 0 30)' pukes with "Args out of range". +(defsubst gnus-limit-string (str width) + (if (> (length str) width) + (substring str 0 width) + str)) + +(defsubst gnus-functionp (form) + "Return non-nil if FORM is funcallable." + (or (and (symbolp form) (fboundp form)) + (and (listp form) (eq (car form) 'lambda)))) + +(defsubst gnus-goto-char (point) + (and point (goto-char point))) + +(defmacro gnus-buffer-exists-p (buffer) + `(let ((buffer ,buffer)) + (when buffer + (funcall (if (stringp buffer) 'get-buffer 'buffer-name) + buffer)))) + +(defmacro gnus-kill-buffer (buffer) + `(let ((buf ,buffer)) + (when (gnus-buffer-exists-p buf) + (kill-buffer buf)))) + +(defun gnus-delete-first (elt list) + "Delete by side effect the first occurrence of ELT as a member of LIST." + (if (equal (car list) elt) + (cdr list) + (let ((total list)) + (while (and (cdr list) + (not (equal (cadr list) elt))) + (setq list (cdr list))) + (when (cdr list) + (setcdr list (cddr list))) + total))) + +;; Delete the current line (and the next N lines). +(defmacro gnus-delete-line (&optional n) + `(delete-region (progn (beginning-of-line) (point)) + (progn (forward-line ,(or n 1)) (point)))) + +(defun gnus-byte-code (func) + "Return a form that can be `eval'ed based on FUNC." + (let ((fval (symbol-function func))) + (if (byte-code-function-p fval) + (let ((flist (append fval nil))) + (setcar flist 'byte-code) + flist) + (cons 'progn (cddr fval))))) + +(defun gnus-extract-address-components (from) + (let (name address) + ;; First find the address - the thing with the @ in it. This may + ;; not be accurate in mail addresses, but does the trick most of + ;; the time in news messages. + (when (string-match "\\b[^@ \t<>]+[!@][^@ \t<>]+\\b" from) + (setq address (substring from (match-beginning 0) (match-end 0)))) + ;; Then we check whether the "name
" format is used. + (and address + ;; Fix by MORIOKA Tomohiko + ;; Linear white space is not required. + (string-match (concat "[ \t]*<" (regexp-quote address) ">") from) + (and (setq name (substring from 0 (match-beginning 0))) + ;; Strip any quotes from the name. + (string-match "\".*\"" name) + (setq name (substring name 1 (1- (match-end 0)))))) + ;; If not, then "address (name)" is used. + (or name + (and (string-match "(.+)" from) + (setq name (substring from (1+ (match-beginning 0)) + (1- (match-end 0))))) + (and (string-match "()" from) + (setq name address)) + ;; Fix by MORIOKA Tomohiko . + ;; XOVER might not support folded From headers. + (and (string-match "(.*" from) + (setq name (substring from (1+ (match-beginning 0)) + (match-end 0))))) + ;; Fix by Hallvard B Furuseth . + (list (or name from) (or address from)))) + +(defun gnus-fetch-field (field) + "Return the value of the header FIELD of current article." + (save-excursion + (save-restriction + (let ((case-fold-search t) + (inhibit-point-motion-hooks t)) + (nnheader-narrow-to-headers) + (message-fetch-field field))))) + +(defun gnus-goto-colon () + (beginning-of-line) + (search-forward ":" (point-at-eol) t)) + +(defun gnus-remove-text-with-property (prop) + "Delete all text in the current buffer with text property PROP." + (save-excursion + (goto-char (point-min)) + (while (not (eobp)) + (while (get-text-property (point) prop) + (delete-char 1)) + (goto-char (next-single-property-change (point) prop nil (point-max)))))) + +(defun gnus-newsgroup-directory-form (newsgroup) + "Make hierarchical directory name from NEWSGROUP name." + (let ((newsgroup (gnus-newsgroup-savable-name newsgroup)) + (len (length newsgroup)) + idx) + ;; If this is a foreign group, we don't want to translate the + ;; entire name. + (if (setq idx (string-match ":" newsgroup)) + (aset newsgroup idx ?/) + (setq idx 0)) + ;; Replace all occurrences of `.' with `/'. + (while (< idx len) + (when (= (aref newsgroup idx) ?.) + (aset newsgroup idx ?/)) + (setq idx (1+ idx))) + newsgroup)) + +(defun gnus-newsgroup-savable-name (group) + ;; Replace any slashes in a group name (eg. an ange-ftp nndoc group) + ;; with dots. + (nnheader-replace-chars-in-string group ?/ ?.)) + +(defun gnus-string> (s1 s2) + (not (or (string< s1 s2) + (string= s1 s2)))) + +;;; Time functions. + +(defun gnus-days-between (date1 date2) + ;; Return the number of days between date1 and date2. + (- (gnus-day-number date1) (gnus-day-number date2))) + +(defun gnus-day-number (date) + (let ((dat (mapcar (lambda (s) (and s (string-to-int s)) ) + (timezone-parse-date date)))) + (timezone-absolute-from-gregorian + (nth 1 dat) (nth 2 dat) (car dat)))) + +(defun gnus-time-to-day (time) + "Convert TIME to day number." + (let ((tim (decode-time time))) + (timezone-absolute-from-gregorian + (nth 4 tim) (nth 3 tim) (nth 5 tim)))) + +(defun gnus-encode-date (date) + "Convert DATE to internal time." + (let* ((parse (timezone-parse-date date)) + (date (mapcar (lambda (d) (and d (string-to-int d))) parse)) + (time (mapcar 'string-to-int (timezone-parse-time (aref parse 3))))) + (encode-time (caddr time) (cadr time) (car time) + (caddr date) (cadr date) (car date) (nth 4 date)))) + +(defun gnus-time-minus (t1 t2) + "Subtract two internal times." + (let ((borrow (< (cadr t1) (cadr t2)))) + (list (- (car t1) (car t2) (if borrow 1 0)) + (- (+ (if borrow 65536 0) (cadr t1)) (cadr t2))))) + +(defun gnus-time-less (t1 t2) + "Say whether time T1 is less than time T2." + (or (< (car t1) (car t2)) + (and (= (car t1) (car t2)) + (< (nth 1 t1) (nth 1 t2))))) + +(defun gnus-file-newer-than (file date) + (let ((fdate (nth 5 (file-attributes file)))) + (or (> (car fdate) (car date)) + (and (= (car fdate) (car date)) + (> (nth 1 fdate) (nth 1 date)))))) + +;;; Keymap macros. + +(defmacro gnus-local-set-keys (&rest plist) + "Set the keys in PLIST in the current keymap." + `(gnus-define-keys-1 (current-local-map) ',plist)) + +(defmacro gnus-define-keys (keymap &rest plist) + "Define all keys in PLIST in KEYMAP." + `(gnus-define-keys-1 (quote ,keymap) (quote ,plist))) + +(defmacro gnus-define-keys-safe (keymap &rest plist) + "Define all keys in PLIST in KEYMAP without overwriting previous definitions." + `(gnus-define-keys-1 (quote ,keymap) (quote ,plist) t)) + +(put 'gnus-define-keys 'lisp-indent-function 1) +(put 'gnus-define-keys-safe 'lisp-indent-function 1) +(put 'gnus-local-set-keys 'lisp-indent-function 1) + +(defmacro gnus-define-keymap (keymap &rest plist) + "Define all keys in PLIST in KEYMAP." + `(gnus-define-keys-1 ,keymap (quote ,plist))) + +(put 'gnus-define-keymap 'lisp-indent-function 1) + +(defun gnus-define-keys-1 (keymap plist &optional safe) + (when (null keymap) + (error "Can't set keys in a null keymap")) + (cond ((symbolp keymap) + (setq keymap (symbol-value keymap))) + ((keymapp keymap)) + ((listp keymap) + (set (car keymap) nil) + (define-prefix-command (car keymap)) + (define-key (symbol-value (caddr keymap)) (cadr keymap) (car keymap)) + (setq keymap (symbol-value (car keymap))))) + (let (key) + (while plist + (when (symbolp (setq key (pop plist))) + (setq key (symbol-value key))) + (if (or (not safe) + (eq (lookup-key keymap key) 'undefined)) + (define-key keymap key (pop plist)) + (pop plist))))) + +(defun gnus-completing-read (default prompt &rest args) + ;; Like `completing-read', except that DEFAULT is the default argument. + (let* ((prompt (if default + (concat prompt " (default " default ") ") + (concat prompt " "))) + (answer (apply 'completing-read prompt args))) + (if (or (null answer) (zerop (length answer))) + default + answer))) + +;; Two silly functions to ensure that all `y-or-n-p' questions clear +;; the echo area. +(defun gnus-y-or-n-p (prompt) + (prog1 + (y-or-n-p prompt) + (message ""))) + +(defun gnus-yes-or-no-p (prompt) + (prog1 + (yes-or-no-p prompt) + (message ""))) + +;; I suspect there's a better way, but I haven't taken the time to do +;; it yet. -erik selberg@cs.washington.edu +(defun gnus-dd-mmm (messy-date) + "Return a string like DD-MMM from a big messy string" + (let ((datevec (ignore-errors (timezone-parse-date messy-date)))) + (if (not datevec) + "??-???" + (format "%2s-%s" + (condition-case () + ;; Make sure leading zeroes are stripped. + (number-to-string (string-to-number (aref datevec 2))) + (error "??")) + (capitalize + (or (car + (nth (1- (string-to-number (aref datevec 1))) + timezone-months-assoc)) + "???")))))) + +(defmacro gnus-date-get-time (date) + "Convert DATE string to Emacs time. +Cache the result as a text property stored in DATE." + ;; Either return the cached value... + `(let ((d ,date)) + (if (equal "" d) + '(0 0) + (or (get-text-property 0 'gnus-time d) + ;; or compute the value... + (let ((time (nnmail-date-to-time d))) + ;; and store it back in the string. + (put-text-property 0 1 'gnus-time time d) + time))))) + +(defsubst gnus-time-iso8601 (time) + "Return a string of TIME in YYMMDDTHHMMSS format." + (format-time-string "%Y%m%dT%H%M%S" time)) + +(defun gnus-date-iso8601 (header) + "Convert the date field in HEADER to YYMMDDTHHMMSS" + (condition-case () + (gnus-time-iso8601 (gnus-date-get-time (mail-header-date header))) + (error ""))) + +(defun gnus-mode-string-quote (string) + "Quote all \"%\"'s in STRING." + (save-excursion + (gnus-set-work-buffer) + (insert string) + (goto-char (point-min)) + (while (search-forward "%" nil t) + (insert "%")) + (buffer-string))) + +;; Make a hash table (default and minimum size is 256). +;; Optional argument HASHSIZE specifies the table size. +(defun gnus-make-hashtable (&optional hashsize) + (make-vector (if hashsize (max (gnus-create-hash-size hashsize) 256) 256) 0)) + +;; Make a number that is suitable for hashing; bigger than MIN and +;; equal to some 2^x. Many machines (such as sparcs) do not have a +;; hardware modulo operation, so they implement it in software. On +;; many sparcs over 50% of the time to intern is spent in the modulo. +;; Yes, it's slower than actually computing the hash from the string! +;; So we use powers of 2 so people can optimize the modulo to a mask. +(defun gnus-create-hash-size (min) + (let ((i 1)) + (while (< i min) + (setq i (* 2 i))) + i)) + +(defcustom gnus-verbose 7 + "*Integer that says how verbose Gnus should be. +The higher the number, the more messages Gnus will flash to say what +it's doing. At zero, Gnus will be totally mute; at five, Gnus will +display most important messages; and at ten, Gnus will keep on +jabbering all the time." + :group 'gnus-start + :type 'integer) + +;; Show message if message has a lower level than `gnus-verbose'. +;; Guideline for numbers: +;; 1 - error messages, 3 - non-serious error messages, 5 - messages +;; for things that take a long time, 7 - not very important messages +;; on stuff, 9 - messages inside loops. +(defun gnus-message (level &rest args) + (if (<= level gnus-verbose) + (apply 'message args) + ;; We have to do this format thingy here even if the result isn't + ;; shown - the return value has to be the same as the return value + ;; from `message'. + (apply 'format args))) + +(defun gnus-error (level &rest args) + "Beep an error if LEVEL is equal to or less than `gnus-verbose'." + (when (<= (floor level) gnus-verbose) + (apply 'message args) + (ding) + (let (duration) + (when (and (floatp level) + (not (zerop (setq duration (* 10 (- level (floor level))))))) + (sit-for duration)))) + nil) + +(defun gnus-split-references (references) + "Return a list of Message-IDs in REFERENCES." + (let ((beg 0) + ids) + (while (string-match "<[^>]+>" references beg) + (push (substring references (match-beginning 0) (setq beg (match-end 0))) + ids)) + (nreverse ids))) + +(defun gnus-parent-id (references &optional n) + "Return the last Message-ID in REFERENCES. +If N, return the Nth ancestor instead." + (when references + (let ((ids (inline (gnus-split-references references)))) + (car (last ids (or n 1)))))) + +(defun gnus-buffer-live-p (buffer) + "Say whether BUFFER is alive or not." + (and buffer + (get-buffer buffer) + (buffer-name (get-buffer buffer)))) + +(defun gnus-horizontal-recenter () + "Recenter the current buffer horizontally." + (if (< (current-column) (/ (window-width) 2)) + (set-window-hscroll (get-buffer-window (current-buffer) t) 0) + (let* ((orig (point)) + (end (window-end (get-buffer-window (current-buffer) t))) + (max 0)) + ;; Find the longest line currently displayed in the window. + (goto-char (window-start)) + (while (and (not (eobp)) + (< (point) end)) + (end-of-line) + (setq max (max max (current-column))) + (forward-line 1)) + (goto-char orig) + ;; Scroll horizontally to center (sort of) the point. + (if (> max (window-width)) + (set-window-hscroll + (get-buffer-window (current-buffer) t) + (min (- (current-column) (/ (window-width) 3)) + (+ 2 (- max (window-width))))) + (set-window-hscroll (get-buffer-window (current-buffer) t) 0)) + max))) + +(defun gnus-read-event-char () + "Get the next event." + (let ((event (read-event))) + ;; should be gnus-characterp, but this can't be called in XEmacs anyway + (cons (and (numberp event) event) event))) + +(defun gnus-sortable-date (date) + "Make sortable string by string-lessp from DATE. +Timezone package is used." + (condition-case () + (progn + (setq date (inline (timezone-fix-time + date nil + (aref (inline (timezone-parse-date date)) 4)))) + (inline + (timezone-make-sortable-date + (aref date 0) (aref date 1) (aref date 2) + (inline + (timezone-make-time-string + (aref date 3) (aref date 4) (aref date 5)))))) + (error ""))) + +(defun gnus-copy-file (file &optional to) + "Copy FILE to TO." + (interactive + (list (read-file-name "Copy file: " default-directory) + (read-file-name "Copy file to: " default-directory))) + (unless to + (setq to (read-file-name "Copy file to: " default-directory))) + (when (file-directory-p to) + (setq to (concat (file-name-as-directory to) + (file-name-nondirectory file)))) + (copy-file file to)) + +(defun gnus-kill-all-overlays () + "Delete all overlays in the current buffer." + (when (fboundp 'overlay-lists) + (let* ((overlayss (overlay-lists)) + (buffer-read-only nil) + (overlays (nconc (car overlayss) (cdr overlayss)))) + (while overlays + (delete-overlay (pop overlays)))))) + +(defvar gnus-work-buffer " *gnus work*") + +(defun gnus-set-work-buffer () + "Put point in the empty Gnus work buffer." + (if (get-buffer gnus-work-buffer) + (progn + (set-buffer gnus-work-buffer) + (erase-buffer)) + (set-buffer (get-buffer-create gnus-work-buffer)) + (kill-all-local-variables) + (buffer-disable-undo (current-buffer)))) + +(defmacro gnus-group-real-name (group) + "Find the real name of a foreign newsgroup." + `(let ((gname ,group)) + (if (string-match "^[^:]+:" gname) + (substring gname (match-end 0)) + gname))) + +(defun gnus-make-sort-function (funs) + "Return a composite sort condition based on the functions in FUNC." + (cond + ((not (listp funs)) funs) + ((null funs) funs) + ((cdr funs) + `(lambda (t1 t2) + ,(gnus-make-sort-function-1 (reverse funs)))) + (t + (car funs)))) + +(defun gnus-make-sort-function-1 (funs) + "Return a composite sort condition based on the functions in FUNC." + (if (cdr funs) + `(or (,(car funs) t1 t2) + (and (not (,(car funs) t2 t1)) + ,(gnus-make-sort-function-1 (cdr funs)))) + `(,(car funs) t1 t2))) + +(defun gnus-turn-off-edit-menu (type) + "Turn off edit meny in `gnus-TYPE-mode-map'." + (define-key (symbol-value (intern (format "gnus-%s-mode-map" type))) + [menu-bar edit] 'undefined)) + +(defun gnus-prin1 (form) + "Use `prin1' on FORM in the current buffer. +Bind `print-quoted' to t while printing." + (let ((print-quoted t) + print-level print-length) + (prin1 form (current-buffer)))) + +(defun gnus-prin1-to-string (form) + "The same as `prin1', but but `print-quoted' to t." + (let ((print-quoted t)) + (prin1-to-string form))) + +(defun gnus-make-directory (directory) + "Make DIRECTORY (and all its parents) if it doesn't exist." + (when (and directory + (not (file-exists-p directory))) + (make-directory directory t)) + t) + +(defun gnus-write-buffer (file) + "Write the current buffer's contents to FILE." + ;; Make sure the directory exists. + (gnus-make-directory (file-name-directory file)) + ;; Write the buffer. + (write-region (point-min) (point-max) file nil 'quietly)) + +(defmacro gnus-delete-assq (key list) + `(let ((listval (eval ,list))) + (setq ,list (delq (assq ,key listval) listval)))) + +(defmacro gnus-delete-assoc (key list) + `(let ((listval ,list)) + (setq ,list (delq (assoc ,key listval) listval)))) + +(defun gnus-delete-file (file) + "Delete FILE if it exists." + (when (file-exists-p file) + (delete-file file))) + +(defun gnus-strip-whitespace (string) + "Return STRING stripped of all whitespace." + (while (string-match "[\r\n\t ]+" string) + (setq string (replace-match "" t t string))) + string) + +(defun gnus-put-text-property-excluding-newlines (beg end prop val) + "The same as `put-text-property', but don't put this prop on any newlines in the region." + (save-match-data + (save-excursion + (save-restriction + (goto-char beg) + (while (re-search-forward "[ \t]*\n" end 'move) + (put-text-property beg (match-beginning 0) prop val) + (setq beg (point))) + (put-text-property beg (point) prop val))))) + +;;; Protected and atomic operations. dmoore@ucsd.edu 21.11.1996 +;;; The primary idea here is to try to protect internal datastructures +;;; from becoming corrupted when the user hits C-g, or if a hook or +;;; similar blows up. Often in Gnus multiple tables/lists need to be +;;; updated at the same time, or information can be lost. + +(defvar gnus-atomic-be-safe t + "If t, certain operations will be protected from interruption by C-g.") + +(defmacro gnus-atomic-progn (&rest forms) + "Evaluate FORMS atomically, which means to protect the evaluation +from being interrupted by the user. An error from the forms themselves +will return without finishing the operation. Since interrupts from +the user are disabled, it is recommended that only the most minimal +operations are performed by FORMS. If you wish to assign many +complicated values atomically, compute the results into temporary +variables and then do only the assignment atomically." + `(let ((inhibit-quit gnus-atomic-be-safe)) + ,@forms)) + +(put 'gnus-atomic-progn 'lisp-indent-function 0) + +(defmacro gnus-atomic-progn-assign (protect &rest forms) + "Evaluate FORMS, but insure that the variables listed in PROTECT +are not changed if anything in FORMS signals an error or otherwise +non-locally exits. The variables listed in PROTECT are updated atomically. +It is safe to use gnus-atomic-progn-assign with long computations. + +Note that if any of the symbols in PROTECT were unbound, they will be +set to nil on a sucessful assignment. In case of an error or other +non-local exit, it will still be unbound." + (let* ((temp-sym-map (mapcar (lambda (x) (list (make-symbol + (concat (symbol-name x) + "-tmp")) + x)) + protect)) + (sym-temp-map (mapcar (lambda (x) (list (cadr x) (car x))) + temp-sym-map)) + (temp-sym-let (mapcar (lambda (x) (list (car x) + `(and (boundp ',(cadr x)) + ,(cadr x)))) + temp-sym-map)) + (sym-temp-let sym-temp-map) + (temp-sym-assign (apply 'append temp-sym-map)) + (sym-temp-assign (apply 'append sym-temp-map)) + (result (make-symbol "result-tmp"))) + `(let (,@temp-sym-let + ,result) + (let ,sym-temp-let + (setq ,result (progn ,@forms)) + (setq ,@temp-sym-assign)) + (let ((inhibit-quit gnus-atomic-be-safe)) + (setq ,@sym-temp-assign)) + ,result))) + +(put 'gnus-atomic-progn-assign 'lisp-indent-function 1) +;(put 'gnus-atomic-progn-assign 'edebug-form-spec '(sexp body)) + +(defmacro gnus-atomic-setq (&rest pairs) + "Similar to setq, except that the real symbols are only assigned when +there are no errors. And when the real symbols are assigned, they are +done so atomically. If other variables might be changed via side-effect, +see gnus-atomic-progn-assign. It is safe to use gnus-atomic-setq +with potentially long computations." + (let ((tpairs pairs) + syms) + (while tpairs + (push (car tpairs) syms) + (setq tpairs (cddr tpairs))) + `(gnus-atomic-progn-assign ,syms + (setq ,@pairs)))) + +;(put 'gnus-atomic-setq 'edebug-form-spec '(body)) + + +;;; Functions for saving to babyl/mail files. + +(defun gnus-output-to-rmail (filename &optional ask) + "Append the current article to an Rmail file named FILENAME." + (require 'rmail) + ;; Most of these codes are borrowed from rmailout.el. + (setq filename (expand-file-name filename)) + (setq rmail-default-rmail-file filename) + (let ((artbuf (current-buffer)) + (tmpbuf (get-buffer-create " *Gnus-output*"))) + (save-excursion + (or (get-file-buffer filename) + (file-exists-p filename) + (if (or (not ask) + (gnus-yes-or-no-p + (concat "\"" filename "\" does not exist, create it? "))) + (let ((file-buffer (create-file-buffer filename))) + (save-excursion + (set-buffer file-buffer) + (rmail-insert-rmail-file-header) + (let ((require-final-newline nil)) + (gnus-write-buffer filename))) + (kill-buffer file-buffer)) + (error "Output file does not exist"))) + (set-buffer tmpbuf) + (erase-buffer) + (insert-buffer-substring artbuf) + (gnus-convert-article-to-rmail) + ;; Decide whether to append to a file or to an Emacs buffer. + (let ((outbuf (get-file-buffer filename))) + (if (not outbuf) + (append-to-file (point-min) (point-max) filename) + ;; File has been visited, in buffer OUTBUF. + (set-buffer outbuf) + (let ((buffer-read-only nil) + (msg (and (boundp 'rmail-current-message) + (symbol-value 'rmail-current-message)))) + ;; If MSG is non-nil, buffer is in RMAIL mode. + (when msg + (widen) + (narrow-to-region (point-max) (point-max))) + (insert-buffer-substring tmpbuf) + (when msg + (goto-char (point-min)) + (widen) + (search-backward "\^_") + (narrow-to-region (point) (point-max)) + (goto-char (1+ (point-min))) + (rmail-count-new-messages t) + (rmail-show-message msg)))))) + (kill-buffer tmpbuf))) + +(defun gnus-output-to-mail (filename &optional ask) + "Append the current article to a mail file named FILENAME." + (setq filename (expand-file-name filename)) + (let ((artbuf (current-buffer)) + (tmpbuf (get-buffer-create " *Gnus-output*"))) + (save-excursion + ;; Create the file, if it doesn't exist. + (when (and (not (get-file-buffer filename)) + (not (file-exists-p filename))) + (if (or (not ask) + (gnus-yes-or-no-p + (concat "\"" filename "\" does not exist, create it? "))) + (let ((file-buffer (create-file-buffer filename))) + (save-excursion + (set-buffer file-buffer) + (let ((require-final-newline nil)) + (gnus-write-buffer filename))) + (kill-buffer file-buffer)) + (error "Output file does not exist"))) + (set-buffer tmpbuf) + (erase-buffer) + (insert-buffer-substring artbuf) + (goto-char (point-min)) + (unless (looking-at "From ") + (insert "From nobody " (current-time-string) "\n")) + ;; Decide whether to append to a file or to an Emacs buffer. + (let ((outbuf (get-file-buffer filename))) + (if (not outbuf) + (append-to-file (point-min) (point-max) filename) + ;; File has been visited, in buffer OUTBUF. + (set-buffer outbuf) + (let ((buffer-read-only nil)) + (goto-char (point-max)) + (insert-buffer-substring tmpbuf))))) + (kill-buffer tmpbuf))) + +(defun gnus-convert-article-to-rmail () + "Convert article in current buffer to Rmail message format." + (let ((buffer-read-only nil)) + ;; Convert article directly into Babyl format. + (goto-char (point-min)) + (insert "\^L\n0, unseen,,\n*** EOOH ***\n") + (while (search-forward "\n\^_" nil t) ;single char + (replace-match "\n^_" t t)) ;2 chars: "^" and "_" + (goto-char (point-max)) + (insert "\^_"))) + +(provide 'gnus-util) + +;;; gnus-util.el ends here diff -r ad457d5f7d04 -r 0293115a14e9 lisp/gnus/gnus-uu.el --- a/lisp/gnus/gnus-uu.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/gnus/gnus-uu.el Mon Aug 13 08:49:20 2007 +0200 @@ -1,5 +1,5 @@ ;;; gnus-uu.el --- extract (uu)encoded files in Gnus -;; Copyright (C) 1985,86,87,93,94,95,96 Free Software Foundation, Inc. +;; Copyright (C) 1985,86,87,93,94,95,96,97 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; Created: 2 Oct 1993 @@ -27,12 +27,31 @@ ;;; Code: (require 'gnus) +(require 'gnus-art) +(require 'message) (require 'gnus-msg) -(eval-when-compile (require 'cl)) + +(defgroup gnus-extract nil + "Extracting encoded files." + :prefix "gnus-uu-" + :group 'gnus) + +(defgroup gnus-extract-view nil + "Viewwing extracted files." + :group 'gnus-extract) + +(defgroup gnus-extract-archive nil + "Extracting encoded archives." + :group 'gnus-extract) + +(defgroup gnus-extract-post nil + "Extracting encoded archives." + :prefix "gnus-uu-post" + :group 'gnus-extract) ;; Default viewing action rules -(defvar gnus-uu-default-view-rules +(defcustom gnus-uu-default-view-rules '(("\\.te?xt$\\|\\.doc$\\|read.*me\\|\\.c?$\\|\\.h$\\|\\.bat$\\|\\.asm$\\|makefile" "cat %s | sed s/\r//g") ("\\.pas$" "cat %s | sed s/\r//g") ("\\.[1-9]$" "groff -mandoc -Tascii %s | sed s/\b.//g") @@ -50,7 +69,7 @@ ("\\.\\(flc\\|fli\\|rle\\|iff\\|pfx\\|avi\\|sme\\|rpza\\|dl\\|qt\\|rsrc\\|mov\\)$" "xanim") ("\\.\\(tar\\|arj\\|zip\\|zoo\\|arc\\|gz\\|Z\\|lzh\\|ar\\|lha\\)$" "gnus-uu-archive")) - "*Default actions to be taken when the user asks to view a file. + "Default actions to be taken when the user asks to view a file. To change the behaviour, you can either edit this variable or set `gnus-uu-user-view-rules' to something useful. @@ -61,38 +80,44 @@ (setq gnus-uu-user-view-rules '((\"jpg$\\\\|gif$\" \"xli\"))) -Both these variables are lists of lists with two string elements. The -first string is a regular expression. If the file name matches this +Both these variables are lists of lists with two string elements. The +first string is a regular expression. If the file name matches this regular expression, the command in the second string is executed with the file as an argument. If the command string contains \"%s\", the file name will be inserted -at that point in the command string. If there's no \"%s\" in the +at that point in the command string. If there's no \"%s\" in the command string, the file name will be appended to the command string before executing. There are several user variables to tailor the behaviour of gnus-uu to -your needs. First we have `gnus-uu-user-view-rules', which is the +your needs. First we have `gnus-uu-user-view-rules', which is the variable gnus-uu first consults when trying to decide how to view a -file. If this variable contains no matches, gnus-uu examines the -default rule variable provided in this package. If gnus-uu finds no +file. If this variable contains no matches, gnus-uu examines the +default rule variable provided in this package. If gnus-uu finds no match here, it uses `gnus-uu-user-view-rules-end' to try to make a -match.") +match." + :group 'gnus-extract-view + :type '(repeat (group regexp (string :tag "Command")))) -(defvar gnus-uu-user-view-rules nil - "*Variable detailing what actions are to be taken to view a file. +(defcustom gnus-uu-user-view-rules nil + "What actions are to be taken to view a file. See the documentation on the `gnus-uu-default-view-rules' variable for -details.") +details." + :group 'gnus-extract-view + :type '(repeat (group regexp (string :tag "Command")))) -(defvar gnus-uu-user-view-rules-end +(defcustom gnus-uu-user-view-rules-end '(("" "file")) - "*Variable saying what actions are to be taken if no rule matched the file name. + "What actions are to be taken if no rule matched the file name. See the documentation on the `gnus-uu-default-view-rules' variable for -details.") +details." + :group 'gnus-extract-view + :type '(repeat (group regexp (string :tag "Command")))) ;; Default unpacking commands -(defvar gnus-uu-default-archive-rules +(defcustom gnus-uu-default-archive-rules '(("\\.tar$" "tar xf") ("\\.zip$" "unzip -o") ("\\.ar$" "ar x") @@ -101,20 +126,25 @@ ("\\.\\(lzh\\|lha\\)$" "lha x") ("\\.Z$" "uncompress") ("\\.gz$" "gunzip") - ("\\.arc$" "arc -x"))) + ("\\.arc$" "arc -x")) + "See `gnus-uu-user-archive-rules'." + :group 'gnus-extract-archive + :type '(repeat (group regexp (string :tag "Command")))) (defvar gnus-uu-destructive-archivers (list "uncompress" "gunzip")) -(defvar gnus-uu-user-archive-rules nil - "*A list that can be set to override the default archive unpacking commands. +(defcustom gnus-uu-user-archive-rules nil + "A list that can be set to override the default archive unpacking commands. To use, for instance, 'untar' to unpack tar files and 'zip -x' to unpack zip files, say the following: (setq gnus-uu-user-archive-rules '((\"\\\\.tar$\" \"untar\") - (\"\\\\.zip$\" \"zip -x\")))") + (\"\\\\.zip$\" \"zip -x\")))" + :group 'gnus-extract-archive + :type '(repeat (group regexp (string :tag "Command")))) -(defvar gnus-uu-ignore-files-by-name nil +(defcustom gnus-uu-ignore-files-by-name nil "*A regular expression saying what files should not be viewed based on name. If, for instance, you want gnus-uu to ignore all .au and .wav files, you could say something like @@ -122,9 +152,12 @@ (setq gnus-uu-ignore-files-by-name \"\\\\.au$\\\\|\\\\.wav$\") Note that this variable can be used in conjunction with the -`gnus-uu-ignore-files-by-type' variable.") +`gnus-uu-ignore-files-by-type' variable." + :group 'gnus-extract + :type '(choice (const :tag "off" nil) + (regexp :format "%v"))) -(defvar gnus-uu-ignore-files-by-type nil +(defcustom gnus-uu-ignore-files-by-type nil "*A regular expression saying what files that shouldn't be viewed, based on MIME file type. If, for instance, you want gnus-uu to ignore all audio files and all mpegs, you could say something like @@ -132,7 +165,10 @@ (setq gnus-uu-ignore-files-by-type \"audio/\\\\|video/mpeg\") Note that this variable can be used in conjunction with the -`gnus-uu-ignore-files-by-name' variable.") +`gnus-uu-ignore-files-by-name' variable." + :group 'gnus-extract + :type '(choice (const :tag "off" nil) + (regexp :format "%v"))) ;; Pseudo-MIME support @@ -177,61 +213,95 @@ ;; Various variables users may set -(defvar gnus-uu-tmp-dir "/tmp/" +(defcustom gnus-uu-tmp-dir "/tmp/" "*Variable saying where gnus-uu is to do its work. -Default is \"/tmp/\".") +Default is \"/tmp/\"." + :group 'gnus-extract + :type 'directory) -(defvar gnus-uu-do-not-unpack-archives nil +(defcustom gnus-uu-do-not-unpack-archives nil "*Non-nil means that gnus-uu won't peek inside archives looking for files to display. -Default is nil.") +Default is nil." + :group 'gnus-extract-archive + :type 'boolean) -(defvar gnus-uu-ignore-default-view-rules nil +(defcustom gnus-uu-ignore-default-view-rules nil "*Non-nil means that gnus-uu will ignore the default viewing rules. -Only the user viewing rules will be consulted. Default is nil.") +Only the user viewing rules will be consulted. Default is nil." + :group 'gnus-extract-view + :type 'boolean) -(defvar gnus-uu-grabbed-file-functions nil - "*Functions run on each file after successful decoding. +(defcustom gnus-uu-grabbed-file-functions nil + "Functions run on each file after successful decoding. They will be called with the name of the file as the argument. Likely functions you can use in this list are `gnus-uu-grab-view' -and `gnus-uu-grab-move'.") - -(defvar gnus-uu-ignore-default-archive-rules nil - "*Non-nil means that gnus-uu will ignore the default archive unpacking commands. -Only the user unpacking commands will be consulted. Default is nil.") +and `gnus-uu-grab-move'." + :group 'gnus-extract + :options '(gnus-uu-grab-view gnus-uu-grab-move) + :type 'hook) -(defvar gnus-uu-kill-carriage-return t +(defcustom gnus-uu-ignore-default-archive-rules nil + "*Non-nil means that gnus-uu will ignore the default archive unpacking commands. +Only the user unpacking commands will be consulted. Default is nil." + :group 'gnus-extract-archive + :type 'boolean) + +(defcustom gnus-uu-kill-carriage-return t "*Non-nil means that gnus-uu will strip all carriage returns from articles. -Default is t.") +Default is t." + :group 'gnus-extract + :type 'boolean) -(defvar gnus-uu-view-with-metamail nil +(defcustom gnus-uu-view-with-metamail nil "*Non-nil means that files will be viewed with metamail. The gnus-uu viewing functions will be ignored and gnus-uu will try -to guess at a content-type based on file name suffixes. Default -it nil.") +to guess at a content-type based on file name suffixes. Default +it nil." + :group 'gnus-extract + :type 'boolean) -(defvar gnus-uu-unmark-articles-not-decoded nil +(defcustom gnus-uu-unmark-articles-not-decoded nil "*Non-nil means that gnus-uu will mark articles that were unsuccessfully decoded as unread. -Default is nil.") +Default is nil." + :group 'gnus-extract + :type 'boolean) -(defvar gnus-uu-correct-stripped-uucode nil +(defcustom gnus-uu-correct-stripped-uucode nil "*Non-nil means that gnus-uu will *try* to fix uuencoded files that have had trailing spaces deleted. -Default is nil.") +Default is nil." + :group 'gnus-extract + :type 'boolean) -(defvar gnus-uu-save-in-digest nil +(defcustom gnus-uu-save-in-digest nil "*Non-nil means that gnus-uu, when asked to save without decoding, will save in digests. If this variable is nil, gnus-uu will just save everything in a -file without any embellishments. The digesting almost conforms to RFC1153 - +file without any embellishments. The digesting almost conforms to RFC1153 - no easy way to specify any meaningful volume and issue numbers were found, -so I simply dropped them.") +so I simply dropped them." + :group 'gnus-extract + :type 'boolean) -(defvar gnus-uu-digest-headers +(defcustom gnus-uu-digest-headers '("^Date:" "^From:" "^To:" "^Cc:" "^Subject:" "^Message-ID:" "^Keywords:" "^Summary:" "^References:") - "*List of regexps to match headers included in digested messages. -The headers will be included in the sequence they are matched.") + "List of regexps to match headers included in digested messages. +The headers will be included in the sequence they are matched." + :group 'gnus-extract + :type '(repeat regexp)) -(defvar gnus-uu-save-separate-articles nil - "*Non-nil means that gnus-uu will save articles in separate files.") +(defcustom gnus-uu-save-separate-articles nil + "*Non-nil means that gnus-uu will save articles in separate files." + :group 'gnus-extract + :type 'boolean) + +(defcustom gnus-uu-be-dangerous 'ask + "*Specifies what to do if unusual situations arise during decoding. +If nil, be as conservative as possible. If t, ignore things that +didn't work, and overwrite existing files. Otherwise, ask each time." + :group 'gnus-extract + :type '(choice (const :tag "conservative" nil) + (const :tag "ask" ask) + (const :tag "liberal" t))) ;; Internal variables @@ -269,35 +339,37 @@ ;; Keymaps -(gnus-define-keys - (gnus-uu-mark-map "P" gnus-summary-mark-map) - "p" gnus-summary-mark-as-processable - "u" gnus-summary-unmark-as-processable - "U" gnus-summary-unmark-all-processable - "v" gnus-uu-mark-over - "s" gnus-uu-mark-series - "r" gnus-uu-mark-region - "R" gnus-uu-mark-by-regexp - "t" gnus-uu-mark-thread - "T" gnus-uu-unmark-thread - "a" gnus-uu-mark-all - "b" gnus-uu-mark-buffer - "S" gnus-uu-mark-sparse) +(gnus-define-keys (gnus-uu-mark-map "P" gnus-summary-mark-map) + "p" gnus-summary-mark-as-processable + "u" gnus-summary-unmark-as-processable + "U" gnus-summary-unmark-all-processable + "v" gnus-uu-mark-over + "s" gnus-uu-mark-series + "r" gnus-uu-mark-region + "R" gnus-uu-mark-by-regexp + "t" gnus-uu-mark-thread + "T" gnus-uu-unmark-thread + "a" gnus-uu-mark-all + "b" gnus-uu-mark-buffer + "S" gnus-uu-mark-sparse + "k" gnus-summary-kill-process-mark + "y" gnus-summary-yank-process-mark + "w" gnus-summary-save-process-mark + "i" gnus-uu-invert-processable) -(gnus-define-keys - (gnus-uu-extract-map "X" gnus-summary-mode-map) - ;;"x" gnus-uu-extract-any - ;;"m" gnus-uu-extract-mime - "u" gnus-uu-decode-uu - "U" gnus-uu-decode-uu-and-save - "s" gnus-uu-decode-unshar - "S" gnus-uu-decode-unshar-and-save - "o" gnus-uu-decode-save - "O" gnus-uu-decode-save - "b" gnus-uu-decode-binhex - "B" gnus-uu-decode-binhex - "p" gnus-uu-decode-postscript - "P" gnus-uu-decode-postscript-and-save) +(gnus-define-keys (gnus-uu-extract-map "X" gnus-summary-mode-map) + ;;"x" gnus-uu-extract-any + ;;"m" gnus-uu-extract-mime + "u" gnus-uu-decode-uu + "U" gnus-uu-decode-uu-and-save + "s" gnus-uu-decode-unshar + "S" gnus-uu-decode-unshar-and-save + "o" gnus-uu-decode-save + "O" gnus-uu-decode-save + "b" gnus-uu-decode-binhex + "B" gnus-uu-decode-binhex + "p" gnus-uu-decode-postscript + "P" gnus-uu-decode-postscript-and-save) (gnus-define-keys (gnus-uu-extract-view-map "v" gnus-uu-extract-map) @@ -317,7 +389,7 @@ (defun gnus-uu-decode-uu (&optional n) "Uudecodes the current article." - (interactive "P") + (interactive "P") (gnus-uu-decode-with-method 'gnus-uu-uustrip-article n)) (defun gnus-uu-decode-uu-and-save (n dir) @@ -431,8 +503,8 @@ "Digests and forwards all articles in this series." (interactive "P") (let ((gnus-uu-save-in-digest t) - (file (make-temp-name (concat gnus-uu-tmp-dir "forward"))) - buf subject from) + (file (make-temp-name (nnheader-concat gnus-uu-tmp-dir "forward"))) + buf subject from newsgroups) (setq gnus-uu-digest-from-subject nil) (gnus-uu-decode-save n file) (setq buf (switch-to-buffer (get-buffer-create " *gnus-uu-forward*"))) @@ -441,32 +513,34 @@ (delete-other-windows) (insert-file file) (let ((fs gnus-uu-digest-from-subject)) - (if (not fs) - () + (when fs (setq from (caar fs) subject (gnus-simplify-subject-fuzzy (cdar fs)) fs (cdr fs)) (while (and fs (or from subject)) - (and from - (or (string= from (caar fs)) - (setq from nil))) - (and subject - (or (string= (gnus-simplify-subject-fuzzy (cdar fs)) - subject) - (setq subject nil))) + (when from + (unless (string= from (caar fs)) + (setq from nil))) + (when subject + (unless (string= (gnus-simplify-subject-fuzzy (cdar fs)) + subject) + (setq subject nil))) (setq fs (cdr fs)))) - (or subject (setq subject "Digested Articles")) - (or from (setq from "Various"))) + (unless subject + (setq subject "Digested Articles")) + (unless from + (setq from + (if (gnus-news-group-p gnus-newsgroup-name) + gnus-newsgroup-name + "Various")))) (goto-char (point-min)) - (and (re-search-forward "^Subject: ") - (progn - (delete-region (point) (gnus-point-at-eol)) - (insert subject))) + (when (re-search-forward "^Subject: ") + (delete-region (point) (point-at-eol)) + (insert subject)) (goto-char (point-min)) - (and (re-search-forward "^From: ") - (progn - (delete-region (point) (gnus-point-at-eol)) - (insert from))) + (when (re-search-forward "^From: ") + (delete-region (point) (point-at-eol)) + (insert from)) (message-forward post) (delete-file file) (kill-buffer buf) @@ -556,6 +630,18 @@ (> (gnus-summary-thread-level) level)))) (gnus-summary-position-point)) +(defun gnus-uu-invert-processable () + "Invert the list of process-marked articles." + (let ((data gnus-newsgroup-data) + d number) + (save-excursion + (while data + (if (memq (setq number (gnus-data-number (pop data))) + gnus-newsgroup-processable) + (gnus-summary-remove-process-mark number) + (gnus-summary-set-process-mark number))))) + (gnus-summary-position-point)) + (defun gnus-uu-mark-over (&optional score) "Mark all articles with a score over SCORE (the prefix.)" (interactive "P") @@ -577,7 +663,8 @@ (gnus-set-global-variables) (let ((marked (nreverse gnus-newsgroup-processable)) subject articles total headers) - (or marked (error "No articles marked with the process mark")) + (unless marked + (error "No articles marked with the process mark")) (setq gnus-newsgroup-processable nil) (save-excursion (while marked @@ -652,7 +739,8 @@ (defun gnus-uu-decode-with-method (method n &optional save not-insert scan cdir) (gnus-uu-initialize scan) - (if save (setq gnus-uu-default-dir save)) + (when save + (setq gnus-uu-default-dir save)) ;; Create the directory we save to. (when (and scan cdir save (not (file-exists-p save))) @@ -661,9 +749,11 @@ files) (setq files (gnus-uu-grab-articles articles method t)) (let ((gnus-current-article (car articles))) - (and scan (setq files (gnus-uu-scan-directory gnus-uu-work-dir)))) - (and save (gnus-uu-save-files files save)) - (if (eq gnus-uu-do-not-unpack-archives nil) + (when scan + (setq files (gnus-uu-scan-directory gnus-uu-work-dir)))) + (when save + (gnus-uu-save-files files save)) + (when (eq gnus-uu-do-not-unpack-archives nil) (setq files (gnus-uu-unpack-files files))) (setq files (nreverse (gnus-uu-get-actions files))) (or not-insert (not gnus-insert-pseudo-articles) @@ -694,11 +784,13 @@ (string-match reg file) (setq fromdir (substring file (match-end 0))) (if (file-directory-p file) - (unless (file-exists-p (concat dir fromdir)) - (make-directory (concat dir fromdir) t)) + (gnus-make-directory (concat dir fromdir)) (setq to-file (concat dir fromdir)) (when (or (not (file-exists-p to-file)) - (gnus-y-or-n-p (format "%s exists; overwrite? " to-file))) + (eq gnus-uu-be-dangerous t) + (and gnus-uu-be-dangerous + (gnus-y-or-n-p (format "%s exists; overwrite? " + to-file)))) (copy-file file to-file t t))))) (gnus-message 5 "Saved %d file%s" len (if (= len 1) "" "s")))) @@ -711,8 +803,8 @@ (gnus-uu-save-separate-articles (save-excursion (set-buffer buffer) - (write-region 1 (point-max) (concat gnus-uu-saved-article-name - gnus-current-article)) + (gnus-write-buffer + (concat gnus-uu-saved-article-name gnus-current-article)) (cond ((eq in-state 'first) (list gnus-uu-saved-article-name 'begin)) ((eq in-state 'first-and-last) (list gnus-uu-saved-article-name 'begin 'end)) @@ -721,7 +813,7 @@ ((not gnus-uu-save-in-digest) (save-excursion (set-buffer buffer) - (write-region 1 (point-max) gnus-uu-saved-article-name t) + (write-region (point-min) (point-max) gnus-uu-saved-article-name t) (cond ((eq in-state 'first) (list gnus-uu-saved-article-name 'begin)) ((eq in-state 'first-and-last) (list gnus-uu-saved-article-name 'begin 'end)) @@ -729,14 +821,13 @@ (t (list 'middle))))) (t (let ((header (gnus-summary-article-header))) - (setq gnus-uu-digest-from-subject - (cons (cons (mail-header-from header) - (mail-header-subject header)) - gnus-uu-digest-from-subject))) + (push (cons (mail-header-from header) + (mail-header-subject header)) + gnus-uu-digest-from-subject)) (let ((name (file-name-nondirectory gnus-uu-saved-article-name)) (delim (concat "^" (make-string 30 ?-) "$")) beg subj headers headline sorthead body end-string state) - (if (or (eq in-state 'first) + (if (or (eq in-state 'first) (eq in-state 'first-and-last)) (progn (setq state (list 'begin)) @@ -748,8 +839,8 @@ (insert (format "Date: %s\nFrom: %s\nSubject: %s Digest\n\nTopics:\n" (current-time-string) name name)))) - (if (not (eq in-state 'end)) - (setq state (list 'middle)))) + (when (not (eq in-state 'end)) + (setq state (list 'middle)))) (save-excursion (set-buffer (get-buffer "*gnus-uu-body*")) (goto-char (setq beg (point-max))) @@ -790,30 +881,29 @@ (insert body) (goto-char (point-max)) (insert (concat "\n" (make-string 30 ?-) "\n\n")) (goto-char beg) - (if (re-search-forward "^Subject: \\(.*\\)$" nil t) - (progn - (setq subj (buffer-substring (match-beginning 1) (match-end 1))) - (save-excursion - (set-buffer (get-buffer "*gnus-uu-pre*")) - (insert (format " %s\n" subj)))))) - (if (or (eq in-state 'last) - (eq in-state 'first-and-last)) - (progn - (save-excursion - (set-buffer (get-buffer "*gnus-uu-pre*")) - (insert (format "\n\n%s\n\n" (make-string 70 ?-))) - (write-region 1 (point-max) gnus-uu-saved-article-name)) - (save-excursion - (set-buffer (get-buffer "*gnus-uu-body*")) - (goto-char (point-max)) - (insert - (concat (setq end-string (format "End of %s Digest" name)) - "\n")) - (insert (concat (make-string (length end-string) ?*) "\n")) - (write-region 1 (point-max) gnus-uu-saved-article-name t)) - (kill-buffer (get-buffer "*gnus-uu-pre*")) - (kill-buffer (get-buffer "*gnus-uu-body*")) - (setq state (cons 'end state)))) + (when (re-search-forward "^Subject: \\(.*\\)$" nil t) + (setq subj (buffer-substring (match-beginning 1) (match-end 1))) + (save-excursion + (set-buffer (get-buffer "*gnus-uu-pre*")) + (insert (format " %s\n" subj))))) + (when (or (eq in-state 'last) + (eq in-state 'first-and-last)) + (save-excursion + (set-buffer (get-buffer "*gnus-uu-pre*")) + (insert (format "\n\n%s\n\n" (make-string 70 ?-))) + (gnus-write-buffer gnus-uu-saved-article-name)) + (save-excursion + (set-buffer (get-buffer "*gnus-uu-body*")) + (goto-char (point-max)) + (insert + (concat (setq end-string (format "End of %s Digest" name)) + "\n")) + (insert (concat (make-string (length end-string) ?*) "\n")) + (write-region + (point-min) (point-max) gnus-uu-saved-article-name t)) + (kill-buffer (get-buffer "*gnus-uu-pre*")) + (kill-buffer (get-buffer "*gnus-uu-body*")) + (push 'end state)) (if (memq 'begin state) (cons gnus-uu-saved-article-name state) state))))) @@ -833,9 +923,9 @@ (set-buffer buffer) (widen) (goto-char (point-min)) - (if (not (re-search-forward gnus-uu-binhex-begin-line nil t)) - (if (not (re-search-forward gnus-uu-binhex-body-line nil t)) - (setq state (list 'wrong-type)))) + (when (not (re-search-forward gnus-uu-binhex-begin-line nil t)) + (when (not (re-search-forward gnus-uu-binhex-body-line nil t)) + (setq state (list 'wrong-type)))) (if (memq 'wrong-type state) () @@ -848,15 +938,16 @@ (setq state (list 'middle))) (goto-char (point-max)) (re-search-backward (concat gnus-uu-binhex-body-line "\\|" - gnus-uu-binhex-end-line) nil t) - (if (looking-at gnus-uu-binhex-end-line) - (setq state (if (memq 'begin state) - (cons 'end state) - (list 'end)))) + gnus-uu-binhex-end-line) + nil t) + (when (looking-at gnus-uu-binhex-end-line) + (setq state (if (memq 'begin state) + (cons 'end state) + (list 'end)))) (beginning-of-line) (forward-line 1) - (if (file-exists-p gnus-uu-binhex-article-name) - (append-to-file start-char (point) gnus-uu-binhex-article-name)))) + (when (file-exists-p gnus-uu-binhex-article-name) + (append-to-file start-char (point) gnus-uu-binhex-article-name)))) (if (memq 'begin state) (cons gnus-uu-binhex-article-name state) state))) @@ -914,11 +1005,11 @@ nil gnus-uu-default-view-rules) gnus-uu-user-view-rules-end))) - (if (and (not (string= (or action "") "gnus-uu-archive")) - gnus-uu-view-with-metamail) - (if (setq action + (when (and (not (string= (or action "") "gnus-uu-archive")) + gnus-uu-view-with-metamail) + (when (setq action (gnus-uu-choose-action file-name gnus-uu-ext-to-mime-list)) - (setq action (format "metamail -d -b -c \"%s\"" action)))) + (setq action (format "metamail -d -b -c \"%s\"" action)))) action)) @@ -929,7 +1020,7 @@ ;; ignores any leading "version numbers" thingies that they use in ;; the comp.binaries groups, and either replaces anything that looks ;; like "2/3" with "[0-9]+/[0-9]+" or, if it can't find something - ;; like that, replaces the last two numbers with "[0-9]+". This, in + ;; like that, replaces the last two numbers with "[0-9]+". This, in ;; my experience, should get most postings of a series. (let ((count 2) (vernum "v[0-9]+[a-z][0-9]+:") @@ -943,10 +1034,9 @@ (setq case-fold-search nil) (goto-char (point-min)) - (if (looking-at vernum) - (progn - (replace-match vernum t t) - (setq beg (length vernum)))) + (when (looking-at vernum) + (replace-match vernum t t) + (setq beg (length vernum))) (goto-char beg) (if (re-search-forward "[ \t]*[0-9]+/[0-9]+" nil t) @@ -957,15 +1047,10 @@ (replace-match "[0-9]+ of [0-9]+") (end-of-line) - (while (and (re-search-backward "[0-9]" nil t) (> count 0)) - (while (and - (looking-at "[0-9]") - (< 1 (goto-char (1- (point)))))) - (re-search-forward "[0-9]+" nil t) - (replace-match "[0-9]+") - (backward-char 5) - (setq count (1- count))))) - + (if (re-search-backward "\\([^0-9]\\)[0-9]+\\([^0-9]+\\)[0-9]+" + nil t) + (replace-match "\\1[0-9]+\\2[0-9]+" t nil nil nil)))) + (goto-char beg) (while (re-search-forward "[ \t]+" nil t) (replace-match "[ \t]*" t t)) @@ -982,12 +1067,13 @@ (let (articles) (cond (n + (setq n (prefix-numeric-value n)) (let ((backward (< n 0)) (n (abs n))) (save-excursion (while (and (> n 0) - (setq articles (cons (gnus-summary-article-number) - articles)) + (push (gnus-summary-article-number) + articles) (gnus-summary-search-forward nil nil backward)) (setq n (1- n)))) (nreverse articles))) @@ -1002,8 +1088,8 @@ (defun gnus-uu-find-articles-matching (&optional subject only-unread do-not-translate) ;; Finds all articles that matches the regexp SUBJECT. If it is - ;; nil, the current article name will be used. If ONLY-UNREAD is - ;; non-nil, only unread articles are chosen. If DO-NOT-TRANSLATE is + ;; nil, the current article name will be used. If ONLY-UNREAD is + ;; non-nil, only unread articles are chosen. If DO-NOT-TRANSLATE is ;; non-nil, article names are not equalized before sorting. (let ((subject (or subject (gnus-uu-reginize-string (gnus-summary-article-subject)))) @@ -1025,24 +1111,23 @@ (= mark gnus-dormant-mark)) (setq subj (mail-header-subject (gnus-data-header d))) (string-match subject subj) - (setq list-of-subjects - (cons (cons subj (gnus-data-number d)) - list-of-subjects))))) + (push (cons subj (gnus-data-number d)) + list-of-subjects)))) ;; Expand numbers, sort, and return the list of article ;; numbers. - (mapcar (lambda (sub) (cdr sub)) + (mapcar (lambda (sub) (cdr sub)) (sort (gnus-uu-expand-numbers list-of-subjects - (not do-not-translate)) + (not do-not-translate)) 'gnus-uu-string<)))))) (defun gnus-uu-expand-numbers (string-list &optional translate) ;; Takes a list of strings and "expands" all numbers in all the ;; strings. That is, this function makes all numbers equal length by - ;; prepending lots of zeroes before each number. This is to ease later + ;; prepending lots of zeroes before each number. This is to ease later ;; sorting to find out what sequence the articles are supposed to be - ;; decoded in. Returns the list of expanded strings. + ;; decoded in. Returns the list of expanded strings. (let ((out-list string-list) string) (save-excursion @@ -1057,9 +1142,9 @@ (replace-match " ")) ;; Translate all characters to "a". (goto-char (point-min)) - (if translate - (while (re-search-forward "[A-Za-z]" nil t) - (replace-match "a" t t))) + (when translate + (while (re-search-forward "[A-Za-z]" nil t) + (replace-match "a" t t))) ;; Expand numbers. (goto-char (point-min)) (while (re-search-forward "[0-9]+" nil t) @@ -1078,14 +1163,14 @@ ;; to apply to each article. ;; ;; The function to be called should take two parameters. The first -;; parameter is the article buffer. The function should leave the -;; result, if any, in this buffer. Most treatment functions will just +;; parameter is the article buffer. The function should leave the +;; result, if any, in this buffer. Most treatment functions will just ;; generate files... ;; ;; The second parameter is the state of the list of articles, and can ;; have four values: `first', `middle', `last' and `first-and-last'. ;; -;; The function should return a list. The list may contain the +;; The function should return a list. The list may contain the ;; following symbols: ;; `error' if an error occurred ;; `begin' if the beginning of an encoded file has been received @@ -1104,15 +1189,14 @@ (if (not (and gnus-uu-has-been-grabbed gnus-uu-unmark-articles-not-decoded)) () - (if dont-unmark-last-article - (progn - (setq art (car gnus-uu-has-been-grabbed)) - (setq gnus-uu-has-been-grabbed (cdr gnus-uu-has-been-grabbed)))) + (when dont-unmark-last-article + (setq art (car gnus-uu-has-been-grabbed)) + (setq gnus-uu-has-been-grabbed (cdr gnus-uu-has-been-grabbed))) (while gnus-uu-has-been-grabbed (gnus-summary-tick-article (car gnus-uu-has-been-grabbed) t) (setq gnus-uu-has-been-grabbed (cdr gnus-uu-has-been-grabbed))) - (if dont-unmark-last-article - (setq gnus-uu-has-been-grabbed (list art)))))) + (when dont-unmark-last-article + (setq gnus-uu-has-been-grabbed (list art)))))) ;; This function takes a list of articles and a function to apply to ;; each article grabbed. @@ -1121,7 +1205,8 @@ ;; the process-function has been successful and nil otherwise. (defun gnus-uu-grab-articles (articles process-function &optional sloppy limit no-errors) - (let ((state 'first) + (let ((state 'first) + (gnus-asynchronous nil) has-been-begin article result-file result-files process-state gnus-summary-display-article-function gnus-article-display-hook gnus-article-prepare-hook @@ -1160,15 +1245,20 @@ ;; If this is the beginning of a decoded file, we push it ;; on to a list. (when (or (memq 'begin process-state) - (and (or (eq state 'first) + (and (or (eq state 'first) (eq state 'first-and-last)) (memq 'ok process-state))) - (if has-been-begin - ;; If there is a `result-file' here, that means that the - ;; file was unsuccessfully decoded, so we delete it. - (when (and result-file - (file-exists-p result-file)) - (delete-file result-file))) + (when has-been-begin + ;; If there is a `result-file' here, that means that the + ;; file was unsuccessfully decoded, so we delete it. + (when (and result-file + (file-exists-p result-file) + (not gnus-uu-be-dangerous) + (or (eq gnus-uu-be-dangerous t) + (gnus-y-or-n-p + (format "Delete unsuccessfully decoded file %s" + result-file)))) + (delete-file result-file))) (when (memq 'begin process-state) (setq result-file (car process-state))) (setq has-been-begin t)) @@ -1192,6 +1282,7 @@ (setq funcs (list funcs))) (while funcs (funcall (pop funcs) result-file)))) + (setq result-file nil) ;; Check whether we have decoded enough articles. (and limit (= (length result-files) limit) (setq articles nil))) @@ -1203,6 +1294,9 @@ (not (memq 'end process-state)) result-file (file-exists-p result-file) + (not gnus-uu-be-dangerous) + (or (eq gnus-uu-be-dangerous t) + (gnus-y-or-n-p (format "Delete incomplete file %s? " result-file))) (delete-file result-file)) ;; If this was a file of the wrong sort, then @@ -1230,7 +1324,7 @@ (gnus-message 2 "Wrong type file")) ((memq 'error process-state) (gnus-message 2 "An error occurred during decoding")) - ((not (or (memq 'ok process-state) + ((not (or (memq 'ok process-state) (memq 'end process-state))) (gnus-message 2 "End of articles reached before end of file"))) ;; Make unsuccessfully decoded articles unread. @@ -1299,6 +1393,7 @@ (let ((nnheader-file-name-translation-alist '((?/ . ?,) (? . ?_) (?* . ?_) (?$ . ?_)))) (nnheader-translate-file-chars (match-string 1)))) + (replace-match (concat "begin 644 " gnus-uu-file-name) t t) ;; Remove any non gnus-uu-body-line right after start. (forward-line 1) @@ -1308,7 +1403,7 @@ ;; If a process is running, we kill it. (when (and gnus-uu-uudecode-process - (memq (process-status gnus-uu-uudecode-process) + (memq (process-status gnus-uu-uudecode-process) '(run stop))) (delete-process gnus-uu-uudecode-process) (gnus-uu-unmark-list-of-grabbed t)) @@ -1333,7 +1428,7 @@ ;; We look for the end of the thing to be decoded. (if (re-search-forward gnus-uu-end-string nil t) - (setq state (cons 'end state)) + (push 'end state) (goto-char (point-max)) (re-search-backward gnus-uu-body-line nil t)) @@ -1358,9 +1453,8 @@ (if (memq 'end state) (progn ;; Send an EOF, just in case. - (condition-case () - (process-send-eof gnus-uu-uudecode-process) - (error nil)) + (ignore-errors + (process-send-eof gnus-uu-uudecode-process)) (while (memq (process-status gnus-uu-uudecode-process) '(open run)) (accept-process-output gnus-uu-uudecode-process 1))) @@ -1388,7 +1482,9 @@ (call-process-region start-char (point-max) shell-file-name nil (get-buffer-create gnus-uu-output-buffer-name) nil - shell-command-switch (concat "cd " gnus-uu-work-dir " ; sh")))) + shell-command-switch + (concat "cd " gnus-uu-work-dir " " + gnus-shell-command-separator " sh")))) state)) ;; Returns the name of what the shar file is going to unpack. @@ -1396,8 +1492,8 @@ (let ((oldpoint (point)) res) (goto-char (point-min)) - (if (re-search-forward gnus-uu-shar-name-marker nil t) - (setq res (buffer-substring (match-beginning 1) (match-end 1)))) + (when (re-search-forward gnus-uu-shar-name-marker nil t) + (setq res (buffer-substring (match-beginning 1) (match-end 1)))) (goto-char oldpoint) res)) @@ -1409,25 +1505,25 @@ (case-fold-search t) rule action) (and - (or no-ignore - (and (not - (and gnus-uu-ignore-files-by-name - (string-match gnus-uu-ignore-files-by-name file-name))) - (not - (and gnus-uu-ignore-files-by-type - (string-match gnus-uu-ignore-files-by-type - (or (gnus-uu-choose-action - file-name gnus-uu-ext-to-mime-list t) - "")))))) + (unless no-ignore + (and (not + (and gnus-uu-ignore-files-by-name + (string-match gnus-uu-ignore-files-by-name file-name))) + (not + (and gnus-uu-ignore-files-by-type + (string-match gnus-uu-ignore-files-by-type + (or (gnus-uu-choose-action + file-name gnus-uu-ext-to-mime-list t) + "")))))) (while (not (or (eq action-list ()) action)) (setq rule (car action-list)) (setq action-list (cdr action-list)) - (if (string-match (car rule) file-name) - (setq action (cadr rule))))) + (when (string-match (car rule) file-name) + (setq action (cadr rule))))) action)) (defun gnus-uu-treat-archive (file-path) - ;; Unpacks an archive. Returns t if unpacking is successful. + ;; Unpacks an archive. Returns t if unpacking is successful. (let ((did-unpack t) action command dir) (setq action (gnus-uu-choose-action @@ -1436,13 +1532,14 @@ nil gnus-uu-default-archive-rules)))) - (if (not action) (error "No unpackers for the file %s" file-path)) + (when (not action) + (error "No unpackers for the file %s" file-path)) (string-match "/[^/]*$" file-path) (setq dir (substring file-path 0 (match-beginning 0))) - (if (member action gnus-uu-destructive-archivers) - (copy-file file-path (concat file-path "~") t)) + (when (member action gnus-uu-destructive-archivers) + (copy-file file-path (concat file-path "~") t)) (setq command (format "cd %s ; %s" dir (gnus-uu-command action file-path))) @@ -1459,8 +1556,8 @@ (gnus-message 2 "Error during unpacking of archive") (setq did-unpack nil)) - (if (member action gnus-uu-destructive-archivers) - (rename-file (concat file-path "~") file-path t)) + (when (member action gnus-uu-destructive-archivers) + (rename-file (concat file-path "~") file-path t)) did-unpack)) @@ -1470,7 +1567,7 @@ (while dirs (if (file-directory-p (setq file (car dirs))) (setq files (append files (gnus-uu-dir-files file))) - (setq files (cons file files))) + (push file files)) (setq dirs (cdr dirs))) files)) @@ -1481,22 +1578,21 @@ file did-unpack) (while files (setq file (cdr (assq 'name (car files)))) - (if (and (not (member file ignore)) - (equal (gnus-uu-get-action (file-name-nondirectory file)) - "gnus-uu-archive")) - (progn - (setq did-unpack (cons file did-unpack)) - (or (gnus-uu-treat-archive file) - (gnus-message 2 "Error during unpacking of %s" file)) - (let* ((newfiles (gnus-uu-ls-r gnus-uu-work-dir)) - (nfiles newfiles)) - (while nfiles - (or (member (car nfiles) totfiles) - (setq ofiles (cons (list (cons 'name (car nfiles)) - (cons 'original file)) - ofiles))) - (setq nfiles (cdr nfiles))) - (setq totfiles newfiles)))) + (when (and (not (member file ignore)) + (equal (gnus-uu-get-action (file-name-nondirectory file)) + "gnus-uu-archive")) + (push file did-unpack) + (unless (gnus-uu-treat-archive file) + (gnus-message 2 "Error during unpacking of %s" file)) + (let* ((newfiles (gnus-uu-ls-r gnus-uu-work-dir)) + (nfiles newfiles)) + (while nfiles + (unless (member (car nfiles) totfiles) + (push (list (cons 'name (car nfiles)) + (cons 'original file)) + ofiles)) + (setq nfiles (cdr nfiles))) + (setq totfiles newfiles))) (setq files (cdr files))) (if did-unpack (gnus-uu-unpack-files ofiles (append did-unpack ignore)) @@ -1506,10 +1602,9 @@ (let* ((files (gnus-uu-directory-files dir t)) (ofiles files)) (while files - (if (file-directory-p (car files)) - (progn - (setq ofiles (delete (car files) ofiles)) - (setq ofiles (append ofiles (gnus-uu-ls-r (car files)))))) + (when (file-directory-p (car files)) + (setq ofiles (delete (car files) ofiles)) + (setq ofiles (append ofiles (gnus-uu-ls-r (car files))))) (setq files (cdr files))) ofiles)) @@ -1521,8 +1616,8 @@ (while files (setq file (car files)) (setq files (cdr files)) - (or (member (file-name-nondirectory file) '("." "..")) - (setq out (cons file out)))) + (unless (member (file-name-nondirectory file) '("." "..")) + (push file out))) (setq out (nreverse out)) out)) @@ -1538,25 +1633,25 @@ (goto-char start) (while (not (eobp)) (progn - (if (looking-at "\n") (replace-match "")) + (when (looking-at "\n") + (replace-match "")) (forward-line 1)))) (while (not (eobp)) (if (looking-at (concat gnus-uu-begin-string "\\|" gnus-uu-end-string)) () - (if (not found) - (progn - (beginning-of-line) - (setq beg (point)) - (end-of-line) - (setq length (- (point) beg)))) + (when (not found) + (beginning-of-line) + (setq beg (point)) + (end-of-line) + (setq length (- (point) beg))) (setq found t) (beginning-of-line) (setq beg (point)) (end-of-line) - (if (not (= length (- (point) beg))) - (insert (make-string (- length (- (point) beg)) ? )))) + (when (not (= length (- (point) beg))) + (insert (make-string (- length (- (point) beg)) ? )))) (forward-line 1))))))) (defvar gnus-uu-tmp-alist nil) @@ -1564,28 +1659,27 @@ (defun gnus-uu-initialize (&optional scan) (let (entry) (if (and (not scan) - (if (setq entry (assoc gnus-newsgroup-name gnus-uu-tmp-alist)) - (if (file-exists-p (cdr entry)) - (setq gnus-uu-work-dir (cdr entry)) - (setq gnus-uu-tmp-alist (delq entry gnus-uu-tmp-alist)) - nil))) + (when (setq entry (assoc gnus-newsgroup-name gnus-uu-tmp-alist)) + (if (file-exists-p (cdr entry)) + (setq gnus-uu-work-dir (cdr entry)) + (setq gnus-uu-tmp-alist (delq entry gnus-uu-tmp-alist)) + nil))) t (setq gnus-uu-tmp-dir (file-name-as-directory (expand-file-name gnus-uu-tmp-dir))) (if (not (file-directory-p gnus-uu-tmp-dir)) (error "Temp directory %s doesn't exist" gnus-uu-tmp-dir) - (if (not (file-writable-p gnus-uu-tmp-dir)) - (error "Temp directory %s can't be written to" - gnus-uu-tmp-dir))) + (when (not (file-writable-p gnus-uu-tmp-dir)) + (error "Temp directory %s can't be written to" + gnus-uu-tmp-dir))) (setq gnus-uu-work-dir (make-temp-name (concat gnus-uu-tmp-dir "gnus"))) - (if (not (file-directory-p gnus-uu-work-dir)) - (gnus-make-directory gnus-uu-work-dir)) + (gnus-make-directory gnus-uu-work-dir) (set-file-modes gnus-uu-work-dir 448) (setq gnus-uu-work-dir (file-name-as-directory gnus-uu-work-dir)) - (setq gnus-uu-tmp-alist (cons (cons gnus-newsgroup-name gnus-uu-work-dir) - gnus-uu-tmp-alist))))) + (push (cons gnus-newsgroup-name gnus-uu-work-dir) + gnus-uu-tmp-alist)))) ;; Kills the temporary uu buffers, kills any processes, etc. @@ -1595,23 +1689,29 @@ (memq (process-status (or gnus-uu-uudecode-process "nevair")) '(stop run)) (delete-process gnus-uu-uudecode-process)) - (and (setq buf (get-buffer gnus-uu-output-buffer-name)) - (kill-buffer buf)))) + (when (setq buf (get-buffer gnus-uu-output-buffer-name)) + (kill-buffer buf)))) -;; Inputs an action and a file and returns a full command, putting -;; quotes round the file name and escaping any quotes in the file name. +(defun gnus-quote-arg-for-sh-or-csh (arg) + (let ((pos 0) new-pos accum) + ;; *** bug: we don't handle newline characters properly + (while (setq new-pos (string-match "[!`\"$\\& \t]" arg pos)) + (push (substring arg pos new-pos) accum) + (push "\\" accum) + (push (list (aref arg new-pos)) accum) + (setq pos (1+ new-pos))) + (if (= pos 0) + arg + (apply 'concat (nconc (nreverse accum) (list (substring arg pos))))))) + +;; Inputs an action and a filename and returns a full command, making sure +;; that the filename will be treated as a single argument when the shell +;; executes the command. (defun gnus-uu-command (action file) - (let ((ofile "")) - (while (string-match "!\\|`\\|\"\\|\\$\\|\\\\\\|&" file) - (progn - (setq ofile - (concat ofile (substring file 0 (match-beginning 0)) "\\" - (substring file (match-beginning 0) (match-end 0)))) - (setq file (substring file (1+ (match-beginning 0)))))) - (setq ofile (concat "\"" ofile file "\"")) + (let ((quoted-file (gnus-quote-arg-for-sh-or-csh file))) (if (string-match "%s" action) - (format action ofile) - (concat action " " ofile)))) + (format action quoted-file) + (concat action " " quoted-file)))) (defun gnus-uu-delete-work-dir (&optional dir) "Delete recursively all files and directories under `gnus-uu-work-dir'." @@ -1643,40 +1743,53 @@ ;;; ;; Any function that is to be used as and encoding method will take two -;; parameters: PATH-NAME and FILE-NAME. (E.g. "/home/gaga/spiral.jpg" +;; parameters: PATH-NAME and FILE-NAME. (E.g. "/home/gaga/spiral.jpg" ;; and "spiral.jpg", respectively.) The function should return nil if ;; the encoding wasn't successful. -(defvar gnus-uu-post-encode-method 'gnus-uu-post-encode-uuencode +(defcustom gnus-uu-post-encode-method 'gnus-uu-post-encode-uuencode "Function used for encoding binary files. There are three functions supplied with gnus-uu for encoding files: `gnus-uu-post-encode-uuencode', which does straight uuencoding; `gnus-uu-post-encode-mime', which encodes with base64 and adds MIME headers; and `gnus-uu-post-encode-mime-uuencode', which encodes with -uuencode and adds MIME headers.") +uuencode and adds MIME headers." + :group 'gnus-extract-post + :type '(radio (function-item gnus-uu-post-encode-uuencode) + (function-item gnus-uu-post-encode-mime) + (function-item gnus-uu-post-encode-mime-uuencode) + (function :tag "Other"))) -(defvar gnus-uu-post-include-before-composing nil +(defcustom gnus-uu-post-include-before-composing nil "Non-nil means that gnus-uu will ask for a file to encode before you compose the article. If this variable is t, you can either include an encoded file with -\\[gnus-uu-post-insert-binary-in-article] or have one included for you when you post the article.") +\\[gnus-uu-post-insert-binary-in-article] or have one included for you when you post the article." + :group 'gnus-extract-post + :type 'boolean) -(defvar gnus-uu-post-length 990 +(defcustom gnus-uu-post-length 990 "Maximum length of an article. The encoded file will be split into how many articles it takes to -post the entire file.") +post the entire file." + :group 'gnus-extract-post + :type 'integer) -(defvar gnus-uu-post-threaded nil +(defcustom gnus-uu-post-threaded nil "Non-nil means that gnus-uu will post the encoded file in a thread. This may not be smart, as no other decoder I have seen are able to -follow threads when collecting uuencoded articles. (Well, I have seen +follow threads when collecting uuencoded articles. (Well, I have seen one package that does that - gnus-uu, but somehow, I don't think that -counts...) Default is nil.") +counts...) Default is nil." + :group 'gnus-extract-post + :type 'boolean) -(defvar gnus-uu-post-separate-description t +(defcustom gnus-uu-post-separate-description t "Non-nil means that the description will be posted in a separate article. -The first article will typically be numbered (0/x). If this variable +The first article will typically be numbered (0/x). If this variable is nil, the description the user enters will be included at the -beginning of the first article, which will be numbered (1/x). Default -is t.") +beginning of the first article, which will be numbered (1/x). Default +is t." + :group 'gnus-extract-post + :type 'boolean) (defvar gnus-uu-post-binary-separator "--binary follows this line--") (defvar gnus-uu-post-message-id nil) @@ -1697,9 +1810,9 @@ (local-set-key "\C-c\C-s" 'gnus-uu-post-news-inews) (local-set-key "\C-c\C-i" 'gnus-uu-post-insert-binary-in-article) - (if gnus-uu-post-include-before-composing - (save-excursion (setq gnus-uu-post-inserted-file-name - (gnus-uu-post-insert-binary))))) + (when gnus-uu-post-include-before-composing + (save-excursion (setq gnus-uu-post-inserted-file-name + (gnus-uu-post-insert-binary))))) (defun gnus-uu-post-insert-binary-in-article () "Inserts an encoded file in the buffer. @@ -1710,33 +1823,30 @@ ;; Encodes with uuencode and substitutes all spaces with backticks. (defun gnus-uu-post-encode-uuencode (path file-name) - (if (gnus-uu-post-encode-file "uuencode" path file-name) - (progn - (goto-char (point-min)) - (forward-line 1) - (while (re-search-forward " " nil t) - (replace-match "`")) - t))) + (when (gnus-uu-post-encode-file "uuencode" path file-name) + (goto-char (point-min)) + (forward-line 1) + (while (re-search-forward " " nil t) + (replace-match "`")) + t)) ;; Encodes with uuencode and adds MIME headers. (defun gnus-uu-post-encode-mime-uuencode (path file-name) - (if (gnus-uu-post-encode-uuencode path file-name) - (progn - (gnus-uu-post-make-mime file-name "x-uue") - t))) + (when (gnus-uu-post-encode-uuencode path file-name) + (gnus-uu-post-make-mime file-name "x-uue") + t)) ;; Encodes with base64 and adds MIME headers (defun gnus-uu-post-encode-mime (path file-name) - (if (gnus-uu-post-encode-file "mmencode" path file-name) - (progn - (gnus-uu-post-make-mime file-name "base64") - t))) + (when (gnus-uu-post-encode-file "mmencode" path file-name) + (gnus-uu-post-make-mime file-name "base64") + t)) ;; Adds MIME headers. (defun gnus-uu-post-make-mime (file-name encoding) (goto-char (point-min)) (insert (format "Content-Type: %s; name=\"%s\"\n" - (gnus-uu-choose-action file-name gnus-uu-ext-to-mime-list) + (gnus-uu-choose-action file-name gnus-uu-ext-to-mime-list) file-name)) (insert (format "Content-Transfer-Encoding: %s\n\n" encoding)) (save-restriction @@ -1745,10 +1855,9 @@ (re-search-forward (concat "^" (regexp-quote mail-header-separator) "$")) (forward-line -1) (narrow-to-region 1 (point)) - (or (mail-fetch-field "mime-version") - (progn - (widen) - (insert "MIME-Version: 1.0\n"))) + (unless (mail-fetch-field "mime-version") + (widen) + (insert "MIME-Version: 1.0\n")) (widen))) ;; Encodes a file PATH with COMMAND, leaving the result in the @@ -1778,39 +1887,38 @@ (setq gnus-inews-article-hook (if (listp gnus-inews-article-hook) gnus-inews-article-hook (list gnus-inews-article-hook))) - (setq gnus-inews-article-hook - (cons - '(lambda () - (save-excursion - (goto-char (point-min)) - (if (re-search-forward "^Message-ID: \\(.*\\)$" nil t) - (setq gnus-uu-post-message-id - (buffer-substring - (match-beginning 1) (match-end 1))) - (setq gnus-uu-post-message-id nil)))) - gnus-inews-article-hook)) + (push + '(lambda () + (save-excursion + (goto-char (point-min)) + (if (re-search-forward "^Message-ID: \\(.*\\)$" nil t) + (setq gnus-uu-post-message-id + (buffer-substring + (match-beginning 1) (match-end 1))) + (setq gnus-uu-post-message-id nil)))) + gnus-inews-article-hook) (gnus-uu-post-encoded file-name t)) (gnus-uu-post-encoded file-name nil))) (setq gnus-uu-post-inserted-file-name nil) - (and gnus-uu-winconf-post-news - (set-window-configuration gnus-uu-winconf-post-news))) + (when gnus-uu-winconf-post-news + (set-window-configuration gnus-uu-winconf-post-news))) ;; Asks for a file to encode, encodes it and inserts the result in -;; the current buffer. Returns the file name the user gave. +;; the current buffer. Returns the file name the user gave. (defun gnus-uu-post-insert-binary () (let ((uuencode-buffer-name "*uuencode buffer*") file-path uubuf file-name) (setq file-path (read-file-name "What file do you want to encode? ")) - (if (not (file-exists-p file-path)) - (error "%s: No such file" file-path)) + (when (not (file-exists-p file-path)) + (error "%s: No such file" file-path)) (goto-char (point-max)) (insert (format "\n%s\n" gnus-uu-post-binary-separator)) - (if (string-match "^~/" file-path) - (setq file-path (concat "$HOME" (substring file-path 1)))) + (when (string-match "^~/" file-path) + (setq file-path (concat "$HOME" (substring file-path 1)))) (if (string-match "/[^/]*$" file-path) (setq file-name (substring file-path (1+ (match-beginning 0)))) (setq file-name file-path)) @@ -1838,12 +1946,13 @@ (setq post-buf (current-buffer)) (goto-char (point-min)) - (if (not (re-search-forward - (if gnus-uu-post-separate-description - (concat "^" (regexp-quote gnus-uu-post-binary-separator) - "$") - (concat "^" (regexp-quote mail-header-separator) "$")) nil t)) - (error "Internal error: No binary/header separator")) + (when (not (re-search-forward + (if gnus-uu-post-separate-description + (concat "^" (regexp-quote gnus-uu-post-binary-separator) + "$") + (concat "^" (regexp-quote mail-header-separator) "$")) + nil t)) + (error "Internal error: No binary/header separator")) (beginning-of-line) (forward-line 1) (setq beg-binary (point)) @@ -1856,11 +1965,11 @@ (goto-char (point-min)) (setq length (count-lines 1 (point-max))) (setq parts (/ length gnus-uu-post-length)) - (if (not (< (% length gnus-uu-post-length) 4)) - (setq parts (1+ parts)))) + (when (not (< (% length gnus-uu-post-length) 4)) + (setq parts (1+ parts)))) - (if gnus-uu-post-separate-description - (forward-line -1)) + (when gnus-uu-post-separate-description + (forward-line -1)) (kill-region (point) (point-max)) (goto-char (point-min)) @@ -1872,10 +1981,9 @@ (goto-char (point-min)) (if (not gnus-uu-post-separate-description) () - (if (and (not threaded) (re-search-forward "^Subject: " nil t)) - (progn - (end-of-line) - (insert (format " (0/%d)" parts)))) + (when (and (not threaded) (re-search-forward "^Subject: " nil t)) + (end-of-line) + (insert (format " (0/%d)" parts))) (message-send)) (save-excursion @@ -1885,17 +1993,17 @@ (set-buffer (get-buffer-create send-buffer-name)) (erase-buffer) (insert header) - (if (and threaded gnus-uu-post-message-id) - (insert (format "References: %s\n" gnus-uu-post-message-id))) + (when (and threaded gnus-uu-post-message-id) + (insert (format "References: %s\n" gnus-uu-post-message-id))) (insert separator) (setq whole-len (- 62 (length (format top-string "" file-name i parts "")))) - (if (> 1 (setq minlen (/ whole-len 2))) - (setq minlen 1)) + (when (> 1 (setq minlen (/ whole-len 2))) + (setq minlen 1)) (setq beg-line (format top-string - (make-string minlen ?-) + (make-string minlen ?-) file-name i parts (make-string (if (= 0 (% whole-len 2)) (1- minlen) minlen) ?-))) @@ -1907,9 +2015,9 @@ (progn (end-of-line) (insert (format " (%d/%d)" i parts))) - (if (or (and (= i 2) gnus-uu-post-separate-description) - (and (= i 1) (not gnus-uu-post-separate-description))) - (replace-match "Subject: Re: ")))) + (when (or (and (= i 2) gnus-uu-post-separate-description) + (and (= i 1) (not gnus-uu-post-separate-description))) + (replace-match "Subject: Re: ")))) (goto-char (point-max)) (save-excursion @@ -1918,8 +2026,8 @@ (if (= i parts) (goto-char (point-max)) (forward-line gnus-uu-post-length)) - (if (and (= (1+ i) parts) (< (count-lines (point) (point-max)) 4)) - (forward-line -4)) + (when (and (= (1+ i) parts) (< (count-lines (point) (point-max)) 4)) + (forward-line -4)) (setq end (point))) (insert-buffer-substring uubuf beg end) (insert beg-line) @@ -1931,26 +2039,25 @@ (concat "^" (regexp-quote mail-header-separator) "$") nil t) (beginning-of-line) (forward-line 2) - (if (re-search-forward - (concat "^" (regexp-quote gnus-uu-post-binary-separator) "$") - nil t) - (progn - (replace-match "") - (forward-line 1))) + (when (re-search-forward + (concat "^" (regexp-quote gnus-uu-post-binary-separator) "$") + nil t) + (replace-match "") + (forward-line 1)) (insert beg-line) (insert "\n") (let (message-sent-message-via) (message-send)))) - (and (setq buf (get-buffer send-buffer-name)) - (kill-buffer buf)) - (and (setq buf (get-buffer encoded-buffer-name)) - (kill-buffer buf)) + (when (setq buf (get-buffer send-buffer-name)) + (kill-buffer buf)) + (when (setq buf (get-buffer encoded-buffer-name)) + (kill-buffer buf)) - (if (not gnus-uu-post-separate-description) - (progn - (set-buffer-modified-p nil) - (and (fboundp 'bury-buffer) (bury-buffer)))))) + (when (not gnus-uu-post-separate-description) + (set-buffer-modified-p nil) + (when (fboundp 'bury-buffer) + (bury-buffer))))) (provide 'gnus-uu) diff -r ad457d5f7d04 -r 0293115a14e9 lisp/gnus/gnus-vm.el --- a/lisp/gnus/gnus-vm.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/gnus/gnus-vm.el Mon Aug 13 08:49:20 2007 +0200 @@ -1,7 +1,7 @@ ;;; gnus-vm.el --- vm interface for Gnus -;; Copyright (C) 1994,95,96 Free Software Foundation, Inc. +;; Copyright (C) 1994,95,96,97 Free Software Foundation, Inc. -;; Author: Per Persson +;; Author: Per Persson ;; Keywords: news, mail ;; This file is part of GNU Emacs. @@ -48,12 +48,12 @@ (or gnus-vm-inhibit-window-system (condition-case nil - (if window-system - (require 'win-vm)) + (when window-system + (require 'win-vm)) (error nil))) -(if (not (featurep 'vm)) - (load "vm")) +(when (not (featurep 'vm)) + (load "vm")) (defun gnus-vm-make-folder (&optional buffer) (let ((article (or buffer (current-buffer))) @@ -94,7 +94,7 @@ (cond ((eq folder 'default) default-name) (folder folder) (t (gnus-read-save-file-name - "Save article in VM folder:" default-name)))) + "Save %s in VM folder:" default-name)))) (gnus-make-directory (file-name-directory folder)) (set-buffer gnus-original-article-buffer) (save-excursion diff -r ad457d5f7d04 -r 0293115a14e9 lisp/gnus/gnus-win.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus/gnus-win.el Mon Aug 13 08:49:20 2007 +0200 @@ -0,0 +1,550 @@ +;;; gnus-win.el --- window configuration functions for Gnus +;; Copyright (C) 1996,97 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen +;; Keywords: news + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;;; Code: + +(require 'gnus) + +(defgroup gnus-windows nil + "Window configuration." + :group 'gnus) + +(defcustom gnus-use-full-window t + "*If non-nil, use the entire Emacs screen." + :group 'gnus-windows + :type 'boolean) + +(defvar gnus-window-configuration nil + "Obsolete variable. See `gnus-buffer-configuration'.") + +(defcustom gnus-window-min-width 2 + "*Minimum width of Gnus buffers." + :group 'gnus-windows + :type 'integer) + +(defcustom gnus-window-min-height 1 + "*Minimum height of Gnus buffers." + :group 'gnus-windows + :type 'integer) + +(defcustom gnus-always-force-window-configuration nil + "*If non-nil, always force the Gnus window configurations." + :group 'gnus-windows + :type 'boolean) + +(defvar gnus-buffer-configuration + '((group + (vertical 1.0 + (group 1.0 point) + (if gnus-carpal '(group-carpal 4)))) + (summary + (vertical 1.0 + (summary 1.0 point) + (if gnus-carpal '(summary-carpal 4)))) + (article + (cond + ((and gnus-use-picons + (eq gnus-picons-display-where 'picons)) + '(frame 1.0 + (vertical 1.0 + (summary 0.25 point) + (if gnus-carpal '(summary-carpal 4)) + (article 1.0)) + (vertical ((height . 5) (width . 15) + (user-position . t) + (left . -1) (top . 1)) + (picons 1.0)))) + (gnus-use-trees + '(vertical 1.0 + (summary 0.25 point) + (tree 0.25) + (article 1.0))) + (t + '(vertical 1.0 + (summary 0.25 point) + (if gnus-carpal '(summary-carpal 4)) + (article 1.0))))) + (server + (vertical 1.0 + (server 1.0 point) + (if gnus-carpal '(server-carpal 2)))) + (browse + (vertical 1.0 + (browse 1.0 point) + (if gnus-carpal '(browse-carpal 2)))) + (message + (vertical 1.0 + (message 1.0 point))) + (pick + (vertical 1.0 + (article 1.0 point))) + (info + (vertical 1.0 + (info 1.0 point))) + (summary-faq + (vertical 1.0 + (summary 0.25) + (faq 1.0 point))) + (edit-article + (vertical 1.0 + (article 1.0 point))) + (edit-form + (vertical 1.0 + (group 0.5) + (edit-form 1.0 point))) + (edit-score + (vertical 1.0 + (summary 0.25) + (edit-score 1.0 point))) + (post + (vertical 1.0 + (post 1.0 point))) + (reply + (vertical 1.0 + (article-copy 0.5) + (message 1.0 point))) + (forward + (vertical 1.0 + (message 1.0 point))) + (reply-yank + (vertical 1.0 + (message 1.0 point))) + (mail-bounce + (vertical 1.0 + (article 0.5) + (message 1.0 point))) + (draft + (vertical 1.0 + (draft 1.0 point))) + (pipe + (vertical 1.0 + (summary 0.25 point) + (if gnus-carpal '(summary-carpal 4)) + ("*Shell Command Output*" 1.0))) + (bug + (vertical 1.0 + ("*Gnus Help Bug*" 0.5) + ("*Gnus Bug*" 1.0 point))) + (score-trace + (vertical 1.0 + (summary 0.5 point) + ("*Score Trace*" 1.0))) + (score-words + (vertical 1.0 + (summary 0.5 point) + ("*Score Words*" 1.0))) + (compose-bounce + (vertical 1.0 + (article 0.5) + (message 1.0 point)))) + "Window configuration for all possible Gnus buffers. +See the Gnus manual for an explanation of the syntax used.") + +(defvar gnus-window-to-buffer + '((group . gnus-group-buffer) + (summary . gnus-summary-buffer) + (article . gnus-article-buffer) + (server . gnus-server-buffer) + (browse . "*Gnus Browse Server*") + (edit-group . gnus-group-edit-buffer) + (edit-form . gnus-edit-form-buffer) + (edit-server . gnus-server-edit-buffer) + (group-carpal . gnus-carpal-group-buffer) + (summary-carpal . gnus-carpal-summary-buffer) + (server-carpal . gnus-carpal-server-buffer) + (browse-carpal . gnus-carpal-browse-buffer) + (edit-score . gnus-score-edit-buffer) + (message . gnus-message-buffer) + (mail . gnus-message-buffer) + (post-news . gnus-message-buffer) + (faq . gnus-faq-buffer) + (picons . "*Picons*") + (tree . gnus-tree-buffer) + (info . gnus-info-buffer) + (article-copy . gnus-article-copy) + (draft . gnus-draft-buffer)) + "Mapping from short symbols to buffer names or buffer variables.") + +;;; Internal variables. + +(defvar gnus-current-window-configuration nil + "The most recently set window configuration.") + +(defvar gnus-created-frames nil) + +(defun gnus-kill-gnus-frames () + "Kill all frames Gnus has created." + (while gnus-created-frames + (when (frame-live-p (car gnus-created-frames)) + ;; We slap a condition-case around this `delete-frame' to ensure + ;; against errors if we try do delete the single frame that's left. + (ignore-errors + (delete-frame (car gnus-created-frames)))) + (pop gnus-created-frames))) + +(defun gnus-window-configuration-element (list) + (while (and list + (not (assq (car list) gnus-window-configuration))) + (pop list)) + (cadr (assq (car list) gnus-window-configuration))) + +(defun gnus-windows-old-to-new (setting) + ;; First we take care of the really, really old Gnus 3 actions. + (when (symbolp setting) + (setq setting + ;; Take care of ooold GNUS 3.x values. + (cond ((eq setting 'SelectArticle) 'article) + ((memq setting '(SelectNewsgroup SelectSubject ExpandSubject)) + 'summary) + ((memq setting '(ExitNewsgroup)) 'group) + (t setting)))) + (if (or (listp setting) + (not (and gnus-window-configuration + (memq setting '(group summary article))))) + setting + (let* ((elem + (cond + ((eq setting 'group) + (gnus-window-configuration-element + '(group newsgroups ExitNewsgroup))) + ((eq setting 'summary) + (gnus-window-configuration-element + '(summary SelectNewsgroup SelectSubject ExpandSubject))) + ((eq setting 'article) + (gnus-window-configuration-element + '(article SelectArticle))))) + (total (apply '+ elem)) + (types '(group summary article)) + (pbuf (if (eq setting 'newsgroups) 'group 'summary)) + (i 0) + perc out) + (while (< i 3) + (or (not (numberp (nth i elem))) + (zerop (nth i elem)) + (progn + (setq perc (if (= i 2) + 1.0 + (/ (float (nth i elem)) total))) + (push (if (eq pbuf (nth i types)) + (list (nth i types) perc 'point) + (list (nth i types) perc)) + out))) + (incf i)) + `(vertical 1.0 ,@(nreverse out))))) + +;;;###autoload +(defun gnus-add-configuration (conf) + "Add the window configuration CONF to `gnus-buffer-configuration'." + (setq gnus-buffer-configuration + (cons conf (delq (assq (car conf) gnus-buffer-configuration) + gnus-buffer-configuration)))) + +(defvar gnus-frame-list nil) + +(defun gnus-configure-frame (split &optional window) + "Split WINDOW according to SPLIT." + (unless window + (setq window (get-buffer-window (current-buffer)))) + (select-window window) + ;; This might be an old-stylee buffer config. + (when (vectorp split) + (setq split (append split nil))) + (when (or (consp (car split)) + (vectorp (car split))) + (push 1.0 split) + (push 'vertical split)) + ;; The SPLIT might be something that is to be evaled to + ;; return a new SPLIT. + (while (and (not (assq (car split) gnus-window-to-buffer)) + (gnus-functionp (car split))) + (setq split (eval split))) + (let* ((type (car split)) + (subs (cddr split)) + (len (if (eq type 'horizontal) (window-width) (window-height))) + (total 0) + (window-min-width (or gnus-window-min-width window-min-width)) + (window-min-height (or gnus-window-min-height window-min-height)) + s result new-win rest comp-subs size sub) + (cond + ;; Nothing to do here. + ((null split)) + ;; Don't switch buffers. + ((null type) + (and (memq 'point split) window)) + ;; This is a buffer to be selected. + ((not (memq type '(frame horizontal vertical))) + (let ((buffer (cond ((stringp type) type) + (t (cdr (assq type gnus-window-to-buffer))))) + buf) + (unless buffer + (error "Illegal buffer type: %s" type)) + (unless (setq buf (get-buffer (if (symbolp buffer) + (symbol-value buffer) buffer))) + (setq buf (get-buffer-create (if (symbolp buffer) + (symbol-value buffer) buffer)))) + (switch-to-buffer buf) + ;; We return the window if it has the `point' spec. + (and (memq 'point split) window))) + ;; This is a frame split. + ((eq type 'frame) + (unless gnus-frame-list + (setq gnus-frame-list (list (window-frame + (get-buffer-window (current-buffer)))))) + (let ((i 0) + params frame fresult) + (while (< i (length subs)) + ;; Frame parameter is gotten from the sub-split. + (setq params (cadr (elt subs i))) + ;; It should be a list. + (unless (listp params) + (setq params nil)) + ;; Create a new frame? + (unless (setq frame (elt gnus-frame-list i)) + (nconc gnus-frame-list (list (setq frame (make-frame params)))) + (push frame gnus-created-frames)) + ;; Is the old frame still alive? + (unless (frame-live-p frame) + (setcar (nthcdr i gnus-frame-list) + (setq frame (make-frame params)))) + ;; Select the frame in question and do more splits there. + (select-frame frame) + (setq fresult (or (gnus-configure-frame (elt subs i)) fresult)) + (incf i)) + ;; Select the frame that has the selected buffer. + (when fresult + (select-frame (window-frame fresult))))) + ;; This is a normal split. + (t + (when (> (length subs) 0) + ;; First we have to compute the sizes of all new windows. + (while subs + (setq sub (append (pop subs) nil)) + (while (and (not (assq (car sub) gnus-window-to-buffer)) + (gnus-functionp (car sub))) + (setq sub (eval sub))) + (when sub + (push sub comp-subs) + (setq size (cadar comp-subs)) + (cond ((equal size 1.0) + (setq rest (car comp-subs)) + (setq s 0)) + ((floatp size) + (setq s (floor (* size len)))) + ((integerp size) + (setq s size)) + (t + (error "Illegal size: %s" size))) + ;; Try to make sure that we are inside the safe limits. + (cond ((zerop s)) + ((eq type 'horizontal) + (setq s (max s window-min-width))) + ((eq type 'vertical) + (setq s (max s window-min-height)))) + (setcar (cdar comp-subs) s) + (incf total s))) + ;; Take care of the "1.0" spec. + (if rest + (setcar (cdr rest) (- len total)) + (error "No 1.0 specs in %s" split)) + ;; The we do the actual splitting in a nice recursive + ;; fashion. + (setq comp-subs (nreverse comp-subs)) + (while comp-subs + (if (null (cdr comp-subs)) + (setq new-win window) + (setq new-win + (split-window window (cadar comp-subs) + (eq type 'horizontal)))) + (setq result (or (gnus-configure-frame + (car comp-subs) window) + result)) + (select-window new-win) + (setq window new-win) + (setq comp-subs (cdr comp-subs)))) + ;; Return the proper window, if any. + (when result + (select-window result)))))) + +(defvar gnus-frame-split-p nil) + +(defun gnus-configure-windows (setting &optional force) + (setq gnus-current-window-configuration setting) + (setq force (or force gnus-always-force-window-configuration)) + (setq setting (gnus-windows-old-to-new setting)) + (let ((split (if (symbolp setting) + (cadr (assq setting gnus-buffer-configuration)) + setting)) + all-visible) + + (setq gnus-frame-split-p nil) + + (unless split + (error "No such setting: %s" setting)) + + (if (and (setq all-visible (gnus-all-windows-visible-p split)) + (not force)) + ;; All the windows mentioned are already visible, so we just + ;; put point in the assigned buffer, and do not touch the + ;; winconf. + (select-window all-visible) + + ;; Either remove all windows or just remove all Gnus windows. + (let ((frame (selected-frame))) + (unwind-protect + (if gnus-use-full-window + ;; We want to remove all other windows. + (if (not gnus-frame-split-p) + ;; This is not a `frame' split, so we ignore the + ;; other frames. + (delete-other-windows) + ;; This is a `frame' split, so we delete all windows + ;; on all frames. + (gnus-delete-windows-in-gnusey-frames)) + ;; Just remove some windows. + (gnus-remove-some-windows) + (switch-to-buffer nntp-server-buffer)) + (select-frame frame))) + + (switch-to-buffer nntp-server-buffer) + (gnus-configure-frame split (get-buffer-window (current-buffer)))))) + +(defun gnus-delete-windows-in-gnusey-frames () + "Do a `delete-other-windows' in all frames that have Gnus windows." + (let ((buffers + (mapcar + (lambda (elem) + (if (symbolp (cdr elem)) + (when (and (boundp (cdr elem)) + (symbol-value (cdr elem))) + (get-buffer (symbol-value (cdr elem)))) + (when (cdr elem) + (get-buffer (cdr elem))))) + gnus-window-to-buffer))) + (mapcar + (lambda (frame) + (unless (eq (cdr (assq 'minibuffer + (frame-parameters frame))) + 'only) + (select-frame frame) + (let (do-delete) + (walk-windows + (lambda (window) + (when (memq (window-buffer window) buffers) + (setq do-delete t)))) + (when do-delete + (delete-other-windows))))) + (frame-list)))) + +(defun gnus-all-windows-visible-p (split) + "Say whether all buffers in SPLIT are currently visible. +In particular, the value returned will be the window that +should have point." + (let ((stack (list split)) + (all-visible t) + type buffer win buf) + (while (and (setq split (pop stack)) + all-visible) + ;; Be backwards compatible. + (when (vectorp split) + (setq split (append split nil))) + (when (or (consp (car split)) + (vectorp (car split))) + (push 1.0 split) + (push 'vertical split)) + ;; The SPLIT might be something that is to be evaled to + ;; return a new SPLIT. + (while (and (not (assq (car split) gnus-window-to-buffer)) + (gnus-functionp (car split))) + (setq split (eval split))) + + (setq type (elt split 0)) + (cond + ;; Nothing here. + ((null split) t) + ;; A buffer. + ((not (memq type '(horizontal vertical frame))) + (setq buffer (cond ((stringp type) type) + (t (cdr (assq type gnus-window-to-buffer))))) + (unless buffer + (error "Illegal buffer type: %s" type)) + (when (setq buf (get-buffer (if (symbolp buffer) + (symbol-value buffer) + buffer))) + (setq win (get-buffer-window buf t))) + (if win + (when (memq 'point split) + (setq all-visible win)) + (setq all-visible nil))) + (t + (when (eq type 'frame) + (setq gnus-frame-split-p t)) + (setq stack (append (cddr split) stack))))) + (unless (eq all-visible t) + all-visible))) + +(defun gnus-window-top-edge (&optional window) + (nth 1 (window-edges window))) + +(defun gnus-remove-some-windows () + (let ((buffers gnus-window-to-buffer) + buf bufs lowest-buf lowest) + (save-excursion + ;; Remove windows on all known Gnus buffers. + (while buffers + (setq buf (cdar buffers)) + (when (symbolp buf) + (setq buf (and (boundp buf) (symbol-value buf)))) + (and buf + (get-buffer-window buf) + (progn + (push buf bufs) + (pop-to-buffer buf) + (when (or (not lowest) + (< (gnus-window-top-edge) lowest)) + (setq lowest (gnus-window-top-edge)) + (setq lowest-buf buf)))) + (setq buffers (cdr buffers))) + ;; Remove windows on *all* summary buffers. + (walk-windows + (lambda (win) + (let ((buf (window-buffer win))) + (when (string-match "^\\*Summary" (buffer-name buf)) + (push buf bufs) + (pop-to-buffer buf) + (when (or (not lowest) + (< (gnus-window-top-edge) lowest)) + (setq lowest-buf buf) + (setq lowest (gnus-window-top-edge))))))) + (when lowest-buf + (pop-to-buffer lowest-buf) + (switch-to-buffer nntp-server-buffer)) + (while bufs + (when (not (eq (car bufs) lowest-buf)) + (delete-windows-on (car bufs))) + (setq bufs (cdr bufs)))))) + +(provide 'gnus-win) + +;;; gnus-win.el ends here diff -r ad457d5f7d04 -r 0293115a14e9 lisp/gnus/gnus-xmas.el --- a/lisp/gnus/gnus-xmas.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/gnus/gnus-xmas.el Mon Aug 13 08:49:20 2007 +0200 @@ -1,5 +1,5 @@ ;;; gnus-xmas.el --- Gnus functions for XEmacs -;; Copyright (C) 1995,96 Free Software Foundation, Inc. +;; Copyright (C) 1995,96,97 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; Keywords: news @@ -26,7 +26,6 @@ ;;; Code: (require 'text-props) -(eval-when-compile (require 'cl)) (defvar menu-bar-mode (featurep 'menubar)) (require 'messagexmas) @@ -36,8 +35,8 @@ automatically.") (defvar gnus-xmas-logo-color-alist - '((flame "#cc3300" "#ff2200") - (pine "#c0cc93" "#f8ffb8") + '((flame "#cc3300" "#ff2200") + (pine "#c0cc93" "#f8ffb8") (moss "#a1cc93" "#d2ffb8") (irish "#04cc90" "#05ff97") (sky "#049acc" "#05deff") @@ -50,7 +49,7 @@ (september "#bf9900" "#ffcc00")) "Color alist used for the Gnus logo.") -(defvar gnus-xmas-logo-color-style 'september +(defvar gnus-xmas-logo-color-style 'flame "Color styles used for the Gnus logo.") (defvar gnus-xmas-logo-colors @@ -118,7 +117,7 @@ (defun gnus-xmas-set-text-properties (start end props &optional buffer) "You should NEVER use this function. It is ideologically blasphemous. It is provided only to ease porting of broken FSF Emacs programs." - (if (stringp buffer) + (if (stringp buffer) nil (map-extents (lambda (extent ignored) (remove-text-properties @@ -131,19 +130,26 @@ (defun gnus-xmas-highlight-selected-summary () ;; Highlight selected article in summary buffer (when gnus-summary-selected-face - (if gnus-newsgroup-selected-overlay - (delete-extent gnus-newsgroup-selected-overlay)) + (when gnus-newsgroup-selected-overlay + (delete-extent gnus-newsgroup-selected-overlay)) (setq gnus-newsgroup-selected-overlay - (make-extent (gnus-point-at-bol) (gnus-point-at-eol))) + (make-extent (point-at-bol) (point-at-eol))) (set-extent-face gnus-newsgroup-selected-overlay gnus-summary-selected-face))) +(defvar gnus-xmas-force-redisplay t + "If non-nil, force a redisplay before recentering the summary buffer. +This is ugly, but it works around a bug in `window-displayed-height'.") + (defun gnus-xmas-summary-recenter () "\"Center\" point in the summary window. If `gnus-auto-center-summary' is nil, or the article buffer isn't displayed, no centering will be performed." ;; Suggested by earle@mahendo.JPL.NASA.GOV (Greg Earle). ;; Recenter only when requested. Suggested by popovich@park.cs.columbia.edu. + ;; Force redisplay to get properly computed window height. + (when gnus-xmas-force-redisplay + (sit-for 0)) (when gnus-auto-center-summary (let* ((height (if (fboundp 'window-displayed-height) (window-displayed-height) @@ -161,8 +167,7 @@ ;; possible valid number, or the second line from the top, ;; whichever is the least. (set-window-start - window (min bottom (save-excursion - (forward-line (- top)) (point))))) + window (min bottom (save-excursion (forward-line (- top)) (point))))) ;; Do horizontal recentering while we're at it. (when (and (get-buffer-window (current-buffer) t) (not (eq gnus-auto-center-summary 'vertical))) @@ -197,7 +202,8 @@ (let* ((pos (event-closest-point event)) (data (get-text-property pos 'gnus-data)) (fun (get-text-property pos 'gnus-callback))) - (if fun (funcall fun data)))) + (when fun + (funcall fun data)))) (defun gnus-xmas-move-overlay (extent start end &optional buffer) (set-extent-endpoints extent start end)) @@ -205,9 +211,9 @@ ;; Fixed by Christopher Davis . (defun gnus-xmas-article-add-button (from to fun &optional data) "Create a button between FROM and TO with callback FUN and data DATA." - (and gnus-article-button-face - (gnus-overlay-put (gnus-make-overlay from to) - 'face gnus-article-button-face)) + (when gnus-article-button-face + (gnus-overlay-put (gnus-make-overlay from to) + 'face gnus-article-button-face)) (gnus-add-text-properties from to (nconc @@ -249,21 +255,18 @@ (next-bottom-edge (car (cdr (cdr (cdr (window-pixel-edges this-window))))))) - (if (< bottom-edge next-bottom-edge) - (progn - (setq bottom-edge next-bottom-edge) - (setq lowest-window this-window))) + (when (< bottom-edge next-bottom-edge) + (setq bottom-edge next-bottom-edge) + (setq lowest-window this-window)) (select-window this-window) - (if (eq last-window this-window) - (progn - (select-window lowest-window) - (setq window-search nil))))))) + (when (eq last-window this-window) + (select-window lowest-window) + (setq window-search nil)))))) (defmacro gnus-xmas-menu-add (type &rest menus) `(gnus-xmas-menu-add-1 ',type ',menus)) (put 'gnus-xmas-menu-add 'lisp-indent-function 1) -(put 'gnus-xmas-menu-add 'lisp-indent-hook 1) (defun gnus-xmas-menu-add-1 (type menus) (when (and menu-bar-mode @@ -293,6 +296,10 @@ (gnus-xmas-menu-add pick gnus-pick-menu)) +(defun gnus-xmas-topic-menu-add () + (gnus-xmas-menu-add topic + gnus-topic-menu)) + (defun gnus-xmas-binary-menu-add () (gnus-xmas-menu-add binary gnus-binary-menu)) @@ -315,12 +322,12 @@ (defun gnus-xmas-read-event-char () "Get the next event." - (let ((event (next-event))) + (let ((event (next-command-event))) + (sit-for 0) ;; We junk all non-key events. Is this naughty? (while (not (key-press-event-p event)) - (setq event (next-event))) + (setq event (next-command-event))) (cons (and (key-press-event-p event) - ; (numberp (event-key event)) (event-to-character event)) event))) @@ -365,14 +372,22 @@ (defun gnus-xmas-define () (setq gnus-mouse-2 [button2]) - (or (memq 'underline (face-list)) - (and (fboundp 'make-face) - (funcall (intern "make-face") 'underline))) + (unless (memq 'underline (face-list)) + (and (fboundp 'make-face) + (funcall (intern "make-face") 'underline))) ;; Must avoid calling set-face-underline-p directly, because it ;; is a defsubst in emacs19, and will make the .elc files non ;; portable! - (or (face-differs-from-default-p 'underline) - (funcall (intern "set-face-underline-p") 'underline t)) + (unless (face-differs-from-default-p 'underline) + (funcall (intern "set-face-underline-p") 'underline t)) + + (cond + ((fboundp 'char-or-char-int-p) + ;; Handle both types of marks for XEmacs-20.x. + (fset 'gnus-characterp 'char-or-char-int-p)) + ;; V19 of XEmacs, probably. + (t + (fset 'gnus-characterp 'characterp))) (fset 'gnus-make-overlay 'make-extent) (fset 'gnus-overlay-put 'set-extent-property) @@ -383,10 +398,15 @@ (fset 'gnus-put-text-property 'gnus-xmas-put-text-property) (require 'text-props) - (if (< emacs-minor-version 14) + (if (and (<= emacs-major-version 19) + (< emacs-minor-version 14)) (fset 'gnus-set-text-properties 'gnus-xmas-set-text-properties)) - (or (boundp 'standard-display-table) (setq standard-display-table nil)) + (when (fboundp 'turn-off-scroll-in-place) + (add-hook 'gnus-article-mode-hook 'turn-off-scroll-in-place)) + + (unless (boundp 'standard-display-table) + (setq standard-display-table nil)) (defvar gnus-mouse-face-prop 'highlight) @@ -406,57 +426,13 @@ (if (compiled-function-p fval) (list 'funcall fval) (cons 'progn (cdr (cdr fval)))))) - - ;; Fix by "jeff (j.d.) sparkes" . - (defvar gnus-display-type (device-class) - "A symbol indicating the display Emacs is running under. -The symbol should be one of `color', `grayscale' or `mono'. If Emacs -guesses this display attribute wrongly, either set this variable in -your `~/.emacs' or set the resource `Emacs.displayType' in your -`~/.Xdefaults'. See also `gnus-background-mode'. - -This is a meta-variable that will affect what default values other -variables get. You would normally not change this variable, but -pounce directly on the real variables themselves.") - (fset 'gnus-x-color-values (if (fboundp 'x-color-values) 'x-color-values (lambda (color) (color-instance-rgb-components - (make-color-instance color))))) - - (defvar gnus-background-mode - (let* ((bg-resource - (condition-case () - (x-get-resource ".backgroundMode" "BackgroundMode" 'string) - (error nil))) - (params (frame-parameters)) - (color (condition-case () - (or (assq 'background-color params) - (color-instance-name - (specifier-instance - (face-background 'default)))) - (error nil)))) - (cond (bg-resource (intern (downcase bg-resource))) - ((and color - (< (apply '+ (gnus-x-color-values color)) - (/ (apply '+ (gnus-x-color-values "white")) 3))) - 'dark) - (t 'light))) - "A symbol indicating the Emacs background brightness. -The symbol should be one of `light' or `dark'. -If Emacs guesses this frame attribute wrongly, either set this variable in -your `~/.emacs' or set the resource `Emacs.backgroundMode' in your -`~/.Xdefaults'. -See also `gnus-display-type'. - -This is a meta-variable that will affect what default values other -variables get. You would normally not change this variable, but -pounce directly on the real variables themselves.") - ) - + (make-color-instance color)))))) (defun gnus-xmas-redefine () @@ -477,9 +453,9 @@ (fset 'gnus-make-local-hook 'make-local-variable) (fset 'gnus-add-hook 'gnus-xmas-add-hook) (fset 'gnus-character-to-event 'character-to-event) - (fset 'gnus-article-show-hidden-text 'gnus-xmas-article-show-hidden-text) (fset 'gnus-mode-line-buffer-identification 'gnus-xmas-mode-line-buffer-identification) + (fset 'gnus-key-press-event-p 'key-press-event-p) (add-hook 'gnus-group-mode-hook 'gnus-xmas-group-menu-add) (add-hook 'gnus-summary-mode-hook 'gnus-xmas-summary-menu-add) @@ -487,6 +463,7 @@ (add-hook 'gnus-score-mode-hook 'gnus-xmas-score-menu-add) (add-hook 'gnus-pick-mode-hook 'gnus-xmas-pick-menu-add) + (add-hook 'gnus-topic-mode-hook 'gnus-xmas-topic-menu-add) (add-hook 'gnus-tree-mode-hook 'gnus-xmas-tree-menu-add) (add-hook 'gnus-binary-mode-hook 'gnus-xmas-binary-menu-add) (add-hook 'gnus-grouplens-mode-hook 'gnus-xmas-grouplens-menu-add) @@ -498,7 +475,8 @@ (when (and (<= emacs-major-version 19) (<= emacs-minor-version 13)) - (setq gnus-article-x-face-too-ugly (if (eq (device-type) 'tty) ".")) + (setq gnus-article-x-face-too-ugly (when (eq (device-type) 'tty) + ".")) (fset 'gnus-highlight-selected-summary 'gnus-xmas-highlight-selected-summary) (fset 'gnus-group-remove-excess-properties @@ -507,8 +485,7 @@ 'gnus-xmas-topic-remove-excess-properties) (fset 'gnus-mode-line-buffer-identification 'identity) (unless (boundp 'shell-command-switch) - (setq shell-command-switch "-c")) - )) + (setq shell-command-switch "-c")))) ;;; XEmacs logo and toolbar. @@ -570,7 +547,7 @@ " "")) ;; And then hack it. - (gnus-indent-rigidly (point-min) (point-max) + (gnus-indent-rigidly (point-min) (point-max) (/ (max (- (window-width) (or x 46)) 0) 2)) (goto-char (point-min)) (forward-line 1) @@ -580,13 +557,11 @@ (insert (make-string (max 0 (* 2 (/ rest 3))) ?\n)))) ;; Fontify some. (goto-char (point-min)) - (and (search-forward "Praxis" nil t) - (put-text-property (match-beginning 0) (match-end 0) 'face 'bold)) + (put-text-property (point-min) (point-max) 'face 'gnus-splash-face) (goto-char (point-min)) - (let* ((mode-string (gnus-group-set-mode-line))) - (setq modeline-buffer-identification - (list (concat gnus-version ": *Group*"))) - (set-buffer-modified-p t)))) + (setq modeline-buffer-identification + (list (concat gnus-version ": *Group*"))) + (set-buffer-modified-p t))) ;;; The toolbar. @@ -600,22 +575,22 @@ `right-toolbar', and `left-toolbar'.") (defvar gnus-group-toolbar - '( - [gnus-group-get-new-news gnus-group-get-new-news t "Get new news"] + '([gnus-group-get-new-news gnus-group-get-new-news t "Get new news"] [gnus-group-get-new-news-this-group gnus-group-get-new-news-this-group t "Get new news in this group"] [gnus-group-catchup-current gnus-group-catchup-current t "Catchup group"] [gnus-group-describe-group gnus-group-describe-group t "Describe group"] + [gnus-group-unsubscribe gnus-group-unsubscribe t "Unsubscribe group"] + [gnus-group-subscribe gnus-group-subscribe t "Subscribe group"] [gnus-group-kill-group gnus-group-kill-group t "Kill group"] [gnus-group-exit gnus-group-exit t "Exit Gnus"] ) "The group buffer toolbar.") (defvar gnus-summary-toolbar - '( - [gnus-summary-prev-unread + '([gnus-summary-prev-unread gnus-summary-prev-unread-article t "Prev unread article"] [gnus-summary-next-unread gnus-summary-next-unread-article t "Next unread article"] @@ -642,6 +617,8 @@ gnus-uu-post-news t "Post an uuencoded article"] [gnus-summary-cancel-article gnus-summary-cancel-article t "Cancel article"] + [gnus-summary-catchup + gnus-summary-catchup t "Catchup"] [gnus-summary-catchup-and-exit gnus-summary-catchup-and-exit t "Catchup and exit"] [gnus-summary-exit gnus-summary-exit t "Exit this summary"] @@ -655,7 +632,7 @@ [gnus-summary-next-unread gnus-summary-next-unread-article t "Next unread article"] [gnus-summary-mail-reply gnus-summary-reply t "Reply"] - [gnus-summary-mail-get gnus-mail-get t "Message get"] +; [gnus-summary-mail-get gnus-mail-get t "Message get"] [gnus-summary-mail-originate gnus-summary-post-news t "Originate"] [gnus-summary-mail-save gnus-summary-save-article t "Save"] [gnus-summary-mail-copy gnus-summary-copy-article t "Copy message"] @@ -671,6 +648,8 @@ gnus-summary-save-article-file t "Save article in file"] [gnus-summary-save-article gnus-summary-save-article t "Save article"] + [gnus-summary-catchup + gnus-summary-catchup t "Catchup"] [gnus-summary-catchup-and-exit gnus-summary-catchup-and-exit t "Catchup and exit"] [gnus-summary-exit gnus-summary-exit t "Exit this summary"] @@ -735,36 +714,50 @@ (set-extent-begin-glyph (make-extent (point) (1+ (point))) xface-glyph)))) -(defun gnus-xmas-article-show-hidden-text (type &optional hide) - "Show all hidden text of type TYPE. -If HIDE, hide the text instead." - (save-excursion - (set-buffer gnus-article-buffer) - (let ((buffer-read-only nil) - (inhibit-point-motion-hooks t) - (beg (point-min))) - (while (gnus-goto-char (text-property-any - beg (point-max) 'gnus-type type)) - (setq beg (point)) - (forward-char) - (if hide - (gnus-hide-text beg (point) gnus-hidden-properties) - (gnus-unhide-text beg (point))) - (setq beg (point))) - (save-window-excursion - (select-window (get-buffer-window (current-buffer))) - (recenter)) - t))) +(defvar gnus-xmas-pointer-glyph + (progn + (setq gnus-xmas-glyph-directory (message-xmas-find-glyph-directory "gnus")) + (make-pointer-glyph (concat gnus-xmas-glyph-directory "gnus-pointer." + (if (featurep 'xpm) "xpm" "xbm"))))) + +(defvar gnus-xmas-modeline-left-extent + (let ((ext (copy-extent modeline-buffer-id-left-extent))) + ;(set-extent-property ext 'pointer gnus-xmas-pointer-glyph) + ext)) + +(defvar gnus-xmas-modeline-right-extent + (let ((ext (copy-extent modeline-buffer-id-right-extent))) + ;(set-extent-property ext 'pointer gnus-xmas-pointer-glyph) + ext)) + +(defvar gnus-xmas-modeline-glyph + (progn + (setq gnus-xmas-glyph-directory (message-xmas-find-glyph-directory "gnus")) + (let* ((file (concat gnus-xmas-glyph-directory "gnus-pointer." + (if (featurep 'xpm) "xpm" "xbm"))) + (glyph (make-glyph file))) + (when (and (featurep 'x) + (file-exists-p file)) + (set-glyph-face glyph 'modeline-buffer-id)) + (set-glyph-property glyph 'image (cons 'tty "Gnus:")) + glyph))) (defun gnus-xmas-mode-line-buffer-identification (line) (let ((line (car line)) chop) (if (not (stringp line)) (list line) - (unless (setq chop (string-match ":" line)) - (setq chop (/ (length line) 2))) - (list (cons modeline-buffer-id-left-extent (substring line 0 chop)) - (cons modeline-buffer-id-right-extent (substring line chop)))))) + (when (string-match "^Gnus:" line) + (setq chop (match-end 0)) + (list + (if gnus-xmas-modeline-glyph + (cons gnus-xmas-modeline-left-extent gnus-xmas-modeline-glyph) + (cons gnus-xmas-modeline-left-extent (substring line 0 chop))) + (cons gnus-xmas-modeline-right-extent (substring line chop))))))) + +(defun gnus-xmas-splash () + (when (eq (device-type) 'x) + (gnus-splash))) (provide 'gnus-xmas) diff -r ad457d5f7d04 -r 0293115a14e9 lisp/gnus/gnus.el --- a/lisp/gnus/gnus.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/gnus/gnus.el Mon Aug 13 08:49:20 2007 +0200 @@ -1,5 +1,5 @@ ;;; gnus.el --- a newsreader for GNU Emacs -;; Copyright (C) 1987,88,89,90,93,94,95,96 Free Software Foundation, Inc. +;; Copyright (C) 1987,88,89,90,93,94,95,96,97 Free Software Foundation, Inc. ;; Author: Masanobu UMEDA ;; Lars Magne Ingebrigtsen @@ -28,4502 +28,593 @@ (eval '(run-hooks 'gnus-load-hook)) -(require 'mail-utils) -(require 'timezone) -(require 'nnheader) -(require 'nnmail) -(require 'nnoo) - -(eval-when-compile (require 'cl)) - -(defvar gnus-directory (or (getenv "SAVEDIR") "~/News/") - "*Directory variable from which all other Gnus file variables are derived.") - -;; Site dependent variables. These variables should be defined in -;; paths.el. - -(defvar gnus-default-nntp-server nil - "Specify a default NNTP server. -This variable should be defined in paths.el, and should never be set -by the user. -If you want to change servers, you should use `gnus-select-method'. -See the documentation to that variable.") - -(defvar gnus-backup-default-subscribed-newsgroups - '("news.announce.newusers" "news.groups.questions" "gnu.emacs.gnus") - "Default default new newsgroups the first time Gnus is run. -Should be set in paths.el, and shouldn't be touched by the user.") - -(defvar gnus-local-domain nil - "Local domain name without a host name. -The DOMAINNAME environment variable is used instead if it is defined. -If the `system-name' function returns the full Internet name, there is -no need to set this variable.") - -(defvar gnus-local-organization nil - "String with a description of what organization (if any) the user belongs to. -The ORGANIZATION environment variable is used instead if it is defined. -If this variable contains a function, this function will be called -with the current newsgroup name as the argument. The function should -return a string. - -In any case, if the string (either in the variable, in the environment -variable, or returned by the function) is a file name, the contents of -this file will be used as the organization.") - -;; Customization variables +(require 'custom) +(require 'gnus-load) -;; Don't touch this variable. -(defvar gnus-nntp-service "nntp" - "*NNTP service name (\"nntp\" or 119). -This is an obsolete variable, which is scarcely used. If you use an -nntp server for your newsgroup and want to change the port number -used to 899, you would say something along these lines: - - (setq gnus-select-method '(nntp \"my.nntp.server\" (nntp-port-number 899)))") - -(defvar gnus-nntpserver-file "/etc/nntpserver" - "*A file with only the name of the nntp server in it.") - -;; This function is used to check both the environment variable -;; NNTPSERVER and the /etc/nntpserver file to see whether one can find -;; an nntp server name default. -(defun gnus-getenv-nntpserver () - (or (getenv "NNTPSERVER") - (and (file-readable-p gnus-nntpserver-file) - (save-excursion - (set-buffer (get-buffer-create " *gnus nntp*")) - (buffer-disable-undo (current-buffer)) - (insert-file-contents gnus-nntpserver-file) - (let ((name (buffer-string))) - (prog1 - (if (string-match "^[ \t\n]*$" name) - nil - name) - (kill-buffer (current-buffer)))))))) - -(defvar gnus-select-method - (nconc - (list 'nntp (or (condition-case () - (gnus-getenv-nntpserver) - (error nil)) - (if (and gnus-default-nntp-server - (not (string= gnus-default-nntp-server ""))) - gnus-default-nntp-server) - (system-name))) - (if (or (null gnus-nntp-service) - (equal gnus-nntp-service "nntp")) - nil - (list gnus-nntp-service))) - "*Default method for selecting a newsgroup. -This variable should be a list, where the first element is how the -news is to be fetched, the second is the address. - -For instance, if you want to get your news via NNTP from -\"flab.flab.edu\", you could say: - -(setq gnus-select-method '(nntp \"flab.flab.edu\")) - -If you want to use your local spool, say: - -(setq gnus-select-method (list 'nnspool (system-name))) - -If you use this variable, you must set `gnus-nntp-server' to nil. +(defgroup gnus nil + "The coffee-brewing, all singing, all dancing, kitchen sink newsreader." + :group 'emacs) -There is a lot more to know about select methods and virtual servers - -see the manual for details.") - -(defvar gnus-message-archive-method - `(nnfolder - "archive" - (nnfolder-directory ,(nnheader-concat message-directory "archive")) - (nnfolder-active-file - ,(nnheader-concat message-directory "archive/active")) - (nnfolder-get-new-mail nil) - (nnfolder-inhibit-expiry t)) - "*Method used for archiving messages you've sent. -This should be a mail method. - -It's probably not a very effective to change this variable once you've -run Gnus once. After doing that, you must edit this server from the -server buffer.") - -(defvar gnus-message-archive-group nil - "*Name of the group in which to save the messages you've written. -This can either be a string, a list of strings; or an alist -of regexps/functions/forms to be evaluated to return a string (or a list -of strings). The functions are called with the name of the current -group (or nil) as a parameter. - -If you want to save your mail in one group and the news articles you -write in another group, you could say something like: - - \(setq gnus-message-archive-group - '((if (message-news-p) - \"misc-news\" - \"misc-mail\"))) - -Normally the group names returned by this variable should be -unprefixed -- which implictly means \"store on the archive server\". -However, you may wish to store the message on some other server. In -that case, just return a fully prefixed name of the group -- -\"nnml+private:mail.misc\", for instance.") - -(defvar gnus-refer-article-method nil - "*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 -nntp method, you might get acceptable results. - -The value of this variable must be a valid select method as discussed -in the documentation of `gnus-select-method'.") +(defgroup gnus-start nil + "Starting your favorite newsreader." + :group 'gnus) -(defvar gnus-secondary-select-methods nil - "*A list of secondary methods that will be used for reading news. -This is a list where each element is a complete select method (see -`gnus-select-method'). - -If, for instance, you want to read your mail with the nnml backend, -you could set this variable: - -(setq gnus-secondary-select-methods '((nnml \"\")))") - -(defvar gnus-secondary-servers nil - "*List of NNTP servers that the user can choose between interactively. -To make Gnus query you for a server, you have to give `gnus' a -non-numeric prefix - `C-u M-x gnus', in short.") - -(defvar gnus-nntp-server nil - "*The name of the host running the NNTP server. -This variable is semi-obsolete. Use the `gnus-select-method' -variable instead.") - -(defvar gnus-startup-file "~/.newsrc" - "*Your `.newsrc' file. -`.newsrc-SERVER' will be used instead if that exists.") - -(defvar gnus-init-file "~/.gnus" - "*Your Gnus elisp startup file. -If a file with the .el or .elc suffixes exist, it will be read -instead.") - -(defvar gnus-group-faq-directory - '("/ftp@mirrors.aol.com:/pub/rtfm/usenet/" - "/ftp@sunsite.auc.dk:/pub/usenet/" - "/ftp@sunsite.doc.ic.ac.uk:/pub/usenet/news-faqs/" - "/ftp@src.doc.ic.ac.uk:/usenet/news-FAQS/" - "/ftp@ftp.seas.gwu.edu:/pub/rtfm/" - "/ftp@rtfm.mit.edu:/pub/usenet/" - "/ftp@ftp.uni-paderborn.de:/pub/FAQ/" - "/ftp@ftp.sunet.se:/pub/usenet/" - "/ftp@nctuccca.edu.tw:/USENET/FAQ/" - "/ftp@hwarang.postech.ac.kr:/pub/usenet/" - "/ftp@ftp.hk.super.net:/mirror/faqs/") - "*Directory where the group FAQs are stored. -This will most commonly be on a remote machine, and the file will be -fetched by ange-ftp. - -This variable can also be a list of directories. In that case, the -first element in the list will be used by default. The others can -be used when being prompted for a site. - -Note that Gnus uses an aol machine as the default directory. If this -feels fundamentally unclean, just think of it as a way to finally get -something of value back from them. - -If the default site is too slow, try one of these: +;; These belong to gnus-group.el. +(defgroup gnus-group nil + "Group buffers." + :link '(custom-manual "(gnus)The Group Buffer") + :group 'gnus) - North America: mirrors.aol.com /pub/rtfm/usenet - ftp.seas.gwu.edu /pub/rtfm - rtfm.mit.edu /pub/usenet - Europe: ftp.uni-paderborn.de /pub/FAQ - src.doc.ic.ac.uk /usenet/news-FAQS - ftp.sunet.se /pub/usenet - sunsite.auc.dk /pub/usenet - Asia: nctuccca.edu.tw /USENET/FAQ - hwarang.postech.ac.kr /pub/usenet - ftp.hk.super.net /mirror/faqs") - -(defvar gnus-group-archive-directory - "/ftp@ftp.hpc.uh.edu:/pub/emacs/ding-list/" - "*The address of the (ding) archives.") - -(defvar gnus-group-recent-archive-directory - "/ftp@ftp.hpc.uh.edu:/pub/emacs/ding-list-recent/" - "*The address of the most recent (ding) articles.") - -(defvar gnus-default-subscribed-newsgroups nil - "*This variable lists what newsgroups should be subscribed the first time Gnus is used. -It should be a list of strings. -If it is `t', Gnus will not do anything special the first time it is -started; it'll just use the normal newsgroups subscription methods.") - -(defvar gnus-use-cross-reference t - "*Non-nil means that cross referenced articles will be marked as read. -If nil, ignore cross references. If t, mark articles as read in -subscribed newsgroups. If neither t nor nil, mark as read in all -newsgroups.") - -(defvar gnus-single-article-buffer t - "*If non-nil, display all articles in the same buffer. -If nil, each group will get its own article buffer.") - -(defvar gnus-use-dribble-file t - "*Non-nil means that Gnus will use a dribble file to store user updates. -If Emacs should crash without saving the .newsrc files, complete -information can be restored from the dribble file.") - -(defvar gnus-dribble-directory nil - "*The directory where dribble files will be saved. -If this variable is nil, the directory where the .newsrc files are -saved will be used.") - -(defvar gnus-asynchronous nil - "*If non-nil, Gnus will supply backends with data needed for async article fetching.") +(defgroup gnus-group-foreign nil + "Foreign groups." + :link '(custom-manual "(gnus)Foreign Groups") + :group 'gnus-group) -(defvar gnus-kill-summary-on-exit t - "*If non-nil, kill the summary buffer when you exit from it. -If nil, the summary will become a \"*Dead Summary*\" buffer, and -it will be killed sometime later.") - -(defvar gnus-large-newsgroup 200 - "*The number of articles which indicates a large newsgroup. -If the number of articles in a newsgroup is greater than this value, -confirmation is required for selecting the newsgroup.") - -;; Suggested by Andrew Eskilsson . -(defvar gnus-no-groups-message "No news is horrible news" - "*Message displayed by Gnus when no groups are available.") - -(defvar gnus-use-long-file-name (not (memq system-type '(usg-unix-v xenix))) - "*Non-nil means that the default name of a file to save articles in is the group name. -If it's nil, the directory form of the group name is used instead. - -If this variable is a list, and the list contains the element -`not-score', long file names will not be used for score files; if it -contains the element `not-save', long file names will not be used for -saving; and if it contains the element `not-kill', long file names -will not be used for kill files. - -Note that the default for this variable varies according to what system -type you're using. On `usg-unix-v' and `xenix' this variable defaults -to nil while on all other systems it defaults to t.") - -(defvar gnus-article-save-directory gnus-directory - "*Name of the directory articles will be saved in (default \"~/News\").") - -(defvar gnus-kill-files-directory gnus-directory - "*Name of the directory where kill files will be stored (default \"~/News\").") - -(defvar gnus-default-article-saver 'gnus-summary-save-in-rmail - "*A function to save articles in your favorite format. -The function must be interactively callable (in other words, it must -be an Emacs command). - -Gnus provides the following functions: - -* gnus-summary-save-in-rmail (Rmail format) -* gnus-summary-save-in-mail (Unix mail format) -* gnus-summary-save-in-folder (MH folder) -* gnus-summary-save-in-file (article format). -* gnus-summary-save-in-vm (use VM's folder format).") - -(defvar gnus-prompt-before-saving 'always - "*This variable says how much prompting is to be done when saving articles. -If it is nil, no prompting will be done, and the articles will be -saved to the default files. If this variable is `always', each and -every article that is saved will be preceded by a prompt, even when -saving large batches of articles. If this variable is neither nil not -`always', there the user will be prompted once for a file name for -each invocation of the saving commands.") +(defgroup gnus-group-levels nil + "Group levels." + :link '(custom-manual "(gnus)Group Levels") + :group 'gnus-group) -(defvar gnus-rmail-save-name (function gnus-plain-save-name) - "*A function generating a file name to save articles in Rmail format. -The function is called with NEWSGROUP, HEADERS, and optional LAST-FILE.") - -(defvar gnus-mail-save-name (function gnus-plain-save-name) - "*A function generating a file name to save articles in Unix mail format. -The function is called with NEWSGROUP, HEADERS, and optional LAST-FILE.") - -(defvar gnus-folder-save-name (function gnus-folder-save-name) - "*A function generating a file name to save articles in MH folder. -The function is called with NEWSGROUP, HEADERS, and optional LAST-FOLDER.") - -(defvar gnus-file-save-name (function gnus-numeric-save-name) - "*A function generating a file name to save articles in article format. -The function is called with NEWSGROUP, HEADERS, and optional -LAST-FILE.") - -(defvar gnus-split-methods - '((gnus-article-archive-name)) - "*Variable used to suggest where articles are to be saved. -For instance, if you would like to save articles related to Gnus in -the file \"gnus-stuff\", and articles related to VM in \"vm-stuff\", -you could set this variable to something like: - - '((\"^Subject:.*gnus\\|^Newsgroups:.*gnus\" \"gnus-stuff\") - (\"^Subject:.*vm\\|^Xref:.*vm\" \"vm-stuff\")) - -This variable is an alist where the where the key is the match and the -value is a list of possible files to save in if the match is non-nil. - -If the match is a string, it is used as a regexp match on the -article. If the match is a symbol, that symbol will be funcalled -from the buffer of the article to be saved with the newsgroup as the -parameter. If it is a list, it will be evaled in the same buffer. - -If this form or function returns a string, this string will be used as -a possible file name; and if it returns a non-nil list, that list will -be used as possible file names.") - -(defvar gnus-move-split-methods nil - "*Variable used to suggest where articles are to be moved to. -It uses the same syntax as the `gnus-split-methods' variable.") - -(defvar gnus-save-score nil - "*If non-nil, save group scoring info.") - -(defvar gnus-use-adaptive-scoring nil - "*If non-nil, use some adaptive scoring scheme.") +(defgroup gnus-group-select nil + "Selecting a Group." + :link '(custom-manual "(gnus)Selecting a Group") + :group 'gnus-group) -(defvar gnus-use-cache 'passive - "*If nil, Gnus will ignore the article cache. -If `passive', it will allow entering (and reading) articles -explicitly entered into the cache. If anything else, use the -cache to the full extent of the law.") - -(defvar gnus-use-trees nil - "*If non-nil, display a thread tree buffer.") - -(defvar gnus-use-grouplens nil - "*If non-nil, use GroupLens ratings.") - -(defvar gnus-keep-backlog nil - "*If non-nil, Gnus will keep read articles for later re-retrieval. -If it is a number N, then Gnus will only keep the last N articles -read. If it is neither nil nor a number, Gnus will keep all read -articles. This is not a good idea.") - -(defvar gnus-use-nocem nil - "*If non-nil, Gnus will read NoCeM cancel messages.") - -(defvar gnus-use-demon nil - "If non-nil, Gnus might use some demons.") - -(defvar gnus-use-scoring t - "*If non-nil, enable scoring.") - -(defvar gnus-use-picons nil - "*If non-nil, display picons.") - -(defvar 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 read (or -just marked as read) article, the old article will not normally be -displayed in the Summary buffer. If this variable is non-nil, Gnus -will attempt to grab the headers to the old articles, and thereby -build complete threads. If it has the value `some', only enough -headers to connect otherwise loose threads will be displayed. -This variable can also be a number. In that case, no more than that -number of old headers will be fetched. - -The server has to support NOV for any of this to work.") - -;see gnus-cus.el -;(defvar gnus-visual t -; "*If non-nil, will do various highlighting. -;If nil, no mouse highlights (or any other highlights) will be -;performed. This might speed up Gnus some when generating large group -;and summary buffers.") - -(defvar gnus-novice-user t - "*Non-nil means that you are a usenet novice. -If non-nil, verbose messages may be displayed and confirmations may be -required.") - -(defvar gnus-expert-user nil - "*Non-nil means that you will never be asked for confirmation about anything. -And that means *anything*.") +(defgroup gnus-group-listing nil + "Showing slices of the group list." + :link '(custom-manual "(gnus)Listing Groups") + :group 'gnus-group) -(defvar gnus-verbose 7 - "*Integer that says how verbose Gnus should be. -The higher the number, the more messages Gnus will flash to say what -it's doing. At zero, Gnus will be totally mute; at five, Gnus will -display most important messages; and at ten, Gnus will keep on -jabbering all the time.") - -(defvar gnus-keep-same-level nil - "*Non-nil means that the next newsgroup after the current will be on the same level. -When you type, for instance, `n' after reading the last article in the -current newsgroup, you will go to the next newsgroup. If this variable -is nil, the next newsgroup will be the next from the group -buffer. -If this variable is non-nil, Gnus will either put you in the -next newsgroup with the same level, or, if no such newsgroup is -available, the next newsgroup with the lowest possible level higher -than the current level. -If this variable is `best', Gnus will make the next newsgroup the one -with the best level.") - -(defvar gnus-summary-make-false-root 'adopt - "*nil means that Gnus won't gather loose threads. -If the root of a thread has expired or been read in a previous -session, the information necessary to build a complete thread has been -lost. Instead of having many small sub-threads from this original thread -scattered all over the summary buffer, Gnus can gather them. - -If non-nil, Gnus will try to gather all loose sub-threads from an -original thread into one large thread. - -If this variable is non-nil, it should be one of `none', `adopt', -`dummy' or `empty'. - -If this variable is `none', Gnus will not make a false root, but just -present the sub-threads after another. -If this variable is `dummy', Gnus will create a dummy root that will -have all the sub-threads as children. -If this variable is `adopt', Gnus will make one of the \"children\" -the parent and mark all the step-children as such. -If this variable is `empty', the \"children\" are printed with empty -subject fields. (Or rather, they will be printed with a string -given by the `gnus-summary-same-subject' variable.)") - -(defvar gnus-summary-gather-exclude-subject "^ *$\\|^(none)$" - "*A regexp to match subjects to be excluded from loose thread gathering. -As loose thread gathering is done on subjects only, that means that -there can be many false gatherings performed. By rooting out certain -common subjects, gathering might become saner.") +(defgroup gnus-group-visual nil + "Sorting the group buffer." + :link '(custom-manual "(gnus)Group Buffer Format") + :group 'gnus-group + :group 'gnus-visual) -(defvar gnus-summary-gather-subject-limit nil - "*Maximum length of subject comparisons when gathering loose threads. -Use nil to compare full subjects. Setting this variable to a low -number will help gather threads that have been corrupted by -newsreaders chopping off subject lines, but it might also mean that -unrelated articles that have subject that happen to begin with the -same few characters will be incorrectly gathered. - -If this variable is `fuzzy', Gnus will use a fuzzy algorithm when -comparing subjects.") - -(defvar gnus-simplify-ignored-prefixes nil - "*Regexp, matches for which are removed from subject lines when simplifying fuzzily.") - -(defvar gnus-build-sparse-threads nil - "*If non-nil, fill in the gaps in threads. -If `some', only fill in the gaps that are needed to tie loose threads -together. If `more', fill in all leaf nodes that Gnus can find. If -non-nil and non-`some', fill in all gaps that Gnus manages to guess.") - -(defvar gnus-summary-thread-gathering-function 'gnus-gather-threads-by-subject - "Function used for gathering loose threads. -There are two pre-defined functions: `gnus-gather-threads-by-subject', -which only takes Subjects into consideration; and -`gnus-gather-threads-by-references', which compared the References -headers of the articles to find matches.") - -;; Added by Per Abrahamsen . -(defvar gnus-summary-same-subject "" - "*String indicating that the current article has the same subject as the previous. -This variable will only be used if the value of -`gnus-summary-make-false-root' is `empty'.") - -(defvar gnus-summary-goto-unread t - "*If non-nil, marking commands will go to the next unread article. -If `never', \\\\[gnus-summary-next-page] will go to the next article, -whether it is read or not.") - -(defvar gnus-group-goto-unread t - "*If non-nil, movement commands will go to the next unread and subscribed group.") - -(defvar gnus-goto-next-group-when-activating t - "*If non-nil, the \\\\[gnus-group-get-new-news-this-group] command will advance point to the next group.") - -(defvar gnus-check-new-newsgroups t - "*Non-nil means that Gnus will run gnus-find-new-newsgroups at startup. -This normally finds new newsgroups by comparing the active groups the -servers have already reported with those Gnus already knows, either alive -or killed. +(defgroup gnus-group-various nil + "Various group options." + :link '(custom-manual "(gnus)Scanning New Messages") + :group 'gnus-group) -When any of the following are true, gnus-find-new-newsgroups will instead -ask the servers (primary, secondary, and archive servers) to list new -groups since the last time it checked: - 1. This variable is `ask-server'. - 2. This variable is a list of select methods (see below). - 3. `gnus-read-active-file' is nil or `some'. - 4. A prefix argument is given to gnus-find-new-newsgroups interactively. - -Thus, if this variable is `ask-server' or a list of select methods or -`gnus-read-active-file' is nil or `some', then the killed list is no -longer necessary, so you could safely set `gnus-save-killed-list' to nil. - -This variable can be a list of select methods which Gnus will query with -the `ask-server' method in addition to the primary, secondary, and archive -servers. - -Eg. - (setq gnus-check-new-newsgroups - '((nntp \"some.server\") (nntp \"other.server\"))) - -If this variable is nil, then you have to tell Gnus explicitly to -check for new newsgroups with \\\\[gnus-find-new-newsgroups].") - -(defvar gnus-check-bogus-newsgroups nil - "*Non-nil means that Gnus will check and remove bogus newsgroup at startup. -If this variable is nil, then you have to tell Gnus explicitly to -check for bogus newsgroups with \\\\[gnus-group-check-bogus-groups].") - -(defvar gnus-read-active-file t - "*Non-nil means that Gnus will read the entire active file at startup. -If this variable is nil, Gnus will only know about the groups in your -`.newsrc' file. - -If this variable is `some', Gnus will try to only read the relevant -parts of the active file from the server. Not all servers support -this, and it might be quite slow with other servers, but this should -generally be faster than both the t and nil value. - -If you set this variable to nil or `some', you probably still want to -be told about new newsgroups that arrive. To do that, set -`gnus-check-new-newsgroups' to `ask-server'. This may not work -properly with all servers.") - -(defvar gnus-level-subscribed 5 - "*Groups with levels less than or equal to this variable are subscribed.") - -(defvar gnus-level-unsubscribed 7 - "*Groups with levels less than or equal to this variable are unsubscribed. -Groups with levels less than `gnus-level-subscribed', which should be -less than this variable, are subscribed.") - -(defvar gnus-level-zombie 8 - "*Groups with this level are zombie groups.") +;; These belong to gnus-sum.el. +(defgroup gnus-summary nil + "Summary buffers." + :link '(custom-manual "(gnus)The Summary Buffer") + :group 'gnus) -(defvar gnus-level-killed 9 - "*Groups with this level are killed.") - -(defvar gnus-level-default-subscribed 3 - "*New subscribed groups will be subscribed at this level.") - -(defvar gnus-level-default-unsubscribed 6 - "*New unsubscribed groups will be unsubscribed at this level.") - -(defvar gnus-activate-level (1+ gnus-level-subscribed) - "*Groups higher than this level won't be activated on startup. -Setting this variable to something log might save lots of time when -you have many groups that you aren't interested in.") - -(defvar gnus-activate-foreign-newsgroups 4 - "*If nil, Gnus will not check foreign newsgroups at startup. -If it is non-nil, it should be a number between one and nine. Foreign -newsgroups that have a level lower or equal to this number will be -activated on startup. For instance, if you want to active all -subscribed newsgroups, but not the rest, you'd set this variable to -`gnus-level-subscribed'. - -If you subscribe to lots of newsgroups from different servers, startup -might take a while. By setting this variable to nil, you'll save time, -but you won't be told how many unread articles there are in the -groups.") - -(defvar gnus-save-newsrc-file t - "*Non-nil means that Gnus will save the `.newsrc' file. -Gnus always saves its own startup file, which is called -\".newsrc.eld\". The file called \".newsrc\" is in a format that can -be readily understood by other newsreaders. If you don't plan on -using other newsreaders, set this variable to nil to save some time on -exit.") - -(defvar gnus-save-killed-list t - "*If non-nil, save the list of killed groups to the startup file. -If you set this variable to nil, you'll save both time (when starting -and quitting) and space (both memory and disk), but it will also mean -that Gnus has no record of which groups are new and which are old, so -the automatic new newsgroups subscription methods become meaningless. - -You should always set `gnus-check-new-newsgroups' to `ask-server' or -nil if you set this variable to nil.") - -(defvar gnus-interactive-catchup t - "*If non-nil, require your confirmation when catching up a group.") - -(defvar gnus-interactive-exit t - "*If non-nil, require your confirmation when exiting Gnus.") - -(defvar gnus-kill-killed t - "*If non-nil, Gnus will apply kill files to already killed articles. -If it is nil, Gnus will never apply kill files to articles that have -already been through the scoring process, which might very well save lots -of time.") +(defgroup gnus-summary-exit nil + "Leaving summary buffers." + :link '(custom-manual "(gnus)Exiting the Summary Buffer") + :group 'gnus-summary) -(defvar gnus-extract-address-components 'gnus-extract-address-components - "*Function for extracting address components from a From header. -Two pre-defined function exist: `gnus-extract-address-components', -which is the default, quite fast, and too simplistic solution, and -`mail-extract-address-components', which works much better, but is -slower.") - -(defvar gnus-summary-default-score 0 - "*Default article score level. -If this variable is nil, scoring will be disabled.") - -(defvar gnus-summary-zcore-fuzz 0 - "*Fuzziness factor for the zcore in the summary buffer. -Articles with scores closer than this to `gnus-summary-default-score' -will not be marked.") - -(defvar gnus-simplify-subject-fuzzy-regexp nil - "*Strings to be removed when doing fuzzy matches. -This can either be a regular expression or list of regular expressions -that will be removed from subject strings if fuzzy subject -simplification is selected.") - -(defvar gnus-permanently-visible-groups nil - "*Regexp to match groups that should always be listed in the group buffer. -This means that they will still be listed when there are no unread -articles in the groups.") - -(defvar gnus-list-groups-with-ticked-articles t - "*If non-nil, list groups that have only ticked articles. -If nil, only list groups that have unread articles.") - -(defvar gnus-group-default-list-level gnus-level-subscribed - "*Default listing level. -Ignored if `gnus-group-use-permanent-levels' is non-nil.") - -(defvar gnus-group-use-permanent-levels nil - "*If non-nil, once you set a level, Gnus will use this level.") - -(defvar gnus-group-list-inactive-groups t - "*If non-nil, inactive groups will be listed.") - -(defvar gnus-show-mime nil - "*If non-nil, do mime processing of articles. -The articles will simply be fed to the function given by -`gnus-show-mime-method'.") - -(defvar gnus-strict-mime t - "*If nil, MIME-decode even if there is no Mime-Version header in the article.") +(defgroup gnus-summary-marks nil + "Marks used in summary buffers." + :link '(custom-manual "(gnus)Marking Articles") + :group 'gnus-summary) -(defvar gnus-show-mime-method 'metamail-buffer - "*Function to process a MIME message. -The function is called from the article buffer.") - -(defvar gnus-decode-encoded-word-method (lambda ()) - "*Function to decode a MIME encoded-words. -The function is called from the article buffer.") - -(defvar gnus-show-threads t - "*If non-nil, display threads in summary mode.") - -(defvar gnus-thread-hide-subtree nil - "*If non-nil, hide all threads initially. -If threads are hidden, you have to run the command -`gnus-summary-show-thread' by hand or use `gnus-select-article-hook' -to expose hidden threads.") - -(defvar gnus-thread-hide-killed t - "*If non-nil, hide killed threads automatically.") - -(defvar gnus-thread-ignore-subject nil - "*If non-nil, ignore subjects and do all threading based on the Reference header. -If nil, which is the default, articles that have different subjects -from their parents will start separate threads.") - -(defvar gnus-thread-operation-ignore-subject t - "*If non-nil, subjects will be ignored when doing thread commands. -This affects commands like `gnus-summary-kill-thread' and -`gnus-summary-lower-thread'. - -If this variable is nil, articles in the same thread with different -subjects will not be included in the operation in question. If this -variable is `fuzzy', only articles that have subjects that are fuzzily -equal will be included.") - -(defvar gnus-thread-indent-level 4 - "*Number that says how much each sub-thread should be indented.") - -(defvar gnus-ignored-newsgroups - (purecopy (mapconcat 'identity - '("^to\\." ; not "real" groups - "^[0-9. \t]+ " ; all digits in name - "[][\"#'()]" ; bogus characters - ) - "\\|")) - "*A regexp to match uninteresting newsgroups in the active file. -Any lines in the active file matching this regular expression are -removed from the newsgroup list before anything else is done to it, -thus making them effectively non-existent.") - -(defvar gnus-ignored-headers - "^Path:\\|^Posting-Version:\\|^Article-I.D.:\\|^Expires:\\|^Date-Received:\\|^References:\\|^Control:\\|^Xref:\\|^Lines:\\|^Posted:\\|^Relay-Version:\\|^Message-ID:\\|^Nf-ID:\\|^Nf-From:\\|^Approved:\\|^Sender:\\|^Received:\\|^Mail-from:" - "*All headers that match this regexp will be hidden. -This variable can also be a list of regexps of headers to be ignored. -If `gnus-visible-headers' is non-nil, this variable will be ignored.") +(defgroup gnus-thread nil + "Ordering articles according to replies." + :link '(custom-manual "(gnus)Threading") + :group 'gnus-summary) -(defvar gnus-visible-headers "^From:\\|^Newsgroups:\\|^Subject:\\|^Date:\\|^Followup-To:\\|^Reply-To:\\|^Organization:\\|^Summary:\\|^Keywords:\\|^To:\\|^Cc:\\|^Posted-To:\\|^Mail-Copies-To:\\|^Apparently-To:\\|^Gnus-Warning:\\|^Resent-" - "*All headers that do not match this regexp will be hidden. -This variable can also be a list of regexp of headers to remain visible. -If this variable is non-nil, `gnus-ignored-headers' will be ignored.") - -(defvar gnus-sorted-header-list - '("^From:" "^Subject:" "^Summary:" "^Keywords:" "^Newsgroups:" "^To:" - "^Cc:" "^Date:" "^Organization:") - "*This variable is a list of regular expressions. -If it is non-nil, headers that match the regular expressions will -be placed first in the article buffer in the sequence specified by -this list.") - -(defvar gnus-boring-article-headers - '(empty followup-to reply-to) - "*Headers that are only to be displayed if they have interesting data. -Possible values in this list are `empty', `newsgroups', `followup-to', -`reply-to', and `date'.") - -(defvar gnus-show-all-headers nil - "*If non-nil, don't hide any headers.") - -(defvar gnus-save-all-headers t - "*If non-nil, don't remove any headers before saving.") - -(defvar gnus-saved-headers gnus-visible-headers - "*Headers to keep if `gnus-save-all-headers' is nil. -If `gnus-save-all-headers' is non-nil, this variable will be ignored. -If that variable is nil, however, all headers that match this regexp -will be kept while the rest will be deleted before saving.") - -(defvar gnus-inhibit-startup-message nil - "*If non-nil, the startup message will not be displayed.") - -(defvar gnus-signature-separator "^-- *$" - "Regexp matching signature separator.") - -(defvar gnus-signature-limit nil - "Provide a limit to what is considered a signature. -If it is a number, no signature may not be longer (in characters) than -that number. If it is a function, the function will be called without -any parameters, and if it returns nil, there is no signature in the -buffer. If it is a string, it will be used as a regexp. If it -matches, the text in question is not a signature.") - -(defvar gnus-auto-extend-newsgroup t - "*If non-nil, extend newsgroup forward and backward when requested.") +(defgroup gnus-summary-format nil + "Formatting of the summary buffer." + :link '(custom-manual "(gnus)Summary Buffer Format") + :group 'gnus-summary) -(defvar gnus-auto-select-first t - "*If nil, don't select the first unread article when entering a group. -If this variable is `best', select the highest-scored unread article -in the group. If neither nil nor `best', select the first unread -article. - -If you want to prevent automatic selection of the first unread article -in some newsgroups, set the variable to nil in -`gnus-select-group-hook'.") - -(defvar gnus-auto-select-next t - "*If non-nil, offer to go to the next group from the end of the previous. -If the value is t and the next newsgroup is empty, Gnus will exit -summary mode and go back to group mode. If the value is neither nil -nor t, Gnus will select the following unread newsgroup. In -particular, if the value is the symbol `quietly', the next unread -newsgroup will be selected without any confirmation, and if it is -`almost-quietly', the next group will be selected without any -confirmation if you are located on the last article in the group. -Finally, if this variable is `slightly-quietly', the `Z n' command -will go to the next group without confirmation.") - -(defvar gnus-auto-select-same nil - "*If non-nil, select the next article with the same subject.") +(defgroup gnus-summary-choose nil + "Choosing Articles." + :link '(custom-manual "(gnus)Choosing Articles") + :group 'gnus-summary) -(defvar gnus-summary-check-current nil - "*If non-nil, consider the current article when moving. -The \"unread\" movement commands will stay on the same line if the -current article is unread.") - -(defvar gnus-auto-center-summary t - "*If non-nil, always center the current summary buffer. -In particular, if `vertical' do only vertical recentering. If non-nil -and non-`vertical', do both horizontal and vertical recentering.") - -(defvar gnus-break-pages t - "*If non-nil, do page breaking on articles. -The page delimiter is specified by the `gnus-page-delimiter' -variable.") - -(defvar gnus-page-delimiter "^\^L" - "*Regexp describing what to use as article page delimiters. -The default value is \"^\^L\", which is a form linefeed at the -beginning of a line.") - -(defvar gnus-use-full-window t - "*If non-nil, use the entire Emacs screen.") - -(defvar gnus-window-configuration nil - "Obsolete variable. See `gnus-buffer-configuration'.") - -(defvar gnus-window-min-width 2 - "*Minimum width of Gnus buffers.") - -(defvar gnus-window-min-height 1 - "*Minimum height of Gnus buffers.") +(defgroup gnus-summary-maneuvering nil + "Summary movement commands." + :link '(custom-manual "(gnus)Summary Maneuvering") + :group 'gnus-summary) -(defvar gnus-buffer-configuration - '((group - (vertical 1.0 - (group 1.0 point) - (if gnus-carpal '(group-carpal 4)))) - (summary - (vertical 1.0 - (summary 1.0 point) - (if gnus-carpal '(summary-carpal 4)))) - (article - (cond - (gnus-use-picons - '(frame 1.0 - (vertical 1.0 - (summary 0.25 point) - (if gnus-carpal '(summary-carpal 4)) - (article 1.0)) - (vertical ((height . 5) (width . 15) - (user-position . t) - (left . -1) (top . 1)) - (picons 1.0)))) - (gnus-use-trees - '(vertical 1.0 - (summary 0.25 point) - (tree 0.25) - (article 1.0))) - (t - '(vertical 1.0 - (summary 0.25 point) - (if gnus-carpal '(summary-carpal 4)) - (article 1.0))))) - (server - (vertical 1.0 - (server 1.0 point) - (if gnus-carpal '(server-carpal 2)))) - (browse - (vertical 1.0 - (browse 1.0 point) - (if gnus-carpal '(browse-carpal 2)))) - (message - (vertical 1.0 - (message 1.0 point))) - (pick - (vertical 1.0 - (article 1.0 point))) - (info - (vertical 1.0 - (info 1.0 point))) - (summary-faq - (vertical 1.0 - (summary 0.25) - (faq 1.0 point))) - (edit-group - (vertical 1.0 - (group 0.5) - (edit-group 1.0 point))) - (edit-server - (vertical 1.0 - (server 0.5) - (edit-server 1.0 point))) - (edit-score - (vertical 1.0 - (summary 0.25) - (edit-score 1.0 point))) - (post - (vertical 1.0 - (post 1.0 point))) - (reply - (vertical 1.0 - (article-copy 0.5) - (message 1.0 point))) - (forward - (vertical 1.0 - (message 1.0 point))) - (reply-yank - (vertical 1.0 - (message 1.0 point))) - (mail-bounce - (vertical 1.0 - (article 0.5) - (message 1.0 point))) - (draft - (vertical 1.0 - (draft 1.0 point))) - (pipe - (vertical 1.0 - (summary 0.25 point) - (if gnus-carpal '(summary-carpal 4)) - ("*Shell Command Output*" 1.0))) - (bug - (vertical 1.0 - ("*Gnus Help Bug*" 0.5) - ("*Gnus Bug*" 1.0 point))) - (compose-bounce - (vertical 1.0 - (article 0.5) - (message 1.0 point)))) - "Window configuration for all possible Gnus buffers. -This variable is a list of lists. Each of these lists has a NAME and -a RULE. The NAMEs are commonsense names like `group', which names a -rule used when displaying the group buffer; `summary', which names a -rule for what happens when you enter a group and do not display an -article buffer; and so on. See the value of this variable for a -complete list of NAMEs. +(defgroup gnus-summary-mail nil + "Mail group commands." + :link '(custom-manual "(gnus)Mail Group Commands") + :group 'gnus-summary) -Each RULE is a list of vectors. The first element in this vector is -the name of the buffer to be displayed; the second element is the -percentage of the screen this buffer is to occupy (a number in the -0.0-0.99 range); the optional third element is `point', which should -be present to denote which buffer point is to go to after making this -buffer configuration.") - -(defvar gnus-window-to-buffer - '((group . gnus-group-buffer) - (summary . gnus-summary-buffer) - (article . gnus-article-buffer) - (server . gnus-server-buffer) - (browse . "*Gnus Browse Server*") - (edit-group . gnus-group-edit-buffer) - (edit-server . gnus-server-edit-buffer) - (group-carpal . gnus-carpal-group-buffer) - (summary-carpal . gnus-carpal-summary-buffer) - (server-carpal . gnus-carpal-server-buffer) - (browse-carpal . gnus-carpal-browse-buffer) - (edit-score . gnus-score-edit-buffer) - (message . gnus-message-buffer) - (mail . gnus-message-buffer) - (post-news . gnus-message-buffer) - (faq . gnus-faq-buffer) - (picons . "*Picons*") - (tree . gnus-tree-buffer) - (info . gnus-info-buffer) - (article-copy . gnus-article-copy) - (draft . gnus-draft-buffer)) - "Mapping from short symbols to buffer names or buffer variables.") - -(defvar gnus-carpal nil - "*If non-nil, display clickable icons.") +(defgroup gnus-summary-sort nil + "Sorting the summary buffer." + :link '(custom-manual "(gnus)Sorting") + :group 'gnus-summary) -(defvar gnus-subscribe-newsgroup-method 'gnus-subscribe-zombies - "*Function called with a group name when new group is detected. -A few pre-made functions are supplied: `gnus-subscribe-randomly' -inserts new groups at the beginning of the list of groups; -`gnus-subscribe-alphabetically' inserts new groups in strict -alphabetic order; `gnus-subscribe-hierarchically' inserts new groups -in hierarchical newsgroup order; `gnus-subscribe-interactively' asks -for your decision; `gnus-subscribe-killed' kills all new groups; -`gnus-subscribe-zombies' will make all new groups into zombies.") - -;; Suggested by a bug report by Hallvard B Furuseth. -;; . -(defvar gnus-subscribe-options-newsgroup-method - (function gnus-subscribe-alphabetically) - "*This function is called to subscribe newsgroups mentioned on \"options -n\" lines. -If, for instance, you want to subscribe to all newsgroups in the -\"no\" and \"alt\" hierarchies, you'd put the following in your -.newsrc file: - -options -n no.all alt.all - -Gnus will the subscribe all new newsgroups in these hierarchies with -the subscription method in this variable.") - -(defvar gnus-subscribe-hierarchical-interactive nil - "*If non-nil, Gnus will offer to subscribe hierarchically. -When a new hierarchy appears, Gnus will ask the user: - -'alt.binaries': Do you want to subscribe to this hierarchy? ([d]ys): - -If the user pressed `d', Gnus will descend the hierarchy, `y' will -subscribe to all newsgroups in the hierarchy and `s' will skip this -hierarchy in its entirety.") - -(defvar gnus-group-sort-function 'gnus-group-sort-by-alphabet - "*Function used for sorting the group buffer. -This function will be called with group info entries as the arguments -for the groups to be sorted. Pre-made functions include -`gnus-group-sort-by-alphabet', `gnus-group-sort-by-unread', -`gnus-group-sort-by-level', `gnus-group-sort-by-score', -`gnus-group-sort-by-method', and `gnus-group-sort-by-rank'. - -This variable can also be a list of sorting functions. In that case, -the most significant sort function should be the last function in the -list.") +(defgroup gnus-summary-visual nil + "Highlighting and menus in the summary buffer." + :link '(custom-manual "(gnus)Summary Highlighting") + :group 'gnus-visual + :group 'gnus-summary) -;; Mark variables suggested by Thomas Michanek -;; . -(defvar gnus-unread-mark ? - "*Mark used for unread articles.") -(defvar gnus-ticked-mark ?! - "*Mark used for ticked articles.") -(defvar gnus-dormant-mark ?? - "*Mark used for dormant articles.") -(defvar gnus-del-mark ?r - "*Mark used for del'd articles.") -(defvar gnus-read-mark ?R - "*Mark used for read articles.") -(defvar gnus-expirable-mark ?E - "*Mark used for expirable articles.") -(defvar gnus-killed-mark ?K - "*Mark used for killed articles.") -(defvar gnus-souped-mark ?F - "*Mark used for killed articles.") -(defvar gnus-kill-file-mark ?X - "*Mark used for articles killed by kill files.") -(defvar gnus-low-score-mark ?Y - "*Mark used for articles with a low score.") -(defvar gnus-catchup-mark ?C - "*Mark used for articles that are caught up.") -(defvar gnus-replied-mark ?A - "*Mark used for articles that have been replied to.") -(defvar gnus-cached-mark ?* - "*Mark used for articles that are in the cache.") -(defvar gnus-saved-mark ?S - "*Mark used for articles that have been saved to.") -(defvar gnus-process-mark ?# - "*Process mark.") -(defvar gnus-ancient-mark ?O - "*Mark used for ancient articles.") -(defvar gnus-sparse-mark ?Q - "*Mark used for sparsely reffed articles.") -(defvar gnus-canceled-mark ?G - "*Mark used for canceled articles.") -(defvar gnus-score-over-mark ?+ - "*Score mark used for articles with high scores.") -(defvar gnus-score-below-mark ?- - "*Score mark used for articles with low scores.") -(defvar gnus-empty-thread-mark ? - "*There is no thread under the article.") -(defvar gnus-not-empty-thread-mark ?= - "*There is a thread under the article.") - -(defvar gnus-shell-command-separator ";" - "String used to separate to shell commands.") - -(defvar gnus-view-pseudo-asynchronously nil - "*If non-nil, Gnus will view pseudo-articles asynchronously.") - -(defvar gnus-view-pseudos nil - "*If `automatic', pseudo-articles will be viewed automatically. -If `not-confirm', pseudos will be viewed automatically, and the user -will not be asked to confirm the command.") +(defgroup gnus-summary-various nil + "Various summary buffer options." + :link '(custom-manual "(gnus)Various Summary Stuff") + :group 'gnus-summary) -(defvar gnus-view-pseudos-separately t - "*If non-nil, one pseudo-article will be created for each file to be viewed. -If nil, all files that use the same viewing command will be given as a -list of parameters to that command.") - -(defvar gnus-insert-pseudo-articles t - "*If non-nil, insert pseudo-articles when decoding articles.") - -(defvar gnus-group-line-format "%M\%S\%p\%P\%5y: %(%g%)%l\n" - "*Format of group lines. -It works along the same lines as a normal formatting string, -with some simple extensions. - -%M Only marked articles (character, \"*\" or \" \") -%S Whether the group is subscribed (character, \"U\", \"K\", \"Z\" or \" \") -%L Level of subscribedness (integer) -%N Number of unread articles (integer) -%I Number of dormant articles (integer) -%i Number of ticked and dormant (integer) -%T Number of ticked articles (integer) -%R Number of read articles (integer) -%t Total number of articles (integer) -%y Number of unread, unticked articles (integer) -%G Group name (string) -%g Qualified group name (string) -%D Group description (string) -%s Select method (string) -%o Moderated group (char, \"m\") -%p Process mark (char) -%O Moderated group (string, \"(m)\" or \"\") -%P Topic indentation (string) -%l Whether there are GroupLens predictions for this group (string) -%n Select from where (string) -%z A string that look like `<%s:%n>' if a foreign select method is used -%u User defined specifier. The next character in the format string should - be a letter. Gnus will call the function gnus-user-format-function-X, - where X is the letter following %u. The function will be passed the - current header as argument. The function should return a string, which - will be inserted into the buffer just like information from any other - group specifier. - -Text between %( and %) will be highlighted with `gnus-mouse-face' when -the mouse point move inside the area. There can only be one such area. - -Note that this format specification is not always respected. For -reasons of efficiency, when listing killed groups, this specification -is ignored altogether. If the spec is changed considerably, your -output may end up looking strange when listing both alive and killed -groups. - -If you use %o or %O, reading the active file will be slower and quite -a bit of extra memory will be used. %D will also worsen performance. -Also note that if you change the format specification to include any -of these specs, you must probably re-start Gnus to see them go into -effect.") - -(defvar gnus-summary-line-format "%U\%R\%z\%I\%(%[%4L: %-20,20n%]%) %s\n" - "*The format specification of the lines in the summary buffer. - -It works along the same lines as a normal formatting string, -with some simple extensions. +;; Belongs to gnus-uu.el +(defgroup gnus-extract-view nil + "Viewing extracted files." + :link '(custom-manual "(gnus)Viewing Files") + :group 'gnus-extract) -%N Article number, left padded with spaces (string) -%S Subject (string) -%s Subject if it is at the root of a thread, and \"\" otherwise (string) -%n Name of the poster (string) -%a Extracted name of the poster (string) -%A Extracted address of the poster (string) -%F Contents of the From: header (string) -%x Contents of the Xref: header (string) -%D Date of the article (string) -%d Date of the article (string) in DD-MMM format -%M Message-id of the article (string) -%r References of the article (string) -%c Number of characters in the article (integer) -%L Number of lines in the article (integer) -%I Indentation based on thread level (a string of spaces) -%T A string with two possible values: 80 spaces if the article - is on thread level two or larger and 0 spaces on level one -%R \"A\" if this article has been replied to, \" \" otherwise (character) -%U Status of this article (character, \"R\", \"K\", \"-\" or \" \") -%[ Opening bracket (character, \"[\" or \"<\") -%] Closing bracket (character, \"]\" or \">\") -%> Spaces of length thread-level (string) -%< Spaces of length (- 20 thread-level) (string) -%i Article score (number) -%z Article zcore (character) -%t Number of articles under the current thread (number). -%e Whether the thread is empty or not (character). -%l GroupLens score (string). -%u User defined specifier. The next character in the format string should - be a letter. Gnus will call the function gnus-user-format-function-X, - where X is the letter following %u. The function will be passed the - current header as argument. The function should return a string, which - will be inserted into the summary just like information from any other - summary specifier. - -Text between %( and %) will be highlighted with `gnus-mouse-face' -when the mouse point is placed inside the area. There can only be one -such area. - -The %U (status), %R (replied) and %z (zcore) specs have to be handled -with care. For reasons of efficiency, Gnus will compute what column -these characters will end up in, and \"hard-code\" that. This means that -it is illegal to have these specs after a variable-length spec. Well, -you might not be arrested, but your summary buffer will look strange, -which is bad enough. - -The smart choice is to have these specs as for to the left as -possible. - -This restriction may disappear in later versions of Gnus.") - -(defvar gnus-summary-dummy-line-format - "* %(: :%) %S\n" - "*The format specification for the dummy roots in the summary buffer. -It works along the same lines as a normal formatting string, -with some simple extensions. - -%S The subject") - -(defvar gnus-summary-mode-line-format "Gnus: %%b [%A] %Z" - "*The format specification for the summary mode line. -It works along the same lines as a normal formatting string, -with some simple extensions: +;; Belongs to gnus-score.el +(defgroup gnus-score nil + "Score and kill file handling." + :group 'gnus) -%G Group name -%p Unprefixed group name -%A Current article number -%V Gnus version -%U Number of unread articles in the group -%e Number of unselected articles in the group -%Z A string with unread/unselected article counts -%g Shortish group name -%S Subject of the current article -%u User-defined spec -%s Current score file name -%d Number of dormant articles -%r Number of articles that have been marked as read in this session -%E Number of articles expunged by the score files") - -(defvar gnus-article-mode-line-format "Gnus: %%b %S" - "*The format specification for the article mode line. -See `gnus-summary-mode-line-format' for a closer description.") - -(defvar gnus-group-mode-line-format "Gnus: %%b {%M\%:%S}" - "*The format specification for the group mode line. -It works along the same lines as a normal formatting string, -with some simple extensions: - -%S The native news server. -%M The native select method. -%: \":\" if %S isn't \"\".") +(defgroup gnus-score-kill nil + "Kill files." + :group 'gnus-score) -(defvar gnus-valid-select-methods - '(("nntp" post address prompt-address) - ("nnspool" post address) - ("nnvirtual" post-mail virtual prompt-address) - ("nnmbox" mail respool address) - ("nnml" mail respool address) - ("nnmh" mail respool address) - ("nndir" post-mail prompt-address address) - ("nneething" none address prompt-address) - ("nndoc" none address prompt-address) - ("nnbabyl" mail address respool) - ("nnkiboze" post virtual) - ("nnsoup" post-mail address) - ("nndraft" post-mail) - ("nnfolder" mail respool address)) - "An alist of valid select methods. -The first element of each list lists should be a string with the name -of the select method. The other elements may be the category of -this method (ie. `post', `mail', `none' or whatever) or other -properties that this method has (like being respoolable). -If you implement a new select method, all you should have to change is -this variable. I think.") - -(defvar gnus-updated-mode-lines '(group article summary tree) - "*List of buffers that should update their mode lines. -The list may contain the symbols `group', `article' and `summary'. If -the corresponding symbol is present, Gnus will keep that mode line -updated with information that may be pertinent. -If this variable is nil, screen refresh may be quicker.") - -;; Added by Keinonen Kari . -(defvar gnus-mode-non-string-length nil - "*Max length of mode-line non-string contents. -If this is nil, Gnus will take space as is needed, leaving the rest -of the modeline intact.") - -;see gnus-cus.el -;(defvar gnus-mouse-face 'highlight -; "*Face used for mouse highlighting in Gnus. -;No mouse highlights will be done if `gnus-visual' is nil.") - -(defvar gnus-summary-mark-below 0 - "*Mark all articles with a score below this variable as read. -This variable is local to each summary buffer and usually set by the -score file.") - -(defvar gnus-article-sort-functions '(gnus-article-sort-by-number) - "*List of functions used for sorting articles in the summary buffer. -This variable is only used when not using a threaded display.") - -(defvar gnus-thread-sort-functions '(gnus-thread-sort-by-number) - "*List of functions used for sorting threads in the summary buffer. -By default, threads are sorted by article number. +(defgroup gnus-score-adapt nil + "Adaptive score files." + :group 'gnus-score) -Each function takes two threads and return non-nil if the first thread -should be sorted before the other. If you use more than one function, -the primary sort function should be the last. You should probably -always include `gnus-thread-sort-by-number' in the list of sorting -functions -- preferably first. - -Ready-mady functions include `gnus-thread-sort-by-number', -`gnus-thread-sort-by-author', `gnus-thread-sort-by-subject', -`gnus-thread-sort-by-date', `gnus-thread-sort-by-score' and -`gnus-thread-sort-by-total-score' (see `gnus-thread-score-function').") - -(defvar gnus-thread-score-function '+ - "*Function used for calculating the total score of a thread. - -The function is called with the scores of the article and each -subthread and should then return the score of the thread. - -Some functions you can use are `+', `max', or `min'.") - -(defvar gnus-summary-expunge-below nil - "All articles that have a score less than this variable will be expunged.") - -(defvar gnus-thread-expunge-below nil - "All threads that have a total score less than this variable will be expunged. -See `gnus-thread-score-function' for en explanation of what a -\"thread score\" is.") - -(defvar gnus-auto-subscribed-groups - "^nnml\\|^nnfolder\\|^nnmbox\\|^nnmh\\|^nnbabyl" - "*All new groups that match this regexp will be subscribed automatically. -Note that this variable only deals with new groups. It has no effect -whatsoever on old groups. - -New groups that match this regexp will not be handled by -`gnus-subscribe-newsgroup-method'. Instead, they will -be subscribed using `gnus-subscribe-options-newsgroup-method'.") - -(defvar gnus-options-subscribe nil - "*All new groups matching this regexp will be subscribed unconditionally. -Note that this variable deals only with new newsgroups. This variable -does not affect old newsgroups. - -New groups that match this regexp will not be handled by -`gnus-subscribe-newsgroup-method'. Instead, they will -be subscribed using `gnus-subscribe-options-newsgroup-method'.") - -(defvar gnus-options-not-subscribe nil - "*All new groups matching this regexp will be ignored. -Note that this variable deals only with new newsgroups. This variable -does not affect old (already subscribed) newsgroups.") - -(defvar gnus-auto-expirable-newsgroups nil - "*Groups in which to automatically mark read articles as expirable. -If non-nil, this should be a regexp that should match all groups in -which to perform auto-expiry. This only makes sense for mail groups.") +(defgroup gnus-score-files nil + "Score and kill file names." + :group 'gnus-score + :group 'gnus-files) -(defvar gnus-total-expirable-newsgroups nil - "*Groups in which to perform expiry of all read articles. -Use with extreme caution. All groups that match this regexp will be -expiring - which means that all read articles will be deleted after -(say) one week. (This only goes for mail groups and the like, of -course.)") - -(defvar gnus-group-uncollapsed-levels 1 - "Number of group name elements to leave alone when making a short group name.") - -(defvar gnus-hidden-properties '(invisible t intangible t) - "Property list to use for hiding text.") - -(defvar gnus-modtime-botch nil - "*Non-nil means .newsrc should be deleted prior to save. -Its use is due to the bogus appearance that .newsrc was modified on -disc.") - -;; Hooks. - -(defvar gnus-group-mode-hook nil - "*A hook for Gnus group mode.") - -(defvar gnus-summary-mode-hook nil - "*A hook for Gnus summary mode. -This hook is run before any variables are set in the summary buffer.") - -(defvar gnus-article-mode-hook nil - "*A hook for Gnus article mode.") - -(defvar gnus-summary-prepare-exit-hook nil - "*A hook called when preparing to exit from the summary buffer. -It calls `gnus-summary-expire-articles' by default.") -(add-hook 'gnus-summary-prepare-exit-hook 'gnus-summary-expire-articles) - -(defvar gnus-summary-exit-hook nil - "*A hook called on exit from the summary buffer.") - -(defvar gnus-check-bogus-groups-hook nil - "A hook run after removing bogus groups.") - -(defvar gnus-group-catchup-group-hook nil - "*A hook run when catching up a group from the group buffer.") - -(defvar gnus-group-update-group-hook nil - "*A hook called when updating group lines.") - -(defvar gnus-open-server-hook nil - "*A hook called just before opening connection to the news server.") - -(defvar gnus-load-hook nil - "*A hook run while Gnus is loaded.") - -(defvar gnus-startup-hook nil - "*A hook called at startup. -This hook is called after Gnus is connected to the NNTP server.") +(defgroup gnus-score-various nil + "Various scoring and killing options." + :group 'gnus-score) -(defvar gnus-get-new-news-hook nil - "*A hook run just before Gnus checks for new news.") - -(defvar gnus-after-getting-new-news-hook nil - "*A hook run after Gnus checks for new news.") - -(defvar gnus-group-prepare-function 'gnus-group-prepare-flat - "*A function that is called to generate the group buffer. -The function is called with three arguments: The first is a number; -all group with a level less or equal to that number should be listed, -if the second is non-nil, empty groups should also be displayed. If -the third is non-nil, it is a number. No groups with a level lower -than this number should be displayed. - -The only current function implemented is `gnus-group-prepare-flat'.") - -(defvar gnus-group-prepare-hook nil - "*A hook called after the group buffer has been generated. -If you want to modify the group buffer, you can use this hook.") - -(defvar gnus-summary-prepare-hook nil - "*A hook called after the summary buffer has been generated. -If you want to modify the summary buffer, you can use this hook.") - -(defvar gnus-summary-generate-hook nil - "*A hook run just before generating the summary buffer. -This hook is commonly used to customize threading variables and the -like.") - -(defvar gnus-article-prepare-hook nil - "*A hook called after an article has been prepared in the article buffer. -If you want to run a special decoding program like nkf, use this hook.") - -;(defvar gnus-article-display-hook nil -; "*A hook called after the article is displayed in the article buffer. -;The hook is designed to change the contents of the article -;buffer. Typical functions that this hook may contain are -;`gnus-article-hide-headers' (hide selected headers), -;`gnus-article-maybe-highlight' (perform fancy article highlighting), -;`gnus-article-hide-signature' (hide signature) and -;`gnus-article-treat-overstrike' (turn \"^H_\" into bold characters).") -;(add-hook 'gnus-article-display-hook 'gnus-article-hide-headers-if-wanted) -;(add-hook 'gnus-article-display-hook 'gnus-article-treat-overstrike) -;(add-hook 'gnus-article-display-hook 'gnus-article-maybe-highlight) - -(defvar gnus-article-x-face-too-ugly nil - "Regexp matching posters whose face shouldn't be shown automatically.") - -(defvar gnus-select-group-hook nil - "*A hook called when a newsgroup is selected. - -If you'd like to simplify subjects like the -`gnus-summary-next-same-subject' command does, you can use the -following hook: +;; Other +(defgroup gnus-visual nil + "Options controling the visual fluff." + :group 'gnus) - (setq gnus-select-group-hook - (list - (lambda () - (mapcar (lambda (header) - (mail-header-set-subject - header - (gnus-simplify-subject - (mail-header-subject header) 're-only))) - gnus-newsgroup-headers))))") - -(defvar gnus-select-article-hook nil - "*A hook called when an article is selected.") - -(defvar gnus-apply-kill-hook '(gnus-apply-kill-file) - "*A hook called to apply kill files to a group. -This hook is intended to apply a kill file to the selected newsgroup. -The function `gnus-apply-kill-file' is called by default. - -Since a general kill file is too heavy to use only for a few -newsgroups, I recommend you to use a lighter hook function. For -example, if you'd like to apply a kill file to articles which contains -a string `rmgroup' in subject in newsgroup `control', you can use the -following hook: +(defgroup gnus-mail-expire nil + "Expiring articles in mail backends." + :group 'gnus-mail) - (setq gnus-apply-kill-hook - (list - (lambda () - (cond ((string-match \"control\" gnus-newsgroup-name) - (gnus-kill \"Subject\" \"rmgroup\") - (gnus-expunge \"X\"))))))") - -(defvar gnus-visual-mark-article-hook - (list 'gnus-highlight-selected-summary) - "*Hook run after selecting an article in the summary buffer. -It is meant to be used for highlighting the article in some way. It -is not run if `gnus-visual' is nil.") - -(defvar gnus-parse-headers-hook nil - "*A hook called before parsing the headers.") -(add-hook 'gnus-parse-headers-hook 'gnus-decode-rfc1522) - -(defvar gnus-exit-group-hook nil - "*A hook called when exiting (not quitting) summary mode.") - -(defvar gnus-suspend-gnus-hook nil - "*A hook called when suspending (not exiting) Gnus.") - -(defvar gnus-exit-gnus-hook nil - "*A hook called when exiting Gnus.") - -(defvar gnus-after-exiting-gnus-hook nil - "*A hook called after exiting Gnus.") - -(defvar gnus-save-newsrc-hook nil - "*A hook called before saving any of the newsrc files.") - -(defvar gnus-save-quick-newsrc-hook nil - "*A hook called just before saving the quick newsrc file. -Can be used to turn version control on or off.") +(defgroup gnus-files nil + "Files used by Gnus." + :group 'gnus) -(defvar gnus-save-standard-newsrc-hook nil - "*A hook called just before saving the standard newsrc file. -Can be used to turn version control on or off.") - -(defvar gnus-summary-update-hook - (list 'gnus-summary-highlight-line) - "*A hook called when a summary line is changed. -The hook will not be called if `gnus-visual' is nil. - -The default function `gnus-summary-highlight-line' will -highlight the line according to the `gnus-summary-highlight' -variable.") - -(defvar gnus-group-update-hook '(gnus-group-highlight-line) - "*A hook called when a group line is changed. -The hook will not be called if `gnus-visual' is nil. - -The default function `gnus-group-highlight-line' will -highlight the line according to the `gnus-group-highlight' -variable.") - -(defvar gnus-mark-article-hook '(gnus-summary-mark-read-and-unread-as-read) - "*A hook called when an article is selected for the first time. -The hook is intended to mark an article as read (or unread) -automatically when it is selected.") - -(defvar gnus-group-change-level-function nil - "Function run when a group level is changed. -It is called with three parameters -- GROUP, LEVEL and OLDLEVEL.") - -;; Remove any hilit infestation. -(add-hook 'gnus-startup-hook - (lambda () - (remove-hook 'gnus-summary-prepare-hook - 'hilit-rehighlight-buffer-quietly) - (remove-hook 'gnus-summary-prepare-hook 'hilit-install-line-hooks) - (setq gnus-mark-article-hook - '(gnus-summary-mark-read-and-unread-as-read)) - (remove-hook 'gnus-article-prepare-hook - 'hilit-rehighlight-buffer-quietly))) - - -;; Internal variables - -(defvar gnus-tree-buffer "*Tree*" - "Buffer where Gnus thread trees are displayed.") - -;; Dummy variable. -(defvar gnus-use-generic-from nil) - -(defvar gnus-thread-indent-array nil) -(defvar gnus-thread-indent-array-level gnus-thread-indent-level) - -(defvar gnus-newsrc-file-version nil) +(defgroup gnus-server nil + "Options related to newsservers and other servers used by Gnus." + :group 'gnus) -(defvar gnus-method-history nil) -;; Variable holding the user answers to all method prompts. - -(defvar gnus-group-history nil) -;; Variable holding the user answers to all group prompts. - -(defvar gnus-server-alist nil - "List of available servers.") - -(defvar gnus-group-indentation-function nil) - -(defvar gnus-topic-indentation "") ;; Obsolete variable. - -(defvar gnus-goto-missing-group-function nil) - -(defvar gnus-override-subscribe-method nil) - -(defvar gnus-group-goto-next-group-function nil - "Function to override finding the next group after listing groups.") - -(defconst gnus-article-mark-lists - '((marked . tick) (replied . reply) - (expirable . expire) (killed . killed) - (bookmarks . bookmark) (dormant . dormant) - (scored . score) (saved . save) - (cached . cache) - )) - -;; Avoid highlighting in kill files. -(defvar gnus-summary-inhibit-highlight nil) -(defvar gnus-newsgroup-selected-overlay nil) - -(defvar gnus-inhibit-hiding nil) -(defvar gnus-group-indentation "") -(defvar gnus-inhibit-limiting nil) -(defvar gnus-created-frames nil) - -(defvar gnus-article-mode-map nil) -(defvar gnus-dribble-buffer nil) -(defvar gnus-headers-retrieved-by nil) -(defvar gnus-article-reply nil) -(defvar gnus-override-method nil) -(defvar gnus-article-check-size nil) - -(defvar gnus-current-score-file nil) -(defvar gnus-newsgroup-adaptive-score-file nil) -(defvar gnus-scores-exclude-files nil) - -(defvar gnus-opened-servers nil) - -(defvar gnus-current-move-group nil) -(defvar gnus-current-copy-group nil) -(defvar gnus-current-crosspost-group nil) - -(defvar gnus-newsgroup-dependencies nil) -(defvar gnus-newsgroup-async nil) -(defvar gnus-group-edit-buffer nil) - -(defvar gnus-newsgroup-adaptive nil) +(defgroup gnus-message '((message custom-group)) + "Composing replies and followups in Gnus." + :group 'gnus) -(defvar gnus-summary-display-table nil) -(defvar gnus-summary-display-article-function nil) - -(defvar gnus-summary-highlight-line-function nil - "Function called after highlighting a summary line.") - -(defvar gnus-group-line-format-alist - `((?M gnus-tmp-marked-mark ?c) - (?S gnus-tmp-subscribed ?c) - (?L gnus-tmp-level ?d) - (?N (cond ((eq number t) "*" ) - ((numberp number) - (int-to-string - (+ number - (gnus-range-length (cdr (assq 'dormant gnus-tmp-marked))) - (gnus-range-length (cdr (assq 'tick gnus-tmp-marked)))))) - (t number)) ?s) - (?R gnus-tmp-number-of-read ?s) - (?t gnus-tmp-number-total ?d) - (?y gnus-tmp-number-of-unread ?s) - (?I (gnus-range-length (cdr (assq 'dormant gnus-tmp-marked))) ?d) - (?T (gnus-range-length (cdr (assq 'tick gnus-tmp-marked))) ?d) - (?i (+ (gnus-range-length (cdr (assq 'dormant gnus-tmp-marked))) - (gnus-range-length (cdr (assq 'tick gnus-tmp-marked)))) ?d) - (?g gnus-tmp-group ?s) - (?G gnus-tmp-qualified-group ?s) - (?c (gnus-short-group-name gnus-tmp-group) ?s) - (?D gnus-tmp-newsgroup-description ?s) - (?o gnus-tmp-moderated ?c) - (?O gnus-tmp-moderated-string ?s) - (?p gnus-tmp-process-marked ?c) - (?s gnus-tmp-news-server ?s) - (?n gnus-tmp-news-method ?s) - (?P gnus-group-indentation ?s) - (?l gnus-tmp-grouplens ?s) - (?z gnus-tmp-news-method-string ?s) - (?u gnus-tmp-user-defined ?s))) +(defgroup gnus-meta nil + "Meta variables controling major portions of Gnus. +In general, modifying these variables does not take affect until Gnus +is restarted, and sometimes reloaded." + :group 'gnus) -(defvar gnus-summary-line-format-alist - `((?N ,(macroexpand '(mail-header-number gnus-tmp-header)) ?d) - (?S ,(macroexpand '(mail-header-subject gnus-tmp-header)) ?s) - (?s gnus-tmp-subject-or-nil ?s) - (?n gnus-tmp-name ?s) - (?A (car (cdr (funcall gnus-extract-address-components gnus-tmp-from))) - ?s) - (?a (or (car (funcall gnus-extract-address-components gnus-tmp-from)) - gnus-tmp-from) ?s) - (?F gnus-tmp-from ?s) - (?x ,(macroexpand '(mail-header-xref gnus-tmp-header)) ?s) - (?D ,(macroexpand '(mail-header-date gnus-tmp-header)) ?s) - (?d (gnus-dd-mmm (mail-header-date gnus-tmp-header)) ?s) - (?M ,(macroexpand '(mail-header-id gnus-tmp-header)) ?s) - (?r ,(macroexpand '(mail-header-references gnus-tmp-header)) ?s) - (?c (or (mail-header-chars gnus-tmp-header) 0) ?d) - (?L gnus-tmp-lines ?d) - (?I gnus-tmp-indentation ?s) - (?T (if (= gnus-tmp-level 0) "" (make-string (frame-width) ? )) ?s) - (?R gnus-tmp-replied ?c) - (?\[ gnus-tmp-opening-bracket ?c) - (?\] gnus-tmp-closing-bracket ?c) - (?\> (make-string gnus-tmp-level ? ) ?s) - (?\< (make-string (max 0 (- 20 gnus-tmp-level)) ? ) ?s) - (?i gnus-tmp-score ?d) - (?z gnus-tmp-score-char ?c) - (?l (bbb-grouplens-score gnus-tmp-header) ?s) - (?V (gnus-thread-total-score (and (boundp 'thread) (car thread))) ?d) - (?U gnus-tmp-unread ?c) - (?t (gnus-summary-number-of-articles-in-thread - (and (boundp 'thread) (car thread)) gnus-tmp-level) - ?d) - (?e (gnus-summary-number-of-articles-in-thread - (and (boundp 'thread) (car thread)) gnus-tmp-level t) - ?c) - (?u gnus-tmp-user-defined ?s)) - "An alist of format specifications that can appear in summary lines, -and what variables they correspond with, along with the type of the -variable (string, integer, character, etc).") +(defgroup gnus-various nil + "Other Gnus options." + :link '(custom-manual "(gnus)Various Various") + :group 'gnus) -(defvar gnus-summary-dummy-line-format-alist - `((?S gnus-tmp-subject ?s) - (?N gnus-tmp-number ?d) - (?u gnus-tmp-user-defined ?s))) +(defgroup gnus-exit nil + "Exiting gnus." + :link '(custom-manual "(gnus)Exiting Gnus") + :group 'gnus) -(defvar gnus-summary-mode-line-format-alist - `((?G gnus-tmp-group-name ?s) - (?g (gnus-short-group-name gnus-tmp-group-name) ?s) - (?p (gnus-group-real-name gnus-tmp-group-name) ?s) - (?A gnus-tmp-article-number ?d) - (?Z gnus-tmp-unread-and-unselected ?s) - (?V gnus-version ?s) - (?U gnus-tmp-unread-and-unticked ?d) - (?S gnus-tmp-subject ?s) - (?e gnus-tmp-unselected ?d) - (?u gnus-tmp-user-defined ?s) - (?d (length gnus-newsgroup-dormant) ?d) - (?t (length gnus-newsgroup-marked) ?d) - (?r (length gnus-newsgroup-reads) ?d) - (?E gnus-newsgroup-expunged-tally ?d) - (?s (gnus-current-score-file-nondirectory) ?s))) - -(defvar gnus-article-mode-line-format-alist - gnus-summary-mode-line-format-alist) - -(defvar gnus-group-mode-line-format-alist - `((?S gnus-tmp-news-server ?s) - (?M gnus-tmp-news-method ?s) - (?u gnus-tmp-user-defined ?s) - (?: gnus-tmp-colon ?s))) - -(defvar gnus-have-read-active-file nil) - -(defconst gnus-maintainer - "gnus-bug@ifi.uio.no (The Gnus Bugfixing Girls + Boys)" - "The mail address of the Gnus maintainers.") - -(defconst gnus-version-number "5.2.40" +(defconst gnus-version-number "5.4.9" "Version number for this version of Gnus.") (defconst gnus-version (format "Gnus v%s" gnus-version-number) "Version string for this version of Gnus.") -(defvar gnus-info-nodes - '((gnus-group-mode "(gnus)The Group Buffer") - (gnus-summary-mode "(gnus)The Summary Buffer") - (gnus-article-mode "(gnus)The Article Buffer") - (gnus-server-mode "(gnus)The Server Buffer") - (gnus-browse-mode "(gnus)Browse Foreign Server") - (gnus-tree-mode "(gnus)Tree Display") - ) - "Alist of major modes and related Info nodes.") +(defcustom gnus-inhibit-startup-message nil + "If non-nil, the startup message will not be displayed. +This variable is used before `.gnus.el' is loaded, so it should +be set in `.emacs' instead." + :group 'gnus-start + :type 'boolean) + +(defcustom gnus-play-startup-jingle nil + "If non-nil, play the Gnus jingle at startup." + :group 'gnus-start + :type 'boolean) + +;;; Kludges to help the transition from the old `custom.el'. + +(unless (featurep 'gnus-xmas) + (defalias 'gnus-make-overlay 'make-overlay) + (defalias 'gnus-overlay-put 'overlay-put) + (defalias 'gnus-move-overlay 'move-overlay) + (defalias 'gnus-overlay-end 'overlay-end) + (defalias 'gnus-extent-detached-p 'ignore) + (defalias 'gnus-extent-start-open 'ignore) + (defalias 'gnus-set-text-properties 'set-text-properties) + (defalias 'gnus-group-remove-excess-properties 'ignore) + (defalias 'gnus-topic-remove-excess-properties 'ignore) + (defalias 'gnus-appt-select-lowest-window 'appt-select-lowest-window) + (defalias 'gnus-mail-strip-quoted-names 'mail-strip-quoted-names) + (defalias 'gnus-make-local-hook 'make-local-hook) + (defalias 'gnus-add-hook 'add-hook) + (defalias 'gnus-character-to-event 'identity) + (defalias 'gnus-add-text-properties 'add-text-properties) + (defalias 'gnus-put-text-property 'put-text-property) + (defalias 'gnus-mode-line-buffer-identification 'identity) + (defalias 'gnus-characterp 'numberp) + (defalias 'gnus-key-press-event-p 'numberp)) + +;; The XEmacs people think this is evil, so it must go. +(defun custom-face-lookup (&optional fg bg stipple bold italic underline) + "Lookup or create a face with specified attributes." + (let ((name (intern (format "custom-face-%s-%s-%s-%S-%S-%S" + (or fg "default") + (or bg "default") + (or stipple "default") + bold italic underline)))) + (if (and (custom-facep name) + (fboundp 'make-face)) + () + (copy-face 'default name) + (when (and fg + (not (string-equal fg "default"))) + (ignore-errors + (set-face-foreground name fg))) + (when (and bg + (not (string-equal bg "default"))) + (ignore-errors + (set-face-background name bg))) + (when (and stipple + (not (string-equal stipple "default")) + (not (eq stipple 'custom:asis)) + (fboundp 'set-face-stipple)) + (set-face-stipple name stipple)) + (when (and bold + (not (eq bold 'custom:asis))) + (ignore-errors + (make-face-bold name))) + (when (and italic + (not (eq italic 'custom:asis))) + (ignore-errors + (make-face-italic name))) + (when (and underline + (not (eq underline 'custom:asis))) + (ignore-errors + (set-face-underline-p name t)))) + name)) + +;; We define these group faces here to avoid the display +;; update forced when creating new faces. + +(defface gnus-group-news-1-face + '((((class color) + (background dark)) + (:foreground "PaleTurquoise" :bold t)) + (((class color) + (background light)) + (:foreground "ForestGreen" :bold t)) + (t + ())) + "Level 1 newsgroup face.") + +(defface gnus-group-news-1-empty-face + '((((class color) + (background dark)) + (:foreground "PaleTurquoise")) + (((class color) + (background light)) + (:foreground "ForestGreen")) + (t + ())) + "Level 1 empty newsgroup face.") + +(defface gnus-group-news-2-face + '((((class color) + (background dark)) + (:foreground "turquoise" :bold t)) + (((class color) + (background light)) + (:foreground "CadetBlue4" :bold t)) + (t + ())) + "Level 2 newsgroup face.") + +(defface gnus-group-news-2-empty-face + '((((class color) + (background dark)) + (:foreground "turquoise")) + (((class color) + (background light)) + (:foreground "CadetBlue4")) + (t + ())) + "Level 2 empty newsgroup face.") + +(defface gnus-group-news-3-face + '((((class color) + (background dark)) + (:bold t)) + (((class color) + (background light)) + (:bold t)) + (t + ())) + "Level 3 newsgroup face.") + +(defface gnus-group-news-3-empty-face + '((((class color) + (background dark)) + ()) + (((class color) + (background light)) + ()) + (t + ())) + "Level 3 empty newsgroup face.") + +(defface gnus-group-news-low-face + '((((class color) + (background dark)) + (:foreground "DarkTurquoise" :bold t)) + (((class color) + (background light)) + (:foreground "DarkGreen" :bold t)) + (t + ())) + "Low level newsgroup face.") + +(defface gnus-group-news-low-empty-face + '((((class color) + (background dark)) + (:foreground "DarkTurquoise")) + (((class color) + (background light)) + (:foreground "DarkGreen")) + (t + ())) + "Low level empty newsgroup face.") + +(defface gnus-group-mail-1-face + '((((class color) + (background dark)) + (:foreground "aquamarine1" :bold t)) + (((class color) + (background light)) + (:foreground "DeepPink3" :bold t)) + (t + (:bold t))) + "Level 1 mailgroup face.") + +(defface gnus-group-mail-1-empty-face + '((((class color) + (background dark)) + (:foreground "aquamarine1")) + (((class color) + (background light)) + (:foreground "DeepPink3")) + (t + (:italic t :bold t))) + "Level 1 empty mailgroup face.") + +(defface gnus-group-mail-2-face + '((((class color) + (background dark)) + (:foreground "aquamarine2" :bold t)) + (((class color) + (background light)) + (:foreground "HotPink3" :bold t)) + (t + (:bold t))) + "Level 2 mailgroup face.") + +(defface gnus-group-mail-2-empty-face + '((((class color) + (background dark)) + (:foreground "aquamarine2")) + (((class color) + (background light)) + (:foreground "HotPink3")) + (t + (:bold t))) + "Level 2 empty mailgroup face.") + +(defface gnus-group-mail-3-face + '((((class color) + (background dark)) + (:foreground "aquamarine3" :bold t)) + (((class color) + (background light)) + (:foreground "magenta4" :bold t)) + (t + (:bold t))) + "Level 3 mailgroup face.") + +(defface gnus-group-mail-3-empty-face + '((((class color) + (background dark)) + (:foreground "aquamarine3")) + (((class color) + (background light)) + (:foreground "magenta4")) + (t + ())) + "Level 3 empty mailgroup face.") + +(defface gnus-group-mail-low-face + '((((class color) + (background dark)) + (:foreground "aquamarine4" :bold t)) + (((class color) + (background light)) + (:foreground "DeepPink4" :bold t)) + (t + (:bold t))) + "Low level mailgroup face.") + +(defface gnus-group-mail-low-empty-face + '((((class color) + (background dark)) + (:foreground "aquamarine4")) + (((class color) + (background light)) + (:foreground "DeepPink4")) + (t + (:bold t))) + "Low level empty mailgroup face.") + +;; Summary mode faces. + +(defface gnus-summary-selected-face '((t + (:underline t))) + "Face used for selected articles.") + +(defface gnus-summary-cancelled-face + '((((class color)) + (:foreground "yellow" :background "black"))) + "Face used for cancelled articles.") + +(defface gnus-summary-high-ticked-face + '((((class color) + (background dark)) + (:foreground "pink" :bold t)) + (((class color) + (background light)) + (:foreground "firebrick" :bold t)) + (t + (:bold t))) + "Face used for high interest ticked articles.") + +(defface gnus-summary-low-ticked-face + '((((class color) + (background dark)) + (:foreground "pink" :italic t)) + (((class color) + (background light)) + (:foreground "firebrick" :italic t)) + (t + (:italic t))) + "Face used for low interest ticked articles.") + +(defface gnus-summary-normal-ticked-face + '((((class color) + (background dark)) + (:foreground "pink")) + (((class color) + (background light)) + (:foreground "firebrick")) + (t + ())) + "Face used for normal interest ticked articles.") + +(defface gnus-summary-high-ancient-face + '((((class color) + (background dark)) + (:foreground "SkyBlue" :bold t)) + (((class color) + (background light)) + (:foreground "RoyalBlue" :bold t)) + (t + (:bold t))) + "Face used for high interest ancient articles.") + +(defface gnus-summary-low-ancient-face + '((((class color) + (background dark)) + (:foreground "SkyBlue" :italic t)) + (((class color) + (background light)) + (:foreground "RoyalBlue" :italic t)) + (t + (:italic t))) + "Face used for low interest ancient articles.") + +(defface gnus-summary-normal-ancient-face + '((((class color) + (background dark)) + (:foreground "SkyBlue")) + (((class color) + (background light)) + (:foreground "RoyalBlue")) + (t + ())) + "Face used for normal interest ancient articles.") + +(defface gnus-summary-high-unread-face + '((t + (:bold t))) + "Face used for high interest unread articles.") + +(defface gnus-summary-low-unread-face + '((t + (:italic t))) + "Face used for low interest unread articles.") + +(defface gnus-summary-normal-unread-face + '((t + ())) + "Face used for normal interest unread articles.") + +(defface gnus-summary-high-read-face + '((((class color) + (background dark)) + (:foreground "PaleGreen" + :bold t)) + (((class color) + (background light)) + (:foreground "DarkGreen" + :bold t)) + (t + (:bold t))) + "Face used for high interest read articles.") + +(defface gnus-summary-low-read-face + '((((class color) + (background dark)) + (:foreground "PaleGreen" + :italic t)) + (((class color) + (background light)) + (:foreground "DarkGreen" + :italic t)) + (t + (:italic t))) + "Face used for low interest read articles.") + +(defface gnus-summary-normal-read-face + '((((class color) + (background dark)) + (:foreground "PaleGreen")) + (((class color) + (background light)) + (:foreground "DarkGreen")) + (t + ())) + "Face used for normal interest read articles.") + + +;;; Splash screen. (defvar gnus-group-buffer "*Group*") -(defvar gnus-summary-buffer "*Summary*") -(defvar gnus-article-buffer "*Article*") -(defvar gnus-server-buffer "*Server*") -(defvar gnus-work-buffer " *gnus work*") - -(defvar gnus-original-article-buffer " *Original Article*") -(defvar gnus-original-article nil) - -(defvar gnus-buffer-list nil - "Gnus buffers that should be killed on exit.") - -(defvar gnus-slave nil - "Whether this Gnus is a slave or not.") - -(defvar gnus-variable-list - '(gnus-newsrc-options gnus-newsrc-options-n - gnus-newsrc-last-checked-date - gnus-newsrc-alist gnus-server-alist - gnus-killed-list gnus-zombie-list - gnus-topic-topology gnus-topic-alist - gnus-format-specs) - "Gnus variables saved in the quick startup file.") - -(defvar gnus-newsrc-options nil - "Options line in the .newsrc file.") - -(defvar gnus-newsrc-options-n nil - "List of regexps representing groups to be subscribed/ignored unconditionally.") - -(defvar gnus-newsrc-last-checked-date nil - "Date Gnus last asked server for new newsgroups.") - -(defvar gnus-topic-topology nil - "The complete topic hierarchy.") - -(defvar gnus-topic-alist nil - "The complete topic-group alist.") - -(defvar gnus-newsrc-alist nil - "Assoc list of read articles. -gnus-newsrc-hashtb should be kept so that both hold the same information.") - -(defvar gnus-newsrc-hashtb nil - "Hashtable of gnus-newsrc-alist.") - -(defvar gnus-killed-list nil - "List of killed newsgroups.") - -(defvar gnus-killed-hashtb nil - "Hash table equivalent of gnus-killed-list.") - -(defvar gnus-zombie-list nil - "List of almost dead newsgroups.") - -(defvar gnus-description-hashtb nil - "Descriptions of newsgroups.") - -(defvar gnus-list-of-killed-groups nil - "List of newsgroups that have recently been killed by the user.") - -(defvar gnus-active-hashtb nil - "Hashtable of active articles.") - -(defvar gnus-moderated-list nil - "List of moderated newsgroups.") - -(defvar gnus-group-marked nil) - -(defvar gnus-current-startup-file nil - "Startup file for the current host.") - -(defvar gnus-last-search-regexp nil - "Default regexp for article search command.") - -(defvar gnus-last-shell-command nil - "Default shell command on article.") - -(defvar gnus-current-select-method nil - "The current method for selecting a newsgroup.") - -(defvar gnus-group-list-mode nil) - -(defvar gnus-article-internal-prepare-hook nil) - -(defvar gnus-newsgroup-name nil) -(defvar gnus-newsgroup-begin nil) -(defvar gnus-newsgroup-end nil) -(defvar gnus-newsgroup-last-rmail nil) -(defvar gnus-newsgroup-last-mail nil) -(defvar gnus-newsgroup-last-folder nil) -(defvar gnus-newsgroup-last-file nil) -(defvar gnus-newsgroup-auto-expire nil) -(defvar gnus-newsgroup-active nil) - -(defvar gnus-newsgroup-data nil) -(defvar gnus-newsgroup-data-reverse nil) -(defvar gnus-newsgroup-limit nil) -(defvar gnus-newsgroup-limits nil) - -(defvar gnus-newsgroup-unreads nil - "List of unread articles in the current newsgroup.") - -(defvar gnus-newsgroup-unselected nil - "List of unselected unread articles in the current newsgroup.") - -(defvar gnus-newsgroup-reads nil - "Alist of read articles and article marks in the current newsgroup.") - -(defvar gnus-newsgroup-expunged-tally nil) - -(defvar gnus-newsgroup-marked nil - "List of ticked articles in the current newsgroup (a subset of unread art).") - -(defvar gnus-newsgroup-killed nil - "List of ranges of articles that have been through the scoring process.") - -(defvar gnus-newsgroup-cached nil - "List of articles that come from the article cache.") - -(defvar gnus-newsgroup-saved nil - "List of articles that have been saved.") - -(defvar gnus-newsgroup-kill-headers nil) - -(defvar gnus-newsgroup-replied nil - "List of articles that have been replied to in the current newsgroup.") - -(defvar gnus-newsgroup-expirable nil - "List of articles in the current newsgroup that can be expired.") - -(defvar gnus-newsgroup-processable nil - "List of articles in the current newsgroup that can be processed.") - -(defvar gnus-newsgroup-bookmarks nil - "List of articles in the current newsgroup that have bookmarks.") - -(defvar gnus-newsgroup-dormant nil - "List of dormant articles in the current newsgroup.") - -(defvar gnus-newsgroup-scored nil - "List of scored articles in the current newsgroup.") - -(defvar gnus-newsgroup-headers nil - "List of article headers in the current newsgroup.") - -(defvar gnus-newsgroup-threads nil) - -(defvar gnus-newsgroup-prepared nil - "Whether the current group has been prepared properly.") - -(defvar gnus-newsgroup-ancient nil - "List of `gnus-fetch-old-headers' articles in the current newsgroup.") - -(defvar gnus-newsgroup-sparse nil) - -(defvar gnus-current-article nil) -(defvar gnus-article-current nil) -(defvar gnus-current-headers nil) -(defvar gnus-have-all-headers nil) -(defvar gnus-last-article nil) -(defvar gnus-newsgroup-history nil) -(defvar gnus-current-kill-article nil) - -;; Save window configuration. -(defvar gnus-prev-winconf nil) - -(defvar gnus-summary-mark-positions nil) -(defvar gnus-group-mark-positions nil) - -(defvar gnus-reffed-article-number nil) - -;;; Let the byte-compiler know that we know about this variable. -(defvar rmail-default-rmail-file) - -(defvar gnus-cache-removable-articles nil) - -(defvar gnus-dead-summary nil) - -(defconst gnus-summary-local-variables - '(gnus-newsgroup-name - gnus-newsgroup-begin gnus-newsgroup-end - gnus-newsgroup-last-rmail gnus-newsgroup-last-mail - gnus-newsgroup-last-folder gnus-newsgroup-last-file - gnus-newsgroup-auto-expire gnus-newsgroup-unreads - gnus-newsgroup-unselected gnus-newsgroup-marked - gnus-newsgroup-reads gnus-newsgroup-saved - gnus-newsgroup-replied gnus-newsgroup-expirable - gnus-newsgroup-processable gnus-newsgroup-killed - gnus-newsgroup-bookmarks gnus-newsgroup-dormant - gnus-newsgroup-headers gnus-newsgroup-threads - gnus-newsgroup-prepared gnus-summary-highlight-line-function - gnus-current-article gnus-current-headers gnus-have-all-headers - gnus-last-article gnus-article-internal-prepare-hook - gnus-newsgroup-dependencies gnus-newsgroup-selected-overlay - gnus-newsgroup-scored gnus-newsgroup-kill-headers - gnus-newsgroup-async gnus-thread-expunge-below - gnus-score-alist gnus-current-score-file gnus-summary-expunge-below - (gnus-summary-mark-below . global) - gnus-newsgroup-active gnus-scores-exclude-files - gnus-newsgroup-history gnus-newsgroup-ancient - gnus-newsgroup-sparse - (gnus-newsgroup-adaptive . gnus-use-adaptive-scoring) - gnus-newsgroup-adaptive-score-file (gnus-reffed-article-number . -1) - (gnus-newsgroup-expunged-tally . 0) - gnus-cache-removable-articles gnus-newsgroup-cached - gnus-newsgroup-data gnus-newsgroup-data-reverse - gnus-newsgroup-limit gnus-newsgroup-limits) - "Variables that are buffer-local to the summary buffers.") - -(defconst gnus-bug-message - "Sending a bug report to the Gnus Towers. -======================================== - -The buffer below is a mail buffer. When you press `C-c C-c', it will -be sent to the Gnus Bug Exterminators. - -At the bottom of the buffer you'll see lots of variable settings. -Please do not delete those. They will tell the Bug People what your -environment is, so that it will be easier to locate the bugs. - -If you have found a bug that makes Emacs go \"beep\", set -debug-on-error to t (`M-x set-variable RET debug-on-error RET t RET') -and include the backtrace in your bug report. - -Please describe the bug in annoying, painstaking detail. - -Thank you for your help in stamping out bugs. -") - -;;; End of variables. - -;; Define some autoload functions Gnus might use. (eval-and-compile - - ;; This little mapcar goes through the list below and marks the - ;; symbols in question as autoloaded functions. - (mapcar - (lambda (package) - (let ((interactive (nth 1 (memq ':interactive package)))) - (mapcar - (lambda (function) - (let (keymap) - (when (consp function) - (setq keymap (car (memq 'keymap function))) - (setq function (car function))) - (autoload function (car package) nil interactive keymap))) - (if (eq (nth 1 package) ':interactive) - (cdddr package) - (cdr package))))) - '(("metamail" metamail-buffer) - ("info" Info-goto-node) - ("hexl" hexl-hex-string-to-integer) - ("pp" pp pp-to-string pp-eval-expression) - ("mail-extr" mail-extract-address-components) - ("nnmail" nnmail-split-fancy nnmail-article-group) - ("nnvirtual" nnvirtual-catchup-group) - ("timezone" timezone-make-date-arpa-standard timezone-fix-time - timezone-make-sortable-date timezone-make-time-string) - ("rmailout" rmail-output) - ("rmail" rmail-insert-rmail-file-header rmail-count-new-messages - rmail-show-message) - ("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-mh-mail-setup gnus-summary-save-article-folder - gnus-Folder-save-name gnus-folder-save-name) - ("gnus-mh" :interactive t gnus-summary-save-in-folder) - ("gnus-vis" gnus-group-make-menu-bar gnus-summary-make-menu-bar - gnus-server-make-menu-bar gnus-article-make-menu-bar - gnus-browse-make-menu-bar gnus-highlight-selected-summary - gnus-summary-highlight-line gnus-carpal-setup-buffer - gnus-group-highlight-line - gnus-article-add-button gnus-insert-next-page-button - gnus-insert-prev-page-button gnus-visual-turn-off-edit-menu) - ("gnus-vis" :interactive t - gnus-article-push-button gnus-article-press-button - gnus-article-highlight gnus-article-highlight-some - gnus-article-highlight-headers gnus-article-highlight-signature - gnus-article-add-buttons gnus-article-add-buttons-to-head - gnus-article-next-button gnus-article-prev-button) - ("gnus-demon" gnus-demon-add-nocem gnus-demon-add-scanmail - gnus-demon-add-disconnection gnus-demon-add-handler - gnus-demon-remove-handler) - ("gnus-demon" :interactive t - gnus-demon-init gnus-demon-cancel) - ("gnus-salt" gnus-highlight-selected-tree gnus-possibly-generate-tree - gnus-tree-open gnus-tree-close) - ("gnus-nocem" gnus-nocem-scan-groups gnus-nocem-close - gnus-nocem-unwanted-article-p) - ("gnus-srvr" gnus-enter-server-buffer gnus-server-set-info) - ("gnus-srvr" gnus-browse-foreign-server) - ("gnus-cite" :interactive t - gnus-article-highlight-citation gnus-article-hide-citation-maybe - gnus-article-hide-citation gnus-article-fill-cited-article - gnus-article-hide-citation-in-followups) - ("gnus-kill" gnus-kill gnus-apply-kill-file-internal - gnus-kill-file-edit-file gnus-kill-file-raise-followups-to-author - gnus-execute gnus-expunge) - ("gnus-cache" gnus-cache-possibly-enter-article gnus-cache-save-buffers - gnus-cache-possibly-remove-articles gnus-cache-request-article - gnus-cache-retrieve-headers gnus-cache-possibly-alter-active - gnus-cache-enter-remove-article gnus-cached-article-p - gnus-cache-open gnus-cache-close gnus-cache-update-article) - ("gnus-cache" :interactive t gnus-jog-cache gnus-cache-enter-article - gnus-cache-remove-article) - ("gnus-score" :interactive t - gnus-summary-increase-score gnus-summary-lower-score - gnus-score-flush-cache gnus-score-close - gnus-score-raise-same-subject-and-select - gnus-score-raise-same-subject gnus-score-default - gnus-score-raise-thread gnus-score-lower-same-subject-and-select - gnus-score-lower-same-subject gnus-score-lower-thread - gnus-possibly-score-headers gnus-summary-raise-score - gnus-summary-set-score gnus-summary-current-score) - ("gnus-score" - (gnus-summary-score-map keymap) gnus-score-save gnus-score-headers - gnus-current-score-file-nondirectory gnus-score-adaptive - gnus-score-find-trace gnus-score-file-name) - ("gnus-edit" :interactive t gnus-score-customize) - ("gnus-topic" :interactive t gnus-topic-mode) - ("gnus-topic" gnus-topic-remove-group) - ("gnus-salt" :interactive t gnus-pick-mode gnus-binary-mode) - ("gnus-uu" (gnus-uu-extract-map keymap) (gnus-uu-mark-map keymap)) - ("gnus-uu" :interactive t - gnus-uu-digest-mail-forward gnus-uu-digest-post-forward - gnus-uu-mark-series gnus-uu-mark-region gnus-uu-mark-buffer - gnus-uu-mark-by-regexp gnus-uu-mark-all - gnus-uu-mark-sparse gnus-uu-mark-thread gnus-uu-decode-uu - gnus-uu-decode-uu-and-save gnus-uu-decode-unshar - gnus-uu-decode-unshar-and-save gnus-uu-decode-save - gnus-uu-decode-binhex gnus-uu-decode-uu-view - gnus-uu-decode-uu-and-save-view gnus-uu-decode-unshar-view - gnus-uu-decode-unshar-and-save-view gnus-uu-decode-save-view - gnus-uu-decode-binhex-view) - ("gnus-msg" (gnus-summary-send-map keymap) - gnus-mail-yank-original gnus-mail-send-and-exit - gnus-article-mail gnus-new-mail gnus-mail-reply - gnus-copy-article-buffer) - ("gnus-msg" :interactive t - gnus-group-post-news gnus-group-mail gnus-summary-post-news - gnus-summary-followup gnus-summary-followup-with-original - gnus-summary-cancel-article gnus-summary-supersede-article - gnus-post-news gnus-inews-news - gnus-summary-reply gnus-summary-reply-with-original - gnus-summary-mail-forward gnus-summary-mail-other-window - gnus-bug) - ("gnus-picon" :interactive t gnus-article-display-picons - gnus-group-display-picons gnus-picons-article-display-x-face - gnus-picons-display-x-face) - ("gnus-gl" bbb-login bbb-logout bbb-grouplens-group-p - gnus-grouplens-mode) - ("smiley" :interactive t gnus-smiley-display) - ("gnus-vm" gnus-vm-mail-setup) - ("gnus-vm" :interactive t gnus-summary-save-in-vm - gnus-summary-save-article-vm)))) - - - -;; Fix by Hallvard B Furuseth . -;; If you want the cursor to go somewhere else, set these two -;; functions in some startup hook to whatever you want. -(defalias 'gnus-summary-position-point 'gnus-goto-colon) -(defalias 'gnus-group-position-point 'gnus-goto-colon) - -;;; Various macros and substs. - -(defun gnus-header-from (header) - (mail-header-from header)) - -(defmacro gnus-eval-in-buffer-window (buffer &rest forms) - "Pop to BUFFER, evaluate FORMS, and then return to the original window." - (let ((tempvar (make-symbol "GnusStartBufferWindow")) - (w (make-symbol "w")) - (buf (make-symbol "buf"))) - `(let* ((,tempvar (selected-window)) - (,buf ,buffer) - (,w (get-buffer-window ,buf 'visible))) - (unwind-protect - (progn - (if ,w - (select-window ,w) - (pop-to-buffer ,buf)) - ,@forms) - (select-window ,tempvar))))) - -(put 'gnus-eval-in-buffer-window 'lisp-indent-function 1) -(put 'gnus-eval-in-buffer-window 'lisp-indent-hook 1) -(put 'gnus-eval-in-buffer-window 'edebug-form-spec '(form body)) - -(defmacro gnus-gethash (string hashtable) - "Get hash value of STRING in HASHTABLE." - `(symbol-value (intern-soft ,string ,hashtable))) - -(defmacro gnus-sethash (string value hashtable) - "Set hash value. Arguments are STRING, VALUE, and HASHTABLE." - `(set (intern ,string ,hashtable) ,value)) - -(defmacro gnus-intern-safe (string hashtable) - "Set hash value. Arguments are STRING, VALUE, and HASHTABLE." - `(let ((symbol (intern ,string ,hashtable))) - (or (boundp symbol) - (set symbol nil)) - symbol)) - -(defmacro gnus-group-unread (group) - "Get the currently computed number of unread articles in GROUP." - `(car (gnus-gethash ,group gnus-newsrc-hashtb))) - -(defmacro gnus-group-entry (group) - "Get the newsrc entry for GROUP." - `(gnus-gethash ,group gnus-newsrc-hashtb)) - -(defmacro gnus-active (group) - "Get active info on GROUP." - `(gnus-gethash ,group gnus-active-hashtb)) - -(defmacro gnus-set-active (group active) - "Set GROUP's active info." - `(gnus-sethash ,group ,active gnus-active-hashtb)) - -;; modified by MORIOKA Tomohiko -;; function `substring' might cut on a middle of multi-octet -;; character. -(defun gnus-truncate-string (str width) - (substring str 0 width)) - -;; Added by Geoffrey T. Dairiki . A safe way -;; to limit the length of a string. This function is necessary since -;; `(substr "abc" 0 30)' pukes with "Args out of range". -(defsubst gnus-limit-string (str width) - (if (> (length str) width) - (substring str 0 width) - str)) - -(defsubst gnus-simplify-subject-re (subject) - "Remove \"Re:\" from subject lines." - (if (string-match "^[Rr][Ee]: *" subject) - (substring subject (match-end 0)) - subject)) - -(defsubst gnus-functionp (form) - "Return non-nil if FORM is funcallable." - (or (and (symbolp form) (fboundp form)) - (and (listp form) (eq (car form) 'lambda)))) - -(defsubst gnus-goto-char (point) - (and point (goto-char point))) - -(defmacro gnus-buffer-exists-p (buffer) - `(let ((buffer ,buffer)) - (and buffer - (funcall (if (stringp buffer) 'get-buffer 'buffer-name) - buffer)))) - -(defmacro gnus-kill-buffer (buffer) - `(let ((buf ,buffer)) - (if (gnus-buffer-exists-p buf) - (kill-buffer buf)))) - -(defsubst gnus-point-at-bol () - "Return point at the beginning of the line." - (let ((p (point))) - (beginning-of-line) - (prog1 - (point) - (goto-char p)))) - -(defsubst gnus-point-at-eol () - "Return point at the end of the line." - (let ((p (point))) - (end-of-line) - (prog1 - (point) - (goto-char p)))) - -(defun gnus-alive-p () - "Say whether Gnus is running or not." - (and gnus-group-buffer - (get-buffer gnus-group-buffer))) - -(defun gnus-delete-first (elt list) - "Delete by side effect the first occurrence of ELT as a member of LIST." - (if (equal (car list) elt) - (cdr list) - (let ((total list)) - (while (and (cdr list) - (not (equal (cadr list) elt))) - (setq list (cdr list))) - (when (cdr list) - (setcdr list (cddr list))) - total))) - -;; Delete the current line (and the next N lines.); -(defmacro gnus-delete-line (&optional n) - `(delete-region (progn (beginning-of-line) (point)) - (progn (forward-line ,(or n 1)) (point)))) - -;; Suggested by Brian Edmonds . -(defvar gnus-init-inhibit nil) -(defun gnus-read-init-file (&optional inhibit-next) - (if gnus-init-inhibit - (setq gnus-init-inhibit nil) - (setq gnus-init-inhibit inhibit-next) - (and gnus-init-file - (or (and (file-exists-p gnus-init-file) - ;; Don't try to load a directory. - (not (file-directory-p gnus-init-file))) - (file-exists-p (concat gnus-init-file ".el")) - (file-exists-p (concat gnus-init-file ".elc"))) - (condition-case var - (load gnus-init-file nil t) - (error - (error "Error in %s: %s" gnus-init-file var)))))) - -;; Info access macros. - -(defmacro gnus-info-group (info) - `(nth 0 ,info)) -(defmacro gnus-info-rank (info) - `(nth 1 ,info)) -(defmacro gnus-info-read (info) - `(nth 2 ,info)) -(defmacro gnus-info-marks (info) - `(nth 3 ,info)) -(defmacro gnus-info-method (info) - `(nth 4 ,info)) -(defmacro gnus-info-params (info) - `(nth 5 ,info)) - -(defmacro gnus-info-level (info) - `(let ((rank (gnus-info-rank ,info))) - (if (consp rank) - (car rank) - rank))) -(defmacro gnus-info-score (info) - `(let ((rank (gnus-info-rank ,info))) - (or (and (consp rank) (cdr rank)) 0))) - -(defmacro gnus-info-set-group (info group) - `(setcar ,info ,group)) -(defmacro gnus-info-set-rank (info rank) - `(setcar (nthcdr 1 ,info) ,rank)) -(defmacro gnus-info-set-read (info read) - `(setcar (nthcdr 2 ,info) ,read)) -(defmacro gnus-info-set-marks (info marks) - `(setcar (nthcdr 3 ,info) ,marks)) -(defmacro gnus-info-set-method (info method) - `(setcar (nthcdr 4 ,info) ,method)) -(defmacro gnus-info-set-params (info params) - `(setcar (nthcdr 5 ,info) ,params)) - -(defmacro gnus-info-set-level (info level) - `(let ((rank (cdr ,info))) - (if (consp (car rank)) - (setcar (car rank) ,level) - (setcar rank ,level)))) -(defmacro gnus-info-set-score (info score) - `(let ((rank (cdr ,info))) - (if (consp (car rank)) - (setcdr (car rank) ,score) - (setcar rank (cons (car rank) ,score))))) - -(defmacro gnus-get-info (group) - `(nth 2 (gnus-gethash ,group gnus-newsrc-hashtb))) - -(defun gnus-byte-code (func) - "Return a form that can be `eval'ed based on FUNC." - (let ((fval (symbol-function func))) - (if (byte-code-function-p fval) - (let ((flist (append fval nil))) - (setcar flist 'byte-code) - flist) - (cons 'progn (cddr fval))))) - -;; Find out whether the gnus-visual TYPE is wanted. -(defun gnus-visual-p (&optional type class) - (and gnus-visual ; Has to be non-nil, at least. - (if (not type) ; We don't care about type. - gnus-visual - (if (listp gnus-visual) ; It's a list, so we check it. - (or (memq type gnus-visual) - (memq class gnus-visual)) - t)))) - -;;; Load the compatability functions. - -(require 'gnus-cus) -(require 'gnus-ems) - - -;;; -;;; Shutdown -;;; - -(defvar gnus-shutdown-alist nil) - -(defun gnus-add-shutdown (function &rest symbols) - "Run FUNCTION whenever one of SYMBOLS is shut down." - (push (cons function symbols) gnus-shutdown-alist)) - -(defun gnus-shutdown (symbol) - "Shut down everything that waits for SYMBOL." - (let ((alist gnus-shutdown-alist) - entry) - (while (setq entry (pop alist)) - (when (memq symbol (cdr entry)) - (funcall (car entry)))))) - - - -;; Format specs. The chunks below are the machine-generated forms -;; that are to be evaled as the result of the default format strings. -;; We write them in here to get them byte-compiled. That way the -;; default actions will be quite fast, while still retaining the full -;; flexibility of the user-defined format specs. - -;; First we have lots of dummy defvars to let the compiler know these -;; are really dynamic variables. - -(defvar gnus-tmp-unread) -(defvar gnus-tmp-replied) -(defvar gnus-tmp-score-char) -(defvar gnus-tmp-indentation) -(defvar gnus-tmp-opening-bracket) -(defvar gnus-tmp-lines) -(defvar gnus-tmp-name) -(defvar gnus-tmp-closing-bracket) -(defvar gnus-tmp-subject-or-nil) -(defvar gnus-tmp-subject) -(defvar gnus-tmp-marked) -(defvar gnus-tmp-marked-mark) -(defvar gnus-tmp-subscribed) -(defvar gnus-tmp-process-marked) -(defvar gnus-tmp-number-of-unread) -(defvar gnus-tmp-group-name) -(defvar gnus-tmp-group) -(defvar gnus-tmp-article-number) -(defvar gnus-tmp-unread-and-unselected) -(defvar gnus-tmp-news-method) -(defvar gnus-tmp-news-server) -(defvar gnus-tmp-article-number) -(defvar gnus-mouse-face) -(defvar gnus-mouse-face-prop) - -(defun gnus-summary-line-format-spec () - (insert gnus-tmp-unread gnus-tmp-replied - gnus-tmp-score-char gnus-tmp-indentation) - (gnus-put-text-property - (point) - (progn - (insert - gnus-tmp-opening-bracket - (format "%4d: %-20s" - gnus-tmp-lines - (if (> (length gnus-tmp-name) 20) - (substring gnus-tmp-name 0 20) - gnus-tmp-name)) - gnus-tmp-closing-bracket) - (point)) - gnus-mouse-face-prop gnus-mouse-face) - (insert " " gnus-tmp-subject-or-nil "\n")) - -(defvar gnus-summary-line-format-spec - (gnus-byte-code 'gnus-summary-line-format-spec)) - -(defun gnus-summary-dummy-line-format-spec () - (insert "* ") - (gnus-put-text-property - (point) - (progn - (insert ": :") - (point)) - gnus-mouse-face-prop gnus-mouse-face) - (insert " " gnus-tmp-subject "\n")) - -(defvar gnus-summary-dummy-line-format-spec - (gnus-byte-code 'gnus-summary-dummy-line-format-spec)) - -(defun gnus-group-line-format-spec () - (insert gnus-tmp-marked-mark gnus-tmp-subscribed - gnus-tmp-process-marked - gnus-group-indentation - (format "%5s: " gnus-tmp-number-of-unread)) - (gnus-put-text-property - (point) - (progn - (insert gnus-tmp-group "\n") - (1- (point))) - gnus-mouse-face-prop gnus-mouse-face)) -(defvar gnus-group-line-format-spec - (gnus-byte-code 'gnus-group-line-format-spec)) - -(defvar gnus-format-specs - `((version . ,emacs-version) - (group ,gnus-group-line-format ,gnus-group-line-format-spec) - (summary-dummy ,gnus-summary-dummy-line-format - ,gnus-summary-dummy-line-format-spec) - (summary ,gnus-summary-line-format ,gnus-summary-line-format-spec))) - -(defvar gnus-article-mode-line-format-spec nil) -(defvar gnus-summary-mode-line-format-spec nil) -(defvar gnus-group-mode-line-format-spec nil) - -;;; Phew. All that gruft is over, fortunately. - - -;;; -;;; Gnus Utility Functions -;;; - -(defun gnus-extract-address-components (from) - (let (name address) - ;; First find the address - the thing with the @ in it. This may - ;; not be accurate in mail addresses, but does the trick most of - ;; the time in news messages. - (if (string-match "\\b[^@ \t<>]+[!@][^@ \t<>]+\\b" from) - (setq address (substring from (match-beginning 0) (match-end 0)))) - ;; Then we check whether the "name
" format is used. - (and address - ;; Fix by MORIOKA Tomohiko - ;; Linear white space is not required. - (string-match (concat "[ \t]*<" (regexp-quote address) ">") from) - (and (setq name (substring from 0 (match-beginning 0))) - ;; Strip any quotes from the name. - (string-match "\".*\"" name) - (setq name (substring name 1 (1- (match-end 0)))))) - ;; If not, then "address (name)" is used. - (or name - (and (string-match "(.+)" from) - (setq name (substring from (1+ (match-beginning 0)) - (1- (match-end 0))))) - (and (string-match "()" from) - (setq name address)) - ;; Fix by MORIOKA Tomohiko . - ;; XOVER might not support folded From headers. - (and (string-match "(.*" from) - (setq name (substring from (1+ (match-beginning 0)) - (match-end 0))))) - ;; Fix by Hallvard B Furuseth . - (list (or name from) (or address from)))) - -(defun gnus-fetch-field (field) - "Return the value of the header FIELD of current article." - (save-excursion - (save-restriction - (let ((case-fold-search t) - (inhibit-point-motion-hooks t)) - (nnheader-narrow-to-headers) - (message-fetch-field field))))) - -(defun gnus-goto-colon () - (beginning-of-line) - (search-forward ":" (gnus-point-at-eol) t)) - -;;;###autoload -(defun gnus-update-format (var) - "Update the format specification near point." - (interactive - (list - (save-excursion - (eval-defun nil) - ;; Find the end of the current word. - (re-search-forward "[ \t\n]" nil t) - ;; Search backward. - (when (re-search-backward "\\(gnus-[-a-z]+-line-format\\)" nil t) - (match-string 1))))) - (let* ((type (intern (progn (string-match "gnus-\\([-a-z]+\\)-line" var) - (match-string 1 var)))) - (entry (assq type gnus-format-specs)) - value spec) - (when entry - (setq gnus-format-specs (delq entry gnus-format-specs))) - (set - (intern (format "%s-spec" var)) - (gnus-parse-format (setq value (symbol-value (intern var))) - (symbol-value (intern (format "%s-alist" var))) - (not (string-match "mode" var)))) - (setq spec (symbol-value (intern (format "%s-spec" var)))) - (push (list type value spec) gnus-format-specs) - - (pop-to-buffer "*Gnus Format*") - (erase-buffer) - (lisp-interaction-mode) - (insert (pp-to-string spec)))) - -(defun gnus-update-format-specifications (&optional force) - "Update all (necessary) format specifications." - ;; Make the indentation array. - (gnus-make-thread-indent-array) - - ;; See whether all the stored info needs to be flushed. - (when (or force - (not (equal emacs-version - (cdr (assq 'version gnus-format-specs))))) - (setq gnus-format-specs nil)) - - ;; Go through all the formats and see whether they need updating. - (let ((types '(summary summary-dummy group - summary-mode group-mode article-mode)) - new-format entry type val) - (while (setq type (pop types)) - ;; Jump to the proper buffer to find out the value of - ;; the variable, if possible. (It may be buffer-local.) - (save-excursion - (let ((buffer (intern (format "gnus-%s-buffer" type))) - val) - (when (and (boundp buffer) - (setq val (symbol-value buffer)) - (get-buffer val) - (buffer-name (get-buffer val))) - (set-buffer (get-buffer val))) - (setq new-format (symbol-value - (intern (format "gnus-%s-line-format" type)))))) - (setq entry (cdr (assq type gnus-format-specs))) - (if (and entry - (equal (car entry) new-format)) - ;; Use the old format. - (set (intern (format "gnus-%s-line-format-spec" type)) - (cadr entry)) - ;; This is a new format. - (setq val - (if (not (stringp new-format)) - ;; This is a function call or something. - new-format - ;; This is a "real" format. - (gnus-parse-format - new-format - (symbol-value - (intern (format "gnus-%s-line-format-alist" - (if (eq type 'article-mode) - 'summary-mode type)))) - (not (string-match "mode$" (symbol-name type)))))) - ;; Enter the new format spec into the list. - (if entry - (progn - (setcar (cdr entry) val) - (setcar entry new-format)) - (push (list type new-format val) gnus-format-specs)) - (set (intern (format "gnus-%s-line-format-spec" type)) val)))) - - (unless (assq 'version gnus-format-specs) - (push (cons 'version emacs-version) gnus-format-specs)) - - (gnus-update-group-mark-positions) - (gnus-update-summary-mark-positions)) - -(defun gnus-update-summary-mark-positions () - "Compute where the summary marks are to go." - (save-excursion - (when (and gnus-summary-buffer - (get-buffer gnus-summary-buffer) - (buffer-name (get-buffer gnus-summary-buffer))) - (set-buffer gnus-summary-buffer)) - (let ((gnus-replied-mark 129) - (gnus-score-below-mark 130) - (gnus-score-over-mark 130) - (thread nil) - (gnus-visual nil) - (spec gnus-summary-line-format-spec) - pos) - (save-excursion - (gnus-set-work-buffer) - (let ((gnus-summary-line-format-spec spec)) - (gnus-summary-insert-line - [0 "" "" "" "" "" 0 0 ""] 0 nil 128 t nil "" nil 1) - (goto-char (point-min)) - (setq pos (list (cons 'unread (and (search-forward "\200" nil t) - (- (point) 2))))) - (goto-char (point-min)) - (push (cons 'replied (and (search-forward "\201" nil t) - (- (point) 2))) - pos) - (goto-char (point-min)) - (push (cons 'score (and (search-forward "\202" nil t) (- (point) 2))) - pos))) - (setq gnus-summary-mark-positions pos)))) - -(defun gnus-update-group-mark-positions () - (save-excursion - (let ((gnus-process-mark 128) - (gnus-group-marked '("dummy.group")) - (gnus-active-hashtb (make-vector 10 0))) - (gnus-set-active "dummy.group" '(0 . 0)) - (gnus-set-work-buffer) - (gnus-group-insert-group-line "dummy.group" 0 nil 0 nil) - (goto-char (point-min)) - (setq gnus-group-mark-positions - (list (cons 'process (and (search-forward "\200" nil t) - (- (point) 2)))))))) - -(defvar gnus-mouse-face-0 'highlight) -(defvar gnus-mouse-face-1 'highlight) -(defvar gnus-mouse-face-2 'highlight) -(defvar gnus-mouse-face-3 'highlight) -(defvar gnus-mouse-face-4 'highlight) - -(defun gnus-mouse-face-function (form type) - `(gnus-put-text-property - (point) (progn ,@form (point)) - gnus-mouse-face-prop - ,(if (equal type 0) - 'gnus-mouse-face - `(quote ,(symbol-value (intern (format "gnus-mouse-face-%d" type))))))) - -(defvar gnus-face-0 'bold) -(defvar gnus-face-1 'italic) -(defvar gnus-face-2 'bold-italic) -(defvar gnus-face-3 'bold) -(defvar gnus-face-4 'bold) - -(defun gnus-face-face-function (form type) - `(gnus-put-text-property - (point) (progn ,@form (point)) - 'face ',(symbol-value (intern (format "gnus-face-%d" type))))) - -(defun gnus-max-width-function (el max-width) - (or (numberp max-width) (signal 'wrong-type-argument '(numberp max-width))) - (if (symbolp el) - `(if (> (length ,el) ,max-width) - (substring ,el 0 ,max-width) - ,el) - `(let ((val (eval ,el))) - (if (numberp val) - (setq val (int-to-string val))) - (if (> (length val) ,max-width) - (substring val 0 ,max-width) - val)))) - -(defun gnus-parse-format (format spec-alist &optional insert) - ;; This function parses the FORMAT string with the help of the - ;; SPEC-ALIST and returns a list that can be eval'ed to return the - ;; string. If the FORMAT string contains the specifiers %( and %) - ;; the text between them will have the mouse-face text property. - (if (string-match - "\\`\\(.*\\)%[0-9]?[{(]\\(.*\\)%[0-9]?[})]\\(.*\n?\\)\\'" - format) - (gnus-parse-complex-format format spec-alist) - ;; This is a simple format. - (gnus-parse-simple-format format spec-alist insert))) - -(defun gnus-parse-complex-format (format spec-alist) - (save-excursion - (gnus-set-work-buffer) - (insert format) - (goto-char (point-min)) - (while (re-search-forward "\"" nil t) - (replace-match "\\\"" nil t)) - (goto-char (point-min)) - (insert "(\"") - (while (re-search-forward "%\\([0-9]+\\)?\\([{}()]\\)" nil t) - (let ((number (if (match-beginning 1) - (match-string 1) "0")) - (delim (aref (match-string 2) 0))) - (if (or (= delim ?\() (= delim ?\{)) - (replace-match (concat "\"(" (if (= delim ?\() "mouse" "face") - " " number " \"")) - (replace-match "\")\"")))) - (goto-char (point-max)) - (insert "\")") - (goto-char (point-min)) - (let ((form (read (current-buffer)))) - (cons 'progn (gnus-complex-form-to-spec form spec-alist))))) - -(defun gnus-complex-form-to-spec (form spec-alist) - (delq nil - (mapcar - (lambda (sform) - (if (stringp sform) - (gnus-parse-simple-format sform spec-alist t) - (funcall (intern (format "gnus-%s-face-function" (car sform))) - (gnus-complex-form-to-spec (cddr sform) spec-alist) - (nth 1 sform)))) - form))) - -(defun gnus-parse-simple-format (format spec-alist &optional insert) - ;; This function parses the FORMAT string with the help of the - ;; SPEC-ALIST and returns a list that can be eval'ed to return a - ;; string. - (let ((max-width 0) - spec flist fstring newspec elem beg result dontinsert) - (save-excursion - (gnus-set-work-buffer) - (insert format) - (goto-char (point-min)) - (while (re-search-forward "%[-0-9]*\\(,[0-9]+\\)?\\([^0-9]\\)\\(.\\)?" - nil t) - (if (= (setq spec (string-to-char (match-string 2))) ?%) - (setq newspec "%" - beg (1+ (match-beginning 0))) - ;; First check if there are any specs that look anything like - ;; "%12,12A", ie. with a "max width specification". These have - ;; to be treated specially. - (if (setq beg (match-beginning 1)) - (setq max-width - (string-to-int - (buffer-substring - (1+ (match-beginning 1)) (match-end 1)))) - (setq max-width 0) - (setq beg (match-beginning 2))) - ;; Find the specification from `spec-alist'. - (unless (setq elem (cdr (assq spec spec-alist))) - (setq elem '("*" ?s))) - ;; Treat user defined format specifiers specially. - (when (eq (car elem) 'gnus-tmp-user-defined) - (setq elem - (list - (list (intern (concat "gnus-user-format-function-" - (match-string 3))) - 'gnus-tmp-header) ?s)) - (delete-region (match-beginning 3) (match-end 3))) - (if (not (zerop max-width)) - (let ((el (car elem))) - (cond ((= (cadr elem) ?c) - (setq el (list 'char-to-string el))) - ((= (cadr elem) ?d) - (setq el (list 'int-to-string el)))) - (setq flist (cons (gnus-max-width-function el max-width) - flist)) - (setq newspec ?s)) - (progn - (setq flist (cons (car elem) flist)) - (setq newspec (cadr elem))))) - ;; Remove the old specification (and possibly a ",12" string). - (delete-region beg (match-end 2)) - ;; Insert the new specification. - (goto-char beg) - (insert newspec)) - (setq fstring (buffer-substring 1 (point-max)))) - ;; Do some postprocessing to increase efficiency. - (setq - result - (cond - ;; Emptyness. - ((string= fstring "") - nil) - ;; Not a format string. - ((not (string-match "%" fstring)) - (list fstring)) - ;; A format string with just a single string spec. - ((string= fstring "%s") - (list (car flist))) - ;; A single character. - ((string= fstring "%c") - (list (car flist))) - ;; A single number. - ((string= fstring "%d") - (setq dontinsert) - (if insert - (list `(princ ,(car flist))) - (list `(int-to-string ,(car flist))))) - ;; Just lots of chars and strings. - ((string-match "\\`\\(%[cs]\\)+\\'" fstring) - (nreverse flist)) - ;; A single string spec at the beginning of the spec. - ((string-match "\\`%[sc][^%]+\\'" fstring) - (list (car flist) (substring fstring 2))) - ;; A single string spec in the middle of the spec. - ((string-match "\\`\\([^%]+\\)%[sc]\\([^%]+\\)\\'" fstring) - (list (match-string 1 fstring) (car flist) (match-string 2 fstring))) - ;; A single string spec in the end of the spec. - ((string-match "\\`\\([^%]+\\)%[sc]\\'" fstring) - (list (match-string 1 fstring) (car flist))) - ;; A more complex spec. - (t - (list (cons 'format (cons fstring (nreverse flist))))))) - - (if insert - (when result - (if dontinsert - result - (cons 'insert result))) - (cond ((stringp result) - result) - ((consp result) - (cons 'concat result)) - (t ""))))) - -(defun gnus-eval-format (format &optional alist props) - "Eval the format variable FORMAT, using ALIST. -If PROPS, insert the result." - (let ((form (gnus-parse-format format alist props))) - (if props - (gnus-add-text-properties (point) (progn (eval form) (point)) props) - (eval form)))) - -(defun gnus-remove-text-with-property (prop) - "Delete all text in the current buffer with text property PROP." - (save-excursion - (goto-char (point-min)) - (while (not (eobp)) - (while (get-text-property (point) prop) - (delete-char 1)) - (goto-char (next-single-property-change (point) prop nil (point-max)))))) - -(defun gnus-set-work-buffer () - (if (get-buffer gnus-work-buffer) - (progn - (set-buffer gnus-work-buffer) - (erase-buffer)) - (set-buffer (get-buffer-create gnus-work-buffer)) - (kill-all-local-variables) - (buffer-disable-undo (current-buffer)) - (gnus-add-current-to-buffer-list))) - -;; Article file names when saving. - -(defun gnus-Numeric-save-name (newsgroup headers &optional last-file) - "Generate file name from NEWSGROUP, HEADERS, and optional LAST-FILE. -If variable `gnus-use-long-file-name' is nil, it is ~/News/News.group/num. -Otherwise, it is like ~/News/news/group/num." - (let ((default - (expand-file-name - (concat (if (gnus-use-long-file-name 'not-save) - (gnus-capitalize-newsgroup newsgroup) - (gnus-newsgroup-directory-form newsgroup)) - "/" (int-to-string (mail-header-number headers))) - gnus-article-save-directory))) - (if (and last-file - (string-equal (file-name-directory default) - (file-name-directory last-file)) - (string-match "^[0-9]+$" (file-name-nondirectory last-file))) - default - (or last-file default)))) - -(defun gnus-numeric-save-name (newsgroup headers &optional last-file) - "Generate file name from NEWSGROUP, HEADERS, and optional LAST-FILE. -If variable `gnus-use-long-file-name' is non-nil, it is -~/News/news.group/num. Otherwise, it is like ~/News/news/group/num." - (let ((default - (expand-file-name - (concat (if (gnus-use-long-file-name 'not-save) - newsgroup - (gnus-newsgroup-directory-form newsgroup)) - "/" (int-to-string (mail-header-number headers))) - gnus-article-save-directory))) - (if (and last-file - (string-equal (file-name-directory default) - (file-name-directory last-file)) - (string-match "^[0-9]+$" (file-name-nondirectory last-file))) - default - (or last-file default)))) - -(defun gnus-Plain-save-name (newsgroup headers &optional last-file) - "Generate file name from NEWSGROUP, HEADERS, and optional LAST-FILE. -If variable `gnus-use-long-file-name' is non-nil, it is -~/News/News.group. Otherwise, it is like ~/News/news/group/news." - (or last-file - (expand-file-name - (if (gnus-use-long-file-name 'not-save) - (gnus-capitalize-newsgroup newsgroup) - (concat (gnus-newsgroup-directory-form newsgroup) "/news")) - gnus-article-save-directory))) - -(defun gnus-plain-save-name (newsgroup headers &optional last-file) - "Generate file name from NEWSGROUP, HEADERS, and optional LAST-FILE. -If variable `gnus-use-long-file-name' is non-nil, it is -~/News/news.group. Otherwise, it is like ~/News/news/group/news." - (or last-file - (expand-file-name - (if (gnus-use-long-file-name 'not-save) - newsgroup - (concat (gnus-newsgroup-directory-form newsgroup) "/news")) - gnus-article-save-directory))) - -;; For subscribing new newsgroup - -(defun gnus-subscribe-hierarchical-interactive (groups) - (let ((groups (sort groups 'string<)) - prefixes prefix start ans group starts) - (while groups - (setq prefixes (list "^")) - (while (and groups prefixes) - (while (not (string-match (car prefixes) (car groups))) - (setq prefixes (cdr prefixes))) - (setq prefix (car prefixes)) - (setq start (1- (length prefix))) - (if (and (string-match "[^\\.]\\." (car groups) start) - (cdr groups) - (setq prefix - (concat "^" (substring (car groups) 0 (match-end 0)))) - (string-match prefix (cadr groups))) - (progn - (setq prefixes (cons prefix prefixes)) - (message "Descend hierarchy %s? ([y]nsq): " - (substring prefix 1 (1- (length prefix)))) - (while (not (memq (setq ans (read-char)) '(?y ?\n ?n ?s ?q))) - (ding) - (message "Descend hierarchy %s? ([y]nsq): " - (substring prefix 1 (1- (length prefix))))) - (cond ((= ans ?n) - (while (and groups - (string-match prefix - (setq group (car groups)))) - (setq gnus-killed-list - (cons group gnus-killed-list)) - (gnus-sethash group group gnus-killed-hashtb) - (setq groups (cdr groups))) - (setq starts (cdr starts))) - ((= ans ?s) - (while (and groups - (string-match prefix - (setq group (car groups)))) - (gnus-sethash group group gnus-killed-hashtb) - (gnus-subscribe-alphabetically (car groups)) - (setq groups (cdr groups))) - (setq starts (cdr starts))) - ((= ans ?q) - (while groups - (setq group (car groups)) - (setq gnus-killed-list (cons group gnus-killed-list)) - (gnus-sethash group group gnus-killed-hashtb) - (setq groups (cdr groups)))) - (t nil))) - (message "Subscribe %s? ([n]yq)" (car groups)) - (while (not (memq (setq ans (read-char)) '(?y ?\n ?q ?n))) - (ding) - (message "Subscribe %s? ([n]yq)" (car groups))) - (setq group (car groups)) - (cond ((= ans ?y) - (gnus-subscribe-alphabetically (car groups)) - (gnus-sethash group group gnus-killed-hashtb)) - ((= ans ?q) - (while groups - (setq group (car groups)) - (setq gnus-killed-list (cons group gnus-killed-list)) - (gnus-sethash group group gnus-killed-hashtb) - (setq groups (cdr groups)))) - (t - (setq gnus-killed-list (cons group gnus-killed-list)) - (gnus-sethash group group gnus-killed-hashtb))) - (setq groups (cdr groups))))))) - -(defun gnus-subscribe-randomly (newsgroup) - "Subscribe new NEWSGROUP by making it the first newsgroup." - (gnus-subscribe-newsgroup newsgroup)) - -(defun gnus-subscribe-alphabetically (newgroup) - "Subscribe new NEWSGROUP and insert it in alphabetical order." - (let ((groups (cdr gnus-newsrc-alist)) - before) - (while (and (not before) groups) - (if (string< newgroup (caar groups)) - (setq before (caar groups)) - (setq groups (cdr groups)))) - (gnus-subscribe-newsgroup newgroup before))) - -(defun gnus-subscribe-hierarchically (newgroup) - "Subscribe new NEWSGROUP and insert it in hierarchical newsgroup order." - ;; Basic ideas by mike-w@cs.aukuni.ac.nz (Mike Williams) - (save-excursion - (set-buffer (find-file-noselect gnus-current-startup-file)) - (let ((groupkey newgroup) - before) - (while (and (not before) groupkey) - (goto-char (point-min)) - (let ((groupkey-re - (concat "^\\(" (regexp-quote groupkey) ".*\\)[!:]"))) - (while (and (re-search-forward groupkey-re nil t) - (progn - (setq before (match-string 1)) - (string< before newgroup))))) - ;; Remove tail of newsgroup name (eg. a.b.c -> a.b) - (setq groupkey - (if (string-match "^\\(.*\\)\\.[^.]+$" groupkey) - (substring groupkey (match-beginning 1) (match-end 1))))) - (gnus-subscribe-newsgroup newgroup before)) - (kill-buffer (current-buffer)))) - -(defun gnus-subscribe-interactively (group) - "Subscribe the new GROUP interactively. -It is inserted in hierarchical newsgroup order if subscribed. If not, -it is killed." - (if (gnus-y-or-n-p (format "Subscribe new newsgroup: %s " group)) - (gnus-subscribe-hierarchically group) - (push group gnus-killed-list))) - -(defun gnus-subscribe-zombies (group) - "Make the new GROUP into a zombie group." - (push group gnus-zombie-list)) - -(defun gnus-subscribe-killed (group) - "Make the new GROUP a killed group." - (push group gnus-killed-list)) - -(defun gnus-subscribe-newsgroup (newsgroup &optional next) - "Subscribe new NEWSGROUP. -If NEXT is non-nil, it is inserted before NEXT. Otherwise it is made -the first newsgroup." - (save-excursion - (goto-char (point-min)) - ;; We subscribe the group by changing its level to `subscribed'. - (gnus-group-change-level - newsgroup gnus-level-default-subscribed - gnus-level-killed (gnus-gethash (or next "dummy.group") - gnus-newsrc-hashtb)) - (gnus-message 5 "Subscribe newsgroup: %s" newsgroup))) - -;; For directories - -(defun gnus-newsgroup-directory-form (newsgroup) - "Make hierarchical directory name from NEWSGROUP name." - (let ((newsgroup (gnus-newsgroup-savable-name newsgroup)) - (len (length newsgroup)) - idx) - ;; If this is a foreign group, we don't want to translate the - ;; entire name. - (if (setq idx (string-match ":" newsgroup)) - (aset newsgroup idx ?/) - (setq idx 0)) - ;; Replace all occurrences of `.' with `/'. - (while (< idx len) - (if (= (aref newsgroup idx) ?.) - (aset newsgroup idx ?/)) - (setq idx (1+ idx))) - newsgroup)) - -(defun gnus-newsgroup-savable-name (group) - ;; Replace any slashes in a group name (eg. an ange-ftp nndoc group) - ;; with dots. - (nnheader-replace-chars-in-string group ?/ ?.)) + (autoload 'gnus-play-jingle "gnus-audio")) -(defun gnus-make-directory (dir) - "Make DIRECTORY recursively." - (unless dir - (error "No directory to make")) - ;; Why don't we use `(make-directory dir 'parents)'? That's just one - ;; of the many mysteries of the universe. - (let* ((dir (expand-file-name dir default-directory)) - dirs err) - (if (string-match "/$" dir) - (setq dir (substring dir 0 (match-beginning 0)))) - ;; First go down the path until we find a directory that exists. - (while (not (file-exists-p dir)) - (setq dirs (cons dir dirs)) - (string-match "/[^/]+$" dir) - (setq dir (substring dir 0 (match-beginning 0)))) - ;; Then create all the subdirs. - (while (and dirs (not err)) - (condition-case () - (make-directory (car dirs)) - (error (setq err t))) - (setq dirs (cdr dirs))) - ;; We return whether we were successful or not. - (not dirs))) - -(defun gnus-capitalize-newsgroup (newsgroup) - "Capitalize NEWSGROUP name." - (and (not (zerop (length newsgroup))) - (concat (char-to-string (upcase (aref newsgroup 0))) - (substring newsgroup 1)))) - -;; Various... things. - -(defun gnus-simplify-subject (subject &optional re-only) - "Remove `Re:' and words in parentheses. -If RE-ONLY is non-nil, strip leading `Re:'s only." - (let ((case-fold-search t)) ;Ignore case. - ;; Remove `Re:', `Re^N:', `Re(n)', and `Re[n]:'. - (when (string-match "\\`\\(re\\([[(^][0-9]+[])]?\\)?:[ \t]*\\)+" subject) - (setq subject (substring subject (match-end 0)))) - ;; Remove uninteresting prefixes. - (if (and (not re-only) - gnus-simplify-ignored-prefixes - (string-match gnus-simplify-ignored-prefixes subject)) - (setq subject (substring subject (match-end 0)))) - ;; Remove words in parentheses from end. - (unless re-only - (while (string-match "[ \t\n]*([^()]*)[ \t\n]*\\'" subject) - (setq subject (substring subject 0 (match-beginning 0))))) - ;; Return subject string. - subject)) - -;; Remove any leading "re:"s, any trailing paren phrases, and simplify -;; all whitespace. -;; Written by Stainless Steel Rat . -(defun gnus-simplify-buffer-fuzzy () - (let ((case-fold-search t)) - (goto-char (point-min)) - (while (search-forward "\t" nil t) - (replace-match " " t t)) - (goto-char (point-min)) - (re-search-forward "^ *\\(re\\|fwd\\)[[{(^0-9]*[])}]?[:;] *" nil t) - (goto-char (match-beginning 0)) - (while (or - (looking-at "^ *\\(re\\|fwd\\)[[{(^0-9]*[])}]?[:;] *") - (looking-at "^[[].*: .*[]]$")) - (goto-char (point-min)) - (while (re-search-forward "^ *\\(re\\|fwd\\)[[{(^0-9]*[])}]?[:;] *" - nil t) - (replace-match "" t t)) - (goto-char (point-min)) - (while (re-search-forward "^[[].*: .*[]]$" nil t) - (goto-char (match-end 0)) - (delete-char -1) - (delete-region - (progn (goto-char (match-beginning 0))) - (re-search-forward ":")))) - (goto-char (point-min)) - (while (re-search-forward " *[[{(][^()\n]*[]})] *$" nil t) - (replace-match "" t t)) - (goto-char (point-min)) - (while (re-search-forward " +" nil t) - (replace-match " " t t)) - (goto-char (point-min)) - (while (re-search-forward " $" nil t) - (replace-match "" t t)) - (goto-char (point-min)) - (while (re-search-forward "^ +" nil t) - (replace-match "" t t)) - (goto-char (point-min)) - (when gnus-simplify-subject-fuzzy-regexp - (if (listp gnus-simplify-subject-fuzzy-regexp) - (let ((list gnus-simplify-subject-fuzzy-regexp)) - (while list - (goto-char (point-min)) - (while (re-search-forward (car list) nil t) - (replace-match "" t t)) - (setq list (cdr list)))) - (while (re-search-forward gnus-simplify-subject-fuzzy-regexp nil t) - (replace-match "" t t)))))) - -(defun gnus-simplify-subject-fuzzy (subject) - "Siplify a subject string fuzzily." - (save-excursion - (gnus-set-work-buffer) - (let ((case-fold-search t)) - (insert subject) - (inline (gnus-simplify-buffer-fuzzy)) - (buffer-string)))) - -;; Add the current buffer to the list of buffers to be killed on exit. -(defun gnus-add-current-to-buffer-list () - (or (memq (current-buffer) gnus-buffer-list) - (setq gnus-buffer-list (cons (current-buffer) gnus-buffer-list)))) - -(defun gnus-string> (s1 s2) - (not (or (string< s1 s2) - (string= s1 s2)))) - -(defun gnus-read-active-file-p () - "Say whether the active file has been read from `gnus-select-method'." - (memq gnus-select-method gnus-have-read-active-file)) - -;;; General various misc type functions. - -(defun gnus-clear-system () - "Clear all variables and buffers." - ;; Clear Gnus variables. - (let ((variables gnus-variable-list)) - (while variables - (set (car variables) nil) - (setq variables (cdr variables)))) - ;; Clear other internal variables. - (setq gnus-list-of-killed-groups nil - gnus-have-read-active-file nil - gnus-newsrc-alist nil - gnus-newsrc-hashtb nil - gnus-killed-list nil - gnus-zombie-list nil - gnus-killed-hashtb nil - gnus-active-hashtb nil - gnus-moderated-list nil - gnus-description-hashtb nil - gnus-current-headers nil - gnus-thread-indent-array nil - gnus-newsgroup-headers nil - gnus-newsgroup-name nil - gnus-server-alist nil - gnus-group-list-mode nil - gnus-opened-servers nil - gnus-group-mark-positions nil - gnus-newsgroup-data nil - gnus-newsgroup-unreads nil - nnoo-state-alist nil - gnus-current-select-method nil) - (gnus-shutdown 'gnus) - ;; Kill the startup file. - (and gnus-current-startup-file - (get-file-buffer gnus-current-startup-file) - (kill-buffer (get-file-buffer gnus-current-startup-file))) - ;; Clear the dribble buffer. - (gnus-dribble-clear) - ;; Kill global KILL file buffer. - (when (get-file-buffer (gnus-newsgroup-kill-file nil)) - (kill-buffer (get-file-buffer (gnus-newsgroup-kill-file nil)))) - (gnus-kill-buffer nntp-server-buffer) - ;; Kill Gnus buffers. - (while gnus-buffer-list - (gnus-kill-buffer (pop gnus-buffer-list))) - ;; Remove Gnus frames. - (gnus-kill-gnus-frames)) - -(defun gnus-kill-gnus-frames () - "Kill all frames Gnus has created." - (while gnus-created-frames - (when (frame-live-p (car gnus-created-frames)) - ;; We slap a condition-case around this `delete-frame' to ensure - ;; against errors if we try do delete the single frame that's left. - (condition-case () - (delete-frame (car gnus-created-frames)) - (error nil))) - (pop gnus-created-frames))) - -(defun gnus-windows-old-to-new (setting) - ;; First we take care of the really, really old Gnus 3 actions. - (when (symbolp setting) - (setq setting - ;; Take care of ooold GNUS 3.x values. - (cond ((eq setting 'SelectArticle) 'article) - ((memq setting '(SelectSubject ExpandSubject)) 'summary) - ((memq setting '(SelectNewsgroup ExitNewsgroup)) 'group) - (t setting)))) - (if (or (listp setting) - (not (and gnus-window-configuration - (memq setting '(group summary article))))) - setting - (let* ((setting (if (eq setting 'group) - (if (assq 'newsgroup gnus-window-configuration) - 'newsgroup - 'newsgroups) setting)) - (elem (cadr (assq setting gnus-window-configuration))) - (total (apply '+ elem)) - (types '(group summary article)) - (pbuf (if (eq setting 'newsgroups) 'group 'summary)) - (i 0) - perc - out) - (while (< i 3) - (or (not (numberp (nth i elem))) - (zerop (nth i elem)) - (progn - (setq perc (if (= i 2) - 1.0 - (/ (float (nth 0 elem)) total))) - (setq out (cons (if (eq pbuf (nth i types)) - (list (nth i types) perc 'point) - (list (nth i types) perc)) - out)))) - (setq i (1+ i))) - `(vertical 1.0 ,@(nreverse out))))) - -;;;###autoload -(defun gnus-add-configuration (conf) - "Add the window configuration CONF to `gnus-buffer-configuration'." - (setq gnus-buffer-configuration - (cons conf (delq (assq (car conf) gnus-buffer-configuration) - gnus-buffer-configuration)))) - -(defvar gnus-frame-list nil) - -(defun gnus-configure-frame (split &optional window) - "Split WINDOW according to SPLIT." - (unless window - (setq window (get-buffer-window (current-buffer)))) - (select-window window) - ;; This might be an old-stylee buffer config. - (when (vectorp split) - (setq split (append split nil))) - (when (or (consp (car split)) - (vectorp (car split))) - (push 1.0 split) - (push 'vertical split)) - ;; The SPLIT might be something that is to be evaled to - ;; return a new SPLIT. - (while (and (not (assq (car split) gnus-window-to-buffer)) - (gnus-functionp (car split))) - (setq split (eval split))) - (let* ((type (car split)) - (subs (cddr split)) - (len (if (eq type 'horizontal) (window-width) (window-height))) - (total 0) - (window-min-width (or gnus-window-min-width window-min-width)) - (window-min-height (or gnus-window-min-height window-min-height)) - s result new-win rest comp-subs size sub) - (cond - ;; Nothing to do here. - ((null split)) - ;; Don't switch buffers. - ((null type) - (and (memq 'point split) window)) - ;; This is a buffer to be selected. - ((not (memq type '(frame horizontal vertical))) - (let ((buffer (cond ((stringp type) type) - (t (cdr (assq type gnus-window-to-buffer))))) - buf) - (unless buffer - (error "Illegal buffer type: %s" type)) - (unless (setq buf (get-buffer (if (symbolp buffer) - (symbol-value buffer) buffer))) - (setq buf (get-buffer-create (if (symbolp buffer) - (symbol-value buffer) buffer)))) - (switch-to-buffer buf) - ;; We return the window if it has the `point' spec. - (and (memq 'point split) window))) - ;; This is a frame split. - ((eq type 'frame) - (unless gnus-frame-list - (setq gnus-frame-list (list (window-frame - (get-buffer-window (current-buffer)))))) - (let ((i 0) - params frame fresult) - (while (< i (length subs)) - ;; Frame parameter is gotten from the sub-split. - (setq params (cadr (elt subs i))) - ;; It should be a list. - (unless (listp params) - (setq params nil)) - ;; Create a new frame? - (unless (setq frame (elt gnus-frame-list i)) - (nconc gnus-frame-list (list (setq frame (make-frame params)))) - (push frame gnus-created-frames)) - ;; Is the old frame still alive? - (unless (frame-live-p frame) - (setcar (nthcdr i gnus-frame-list) - (setq frame (make-frame params)))) - ;; Select the frame in question and do more splits there. - (select-frame frame) - (setq fresult (or (gnus-configure-frame (elt subs i)) fresult)) - (incf i)) - ;; Select the frame that has the selected buffer. - (when fresult - (select-frame (window-frame fresult))))) - ;; This is a normal split. - (t - (when (> (length subs) 0) - ;; First we have to compute the sizes of all new windows. - (while subs - (setq sub (append (pop subs) nil)) - (while (and (not (assq (car sub) gnus-window-to-buffer)) - (gnus-functionp (car sub))) - (setq sub (eval sub))) - (when sub - (push sub comp-subs) - (setq size (cadar comp-subs)) - (cond ((equal size 1.0) - (setq rest (car comp-subs)) - (setq s 0)) - ((floatp size) - (setq s (floor (* size len)))) - ((integerp size) - (setq s size)) - (t - (error "Illegal size: %s" size))) - ;; Try to make sure that we are inside the safe limits. - (cond ((zerop s)) - ((eq type 'horizontal) - (setq s (max s window-min-width))) - ((eq type 'vertical) - (setq s (max s window-min-height)))) - (setcar (cdar comp-subs) s) - (incf total s))) - ;; Take care of the "1.0" spec. - (if rest - (setcar (cdr rest) (- len total)) - (error "No 1.0 specs in %s" split)) - ;; The we do the actual splitting in a nice recursive - ;; fashion. - (setq comp-subs (nreverse comp-subs)) - (while comp-subs - (if (null (cdr comp-subs)) - (setq new-win window) - (setq new-win - (split-window window (cadar comp-subs) - (eq type 'horizontal)))) - (setq result (or (gnus-configure-frame - (car comp-subs) window) result)) - (select-window new-win) - (setq window new-win) - (setq comp-subs (cdr comp-subs)))) - ;; Return the proper window, if any. - (when result - (select-window result)))))) - -(defvar gnus-frame-split-p nil) - -(defun gnus-configure-windows (setting &optional force) - (setq setting (gnus-windows-old-to-new setting)) - (let ((split (if (symbolp setting) - (cadr (assq setting gnus-buffer-configuration)) - setting)) - all-visible) - - (setq gnus-frame-split-p nil) - - (unless split - (error "No such setting: %s" setting)) - - (if (and (setq all-visible (gnus-all-windows-visible-p split)) - (not force)) - ;; All the windows mentioned are already visible, so we just - ;; put point in the assigned buffer, and do not touch the - ;; winconf. - (select-window all-visible) - - ;; Either remove all windows or just remove all Gnus windows. - (let ((frame (selected-frame))) - (unwind-protect - (if gnus-use-full-window - ;; We want to remove all other windows. - (if (not gnus-frame-split-p) - ;; This is not a `frame' split, so we ignore the - ;; other frames. - (delete-other-windows) - ;; This is a `frame' split, so we delete all windows - ;; on all frames. - (mapcar - (lambda (frame) - (unless (eq (cdr (assq 'minibuffer - (frame-parameters frame))) - 'only) - (select-frame frame) - (delete-other-windows))) - (frame-list))) - ;; Just remove some windows. - (gnus-remove-some-windows) - (switch-to-buffer nntp-server-buffer)) - (select-frame frame))) - - (switch-to-buffer nntp-server-buffer) - (gnus-configure-frame split (get-buffer-window (current-buffer)))))) - -(defun gnus-all-windows-visible-p (split) - "Say whether all buffers in SPLIT are currently visible. -In particular, the value returned will be the window that -should have point." - (let ((stack (list split)) - (all-visible t) - type buffer win buf) - (while (and (setq split (pop stack)) - all-visible) - ;; Be backwards compatible. - (when (vectorp split) - (setq split (append split nil))) - (when (or (consp (car split)) - (vectorp (car split))) - (push 1.0 split) - (push 'vertical split)) - ;; The SPLIT might be something that is to be evaled to - ;; return a new SPLIT. - (while (and (not (assq (car split) gnus-window-to-buffer)) - (gnus-functionp (car split))) - (setq split (eval split))) - - (setq type (elt split 0)) - (cond - ;; Nothing here. - ((null split) t) - ;; A buffer. - ((not (memq type '(horizontal vertical frame))) - (setq buffer (cond ((stringp type) type) - (t (cdr (assq type gnus-window-to-buffer))))) - (unless buffer - (error "Illegal buffer type: %s" type)) - (when (setq buf (get-buffer (if (symbolp buffer) - (symbol-value buffer) - buffer))) - (setq win (get-buffer-window buf t))) - (if win - (when (memq 'point split) - (setq all-visible win)) - (setq all-visible nil))) - (t - (when (eq type 'frame) - (setq gnus-frame-split-p t)) - (setq stack (append (cddr split) stack))))) - (unless (eq all-visible t) - all-visible))) - -(defun gnus-window-top-edge (&optional window) - (nth 1 (window-edges window))) - -(defun gnus-remove-some-windows () - (let ((buffers gnus-window-to-buffer) - buf bufs lowest-buf lowest) - (save-excursion - ;; Remove windows on all known Gnus buffers. - (while buffers - (setq buf (cdar buffers)) - (if (symbolp buf) - (setq buf (and (boundp buf) (symbol-value buf)))) - (and buf - (get-buffer-window buf) - (progn - (setq bufs (cons buf bufs)) - (pop-to-buffer buf) - (if (or (not lowest) - (< (gnus-window-top-edge) lowest)) - (progn - (setq lowest (gnus-window-top-edge)) - (setq lowest-buf buf))))) - (setq buffers (cdr buffers))) - ;; Remove windows on *all* summary buffers. - (walk-windows - (lambda (win) - (let ((buf (window-buffer win))) - (if (string-match "^\\*Summary" (buffer-name buf)) - (progn - (setq bufs (cons buf bufs)) - (pop-to-buffer buf) - (if (or (not lowest) - (< (gnus-window-top-edge) lowest)) - (progn - (setq lowest-buf buf) - (setq lowest (gnus-window-top-edge))))))))) - (and lowest-buf - (progn - (pop-to-buffer lowest-buf) - (switch-to-buffer nntp-server-buffer))) - (while bufs - (and (not (eq (car bufs) lowest-buf)) - (delete-windows-on (car bufs))) - (setq bufs (cdr bufs)))))) - -(defun gnus-version (&optional arg) - "Version number of this version of Gnus. -If ARG, insert string at point." - (interactive "P") - (let ((methods gnus-valid-select-methods) - (mess gnus-version) - meth) - ;; Go through all the legal select methods and add their version - ;; numbers to the total version string. Only the backends that are - ;; currently in use will have their message numbers taken into - ;; consideration. - (while methods - (setq meth (intern (concat (caar methods) "-version"))) - (and (boundp meth) - (stringp (symbol-value meth)) - (setq mess (concat mess "; " (symbol-value meth)))) - (setq methods (cdr methods))) - (if arg - (insert (message mess)) - (message mess)))) - -(defun gnus-info-find-node () - "Find Info documentation of Gnus." - (interactive) - ;; Enlarge info window if needed. - (let ((mode major-mode) - gnus-info-buffer) - (Info-goto-node (cadr (assq mode gnus-info-nodes))) - (setq gnus-info-buffer (current-buffer)) - (gnus-configure-windows 'info))) - -(defun gnus-days-between (date1 date2) - ;; Return the number of days between date1 and date2. - (- (gnus-day-number date1) (gnus-day-number date2))) - -(defun gnus-day-number (date) - (let ((dat (mapcar (lambda (s) (and s (string-to-int s)) ) - (timezone-parse-date date)))) - (timezone-absolute-from-gregorian - (nth 1 dat) (nth 2 dat) (car dat)))) - -(defun gnus-encode-date (date) - "Convert DATE to internal time." - (let* ((parse (timezone-parse-date date)) - (date (mapcar (lambda (d) (and d (string-to-int d))) parse)) - (time (mapcar 'string-to-int (timezone-parse-time (aref parse 3))))) - (encode-time (caddr time) (cadr time) (car time) - (caddr date) (cadr date) (car date) (nth 4 date)))) - -(defun gnus-time-minus (t1 t2) - "Subtract two internal times." - (let ((borrow (< (cadr t1) (cadr t2)))) - (list (- (car t1) (car t2) (if borrow 1 0)) - (- (+ (if borrow 65536 0) (cadr t1)) (cadr t2))))) - -(defun gnus-file-newer-than (file date) - (let ((fdate (nth 5 (file-attributes file)))) - (or (> (car fdate) (car date)) - (and (= (car fdate) (car date)) - (> (nth 1 fdate) (nth 1 date)))))) - -(defmacro gnus-local-set-keys (&rest plist) - "Set the keys in PLIST in the current keymap." - `(gnus-define-keys-1 (current-local-map) ',plist)) - -(defmacro gnus-define-keys (keymap &rest plist) - "Define all keys in PLIST in KEYMAP." - `(gnus-define-keys-1 (quote ,keymap) (quote ,plist))) - -(put 'gnus-define-keys 'lisp-indent-function 1) -(put 'gnus-define-keys 'lisp-indent-hook 1) -(put 'gnus-define-keymap 'lisp-indent-function 1) -(put 'gnus-define-keymap 'lisp-indent-hook 1) - -(defmacro gnus-define-keymap (keymap &rest plist) - "Define all keys in PLIST in KEYMAP." - `(gnus-define-keys-1 ,keymap (quote ,plist))) - -(defun gnus-define-keys-1 (keymap plist) - (when (null keymap) - (error "Can't set keys in a null keymap")) - (cond ((symbolp keymap) - (setq keymap (symbol-value keymap))) - ((keymapp keymap)) - ((listp keymap) - (set (car keymap) nil) - (define-prefix-command (car keymap)) - (define-key (symbol-value (caddr keymap)) (cadr keymap) (car keymap)) - (setq keymap (symbol-value (car keymap))))) - (let (key) - (while plist - (when (symbolp (setq key (pop plist))) - (setq key (symbol-value key))) - (define-key keymap key (pop plist))))) - -(defun gnus-group-read-only-p (&optional group) - "Check whether GROUP supports editing or not. -If GROUP is nil, `gnus-newsgroup-name' will be checked instead. Note -that that variable is buffer-local to the summary buffers." - (let ((group (or group gnus-newsgroup-name))) - (not (gnus-check-backend-function 'request-replace-article group)))) - -(defun gnus-group-total-expirable-p (group) - "Check whether GROUP is total-expirable or not." - (let ((params (gnus-info-params (gnus-get-info group)))) - (or (memq 'total-expire params) - (cdr (assq 'total-expire params)) ; (total-expire . t) - (and gnus-total-expirable-newsgroups ; Check var. - (string-match gnus-total-expirable-newsgroups group))))) - -(defun gnus-group-auto-expirable-p (group) - "Check whether GROUP is total-expirable or not." - (let ((params (gnus-info-params (gnus-get-info group)))) - (or (memq 'auto-expire params) - (cdr (assq 'auto-expire params)) ; (auto-expire . t) - (and gnus-auto-expirable-newsgroups ; Check var. - (string-match gnus-auto-expirable-newsgroups group))))) - -(defun gnus-virtual-group-p (group) - "Say whether GROUP is virtual or not." - (memq 'virtual (assoc (symbol-name (car (gnus-find-method-for-group group))) - gnus-valid-select-methods))) - -(defun gnus-news-group-p (group &optional article) - "Return non-nil if GROUP (and ARTICLE) come from a news server." - (or (gnus-member-of-valid 'post group) ; Ordinary news group. - (and (gnus-member-of-valid 'post-mail group) ; Combined group. - (eq (gnus-request-type group article) 'news)))) - -(defsubst gnus-simplify-subject-fully (subject) - "Simplify a subject string according to the user's wishes." - (cond - ((null gnus-summary-gather-subject-limit) - (gnus-simplify-subject-re subject)) - ((eq gnus-summary-gather-subject-limit 'fuzzy) - (gnus-simplify-subject-fuzzy subject)) - ((numberp gnus-summary-gather-subject-limit) - (gnus-limit-string (gnus-simplify-subject-re subject) - gnus-summary-gather-subject-limit)) - (t - subject))) - -(defsubst gnus-subject-equal (s1 s2 &optional simple-first) - "Check whether two subjects are equal. If optional argument -simple-first is t, first argument is already simplified." - (cond - ((null simple-first) - (equal (gnus-simplify-subject-fully s1) - (gnus-simplify-subject-fully s2))) - (t - (equal s1 - (gnus-simplify-subject-fully s2))))) - -;; Returns a list of writable groups. -(defun gnus-writable-groups () - (let ((alist gnus-newsrc-alist) - groups group) - (while (setq group (car (pop alist))) - (unless (gnus-group-read-only-p group) - (push group groups))) - (nreverse groups))) - -(defun gnus-completing-read (default prompt &rest args) - ;; Like `completing-read', except that DEFAULT is the default argument. - (let* ((prompt (if default - (concat prompt " (default " default ") ") - (concat prompt " "))) - (answer (apply 'completing-read prompt args))) - (if (or (null answer) (zerop (length answer))) - default - answer))) +(defface gnus-splash-face + '((((class color) + (background dark)) + (:foreground "red")) + (((class color) + (background light)) + (:foreground "red")) + (t + ())) + "Level 1 newsgroup face.") -;; Two silly functions to ensure that all `y-or-n-p' questions clear -;; the echo area. -(defun gnus-y-or-n-p (prompt) - (prog1 - (y-or-n-p prompt) - (message ""))) - -(defun gnus-yes-or-no-p (prompt) - (prog1 - (yes-or-no-p prompt) - (message ""))) - -;; Check whether to use long file names. -(defun gnus-use-long-file-name (symbol) - ;; The variable has to be set... - (and gnus-use-long-file-name - ;; If it isn't a list, then we return t. - (or (not (listp gnus-use-long-file-name)) - ;; If it is a list, and the list contains `symbol', we - ;; return nil. - (not (memq symbol gnus-use-long-file-name))))) - -;; I suspect there's a better way, but I haven't taken the time to do -;; it yet. -erik selberg@cs.washington.edu -(defun gnus-dd-mmm (messy-date) - "Return a string like DD-MMM from a big messy string" - (let ((datevec (condition-case () (timezone-parse-date messy-date) - (error nil)))) - (if (not datevec) - "??-???" - (format "%2s-%s" - (condition-case () - ;; Make sure leading zeroes are stripped. - (number-to-string (string-to-number (aref datevec 2))) - (error "??")) - (capitalize - (or (car - (nth (1- (string-to-number (aref datevec 1))) - timezone-months-assoc)) - "???")))))) - -(defun gnus-mode-string-quote (string) - "Quote all \"%\" in STRING." +(defun gnus-splash () (save-excursion - (gnus-set-work-buffer) - (insert string) - (goto-char (point-min)) - (while (search-forward "%" nil t) - (insert "%")) - (buffer-string))) - -;; Make a hash table (default and minimum size is 255). -;; Optional argument HASHSIZE specifies the table size. -(defun gnus-make-hashtable (&optional hashsize) - (make-vector (if hashsize (max (gnus-create-hash-size hashsize) 255) 255) 0)) - -;; Make a number that is suitable for hashing; bigger than MIN and one -;; less than 2^x. -(defun gnus-create-hash-size (min) - (let ((i 1)) - (while (< i min) - (setq i (* 2 i))) - (1- i))) - -;; Show message if message has a lower level than `gnus-verbose'. -;; Guideline for numbers: -;; 1 - error messages, 3 - non-serious error messages, 5 - messages -;; for things that take a long time, 7 - not very important messages -;; on stuff, 9 - messages inside loops. -(defun gnus-message (level &rest args) - (if (<= level gnus-verbose) - (apply 'message args) - ;; We have to do this format thingy here even if the result isn't - ;; shown - the return value has to be the same as the return value - ;; from `message'. - (apply 'format args))) - -(defun gnus-error (level &rest args) - "Beep an error if LEVEL is equal to or less than `gnus-verbose'." - (when (<= (floor level) gnus-verbose) - (apply 'message args) - (ding) - (let (duration) - (when (and (floatp level) - (not (zerop (setq duration (* 10 (- level (floor level))))))) - (sit-for duration)))) - nil) - -;; Generate a unique new group name. -(defun gnus-generate-new-group-name (leaf) - (let ((name leaf) - (num 0)) - (while (gnus-gethash name gnus-newsrc-hashtb) - (setq name (concat leaf "<" (int-to-string (setq num (1+ num))) ">"))) - name)) - -(defsubst gnus-hide-text (b e props) - "Set text PROPS on the B to E region, extending `intangible' 1 past B." - (gnus-add-text-properties b e props) - (when (memq 'intangible props) - (gnus-put-text-property (max (1- b) (point-min)) - b 'intangible (cddr (memq 'intangible props))))) - -(defsubst gnus-unhide-text (b e) - "Remove hidden text properties from region between B and E." - (remove-text-properties b e gnus-hidden-properties) - (when (memq 'intangible gnus-hidden-properties) - (gnus-put-text-property (max (1- b) (point-min)) - b 'intangible nil))) - -(defun gnus-hide-text-type (b e type) - "Hide text of TYPE between B and E." - (gnus-hide-text b e (cons 'gnus-type (cons type gnus-hidden-properties)))) - -(defun gnus-parent-headers (headers &optional generation) - "Return the headers of the GENERATIONeth parent of HEADERS." - (unless generation - (setq generation 1)) - (let (references parent) - (while (and headers (not (zerop generation))) - (setq references (mail-header-references headers)) - (when (and references - (setq parent (gnus-parent-id references)) - (setq headers (car (gnus-id-to-thread parent)))) - (decf generation))) - headers)) - -(defun gnus-parent-id (references) - "Return the last Message-ID in REFERENCES." - (when (and references - (string-match "\\(<[^\n<>]+>\\)[ \t\n]*\\'" references)) - (substring references (match-beginning 1) (match-end 1)))) - -(defun gnus-split-references (references) - "Return a list of Message-IDs in REFERENCES." - (let ((beg 0) - ids) - (while (string-match "<[^>]+>" references beg) - (push (substring references (match-beginning 0) (setq beg (match-end 0))) - ids)) - (nreverse ids))) - -(defun gnus-buffer-live-p (buffer) - "Say whether BUFFER is alive or not." - (and buffer - (get-buffer buffer) - (buffer-name (get-buffer buffer)))) - -(defun gnus-ephemeral-group-p (group) - "Say whether GROUP is ephemeral or not." - (gnus-group-get-parameter group 'quit-config)) - -(defun gnus-group-quit-config (group) - "Return the quit-config of GROUP." - (gnus-group-get-parameter group 'quit-config)) - -(defun gnus-simplify-mode-line () - "Make mode lines a bit simpler." - (setq mode-line-modified "-- ") - (when (listp mode-line-format) - (make-local-variable 'mode-line-format) - (setq mode-line-format (copy-sequence mode-line-format)) - (when (equal (nth 3 mode-line-format) " ") - (setcar (nthcdr 3 mode-line-format) " ")))) - -;;; List and range functions - -(defun gnus-last-element (list) - "Return last element of LIST." - (while (cdr list) - (setq list (cdr list))) - (car list)) - -(defun gnus-copy-sequence (list) - "Do a complete, total copy of a list." - (if (and (consp list) (not (consp (cdr list)))) - (cons (car list) (cdr list)) - (mapcar (lambda (elem) (if (consp elem) - (if (consp (cdr elem)) - (gnus-copy-sequence elem) - (cons (car elem) (cdr elem))) - elem)) - list))) - -(defun gnus-set-difference (list1 list2) - "Return a list of elements of LIST1 that do not appear in LIST2." - (let ((list1 (copy-sequence list1))) - (while list2 - (setq list1 (delq (car list2) list1)) - (setq list2 (cdr list2))) - list1)) - -(defun gnus-sorted-complement (list1 list2) - "Return a list of elements of LIST1 that do not appear in LIST2. -Both lists have to be sorted over <." - (let (out) - (if (or (null list1) (null list2)) - (or list1 list2) - (while (and list1 list2) - (cond ((= (car list1) (car list2)) - (setq list1 (cdr list1) - list2 (cdr list2))) - ((< (car list1) (car list2)) - (setq out (cons (car list1) out)) - (setq list1 (cdr list1))) - (t - (setq out (cons (car list2) out)) - (setq list2 (cdr list2))))) - (nconc (nreverse out) (or list1 list2))))) - -(defun gnus-intersection (list1 list2) - (let ((result nil)) - (while list2 - (if (memq (car list2) list1) - (setq result (cons (car list2) result))) - (setq list2 (cdr list2))) - result)) - -(defun gnus-sorted-intersection (list1 list2) - ;; LIST1 and LIST2 have to be sorted over <. - (let (out) - (while (and list1 list2) - (cond ((= (car list1) (car list2)) - (setq out (cons (car list1) out) - list1 (cdr list1) - list2 (cdr list2))) - ((< (car list1) (car list2)) - (setq list1 (cdr list1))) - (t - (setq list2 (cdr list2))))) - (nreverse out))) - -(defun gnus-set-sorted-intersection (list1 list2) - ;; LIST1 and LIST2 have to be sorted over <. - ;; This function modifies LIST1. - (let* ((top (cons nil list1)) - (prev top)) - (while (and list1 list2) - (cond ((= (car list1) (car list2)) - (setq prev list1 - list1 (cdr list1) - list2 (cdr list2))) - ((< (car list1) (car list2)) - (setcdr prev (cdr list1)) - (setq list1 (cdr list1))) - (t - (setq list2 (cdr list2))))) - (setcdr prev nil) - (cdr top))) - -(defun gnus-compress-sequence (numbers &optional always-list) - "Convert list of numbers to a list of ranges or a single range. -If ALWAYS-LIST is non-nil, this function will always release a list of -ranges." - (let* ((first (car numbers)) - (last (car numbers)) - result) - (if (null numbers) - nil - (if (not (listp (cdr numbers))) - numbers - (while numbers - (cond ((= last (car numbers)) nil) ;Omit duplicated number - ((= (1+ last) (car numbers)) ;Still in sequence - (setq last (car numbers))) - (t ;End of one sequence - (setq result - (cons (if (= first last) first - (cons first last)) result)) - (setq first (car numbers)) - (setq last (car numbers)))) - (setq numbers (cdr numbers))) - (if (and (not always-list) (null result)) - (if (= first last) (list first) (cons first last)) - (nreverse (cons (if (= first last) first (cons first last)) - result))))))) - -(defalias 'gnus-uncompress-sequence 'gnus-uncompress-range) -(defun gnus-uncompress-range (ranges) - "Expand a list of ranges into a list of numbers. -RANGES is either a single range on the form `(num . num)' or a list of -these ranges." - (let (first last result) - (cond - ((null ranges) - nil) - ((not (listp (cdr ranges))) - (setq first (car ranges)) - (setq last (cdr ranges)) - (while (<= first last) - (setq result (cons first result)) - (setq first (1+ first))) - (nreverse result)) - (t - (while ranges - (if (atom (car ranges)) - (if (numberp (car ranges)) - (setq result (cons (car ranges) result))) - (setq first (caar ranges)) - (setq last (cdar ranges)) - (while (<= first last) - (setq result (cons first result)) - (setq first (1+ first)))) - (setq ranges (cdr ranges))) - (nreverse result))))) - -(defun gnus-add-to-range (ranges list) - "Return a list of ranges that has all articles from both RANGES and LIST. -Note: LIST has to be sorted over `<'." - (if (not ranges) - (gnus-compress-sequence list t) - (setq list (copy-sequence list)) - (or (listp (cdr ranges)) - (setq ranges (list ranges))) - (let ((out ranges) - ilist lowest highest temp) - (while (and ranges list) - (setq ilist list) - (setq lowest (or (and (atom (car ranges)) (car ranges)) - (caar ranges))) - (while (and list (cdr list) (< (cadr list) lowest)) - (setq list (cdr list))) - (if (< (car ilist) lowest) - (progn - (setq temp list) - (setq list (cdr list)) - (setcdr temp nil) - (setq out (nconc (gnus-compress-sequence ilist t) out)))) - (setq highest (or (and (atom (car ranges)) (car ranges)) - (cdar ranges))) - (while (and list (<= (car list) highest)) - (setq list (cdr list))) - (setq ranges (cdr ranges))) - (if list - (setq out (nconc (gnus-compress-sequence list t) out))) - (setq out (sort out (lambda (r1 r2) - (< (or (and (atom r1) r1) (car r1)) - (or (and (atom r2) r2) (car r2)))))) - (setq ranges out) - (while ranges - (if (atom (car ranges)) - (if (cdr ranges) - (if (atom (cadr ranges)) - (if (= (1+ (car ranges)) (cadr ranges)) - (progn - (setcar ranges (cons (car ranges) - (cadr ranges))) - (setcdr ranges (cddr ranges)))) - (if (= (1+ (car ranges)) (caadr ranges)) - (progn - (setcar (cadr ranges) (car ranges)) - (setcar ranges (cadr ranges)) - (setcdr ranges (cddr ranges)))))) - (if (cdr ranges) - (if (atom (cadr ranges)) - (if (= (1+ (cdar ranges)) (cadr ranges)) - (progn - (setcdr (car ranges) (cadr ranges)) - (setcdr ranges (cddr ranges)))) - (if (= (1+ (cdar ranges)) (caadr ranges)) - (progn - (setcdr (car ranges) (cdadr ranges)) - (setcdr ranges (cddr ranges))))))) - (setq ranges (cdr ranges))) - out))) - -(defun gnus-remove-from-range (ranges list) - "Return a list of ranges that has all articles from LIST removed from RANGES. -Note: LIST has to be sorted over `<'." - ;; !!! This function shouldn't look like this, but I've got a headache. - (gnus-compress-sequence - (gnus-sorted-complement - (gnus-uncompress-range ranges) list))) - -(defun gnus-member-of-range (number ranges) - (if (not (listp (cdr ranges))) - (and (>= number (car ranges)) - (<= number (cdr ranges))) - (let ((not-stop t)) - (while (and ranges - (if (numberp (car ranges)) - (>= number (car ranges)) - (>= number (caar ranges))) - not-stop) - (if (if (numberp (car ranges)) - (= number (car ranges)) - (and (>= number (caar ranges)) - (<= number (cdar ranges)))) - (setq not-stop nil)) - (setq ranges (cdr ranges))) - (not not-stop)))) - -(defun gnus-range-length (range) - "Return the length RANGE would have if uncompressed." - (length (gnus-uncompress-range range))) - -(defun gnus-sublist-p (list sublist) - "Test whether all elements in SUBLIST are members of LIST." - (let ((sublistp t)) - (while sublist - (unless (memq (pop sublist) list) - (setq sublistp nil - sublist nil))) - sublistp)) - - -;;; -;;; Gnus group mode -;;; - -(defvar gnus-group-mode-map nil) -(put 'gnus-group-mode 'mode-class 'special) - -(unless gnus-group-mode-map - (setq gnus-group-mode-map (make-keymap)) - (suppress-keymap gnus-group-mode-map) - - (gnus-define-keys gnus-group-mode-map - " " gnus-group-read-group - "=" gnus-group-select-group - "\r" gnus-group-select-group - "\M-\r" gnus-group-quick-select-group - "j" gnus-group-jump-to-group - "n" gnus-group-next-unread-group - "p" gnus-group-prev-unread-group - "\177" gnus-group-prev-unread-group - [delete] gnus-group-prev-unread-group - "N" gnus-group-next-group - "P" gnus-group-prev-group - "\M-n" gnus-group-next-unread-group-same-level - "\M-p" gnus-group-prev-unread-group-same-level - "," gnus-group-best-unread-group - "." gnus-group-first-unread-group - "u" gnus-group-unsubscribe-current-group - "U" gnus-group-unsubscribe-group - "c" gnus-group-catchup-current - "C" gnus-group-catchup-current-all - "l" gnus-group-list-groups - "L" gnus-group-list-all-groups - "m" gnus-group-mail - "g" gnus-group-get-new-news - "\M-g" gnus-group-get-new-news-this-group - "R" gnus-group-restart - "r" gnus-group-read-init-file - "B" gnus-group-browse-foreign-server - "b" gnus-group-check-bogus-groups - "F" gnus-find-new-newsgroups - "\C-c\C-d" gnus-group-describe-group - "\M-d" gnus-group-describe-all-groups - "\C-c\C-a" gnus-group-apropos - "\C-c\M-\C-a" gnus-group-description-apropos - "a" gnus-group-post-news - "\ek" gnus-group-edit-local-kill - "\eK" gnus-group-edit-global-kill - "\C-k" gnus-group-kill-group - "\C-y" gnus-group-yank-group - "\C-w" gnus-group-kill-region - "\C-x\C-t" gnus-group-transpose-groups - "\C-c\C-l" gnus-group-list-killed - "\C-c\C-x" gnus-group-expire-articles - "\C-c\M-\C-x" gnus-group-expire-all-groups - "V" gnus-version - "s" gnus-group-save-newsrc - "z" gnus-group-suspend -; "Z" gnus-group-clear-dribble - "q" gnus-group-exit - "Q" gnus-group-quit - "?" gnus-group-describe-briefly - "\C-c\C-i" gnus-info-find-node - "\M-e" gnus-group-edit-group-method - "^" gnus-group-enter-server-mode - gnus-mouse-2 gnus-mouse-pick-group - "<" beginning-of-buffer - ">" end-of-buffer - "\C-c\C-b" gnus-bug - "\C-c\C-s" gnus-group-sort-groups - "t" gnus-topic-mode - "\C-c\M-g" gnus-activate-all-groups - "\M-&" gnus-group-universal-argument - "#" gnus-group-mark-group - "\M-#" gnus-group-unmark-group) - - (gnus-define-keys (gnus-group-mark-map "M" gnus-group-mode-map) - "m" gnus-group-mark-group - "u" gnus-group-unmark-group - "w" gnus-group-mark-region - "m" gnus-group-mark-buffer - "r" gnus-group-mark-regexp - "U" gnus-group-unmark-all-groups) - - (gnus-define-keys (gnus-group-group-map "G" gnus-group-mode-map) - "d" gnus-group-make-directory-group - "h" gnus-group-make-help-group - "a" gnus-group-make-archive-group - "k" gnus-group-make-kiboze-group - "m" gnus-group-make-group - "E" gnus-group-edit-group - "e" gnus-group-edit-group-method - "p" gnus-group-edit-group-parameters - "v" gnus-group-add-to-virtual - "V" gnus-group-make-empty-virtual - "D" gnus-group-enter-directory - "f" gnus-group-make-doc-group - "r" gnus-group-rename-group - "\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 - "u" gnus-group-sort-groups-by-unread - "l" gnus-group-sort-groups-by-level - "v" gnus-group-sort-groups-by-score - "r" gnus-group-sort-groups-by-rank - "m" gnus-group-sort-groups-by-method) - - (gnus-define-keys (gnus-group-list-map "A" gnus-group-mode-map) - "k" gnus-group-list-killed - "z" gnus-group-list-zombies - "s" gnus-group-list-groups - "u" gnus-group-list-all-groups - "A" gnus-group-list-active - "a" gnus-group-apropos - "d" gnus-group-description-apropos - "m" gnus-group-list-matching - "M" gnus-group-list-all-matching - "l" gnus-group-list-level) - - (gnus-define-keys (gnus-group-score-map "W" gnus-group-mode-map) - "f" gnus-score-flush-cache) - - (gnus-define-keys (gnus-group-help-map "H" gnus-group-mode-map) - "f" gnus-group-fetch-faq) - - (gnus-define-keys (gnus-group-sub-map "S" gnus-group-mode-map) - "l" gnus-group-set-current-level - "t" gnus-group-unsubscribe-current-group - "s" gnus-group-unsubscribe-group - "k" gnus-group-kill-group - "y" gnus-group-yank-group - "w" gnus-group-kill-region - "\C-k" gnus-group-kill-level - "z" gnus-group-kill-all-zombies)) - -(defun gnus-group-mode () - "Major mode for reading news. - -All normal editing commands are switched off. -\\ -The group buffer lists (some of) the groups available. For instance, -`\\[gnus-group-list-groups]' will list all subscribed groups with unread articles, while `\\[gnus-group-list-zombies]' -lists all zombie groups. - -Groups that are displayed can be entered with `\\[gnus-group-read-group]'. To subscribe -to a group not displayed, type `\\[gnus-group-unsubscribe-group]'. - -For more in-depth information on this mode, read the manual (`\\[gnus-info-find-node]'). - -The following commands are available: - -\\{gnus-group-mode-map}" - (interactive) - (when (and menu-bar-mode - (gnus-visual-p 'group-menu 'menu)) - (gnus-group-make-menu-bar)) - (kill-all-local-variables) - (gnus-simplify-mode-line) - (setq major-mode 'gnus-group-mode) - (setq mode-name "Group") - (gnus-group-set-mode-line) - (setq mode-line-process nil) - (use-local-map gnus-group-mode-map) - (buffer-disable-undo (current-buffer)) - (setq truncate-lines t) - (setq buffer-read-only t) - (gnus-make-local-hook 'post-command-hook) - (gnus-add-hook 'post-command-hook 'gnus-clear-inboxes-moved nil t) - (run-hooks 'gnus-group-mode-hook)) - -(defun gnus-clear-inboxes-moved () - (setq nnmail-moved-inboxes nil)) - -(defun gnus-mouse-pick-group (e) - "Enter the group under the mouse pointer." - (interactive "e") - (mouse-set-point e) - (gnus-group-read-group nil)) - -;; Look at LEVEL and find out what the level is really supposed to be. -;; If LEVEL is non-nil, LEVEL will be returned, if not, what happens -;; will depend on whether `gnus-group-use-permanent-levels' is used. -(defun gnus-group-default-level (&optional level number-or-nil) - (cond - (gnus-group-use-permanent-levels - (or (setq gnus-group-use-permanent-levels - (or level (if (numberp gnus-group-use-permanent-levels) - gnus-group-use-permanent-levels - (or gnus-group-default-list-level - gnus-level-subscribed)))) - gnus-group-default-list-level gnus-level-subscribed)) - (number-or-nil - level) - (t - (or level gnus-group-default-list-level gnus-level-subscribed)))) - -;;;###autoload -(defun gnus-slave-no-server (&optional arg) - "Read network news as a slave, without connecting to local server" - (interactive "P") - (gnus-no-server arg t)) - -;;;###autoload -(defun gnus-no-server (&optional arg slave) - "Read network news. -If ARG is a positive number, Gnus will use that as the -startup level. If ARG is nil, Gnus will be started at level 2. -If ARG is non-nil and not a positive number, Gnus will -prompt the user for the name of an NNTP server to use. -As opposed to `gnus', this command will not connect to the local server." - (interactive "P") - (let ((val (or arg (1- gnus-level-default-subscribed)))) - (gnus val t slave) - (make-local-variable 'gnus-group-use-permanent-levels) - (setq gnus-group-use-permanent-levels val))) - -;;;###autoload -(defun gnus-slave (&optional arg) - "Read news as a slave." - (interactive "P") - (gnus arg nil 'slave)) - -;;;###autoload -(defun gnus-other-frame (&optional arg) - "Pop up a frame to read news." - (interactive "P") - (if (get-buffer gnus-group-buffer) - (let ((pop-up-frames t)) - (gnus arg)) - (select-frame (make-frame)) - (gnus arg))) - -;;;###autoload -(defun gnus (&optional arg dont-connect slave) - "Read network news. -If ARG is non-nil and a positive number, Gnus will use that as the -startup level. If ARG is non-nil and not a positive number, Gnus will -prompt the user for the name of an NNTP server to use." - (interactive "P") - - (if (get-buffer gnus-group-buffer) - (progn - (switch-to-buffer gnus-group-buffer) - (gnus-group-get-new-news)) - - (gnus-clear-system) - (nnheader-init-server-buffer) - (gnus-read-init-file) - (setq gnus-slave slave) - - (gnus-group-setup-buffer) + (switch-to-buffer gnus-group-buffer) (let ((buffer-read-only nil)) (erase-buffer) - (if (not gnus-inhibit-startup-message) - (progn - (gnus-group-startup-message) - (sit-for 0)))) - - (let ((level (and (numberp arg) (> arg 0) arg)) - did-connect) - (unwind-protect - (progn - (or dont-connect - (setq did-connect - (gnus-start-news-server (and arg (not level)))))) - (if (and (not dont-connect) - (not did-connect)) - (gnus-group-quit) - (run-hooks 'gnus-startup-hook) - ;; NNTP server is successfully open. - - ;; Find the current startup file name. - (setq gnus-current-startup-file - (gnus-make-newsrc-file gnus-startup-file)) - - ;; Read the dribble file. - (when (or gnus-slave gnus-use-dribble-file) - (gnus-dribble-read-file)) - - ;; Allow using GroupLens predictions. - (when gnus-use-grouplens - (bbb-login) - (add-hook 'gnus-summary-mode-hook 'gnus-grouplens-mode)) - - (gnus-summary-make-display-table) - ;; Do the actual startup. - (gnus-setup-news nil level dont-connect) - ;; Generate the group buffer. - (gnus-group-list-groups level) - (gnus-group-first-unread-group) - (gnus-configure-windows 'group) - (gnus-group-set-mode-line)))))) - -(defun gnus-unload () - "Unload all Gnus features." - (interactive) - (or (boundp 'load-history) - (error "Sorry, `gnus-unload' is not implemented in this Emacs version.")) - (let ((history load-history) - feature) - (while history - (and (string-match "^\\(gnus\\|nn\\)" (caar history)) - (setq feature (cdr (assq 'provide (car history)))) - (unload-feature feature 'force)) - (setq history (cdr history))))) - -(defun gnus-compile () - "Byte-compile the user-defined format specs." - (interactive) - (let ((entries gnus-format-specs) - entry gnus-tmp-func) - (save-excursion - (gnus-message 7 "Compiling format specs...") - - (while entries - (setq entry (pop entries)) - (if (eq (car entry) 'version) - (setq gnus-format-specs (delq entry gnus-format-specs)) - (when (and (listp (caddr entry)) - (not (eq 'byte-code (caaddr entry)))) - (fset 'gnus-tmp-func - `(lambda () ,(caddr entry))) - (byte-compile 'gnus-tmp-func) - (setcar (cddr entry) (gnus-byte-code 'gnus-tmp-func))))) - - (push (cons 'version emacs-version) gnus-format-specs) - ;; Mark the .newsrc.eld file as "dirty". - (gnus-dribble-enter " ") - (gnus-message 7 "Compiling user specs...done")))) + (unless gnus-inhibit-startup-message + (gnus-group-startup-message) + (sit-for 0) + (when gnus-play-startup-jingle + (gnus-play-jingle)))))) (defun gnus-indent-rigidly (start end arg) "Indent rigidly using only spaces and no tabs." @@ -4531,9 +622,13 @@ (save-restriction (narrow-to-region start end) (indent-rigidly start end arg) + ;; We translate tabs into spaces -- not everybody uses + ;; an 8-character tab. (goto-char (point-min)) (while (search-forward "\t" nil t) - (replace-match " " t t))))) + (replace-match " " t t))))) + +(defvar gnus-simple-splash nil) (defun gnus-group-startup-message (&optional x y) "Insert startup message in current buffer." @@ -4571,175 +666,1375 @@ (rest (- wheight pheight))) (insert (make-string (max 0 (* 2 (/ rest 3))) ?\n))) ;; Fontify some. - (goto-char (point-min)) - (and (search-forward "Praxis" nil t) - (gnus-put-text-property (match-beginning 0) (match-end 0) 'face 'bold)) + (put-text-property (point-min) (point-max) 'face 'gnus-splash-face) (goto-char (point-min)) - (let* ((mode-string (gnus-group-set-mode-line))) - (setq mode-line-buffer-identification - (list (concat gnus-version (substring (car mode-string) 4)))) - (set-buffer-modified-p t))) + (setq mode-line-buffer-identification (concat " " gnus-version)) + (setq gnus-simple-splash t) + (set-buffer-modified-p t)) + +(eval-when (load) + (let ((command (format "%s" this-command))) + (when (and (string-match "gnus" command) + (not (string-match "gnus-other-frame" command))) + (gnus-splash)))) + +;;; Do the rest. + +(require 'custom) +(require 'gnus-util) +(require 'nnheader) + +(defcustom gnus-directory (or (getenv "SAVEDIR") "~/News/") + "Directory variable from which all other Gnus file variables are derived." + :group 'gnus-files + :type 'directory) + +(defcustom gnus-default-directory nil + "*Default directory for all Gnus buffers." + :group 'gnus-files + :type '(choice (const :tag "current" nil) + directory)) + +;; Site dependent variables. These variables should be defined in +;; paths.el. + +(defvar gnus-default-nntp-server nil + "Specify a default NNTP server. +This variable should be defined in paths.el, and should never be set +by the user. +If you want to change servers, you should use `gnus-select-method'. +See the documentation to that variable.") + +;; Don't touch this variable. +(defvar gnus-nntp-service "nntp" + "NNTP service name (\"nntp\" or 119). +This is an obsolete variable, which is scarcely used. If you use an +nntp server for your newsgroup and want to change the port number +used to 899, you would say something along these lines: + + (setq gnus-select-method '(nntp \"my.nntp.server\" (nntp-port-number 899)))") + +(defcustom gnus-nntpserver-file "/etc/nntpserver" + "A file with only the name of the nntp server in it." + :group 'gnus-files + :group 'gnus-server + :type 'file) + +;; This function is used to check both the environment variable +;; NNTPSERVER and the /etc/nntpserver file to see whether one can find +;; an nntp server name default. +(defun gnus-getenv-nntpserver () + (or (getenv "NNTPSERVER") + (and (file-readable-p gnus-nntpserver-file) + (save-excursion + (set-buffer (get-buffer-create " *gnus nntp*")) + (buffer-disable-undo (current-buffer)) + (insert-file-contents gnus-nntpserver-file) + (let ((name (buffer-string))) + (prog1 + (if (string-match "^[ \t\n]*$" name) + nil + name) + (kill-buffer (current-buffer)))))))) + +(defcustom gnus-select-method + (ignore-errors + (nconc + (list 'nntp (or (ignore-errors + (gnus-getenv-nntpserver)) + (when (and gnus-default-nntp-server + (not (string= gnus-default-nntp-server ""))) + gnus-default-nntp-server) + (system-name))) + (if (or (null gnus-nntp-service) + (equal gnus-nntp-service "nntp")) + nil + (list gnus-nntp-service)))) + "Default method for selecting a newsgroup. +This variable should be a list, where the first element is how the +news is to be fetched, the second is the address. + +For instance, if you want to get your news via NNTP from +\"flab.flab.edu\", you could say: + +\(setq gnus-select-method '(nntp \"flab.flab.edu\")) + +If you want to use your local spool, say: + +\(setq gnus-select-method (list 'nnspool (system-name))) + +If you use this variable, you must set `gnus-nntp-server' to nil. + +There is a lot more to know about select methods and virtual servers - +see the manual for details." + :group 'gnus-server + :type 'gnus-select-method) + +(defcustom gnus-message-archive-method + `(nnfolder + "archive" + (nnfolder-directory ,(nnheader-concat message-directory "archive")) + (nnfolder-active-file + ,(nnheader-concat message-directory "archive/active")) + (nnfolder-get-new-mail nil) + (nnfolder-inhibit-expiry t)) + "Method used for archiving messages you've sent. +This should be a mail method. + +It's probably not a very effective to change this variable once you've +run Gnus once. After doing that, you must edit this server from the +server buffer." + :group 'gnus-server + :group 'gnus-message + :type 'gnus-select-method) + +(defcustom gnus-message-archive-group nil + "*Name of the group in which to save the messages you've written. +This can either be a string, a list of strings; or an alist +of regexps/functions/forms to be evaluated to return a string (or a list +of strings). The functions are called with the name of the current +group (or nil) as a parameter. + +If you want to save your mail in one group and the news articles you +write in another group, you could say something like: + + \(setq gnus-message-archive-group + '((if (message-news-p) + \"misc-news\" + \"misc-mail\"))) + +Normally the group names returned by this variable should be +unprefixed -- which implicitly means \"store on the archive server\". +However, you may wish to store the message on some other server. In +that case, just return a fully prefixed name of the group -- +\"nnml+private:mail.misc\", for instance." + :group 'gnus-message + :type '(choice (const :tag "none" nil) + string)) + +(defcustom gnus-secondary-servers nil + "List of NNTP servers that the user can choose between interactively. +To make Gnus query you for a server, you have to give `gnus' a +non-numeric prefix - `C-u M-x gnus', in short." + :group 'gnus-server + :type '(repeat string)) + +(defcustom gnus-nntp-server nil + "*The name of the host running the NNTP server. +This variable is semi-obsolete. Use the `gnus-select-method' +variable instead." + :group 'gnus-server + :type '(choice (const :tag "disable" nil) + string)) + +(defcustom gnus-secondary-select-methods nil + "A list of secondary methods that will be used for reading news. +This is a list where each element is a complete select method (see +`gnus-select-method'). + +If, for instance, you want to read your mail with the nnml backend, +you could set this variable: -(defun gnus-group-setup-buffer () - (or (get-buffer gnus-group-buffer) - (progn - (switch-to-buffer gnus-group-buffer) - (gnus-add-current-to-buffer-list) - (gnus-group-mode) - (and gnus-carpal (gnus-carpal-setup-buffer 'group))))) +\(setq gnus-secondary-select-methods '((nnml \"\")))" +:group 'gnus-server +:type '(repeat gnus-select-method)) + +(defvar gnus-backup-default-subscribed-newsgroups + '("news.announce.newusers" "news.groups.questions" "gnu.emacs.gnus") + "Default default new newsgroups the first time Gnus is run. +Should be set in paths.el, and shouldn't be touched by the user.") + +(defcustom gnus-local-domain nil + "Local domain name without a host name. +The DOMAINNAME environment variable is used instead if it is defined. +If the `system-name' function returns the full Internet name, there is +no need to set this variable." + :group 'gnus-message + :type '(choice (const :tag "default" nil) + string)) + +(defcustom gnus-local-organization nil + "String with a description of what organization (if any) the user belongs to. +The ORGANIZATION environment variable is used instead if it is defined. +If this variable contains a function, this function will be called +with the current newsgroup name as the argument. The function should +return a string. + +In any case, if the string (either in the variable, in the environment +variable, or returned by the function) is a file name, the contents of +this file will be used as the organization." + :group 'gnus-message + :type '(choice (const :tag "default" nil) + string)) + +;; Customization variables + +(defcustom gnus-refer-article-method nil + "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 +nntp method, you might get acceptable results. + +The value of this variable must be a valid select method as discussed +in the documentation of `gnus-select-method'." + :group 'gnus-server + :type '(choice (const :tag "default" nil) + gnus-select-method)) + +(defcustom gnus-group-faq-directory + '("/ftp@mirrors.aol.com:/pub/rtfm/usenet/" + "/ftp@sunsite.auc.dk:/pub/usenet/" + "/ftp@sunsite.doc.ic.ac.uk:/pub/usenet/news-faqs/" + "/ftp@src.doc.ic.ac.uk:/usenet/news-FAQS/" + "/ftp@ftp.seas.gwu.edu:/pub/rtfm/" + "/ftp@rtfm.mit.edu:/pub/usenet/" + "/ftp@ftp.uni-paderborn.de:/pub/FAQ/" + "/ftp@ftp.sunet.se:/pub/usenet/" + "/ftp@nctuccca.edu.tw:/USENET/FAQ/" + "/ftp@hwarang.postech.ac.kr:/pub/usenet/" + "/ftp@ftp.hk.super.net:/mirror/faqs/") + "Directory where the group FAQs are stored. +This will most commonly be on a remote machine, and the file will be +fetched by ange-ftp. + +This variable can also be a list of directories. In that case, the +first element in the list will be used by default. The others can +be used when being prompted for a site. + +Note that Gnus uses an aol machine as the default directory. If this +feels fundamentally unclean, just think of it as a way to finally get +something of value back from them. + +If the default site is too slow, try one of these: + + North America: mirrors.aol.com /pub/rtfm/usenet + ftp.seas.gwu.edu /pub/rtfm + rtfm.mit.edu /pub/usenet + Europe: ftp.uni-paderborn.de /pub/FAQ + src.doc.ic.ac.uk /usenet/news-FAQS + ftp.sunet.se /pub/usenet + sunsite.auc.dk /pub/usenet + Asia: nctuccca.edu.tw /USENET/FAQ + hwarang.postech.ac.kr /pub/usenet + ftp.hk.super.net /mirror/faqs" + :group 'gnus-group-various + :type '(choice directory + (repeat directory))) + +(defcustom gnus-use-cross-reference t + "*Non-nil means that cross referenced articles will be marked as read. +If nil, ignore cross references. If t, mark articles as read in +subscribed newsgroups. If neither t nor nil, mark as read in all +newsgroups." + :group 'gnus-server + :type '(choice (const :tag "off" nil) + (const :tag "subscribed" t) + (sexp :format "all" + :value always))) + +(defcustom gnus-process-mark ?# + "*Process mark." + :group 'gnus-group-visual + :group 'gnus-summary-marks + :type 'character) + +(defcustom gnus-asynchronous nil + "*If non-nil, Gnus will supply backends with data needed for async article fetching." + :group 'gnus-asynchronous + :type 'boolean) + +(defcustom gnus-large-newsgroup 200 + "*The number of articles which indicates a large newsgroup. +If the number of articles in a newsgroup is greater than this value, +confirmation is required for selecting the newsgroup." + :group 'gnus-group-select + :type 'integer) + +(defcustom gnus-use-long-file-name (not (memq system-type '(usg-unix-v xenix))) + "*Non-nil means that the default name of a file to save articles in is the group name. +If it's nil, the directory form of the group name is used instead. + +If this variable is a list, and the list contains the element +`not-score', long file names will not be used for score files; if it +contains the element `not-save', long file names will not be used for +saving; and if it contains the element `not-kill', long file names +will not be used for kill files. + +Note that the default for this variable varies according to what system +type you're using. On `usg-unix-v' and `xenix' this variable defaults +to nil while on all other systems it defaults to t." + :group 'gnus-start + :type 'boolean) + +(defcustom gnus-kill-files-directory gnus-directory + "*Name of the directory where kill files will be stored (default \"~/News\")." + :group 'gnus-score-files + :group 'gnus-score-kill + :type 'directory) + +(defcustom gnus-save-score nil + "*If non-nil, save group scoring info." + :group 'gnus-score-various + :group 'gnus-start + :type 'boolean) + +(defcustom gnus-use-undo t + "*If non-nil, allow undoing in Gnus group mode buffers." + :group 'gnus-meta + :type 'boolean) + +(defcustom gnus-use-adaptive-scoring nil + "*If non-nil, use some adaptive scoring scheme. +If a list, then the values `word' and `line' are meaningful. The +former will perform adaption on individual words in the subject +header while `line' will perform adaption on several headers." + :group 'gnus-meta + :group 'gnus-score-adapt + :type '(set (const word) (const line))) + +(defcustom gnus-use-cache 'passive + "*If nil, Gnus will ignore the article cache. +If `passive', it will allow entering (and reading) articles +explicitly entered into the cache. If anything else, use the +cache to the full extent of the law." + :group 'gnus-meta + :group 'gnus-cache + :type '(choice (const :tag "off" nil) + (const :tag "passive" passive) + (const :tag "active" t))) -(defun gnus-group-list-groups (&optional level unread lowest) - "List newsgroups with level LEVEL or lower that have unread articles. -Default is all subscribed groups. -If argument UNREAD is non-nil, groups with no unread articles are also -listed." - (interactive (list (if current-prefix-arg - (prefix-numeric-value current-prefix-arg) - (or - (gnus-group-default-level nil t) - gnus-group-default-list-level - gnus-level-subscribed)))) - (or level - (setq level (car gnus-group-list-mode) - unread (cdr gnus-group-list-mode))) - (setq level (gnus-group-default-level level)) - (gnus-group-setup-buffer) ;May call from out of group buffer - (gnus-update-format-specifications) - (let ((case-fold-search nil) - (props (text-properties-at (gnus-point-at-bol))) - (group (gnus-group-group-name))) - (set-buffer gnus-group-buffer) - (funcall gnus-group-prepare-function level unread lowest) - (if (zerop (buffer-size)) - (gnus-message 5 gnus-no-groups-message) - (goto-char (point-max)) - (when (or (not gnus-group-goto-next-group-function) - (not (funcall gnus-group-goto-next-group-function - group props))) - (if (not group) - ;; Go to the first group with unread articles. - (gnus-group-search-forward t) - ;; Find the right group to put point on. If the current group - ;; has disappeared in the new listing, try to find the next - ;; one. If no next one can be found, just leave point at the - ;; first newsgroup in the buffer. - (if (not (gnus-goto-char - (text-property-any - (point-min) (point-max) - 'gnus-group (gnus-intern-safe group gnus-active-hashtb)))) - (let ((newsrc (cdddr (gnus-gethash group gnus-newsrc-hashtb)))) - (while (and newsrc - (not (gnus-goto-char - (text-property-any - (point-min) (point-max) 'gnus-group - (gnus-intern-safe - (caar newsrc) gnus-active-hashtb))))) - (setq newsrc (cdr newsrc))) - (or newsrc (progn (goto-char (point-max)) - (forward-line -1))))))) - ;; Adjust cursor point. - (gnus-group-position-point)))) +(defcustom gnus-use-trees nil + "*If non-nil, display a thread tree buffer." + :group 'gnus-meta + :type 'boolean) + +(defcustom gnus-use-grouplens nil + "*If non-nil, use GroupLens ratings." + :group 'gnus-meta + :type 'boolean) + +(defcustom gnus-keep-backlog nil + "*If non-nil, Gnus will keep read articles for later re-retrieval. +If it is a number N, then Gnus will only keep the last N articles +read. If it is neither nil nor a number, Gnus will keep all read +articles. This is not a good idea." + :group 'gnus-meta + :type '(choice (const :tag "off" nil) + integer + (sexp :format "all" + :value t))) + +(defcustom gnus-use-nocem nil + "*If non-nil, Gnus will read NoCeM cancel messages." + :group 'gnus-meta + :type 'boolean) + +(defcustom gnus-suppress-duplicates nil + "*If non-nil, Gnus will mark duplicate copies of the same article as read." + :group 'gnus-meta + :type 'boolean) + +(defcustom gnus-use-demon nil + "If non-nil, Gnus might use some demons." + :group 'gnus-meta + :type 'boolean) + +(defcustom gnus-use-scoring t + "*If non-nil, enable scoring." + :group 'gnus-meta + :type 'boolean) + +(defcustom gnus-use-picons nil + "*If non-nil, display picons." + :group 'gnus-meta + :type 'boolean) + +(defcustom gnus-summary-prepare-exit-hook + '(gnus-summary-expire-articles) + "A hook called when preparing to exit from the summary buffer. +It calls `gnus-summary-expire-articles' by default." + :group 'gnus-summary-exit + :type 'hook) + +(defcustom gnus-novice-user t + "*Non-nil means that you are a usenet novice. +If non-nil, verbose messages may be displayed and confirmations may be +required." + :group 'gnus-meta + :type 'boolean) + +(defcustom gnus-expert-user nil + "*Non-nil means that you will never be asked for confirmation about anything. +And that means *anything*." + :group 'gnus-meta + :type 'boolean) + +(defcustom gnus-interactive-catchup t + "*If non-nil, require your confirmation when catching up a group." + :group 'gnus-group-select + :type 'boolean) + +(defcustom gnus-interactive-exit t + "*If non-nil, require your confirmation when exiting Gnus." + :group 'gnus-exit + :type 'boolean) + +(defcustom gnus-extract-address-components 'gnus-extract-address-components + "*Function for extracting address components from a From header. +Two pre-defined function exist: `gnus-extract-address-components', +which is the default, quite fast, and too simplistic solution, and +`mail-extract-address-components', which works much better, but is +slower." + :group 'gnus-summary-format + :type '(radio (function-item gnus-extract-address-components) + (function-item mail-extract-address-components) + (function :tag "Other"))) + +(defcustom gnus-carpal nil + "*If non-nil, display clickable icons." + :group 'gnus-meta + :type 'boolean) + +(defcustom gnus-shell-command-separator ";" + "String used to separate to shell commands." + :group 'gnus-files + :type 'string) + +(defcustom gnus-valid-select-methods + '(("nntp" post address prompt-address physical-address) + ("nnspool" post address) + ("nnvirtual" post-mail virtual prompt-address) + ("nnmbox" mail respool address) + ("nnml" mail respool address) + ("nnmh" mail respool address) + ("nndir" post-mail prompt-address physical-address) + ("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" none address prompt-address physical-address) + ("nnweb" none)) + "An alist of valid select methods. +The first element of each list lists should be a string with the name +of the select method. The other elements may be the category of +this method (i. e., `post', `mail', `none' or whatever) or other +properties that this method has (like being respoolable). +If you implement a new select method, all you should have to change is +this variable. I think." + :group 'gnus-server + :type '(repeat (group (string :tag "Name") + (radio-button-choice (const :format "%v " post) + (const :format "%v " mail) + (const :format "%v " none) + (const post-mail)) + (checklist :inline t + (const :format "%v " address) + (const :format "%v " prompt-address) + (const :format "%v " virtual) + (const respool))))) + +(define-widget 'gnus-select-method 'list + "Widget for entering a select method." + :args `((choice :tag "Method" + ,@(mapcar (lambda (entry) + (list 'const :format "%v\n" + (intern (car entry)))) + gnus-valid-select-methods)) + (string :tag "Address") + (editable-list :inline t + (list :format "%v" + variable + (sexp :tag "Value"))))) + +(defcustom gnus-updated-mode-lines '(group article summary tree) + "List of buffers that should update their mode lines. +The list may contain the symbols `group', `article', `tree' and +`summary'. If the corresponding symbol is present, Gnus will keep +that mode line updated with information that may be pertinent. +If this variable is nil, screen refresh may be quicker." + :group 'gnus-various + :type '(set (const group) + (const article) + (const summary) + (const tree))) + +;; Added by Keinonen Kari . +(defcustom gnus-mode-non-string-length nil + "*Max length of mode-line non-string contents. +If this is nil, Gnus will take space as is needed, leaving the rest +of the modeline intact." + :group 'gnus-various + :type '(choice (const nil) + integer)) -(defun gnus-group-list-level (level &optional all) - "List groups on LEVEL. -If ALL (the prefix), also list groups that have no unread articles." - (interactive "nList groups on level: \nP") - (gnus-group-list-groups level all level)) +(defcustom gnus-auto-expirable-newsgroups nil + "*Groups in which to automatically mark read articles as expirable. +If non-nil, this should be a regexp that should match all groups in +which to perform auto-expiry. This only makes sense for mail groups." + :group 'gnus-mail-expire + :type '(choice (const nil) + regexp)) + +(defcustom gnus-total-expirable-newsgroups nil + "*Groups in which to perform expiry of all read articles. +Use with extreme caution. All groups that match this regexp will be +expiring - which means that all read articles will be deleted after +\(say) one week. (This only goes for mail groups and the like, of +course.)" + :group 'gnus-mail-expire + :type '(choice (const nil) + regexp)) + +(defcustom gnus-group-uncollapsed-levels 1 + "Number of group name elements to leave alone when making a short group name." + :group 'gnus-group-visual + :type 'integer) + +(defcustom gnus-group-use-permanent-levels nil + "*If non-nil, once you set a level, Gnus will use this level." + :group 'gnus-group-levels + :type 'boolean) + +;; Hooks. + +(defcustom gnus-load-hook nil + "A hook run while Gnus is loaded." + :group 'gnus-start + :type 'hook) + +(defcustom gnus-apply-kill-hook '(gnus-apply-kill-file) + "A hook called to apply kill files to a group. +This hook is intended to apply a kill file to the selected newsgroup. +The function `gnus-apply-kill-file' is called by default. + +Since a general kill file is too heavy to use only for a few +newsgroups, I recommend you to use a lighter hook function. For +example, if you'd like to apply a kill file to articles which contains +a string `rmgroup' in subject in newsgroup `control', you can use the +following hook: + + (setq gnus-apply-kill-hook + (list + (lambda () + (cond ((string-match \"control\" gnus-newsgroup-name) + (gnus-kill \"Subject\" \"rmgroup\") + (gnus-expunge \"X\"))))))" + :group 'gnus-score-kill + :options '(gnus-apply-kill-file) + :type 'hook) + +(defcustom gnus-group-change-level-function nil + "Function run when a group level is changed. +It is called with three parameters -- GROUP, LEVEL and OLDLEVEL." + :group 'gnus-group-level + :type 'function) + +;;; Face thingies. + +(defcustom gnus-visual + '(summary-highlight group-highlight article-highlight + mouse-face + summary-menu group-menu article-menu + tree-highlight menu highlight + browse-menu server-menu + page-marker tree-menu binary-menu pick-menu + grouplens-menu) + "Enable visual features. +If `visual' is disabled, there will be no menus and few faces. Most of +the visual customization options below will be ignored. Gnus will use +less space and be faster as a result. + +This variable can also be a list of visual elements to switch on. For +instance, to switch off all visual things except menus, you can say: + + (setq gnus-visual '(menu)) + +Valid elements include `summary-highlight', `group-highlight', +`article-highlight', `mouse-face', `summary-menu', `group-menu', +`article-menu', `tree-highlight', `menu', `highlight', `browse-menu', +`server-menu', `page-marker', `tree-menu', `binary-menu', `pick-menu', +and `grouplens-menu'." + :group 'gnus-meta + :group 'gnus-visual + :type '(set (const summary-highlight) + (const group-highlight) + (const article-highlight) + (const mouse-face) + (const summary-menu) + (const group-menu) + (const article-menu) + (const tree-highlight) + (const menu) + (const highlight) + (const browse-menu) + (const server-menu) + (const page-marker) + (const tree-menu) + (const binary-menu) + (const pick-menu) + (const grouplens-menu))) + +(defcustom gnus-mouse-face + (condition-case () + (if (gnus-visual-p 'mouse-face 'highlight) + (if (boundp 'gnus-mouse-face) + (or gnus-mouse-face 'highlight) + 'highlight) + 'default) + (error 'highlight)) + "Face used for group or summary buffer mouse highlighting. +The line beneath the mouse pointer will be highlighted with this +face." + :group 'gnus-visual + :type 'face) + +(defcustom gnus-article-display-hook + (if (and (string-match "XEmacs" emacs-version) + (featurep 'xface)) + '(gnus-article-hide-headers-if-wanted + gnus-article-hide-boring-headers + gnus-article-treat-overstrike + gnus-article-maybe-highlight + gnus-article-display-x-face) + '(gnus-article-hide-headers-if-wanted + gnus-article-hide-boring-headers + gnus-article-treat-overstrike + gnus-article-maybe-highlight)) + "Controls how the article buffer will look. + +If you leave the list empty, the article will appear exactly as it is +stored on the disk. The list entries will hide or highlight various +parts of the article, making it easier to find the information you +want." + :group 'gnus-article-highlight + :group 'gnus-visual + :type 'hook + :options '(gnus-article-add-buttons + gnus-article-add-buttons-to-head + gnus-article-emphasize + gnus-article-fill-cited-article + gnus-article-remove-cr + gnus-article-de-quoted-unreadable + gnus-article-display-x-face + gnus-summary-stop-page-breaking + ;; gnus-summary-caesar-message + ;; gnus-summary-verbose-headers + gnus-summary-toggle-mime + gnus-article-hide + gnus-article-hide-headers + gnus-article-hide-boring-headers + gnus-article-hide-signature + gnus-article-hide-citation + gnus-article-hide-pgp + gnus-article-hide-pem + gnus-article-highlight + gnus-article-highlight-headers + gnus-article-highlight-citation + gnus-article-highlight-signature + gnus-article-date-ut + gnus-article-date-local + gnus-article-date-lapsed + gnus-article-date-original + gnus-article-remove-trailing-blank-lines + gnus-article-strip-leading-blank-lines + gnus-article-strip-multiple-blank-lines + gnus-article-strip-blank-lines + gnus-article-treat-overstrike + )) -(defun gnus-group-prepare-flat (level &optional all lowest regexp) - "List all newsgroups with unread articles of level LEVEL or lower. -If ALL is non-nil, list groups that have no unread articles. -If LOWEST is non-nil, list all newsgroups of level LOWEST or higher. -If REGEXP, only list groups matching REGEXP." - (set-buffer gnus-group-buffer) - (let ((buffer-read-only nil) - (newsrc (cdr gnus-newsrc-alist)) - (lowest (or lowest 1)) - info clevel unread group params) - (erase-buffer) - (if (< lowest gnus-level-zombie) - ;; List living groups. - (while newsrc - (setq info (car newsrc) - group (gnus-info-group info) - params (gnus-info-params info) - newsrc (cdr newsrc) - unread (car (gnus-gethash group gnus-newsrc-hashtb))) - (and unread ; This group might be bogus - (or (not regexp) - (string-match regexp group)) - (<= (setq clevel (gnus-info-level info)) level) - (>= clevel lowest) - (or all ; We list all groups? - (if (eq unread t) ; Unactivated? - gnus-group-list-inactive-groups ; We list unactivated - (> unread 0)) ; We list groups with unread articles - (and gnus-list-groups-with-ticked-articles - (cdr (assq 'tick (gnus-info-marks info)))) - ; And groups with tickeds - ;; Check for permanent visibility. - (and gnus-permanently-visible-groups - (string-match gnus-permanently-visible-groups - group)) - (memq 'visible params) - (cdr (assq 'visible params))) - (gnus-group-insert-group-line - group (gnus-info-level info) - (gnus-info-marks info) unread (gnus-info-method info))))) + +;;; Internal variables + +(defvar gnus-group-get-parameter-function 'gnus-group-get-parameter) +(defvar gnus-original-article-buffer " *Original Article*") +(defvar gnus-newsgroup-name nil) + +(defvar gnus-current-select-method nil + "The current method for selecting a newsgroup.") + +(defvar gnus-tree-buffer "*Tree*" + "Buffer where Gnus thread trees are displayed.") + +;; Dummy variable. +(defvar gnus-use-generic-from nil) + +;; Variable holding the user answers to all method prompts. +(defvar gnus-method-history nil) +(defvar gnus-group-history nil) + +;; Variable holding the user answers to all mail method prompts. +(defvar gnus-mail-method-history nil) + +;; Variable holding the user answers to all group prompts. +(defvar gnus-group-history nil) + +(defvar gnus-server-alist nil + "List of available servers.") + +(defvar gnus-predefined-server-alist + `(("cache" + (nnspool "cache" + (nnspool-spool-directory "~/News/cache/") + (nnspool-nov-directory "~/News/cache/") + (nnspool-active-file "~/News/cache/active")))) + "List of predefined (convenience) servers.") + +(defvar gnus-topic-indentation "") ;; Obsolete variable. + +(defconst gnus-article-mark-lists + '((marked . tick) (replied . reply) + (expirable . expire) (killed . killed) + (bookmarks . bookmark) (dormant . dormant) + (scored . score) (saved . save) + (cached . cache))) + +(defvar gnus-headers-retrieved-by nil) +(defvar gnus-article-reply nil) +(defvar gnus-override-method nil) +(defvar gnus-article-check-size nil) +(defvar gnus-opened-servers nil) + +(defvar gnus-current-kill-article nil) + +(defvar gnus-have-read-active-file nil) + +(defconst gnus-maintainer + "gnus-bug@ifi.uio.no (The Gnus Bugfixing Girls + Boys)" + "The mail address of the Gnus maintainers.") + +(defvar gnus-info-nodes + '((gnus-group-mode "(gnus)The Group Buffer") + (gnus-summary-mode "(gnus)The Summary Buffer") + (gnus-article-mode "(gnus)The Article Buffer") + (mime/viewer-mode "(gnus)The Article Buffer") + (gnus-server-mode "(gnus)The Server Buffer") + (gnus-browse-mode "(gnus)Browse Foreign Server") + (gnus-tree-mode "(gnus)Tree Display")) + "Alist of major modes and related Info nodes.") + +(defvar gnus-group-buffer "*Group*") +(defvar gnus-summary-buffer "*Summary*") +(defvar gnus-article-buffer "*Article*") +(defvar gnus-server-buffer "*Server*") + +(defvar gnus-buffer-list nil + "Gnus buffers that should be killed on exit.") + +(defvar gnus-slave nil + "Whether this Gnus is a slave or not.") + +(defvar gnus-batch-mode nil + "Whether this Gnus is running in batch mode or not.") + +(defvar gnus-variable-list + '(gnus-newsrc-options gnus-newsrc-options-n + gnus-newsrc-last-checked-date + gnus-newsrc-alist gnus-server-alist + gnus-killed-list gnus-zombie-list + gnus-topic-topology gnus-topic-alist + gnus-format-specs) + "Gnus variables saved in the quick startup file.") + +(defvar gnus-newsrc-alist nil + "Assoc list of read articles. +gnus-newsrc-hashtb should be kept so that both hold the same information.") + +(defvar gnus-newsrc-hashtb nil + "Hashtable of gnus-newsrc-alist.") + +(defvar gnus-killed-list nil + "List of killed newsgroups.") + +(defvar gnus-killed-hashtb nil + "Hash table equivalent of gnus-killed-list.") + +(defvar gnus-zombie-list nil + "List of almost dead newsgroups.") + +(defvar gnus-description-hashtb nil + "Descriptions of newsgroups.") + +(defvar gnus-list-of-killed-groups nil + "List of newsgroups that have recently been killed by the user.") + +(defvar gnus-active-hashtb nil + "Hashtable of active articles.") + +(defvar gnus-moderated-hashtb nil + "Hashtable of moderated newsgroups.") + +;; Save window configuration. +(defvar gnus-prev-winconf nil) + +(defvar gnus-reffed-article-number nil) + +;;; Let the byte-compiler know that we know about this variable. +(defvar rmail-default-rmail-file) + +(defvar gnus-dead-summary nil) + +;;; End of variables. + +;; Define some autoload functions Gnus might use. +(eval-and-compile + + ;; This little mapcar goes through the list below and marks the + ;; symbols in question as autoloaded functions. + (mapcar + (lambda (package) + (let ((interactive (nth 1 (memq ':interactive package)))) + (mapcar + (lambda (function) + (let (keymap) + (when (consp function) + (setq keymap (car (memq 'keymap function))) + (setq function (car function))) + (autoload function (car package) nil interactive keymap))) + (if (eq (nth 1 package) ':interactive) + (cdddr package) + (cdr package))))) + '(("metamail" metamail-buffer) + ("info" Info-goto-node) + ("hexl" hexl-hex-string-to-integer) + ("pp" pp pp-to-string pp-eval-expression) + ("ps-print" ps-print-preprint) + ("mail-extr" mail-extract-address-components) + ("message" :interactive t + message-send-and-exit message-yank-original) + ("nnmail" nnmail-split-fancy nnmail-article-group nnmail-date-to-time) + ("nnvirtual" nnvirtual-catchup-group nnvirtual-convert-headers) + ("timezone" timezone-make-date-arpa-standard timezone-fix-time + timezone-make-sortable-date timezone-make-time-string) + ("rmailout" rmail-output) + ("rmail" rmail-insert-rmail-file-header rmail-count-new-messages + rmail-show-message) + ("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) + ("gnus-mh" :interactive t gnus-summary-save-in-folder) + ("gnus-demon" gnus-demon-add-nocem gnus-demon-add-scanmail + gnus-demon-add-rescan gnus-demon-add-scan-timestamps + gnus-demon-add-disconnection gnus-demon-add-handler + gnus-demon-remove-handler) + ("gnus-demon" :interactive t + gnus-demon-init gnus-demon-cancel) + ("gnus-salt" gnus-highlight-selected-tree gnus-possibly-generate-tree + gnus-tree-open gnus-tree-close gnus-carpal-setup-buffer) + ("gnus-nocem" gnus-nocem-scan-groups gnus-nocem-close + gnus-nocem-unwanted-article-p) + ("gnus-srvr" gnus-enter-server-buffer gnus-server-set-info) + ("gnus-srvr" gnus-browse-foreign-server) + ("gnus-cite" :interactive t + gnus-article-highlight-citation gnus-article-hide-citation-maybe + gnus-article-hide-citation gnus-article-fill-cited-article + gnus-article-hide-citation-in-followups) + ("gnus-kill" gnus-kill gnus-apply-kill-file-internal + gnus-kill-file-edit-file gnus-kill-file-raise-followups-to-author + gnus-execute gnus-expunge) + ("gnus-cache" gnus-cache-possibly-enter-article gnus-cache-save-buffers + gnus-cache-possibly-remove-articles gnus-cache-request-article + gnus-cache-retrieve-headers gnus-cache-possibly-alter-active + gnus-cache-enter-remove-article gnus-cached-article-p + gnus-cache-open gnus-cache-close gnus-cache-update-article) + ("gnus-cache" :interactive t gnus-jog-cache gnus-cache-enter-article + gnus-cache-remove-article gnus-summary-insert-cached-articles) + ("gnus-score" :interactive t + gnus-summary-increase-score gnus-summary-set-score + gnus-summary-raise-thread gnus-summary-raise-same-subject + gnus-summary-raise-score gnus-summary-raise-same-subject-and-select + gnus-summary-lower-thread gnus-summary-lower-same-subject + gnus-summary-lower-score gnus-summary-lower-same-subject-and-select + gnus-summary-current-score gnus-score-default + gnus-score-flush-cache gnus-score-close + gnus-possibly-score-headers gnus-score-followup-article + gnus-score-followup-thread) + ("gnus-score" + (gnus-summary-score-map keymap) gnus-score-save gnus-score-headers + gnus-current-score-file-nondirectory gnus-score-adaptive + gnus-score-find-trace gnus-score-file-name) + ("gnus-cus" :interactive t gnus-group-customize gnus-score-customize) + ("gnus-topic" :interactive t gnus-topic-mode) + ("gnus-topic" gnus-topic-remove-group gnus-topic-set-parameters) + ("gnus-salt" :interactive t gnus-pick-mode gnus-binary-mode) + ("gnus-uu" (gnus-uu-extract-map keymap) (gnus-uu-mark-map keymap)) + ("gnus-uu" :interactive t + gnus-uu-digest-mail-forward gnus-uu-digest-post-forward + gnus-uu-mark-series gnus-uu-mark-region gnus-uu-mark-buffer + gnus-uu-mark-by-regexp gnus-uu-mark-all + gnus-uu-mark-sparse gnus-uu-mark-thread gnus-uu-decode-uu + gnus-uu-decode-uu-and-save gnus-uu-decode-unshar + gnus-uu-decode-unshar-and-save gnus-uu-decode-save + gnus-uu-decode-binhex gnus-uu-decode-uu-view + gnus-uu-decode-uu-and-save-view gnus-uu-decode-unshar-view + gnus-uu-decode-unshar-and-save-view gnus-uu-decode-save-view + gnus-uu-decode-binhex-view) + ("gnus-uu" gnus-uu-delete-work-dir) + ("gnus-msg" (gnus-summary-send-map keymap) + gnus-article-mail gnus-copy-article-buffer gnus-extended-version) + ("gnus-msg" :interactive t + gnus-group-post-news gnus-group-mail gnus-summary-post-news + gnus-summary-followup gnus-summary-followup-with-original + gnus-summary-cancel-article gnus-summary-supersede-article + gnus-post-news gnus-summary-reply gnus-summary-reply-with-original + gnus-summary-mail-forward gnus-summary-mail-other-window + gnus-summary-resend-message gnus-summary-resend-bounced-mail + gnus-bug) + ("gnus-picon" :interactive t gnus-article-display-picons + gnus-group-display-picons gnus-picons-article-display-x-face + gnus-picons-display-x-face) + ("gnus-gl" bbb-login bbb-logout bbb-grouplens-group-p + gnus-grouplens-mode) + ("smiley" :interactive t gnus-smiley-display) + ("gnus-win" gnus-configure-windows gnus-add-configuration) + ("gnus-sum" gnus-summary-insert-line gnus-summary-read-group + gnus-list-of-unread-articles gnus-list-of-read-articles + gnus-offer-save-summaries gnus-make-thread-indent-array + gnus-summary-exit gnus-update-read-articles) + ("gnus-group" gnus-group-insert-group-line gnus-group-quit + gnus-group-list-groups gnus-group-first-unread-group + gnus-group-set-mode-line gnus-group-set-info gnus-group-save-newsrc + gnus-group-setup-buffer gnus-group-get-new-news + gnus-group-make-help-group gnus-group-update-group) + ("gnus-bcklg" gnus-backlog-request-article gnus-backlog-enter-article + gnus-backlog-remove-article) + ("gnus-art" gnus-article-read-summary-keys gnus-article-save + gnus-article-prepare gnus-article-set-window-start + gnus-article-next-page gnus-article-prev-page + gnus-request-article-this-buffer gnus-article-mode + gnus-article-setup-buffer gnus-narrow-to-page) + ("gnus-art" :interactive t + gnus-article-hide-headers gnus-article-hide-boring-headers + gnus-article-treat-overstrike gnus-article-word-wrap + gnus-article-remove-cr gnus-article-remove-trailing-blank-lines + gnus-article-display-x-face gnus-article-de-quoted-unreadable + gnus-article-mime-decode-quoted-printable gnus-article-hide-pgp + gnus-article-hide-pem gnus-article-hide-signature + gnus-article-strip-leading-blank-lines gnus-article-date-local + gnus-article-date-original gnus-article-date-lapsed + gnus-article-show-all-headers + gnus-article-edit-mode gnus-article-edit-article + gnus-article-edit-done gnus-decode-rfc1522 article-decode-rfc1522) + ("gnus-int" gnus-request-type) + ("gnus-start" gnus-newsrc-parse-options gnus-1 gnus-no-server-1 + gnus-dribble-enter) + ("gnus-dup" gnus-dup-suppress-articles gnus-dup-unsuppress-article + 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 + gnus-async-prefetch-article gnus-async-prefetch-remove-group + gnus-async-halt-prefetch) + ("gnus-vm" :interactive t gnus-summary-save-in-vm + gnus-summary-save-article-vm)))) + +;;; gnus-sum.el thingies + + +(defcustom gnus-summary-line-format "%U\%R\%z\%I\%(%[%4L: %-20,20n%]%) %s\n" + "*The format specification of the lines in the summary buffer. + +It works along the same lines as a normal formatting string, +with some simple extensions. + +%N Article number, left padded with spaces (string) +%S Subject (string) +%s Subject if it is at the root of a thread, and \"\" otherwise (string) +%n Name of the poster (string) +%a Extracted name of the poster (string) +%A Extracted address of the poster (string) +%F Contents of the From: header (string) +%x Contents of the Xref: header (string) +%D Date of the article (string) +%d Date of the article (string) in DD-MMM format +%M Message-id of the article (string) +%r References of the article (string) +%c Number of characters in the article (integer) +%L Number of lines in the article (integer) +%I Indentation based on thread level (a string of spaces) +%T A string with two possible values: 80 spaces if the article + is on thread level two or larger and 0 spaces on level one +%R \"A\" if this article has been replied to, \" \" otherwise (character) +%U Status of this article (character, \"R\", \"K\", \"-\" or \" \") +%[ Opening bracket (character, \"[\" or \"<\") +%] Closing bracket (character, \"]\" or \">\") +%> Spaces of length thread-level (string) +%< Spaces of length (- 20 thread-level) (string) +%i Article score (number) +%z Article zcore (character) +%t Number of articles under the current thread (number). +%e Whether the thread is empty or not (character). +%l GroupLens score (string). +%V Total thread score (number). +%P The line number (number). +%u User defined specifier. The next character in the format string should + be a letter. Gnus will call the function gnus-user-format-function-X, + where X is the letter following %u. The function will be passed the + current header as argument. The function should return a string, which + will be inserted into the summary just like information from any other + summary specifier. - ;; List dead groups. - (and (>= level gnus-level-zombie) (<= lowest gnus-level-zombie) - (gnus-group-prepare-flat-list-dead - (setq gnus-zombie-list (sort gnus-zombie-list 'string<)) - gnus-level-zombie ?Z - regexp)) - (and (>= level gnus-level-killed) (<= lowest gnus-level-killed) - (gnus-group-prepare-flat-list-dead - (setq gnus-killed-list (sort gnus-killed-list 'string<)) - gnus-level-killed ?K regexp)) +Text between %( and %) will be highlighted with `gnus-mouse-face' +when the mouse point is placed inside the area. There can only be one +such area. + +The %U (status), %R (replied) and %z (zcore) specs have to be handled +with care. For reasons of efficiency, Gnus will compute what column +these characters will end up in, and \"hard-code\" that. This means that +it is illegal to have these specs after a variable-length spec. Well, +you might not be arrested, but your summary buffer will look strange, +which is bad enough. + +The smart choice is to have these specs as for to the left as +possible. + +This restriction may disappear in later versions of Gnus." + :type 'string + :group 'gnus-summary-format) + +;;; +;;; Skeleton keymaps +;;; + +(defun gnus-suppress-keymap (keymap) + (suppress-keymap keymap) + (let ((keys `([delete] "\177" "\M-u"))) ;gnus-mouse-2 + (while keys + (define-key keymap (pop keys) 'undefined)))) + +(defvar gnus-article-mode-map + (let ((keymap (make-keymap))) + (gnus-suppress-keymap keymap) + keymap)) +(defvar gnus-summary-mode-map + (let ((keymap (make-keymap))) + (gnus-suppress-keymap keymap) + keymap)) +(defvar gnus-group-mode-map + (let ((keymap (make-keymap))) + (gnus-suppress-keymap keymap) + keymap)) + + + +;; Fix by Hallvard B Furuseth . +;; If you want the cursor to go somewhere else, set these two +;; functions in some startup hook to whatever you want. +(defalias 'gnus-summary-position-point 'gnus-goto-colon) +(defalias 'gnus-group-position-point 'gnus-goto-colon) + +;;; Various macros and substs. + +(defun gnus-header-from (header) + (mail-header-from header)) + +(defmacro gnus-gethash (string hashtable) + "Get hash value of STRING in HASHTABLE." + `(symbol-value (intern-soft ,string ,hashtable))) + +(defmacro gnus-sethash (string value hashtable) + "Set hash value. Arguments are STRING, VALUE, and HASHTABLE." + `(set (intern ,string ,hashtable) ,value)) +(put 'gnus-sethash 'edebug-form-spec '(form form form)) + +(defmacro gnus-group-unread (group) + "Get the currently computed number of unread articles in GROUP." + `(car (gnus-gethash ,group gnus-newsrc-hashtb))) + +(defmacro gnus-group-entry (group) + "Get the newsrc entry for GROUP." + `(gnus-gethash ,group gnus-newsrc-hashtb)) + +(defmacro gnus-active (group) + "Get active info on GROUP." + `(gnus-gethash ,group gnus-active-hashtb)) + +(defmacro gnus-set-active (group active) + "Set GROUP's active info." + `(gnus-sethash ,group ,active gnus-active-hashtb)) - (gnus-group-set-mode-line) - (setq gnus-group-list-mode (cons level all)) - (run-hooks 'gnus-group-prepare-hook))) +(defun gnus-alive-p () + "Say whether Gnus is running or not." + (and gnus-group-buffer + (get-buffer gnus-group-buffer) + (save-excursion + (set-buffer gnus-group-buffer) + (eq major-mode 'gnus-group-mode)))) + +;; Info access macros. + +(defmacro gnus-info-group (info) + `(nth 0 ,info)) +(defmacro gnus-info-rank (info) + `(nth 1 ,info)) +(defmacro gnus-info-read (info) + `(nth 2 ,info)) +(defmacro gnus-info-marks (info) + `(nth 3 ,info)) +(defmacro gnus-info-method (info) + `(nth 4 ,info)) +(defmacro gnus-info-params (info) + `(nth 5 ,info)) + +(defmacro gnus-info-level (info) + `(let ((rank (gnus-info-rank ,info))) + (if (consp rank) + (car rank) + rank))) +(defmacro gnus-info-score (info) + `(let ((rank (gnus-info-rank ,info))) + (or (and (consp rank) (cdr rank)) 0))) + +(defmacro gnus-info-set-group (info group) + `(setcar ,info ,group)) +(defmacro gnus-info-set-rank (info rank) + `(setcar (nthcdr 1 ,info) ,rank)) +(defmacro gnus-info-set-read (info read) + `(setcar (nthcdr 2 ,info) ,read)) +(defmacro gnus-info-set-marks (info marks &optional extend) + (if extend + `(gnus-info-set-entry ,info ,marks 3) + `(setcar (nthcdr 3 ,info) ,marks))) +(defmacro gnus-info-set-method (info method &optional extend) + (if extend + `(gnus-info-set-entry ,info ,method 4) + `(setcar (nthcdr 4 ,info) ,method))) +(defmacro gnus-info-set-params (info params &optional extend) + (if extend + `(gnus-info-set-entry ,info ,params 5) + `(setcar (nthcdr 5 ,info) ,params))) + +(defun gnus-info-set-entry (info entry number) + ;; Extend the info until we have enough elements. + (while (<= (length info) number) + (nconc info (list nil))) + ;; Set the entry. + (setcar (nthcdr number info) entry)) + +(defmacro gnus-info-set-level (info level) + `(let ((rank (cdr ,info))) + (if (consp (car rank)) + (setcar (car rank) ,level) + (setcar rank ,level)))) +(defmacro gnus-info-set-score (info score) + `(let ((rank (cdr ,info))) + (if (consp (car rank)) + (setcdr (car rank) ,score) + (setcar rank (cons (car rank) ,score))))) + +(defmacro gnus-get-info (group) + `(nth 2 (gnus-gethash ,group gnus-newsrc-hashtb))) + +;; Byte-compiler warning. +(defvar gnus-visual) +;; Find out whether the gnus-visual TYPE is wanted. +(defun gnus-visual-p (&optional type class) + (and gnus-visual ; Has to be non-nil, at least. + (if (not type) ; We don't care about type. + gnus-visual + (if (listp gnus-visual) ; It's a list, so we check it. + (or (memq type gnus-visual) + (memq class gnus-visual)) + t)))) + +;;; Load the compatability functions. + +(require 'gnus-ems) -(defun gnus-group-prepare-flat-list-dead (groups level mark regexp) - ;; List zombies and killed lists somewhat faster, which was - ;; suggested by Jack Vinson . It does - ;; this by ignoring the group format specification altogether. - (let (group) - (if regexp - ;; This loop is used when listing groups that match some - ;; regexp. - (while groups - (setq group (pop groups)) - (when (string-match regexp group) - (gnus-add-text-properties - (point) (prog1 (1+ (point)) - (insert " " mark " *: " group "\n")) - (list 'gnus-group (gnus-intern-safe group gnus-active-hashtb) - 'gnus-unread t - 'gnus-level level)))) - ;; This loop is used when listing all groups. - (while groups - (gnus-add-text-properties - (point) (prog1 (1+ (point)) - (insert " " mark " *: " - (setq group (pop groups)) "\n")) - (list 'gnus-group (gnus-intern-safe group gnus-active-hashtb) - 'gnus-unread t - 'gnus-level level)))))) + +;;; +;;; Shutdown +;;; + +(defvar gnus-shutdown-alist nil) + +(defun gnus-add-shutdown (function &rest symbols) + "Run FUNCTION whenever one of SYMBOLS is shut down." + (push (cons function symbols) gnus-shutdown-alist)) + +(defun gnus-shutdown (symbol) + "Shut down everything that waits for SYMBOL." + (let ((alist gnus-shutdown-alist) + entry) + (while (setq entry (pop alist)) + (when (memq symbol (cdr entry)) + (funcall (car entry)))))) + + +;;; +;;; Gnus Utility Functions +;;; + +;; Add the current buffer to the list of buffers to be killed on exit. +(defun gnus-add-current-to-buffer-list () + (or (memq (current-buffer) gnus-buffer-list) + (push (current-buffer) gnus-buffer-list))) + +(defun gnus-version (&optional arg) + "Version number of this version of Gnus. +If ARG, insert string at point." + (interactive "P") + (let ((methods gnus-valid-select-methods) + (mess gnus-version) + meth) + ;; Go through all the legal select methods and add their version + ;; numbers to the total version string. Only the backends that are + ;; currently in use will have their message numbers taken into + ;; consideration. + (while methods + (setq meth (intern (concat (caar methods) "-version"))) + (and (boundp meth) + (stringp (symbol-value meth)) + (setq mess (concat mess "; " (symbol-value meth)))) + (setq methods (cdr methods))) + (if arg + (insert (message mess)) + (message mess)))) + +(defun gnus-continuum-version (version) + "Return VERSION as a floating point number." + (when (or (string-match "^\\([^ ]+\\)? ?Gnus v?\\([0-9.]+\\)$" version) + (string-match "^\\(.?\\)gnus-\\([0-9.]+\\)$" version)) + (let* ((alpha (and (match-beginning 1) (match-string 1 version))) + (number (match-string 2 version)) + major minor least) + (string-match "\\([0-9]\\)\\.\\([0-9]+\\)\\.?\\([0-9]+\\)?" number) + (setq major (string-to-number (match-string 1 number))) + (setq minor (string-to-number (match-string 2 number))) + (setq least (if (match-beginning 3) + (string-to-number (match-string 3 number)) + 0)) + (string-to-number + (if (zerop major) + (format "%s00%02d%02d" + (cond + ((member alpha '("(ding)" "d")) "4.99") + ((member alpha '("September" "s")) "5.01") + ((member alpha '("Red" "r")) "5.03")) + minor least) + (format "%d.%02d%02d" major minor least)))))) + +(defun gnus-info-find-node () + "Find Info documentation of Gnus." + (interactive) + ;; Enlarge info window if needed. + (let (gnus-info-buffer) + (Info-goto-node (cadr (assq major-mode gnus-info-nodes))) + (setq gnus-info-buffer (current-buffer)) + (gnus-configure-windows 'info))) + +;;; More various functions. -(defmacro gnus-group-real-name (group) - "Find the real name of a foreign newsgroup." - `(let ((gname ,group)) - (if (string-match ":[^:]+$" gname) - (substring gname (1+ (match-beginning 0))) - gname))) +(defun gnus-group-read-only-p (&optional group) + "Check whether GROUP supports editing or not. +If GROUP is nil, `gnus-newsgroup-name' will be checked instead. Note +that that variable is buffer-local to the summary buffers." + (let ((group (or group gnus-newsgroup-name))) + (not (gnus-check-backend-function 'request-replace-article group)))) + +(defun gnus-group-total-expirable-p (group) + "Check whether GROUP is total-expirable or not." + (let ((params (gnus-group-find-parameter group)) + val) + (cond + ((memq 'total-expire params) + t) + ((setq val (assq 'total-expire params)) ; (auto-expire . t) + (cdr val)) + (gnus-total-expirable-newsgroups ; Check var. + (string-match gnus-total-expirable-newsgroups group))))) + +(defun gnus-group-auto-expirable-p (group) + "Check whether GROUP is total-expirable or not." + (let ((params (gnus-group-find-parameter group)) + val) + (cond + ((memq 'auto-expire params) + t) + ((setq val (assq 'auto-expire params)) ; (auto-expire . t) + (cdr val)) + (gnus-auto-expirable-newsgroups ; Check var. + (string-match gnus-auto-expirable-newsgroups group))))) + +(defun gnus-virtual-group-p (group) + "Say whether GROUP is virtual or not." + (memq 'virtual (assoc (symbol-name (car (gnus-find-method-for-group group))) + gnus-valid-select-methods))) + +(defun gnus-news-group-p (group &optional article) + "Return non-nil if GROUP (and ARTICLE) come from a news server." + (or (gnus-member-of-valid 'post group) ; Ordinary news group. + (and (gnus-member-of-valid 'post-mail group) ; Combined group. + (eq (gnus-request-type group article) 'news)))) + +;; Returns a list of writable groups. +(defun gnus-writable-groups () + (let ((alist gnus-newsrc-alist) + groups group) + (while (setq group (car (pop alist))) + (unless (gnus-group-read-only-p group) + (push group groups))) + (nreverse groups))) + +;; Check whether to use long file names. +(defun gnus-use-long-file-name (symbol) + ;; The variable has to be set... + (and gnus-use-long-file-name + ;; If it isn't a list, then we return t. + (or (not (listp gnus-use-long-file-name)) + ;; If it is a list, and the list contains `symbol', we + ;; return nil. + (not (memq symbol gnus-use-long-file-name))))) + +;; Generate a unique new group name. +(defun gnus-generate-new-group-name (leaf) + (let ((name leaf) + (num 0)) + (while (gnus-gethash name gnus-newsrc-hashtb) + (setq name (concat leaf "<" (int-to-string (setq num (1+ num))) ">"))) + name)) + +(defun gnus-ephemeral-group-p (group) + "Say whether GROUP is ephemeral or not." + (gnus-group-get-parameter group 'quit-config)) + +(defun gnus-group-quit-config (group) + "Return the quit-config of GROUP." + (gnus-group-get-parameter group 'quit-config)) + +(defun gnus-kill-ephemeral-group (group) + "Remove ephemeral GROUP from relevant structures." + (gnus-sethash group nil gnus-newsrc-hashtb)) + +(defun gnus-simplify-mode-line () + "Make mode lines a bit simpler." + (setq mode-line-modified "-- ") + (when (listp mode-line-format) + (make-local-variable 'mode-line-format) + (setq mode-line-format (copy-sequence mode-line-format)) + (when (equal (nth 3 mode-line-format) " ") + (setcar (nthcdr 3 mode-line-format) " ")))) + +;;; Servers and groups. (defsubst gnus-server-add-address (method) (let ((method-name (symbol-name (car method)))) (if (and (memq 'address (assoc method-name gnus-valid-select-methods)) - (not (assq (intern (concat method-name "-address")) method))) + (not (assq (intern (concat method-name "-address")) method)) + (memq 'physical-address (assq (car method) + gnus-valid-select-methods))) (append method (list (list (intern (concat method-name "-address")) (nth 1 method)))) method))) @@ -4768,6 +2063,8 @@ (and (equal server "native") gnus-select-method) ;; It should be in the server alist. (cdr (assoc server gnus-server-alist)) + ;; It could be in the predefined server alist. + (cdr (assoc server gnus-predefined-server-alist)) ;; If not, we look through all the opened server ;; to see whether we can find it there. (let ((opened gnus-opened-servers)) @@ -4828,13 +2125,13 @@ (if (not method) group (concat (format "%s" (car method)) - (if (and - (or (assoc (format "%s" (car method)) - (gnus-methods-using 'address)) - (gnus-server-equal method gnus-message-archive-method)) - (nth 1 method) - (not (string= (nth 1 method) ""))) - (concat "+" (nth 1 method))) + (when (and + (or (assoc (format "%s" (car method)) + (gnus-methods-using 'address)) + (gnus-server-equal method gnus-message-archive-method)) + (nth 1 method) + (not (string= (nth 1 method) ""))) + (concat "+" (nth 1 method))) ":" group))) (defun gnus-group-real-prefix (group) @@ -4844,7 +2141,8 @@ "")) (defun gnus-group-method (group) - "Return the server or method used for selecting GROUP." + "Return the server or method used for selecting GROUP. +You should probably use `gnus-find-method-for-group' instead." (let ((prefix (gnus-group-real-prefix group))) (if (equal prefix "") gnus-select-method @@ -4890,8 +2188,18 @@ "Say whether the group is secondary or not." (gnus-secondary-method-p (gnus-find-method-for-group group))) +(defun gnus-group-find-parameter (group &optional symbol) + "Return the group parameters for GROUP. +If SYMBOL, return the value of that symbol in the group parameters." + (save-excursion + (set-buffer gnus-group-buffer) + (let ((parameters (funcall gnus-group-get-parameter-function group))) + (if symbol + (gnus-group-parameter-value parameters symbol) + parameters)))) + (defun gnus-group-get-parameter (group &optional symbol) - "Returns the group parameters for GROUP. + "Return the group parameters for GROUP. If SYMBOL, return the value of that symbol in the group parameters." (let ((params (gnus-info-params (gnus-get-info group)))) (if symbol @@ -4907,7 +2215,7 @@ "Add parameter PARAM to GROUP." (let ((info (gnus-get-info group))) (if (not info) - () ; This is a dead group. We just ignore it. + () ; This is a dead group. We just ignore it. ;; Cons the new param to the old one and update. (gnus-group-set-info (cons param (gnus-info-params info)) group 'params)))) @@ -4916,13 +2224,13 @@ "Set parameter NAME to VALUE in GROUP." (let ((info (gnus-get-info group))) (if (not info) - () ; This is a dead group. We just ignore it. + () ; This is a dead group. We just ignore it. (let ((old-params (gnus-info-params info)) (new-params (list (cons name value)))) (while old-params - (if (or (not (listp (car old-params))) - (not (eq (caar old-params) name))) - (setq new-params (append new-params (list (car old-params))))) + (when (or (not (listp (car old-params))) + (not (eq (caar old-params) name))) + (setq new-params (append new-params (list (car old-params))))) (setq old-params (cdr old-params))) (gnus-group-set-info new-params group 'params))))) @@ -4933,4955 +2241,40 @@ (when info (gnus-info-set-score info (+ (gnus-info-score info) (or score 1)))))) -(defun gnus-summary-bubble-group () - "Increase the score of the current group. -This is a handy function to add to `gnus-summary-exit-hook' to -increase the score of each group you read." - (gnus-group-add-score gnus-newsgroup-name)) - -(defun gnus-group-set-info (info &optional method-only-group part) - (let* ((entry (gnus-gethash - (or method-only-group (gnus-info-group info)) - gnus-newsrc-hashtb)) - (part-info info) - (info (if method-only-group (nth 2 entry) info)) - method) - (when method-only-group - (unless entry - (error "Trying to change non-existent group %s" method-only-group)) - ;; We have received parts of the actual group info - either the - ;; select method or the group parameters. We first check - ;; whether we have to extend the info, and if so, do that. - (let ((len (length info)) - (total (if (eq part 'method) 5 6))) - (when (< len total) - (setcdr (nthcdr (1- len) info) - (make-list (- total len) nil))) - ;; Then we enter the new info. - (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) - (setq method (gnus-info-method info)) - (when (gnus-server-equal method "native") - (setq method nil)) - (save-excursion - (set-buffer gnus-group-buffer) - (if method - ;; It's a foreign group... - (gnus-group-make-group - (gnus-group-real-name (gnus-info-group info)) - (if (stringp method) method - (prin1-to-string (car method))) - (and (consp method) - (nth 1 (gnus-info-method info)))) - ;; It's a native group. - (gnus-group-make-group (gnus-info-group info)))) - (gnus-message 6 "Note: New group created") - (setq entry - (gnus-gethash (gnus-group-prefixed-name - (gnus-group-real-name (gnus-info-group info)) - (or (gnus-info-method info) gnus-select-method)) - gnus-newsrc-hashtb)))) - ;; Whether it was a new group or not, we now have the entry, so we - ;; can do the update. - (if entry - (progn - (setcar (nthcdr 2 entry) info) - (when (and (not (eq (car entry) t)) - (gnus-active (gnus-info-group info))) - (setcar entry (length (gnus-list-of-unread-articles (car info)))))) - (error "No such group: %s" (gnus-info-group info))))) - -(defun gnus-group-set-method-info (group select-method) - (gnus-group-set-info select-method group 'method)) - -(defun gnus-group-set-params-info (group params) - (gnus-group-set-info params group 'params)) - -(defun gnus-group-update-group-line () - "Update the current line in the group buffer." - (let* ((buffer-read-only nil) - (group (gnus-group-group-name)) - (entry (and group (gnus-gethash group gnus-newsrc-hashtb))) - gnus-group-indentation) - (when group - (and entry - (not (gnus-ephemeral-group-p group)) - (gnus-dribble-enter - (concat "(gnus-group-set-info '" - (prin1-to-string (nth 2 entry)) ")"))) - (setq gnus-group-indentation (gnus-group-group-indentation)) - (gnus-delete-line) - (gnus-group-insert-group-line-info group) - (forward-line -1) - (gnus-group-position-point)))) - -(defun gnus-group-insert-group-line-info (group) - "Insert GROUP on the current line." - (let ((entry (gnus-gethash group gnus-newsrc-hashtb)) - active info) - (if entry - (progn - ;; (Un)subscribed group. - (setq info (nth 2 entry)) - (gnus-group-insert-group-line - group (gnus-info-level info) (gnus-info-marks info) - (or (car entry) t) (gnus-info-method info))) - ;; This group is dead. - (gnus-group-insert-group-line - group - (if (member group gnus-zombie-list) gnus-level-zombie gnus-level-killed) - nil - (if (setq active (gnus-active group)) - (- (1+ (cdr active)) (car active)) 0) - nil)))) - -(defun gnus-group-insert-group-line (gnus-tmp-group gnus-tmp-level - gnus-tmp-marked number - gnus-tmp-method) - "Insert a group line in the group buffer." - (let* ((gnus-tmp-active (gnus-active gnus-tmp-group)) - (gnus-tmp-number-total - (if gnus-tmp-active - (1+ (- (cdr gnus-tmp-active) (car gnus-tmp-active))) - 0)) - (gnus-tmp-number-of-unread - (if (numberp number) (int-to-string (max 0 number)) - "*")) - (gnus-tmp-number-of-read - (if (numberp number) - (int-to-string (max 0 (- gnus-tmp-number-total number))) - "*")) - (gnus-tmp-subscribed - (cond ((<= gnus-tmp-level gnus-level-subscribed) ? ) - ((<= gnus-tmp-level gnus-level-unsubscribed) ?U) - ((= gnus-tmp-level gnus-level-zombie) ?Z) - (t ?K))) - (gnus-tmp-qualified-group (gnus-group-real-name gnus-tmp-group)) - (gnus-tmp-newsgroup-description - (if gnus-description-hashtb - (or (gnus-gethash gnus-tmp-group gnus-description-hashtb) "") - "")) - (gnus-tmp-moderated - (if (member gnus-tmp-group gnus-moderated-list) ?m ? )) - (gnus-tmp-moderated-string - (if (eq gnus-tmp-moderated ?m) "(m)" "")) - (gnus-tmp-method - (gnus-server-get-method gnus-tmp-group gnus-tmp-method)) - (gnus-tmp-news-server (or (cadr gnus-tmp-method) "")) - (gnus-tmp-news-method (or (car gnus-tmp-method) "")) - (gnus-tmp-news-method-string - (if gnus-tmp-method - (format "(%s:%s)" (car gnus-tmp-method) - (cadr gnus-tmp-method)) "")) - (gnus-tmp-marked-mark - (if (and (numberp number) - (zerop number) - (cdr (assq 'tick gnus-tmp-marked))) - ?* ? )) - (gnus-tmp-process-marked - (if (member gnus-tmp-group gnus-group-marked) - gnus-process-mark ? )) - (gnus-tmp-grouplens - (or (and gnus-use-grouplens - (bbb-grouplens-group-p gnus-tmp-group)) - "")) - (buffer-read-only nil) - header gnus-tmp-header) ; passed as parameter to user-funcs. - (beginning-of-line) - (gnus-add-text-properties - (point) - (prog1 (1+ (point)) - ;; Insert the text. - (eval gnus-group-line-format-spec)) - `(gnus-group ,(gnus-intern-safe gnus-tmp-group gnus-active-hashtb) - gnus-unread ,(if (numberp number) - (string-to-int gnus-tmp-number-of-unread) - t) - gnus-marked ,gnus-tmp-marked-mark - gnus-indentation ,gnus-group-indentation - gnus-level ,gnus-tmp-level)) - (when (inline (gnus-visual-p 'group-highlight 'highlight)) - (forward-line -1) - (run-hooks 'gnus-group-update-hook) - (forward-line)) - ;; Allow XEmacs to remove front-sticky text properties. - (gnus-group-remove-excess-properties))) - -(defun gnus-group-update-group (group &optional visible-only) - "Update all lines where GROUP appear. -If VISIBLE-ONLY is non-nil, the group won't be displayed if it isn't -already." - (save-excursion - (set-buffer gnus-group-buffer) - ;; 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-gethash group gnus-newsrc-hashtb))) - (if (and entry (not (gnus-ephemeral-group-p group))) - (gnus-dribble-enter - (concat "(gnus-group-set-info '" (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) - (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-gethash group gnus-newsrc-hashtb)))) - (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) - (run-hooks 'gnus-group-update-group-hook)))) - (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) - (let* ((gformat (or gnus-group-mode-line-format-spec - (setq gnus-group-mode-line-format-spec - (gnus-parse-format - gnus-group-mode-line-format - gnus-group-mode-line-format-alist)))) - (gnus-tmp-news-server (cadr gnus-select-method)) - (gnus-tmp-news-method (car gnus-select-method)) - (gnus-tmp-colon (if (equal gnus-tmp-news-server "") "" ":")) - (max-len 60) - gnus-tmp-header ;Dummy binding for user-defined formats - ;; Get the resulting string. - (modified - (and gnus-dribble-buffer - (buffer-name gnus-dribble-buffer) - (buffer-modified-p gnus-dribble-buffer) - (save-excursion - (set-buffer gnus-dribble-buffer) - (not (zerop (buffer-size)))))) - (mode-string (eval gformat))) - ;; Say whether the dribble buffer has been modified. - (setq mode-line-modified - (if modified "---*- " "----- ")) - ;; If the line is too long, we chop it off. - (when (> (length mode-string) max-len) - (setq mode-string (substring mode-string 0 (- max-len 4)))) - (prog1 - (setq mode-line-buffer-identification - (gnus-mode-line-buffer-identification - (list mode-string))) - (set-buffer-modified-p modified)))))) - -(defun gnus-group-group-name () - "Get the name of the newsgroup on the current line." - (let ((group (get-text-property (gnus-point-at-bol) 'gnus-group))) - (and group (symbol-name group)))) - -(defun gnus-group-group-level () - "Get the level of the newsgroup on the current line." - (get-text-property (gnus-point-at-bol) 'gnus-level)) - -(defun gnus-group-group-indentation () - "Get the indentation of the newsgroup on the current line." - (or (get-text-property (gnus-point-at-bol) 'gnus-indentation) - (and gnus-group-indentation-function - (funcall gnus-group-indentation-function)) - "")) - -(defun gnus-group-group-unread () - "Get the number of unread articles of the newsgroup on the current line." - (get-text-property (gnus-point-at-bol) 'gnus-unread)) - -(defun gnus-group-search-forward (&optional backward all level first-too) - "Find the next newsgroup with unread articles. -If BACKWARD is non-nil, find the previous newsgroup instead. -If ALL is non-nil, just find any newsgroup. -If LEVEL is non-nil, find group with level LEVEL, or higher if no such -group exists. -If FIRST-TOO, the current line is also eligible as a target." - (let ((way (if backward -1 1)) - (low gnus-level-killed) - (beg (point)) - pos found lev) - (if (and backward (progn (beginning-of-line)) (bobp)) - nil - (or first-too (forward-line way)) - (while (and - (not (eobp)) - (not (setq - found - (and (or all - (and - (let ((unread - (get-text-property (point) 'gnus-unread))) - (and (numberp unread) (> unread 0))) - (setq lev (get-text-property (point) - 'gnus-level)) - (<= lev gnus-level-subscribed))) - (or (not level) - (and (setq lev (get-text-property (point) - 'gnus-level)) - (or (= lev level) - (and (< lev low) - (< level lev) - (progn - (setq low lev) - (setq pos (point)) - nil)))))))) - (zerop (forward-line way))))) - (if found - (progn (gnus-group-position-point) t) - (goto-char (or pos beg)) - (and pos t)))) - -;;; Gnus group mode commands - -;; Group marking. - -(defun gnus-group-mark-group (n &optional unmark no-advance) - "Mark the current group." - (interactive "p") - (let ((buffer-read-only nil) - group) - (while (and (> n 0) - (not (eobp))) - (when (setq group (gnus-group-group-name)) - ;; Update the mark. - (beginning-of-line) - (forward-char - (or (cdr (assq 'process gnus-group-mark-positions)) 2)) - (delete-char 1) - (if unmark - (progn - (insert " ") - (setq gnus-group-marked (delete group gnus-group-marked))) - (insert "#") - (setq gnus-group-marked - (cons group (delete group gnus-group-marked))))) - (or no-advance (gnus-group-next-group 1)) - (decf n)) - (gnus-summary-position-point) - n)) - -(defun gnus-group-unmark-group (n) - "Remove the mark from the current group." - (interactive "p") - (gnus-group-mark-group n 'unmark) - (gnus-group-position-point)) - -(defun gnus-group-unmark-all-groups () - "Unmark all groups." - (interactive) - (let ((groups gnus-group-marked)) - (save-excursion - (while groups - (gnus-group-remove-mark (pop groups))))) - (gnus-group-position-point)) - -(defun gnus-group-mark-region (unmark beg end) - "Mark all groups between point and mark. -If UNMARK, remove the mark instead." - (interactive "P\nr") - (let ((num (count-lines beg end))) - (save-excursion - (goto-char beg) - (- num (gnus-group-mark-group num unmark))))) - -(defun gnus-group-mark-buffer (&optional unmark) - "Mark all groups in the buffer. -If UNMARK, remove the mark instead." - (interactive "P") - (gnus-group-mark-region unmark (point-min) (point-max))) - -(defun gnus-group-mark-regexp (regexp) - "Mark all groups that match some regexp." - (interactive "sMark (regexp): ") - (let ((alist (cdr gnus-newsrc-alist)) - group) - (while alist - (when (string-match regexp (setq group (gnus-info-group (pop alist)))) - (gnus-group-set-mark group)))) - (gnus-group-position-point)) - -(defun gnus-group-remove-mark (group) - "Remove the process mark from GROUP and move point there. -Return nil if the group isn't displayed." - (if (gnus-group-goto-group group) - (save-excursion - (gnus-group-mark-group 1 'unmark t) - t) - (setq gnus-group-marked - (delete group gnus-group-marked)) - nil)) - -(defun gnus-group-set-mark (group) - "Set the process mark on GROUP." - (if (gnus-group-goto-group group) - (save-excursion - (gnus-group-mark-group 1 nil t)) - (setq gnus-group-marked (cons group (delete group gnus-group-marked))))) - -(defun gnus-group-universal-argument (arg &optional groups func) - "Perform any command on all groups accoring to the process/prefix convention." - (interactive "P") - (let ((groups (or groups (gnus-group-process-prefix arg))) - group func) - (if (eq (setq func (or func - (key-binding - (read-key-sequence - (substitute-command-keys - "\\\\[gnus-group-universal-argument]"))))) - 'undefined) - (gnus-error 1 "Undefined key") - (while groups - (gnus-group-remove-mark (setq group (pop groups))) - (command-execute func)))) - (gnus-group-position-point)) - -(defun gnus-group-process-prefix (n) - "Return a list of groups to work on. -Take into consideration N (the prefix) and the list of marked groups." - (cond - (n - (setq n (prefix-numeric-value n)) - ;; There is a prefix, so we return a list of the N next - ;; groups. - (let ((way (if (< n 0) -1 1)) - (n (abs n)) - group groups) - (save-excursion - (while (and (> n 0) - (setq group (gnus-group-group-name))) - (setq groups (cons group groups)) - (setq n (1- n)) - (gnus-group-next-group way))) - (nreverse groups))) - ((and (boundp 'transient-mark-mode) - transient-mark-mode - (boundp 'mark-active) - mark-active) - ;; Work on the region between point and mark. - (let ((max (max (point) (mark))) - groups) - (save-excursion - (goto-char (min (point) (mark))) - (while - (and - (push (gnus-group-group-name) groups) - (zerop (gnus-group-next-group 1)) - (< (point) max))) - (nreverse groups)))) - (gnus-group-marked - ;; No prefix, but a list of marked articles. - (reverse gnus-group-marked)) - (t - ;; Neither marked articles or a prefix, so we return the - ;; current group. - (let ((group (gnus-group-group-name))) - (and group (list group)))))) - -;; Selecting groups. - -(defun gnus-group-read-group (&optional all no-article group) - "Read news in this newsgroup. -If the prefix argument ALL is non-nil, already read articles become -readable. IF ALL is a number, fetch this number of articles. If the -optional argument NO-ARTICLE is non-nil, no article will be -auto-selected upon group entry. If GROUP is non-nil, fetch that -group." - (interactive "P") - (let ((group (or group (gnus-group-group-name))) - number active marked entry) - (or group (error "No group on current line")) - (setq marked (nth 3 (nth 2 (setq entry (gnus-gethash - group gnus-newsrc-hashtb))))) - ;; This group might be a dead group. In that case we have to get - ;; the number of unread articles from `gnus-active-hashtb'. - (setq number - (cond ((numberp all) all) - (entry (car entry)) - ((setq active (gnus-active group)) - (- (1+ (cdr active)) (car active))))) - (gnus-summary-read-group - group (or all (and (numberp number) - (zerop (+ number (gnus-range-length - (cdr (assq 'tick marked))) - (gnus-range-length - (cdr (assq 'dormant marked))))))) - no-article))) - -(defun gnus-group-select-group (&optional all) - "Select this newsgroup. -No article is selected automatically. -If ALL is non-nil, already read articles become readable. -If ALL is a number, fetch this number of articles." - (interactive "P") - (gnus-group-read-group all t)) - -(defun gnus-group-quick-select-group (&optional all) - "Select the current group \"quickly\". -This means that no highlighting or scoring will be performed." - (interactive "P") - (let (gnus-visual - gnus-score-find-score-files-function - gnus-apply-kill-hook - gnus-summary-expunge-below) - (gnus-group-read-group all t))) - -(defun gnus-group-visible-select-group (&optional all) - "Select the current group without hiding any articles." - (interactive "P") - (let ((gnus-inhibit-limiting t)) - (gnus-group-read-group all t))) - -;;;###autoload -(defun gnus-fetch-group (group) - "Start Gnus if necessary and enter GROUP. -Returns whether the fetching was successful or not." - (interactive "sGroup name: ") - (or (get-buffer gnus-group-buffer) - (gnus)) - (gnus-group-read-group nil nil group)) - -;; Enter a group that is not in the group buffer. Non-nil is returned -;; if selection was successful. -(defun gnus-group-read-ephemeral-group - (group method &optional activate quit-config) - (let ((group (if (gnus-group-foreign-p group) group - (gnus-group-prefixed-name group method)))) - (gnus-sethash - group - `(t nil (,group ,gnus-level-default-subscribed nil nil ,method - ((quit-config . ,(if quit-config quit-config - (cons (current-buffer) 'summary)))))) - gnus-newsrc-hashtb) - (set-buffer gnus-group-buffer) - (or (gnus-check-server method) - (error "Unable to contact server: %s" (gnus-status-message method))) - (if activate (or (gnus-request-group group) - (error "Couldn't request group"))) - (condition-case () - (gnus-group-read-group t t group) - (error nil) - (quit nil)))) - -(defun gnus-group-jump-to-group (group) - "Jump to newsgroup GROUP." - (interactive - (list (completing-read - "Group: " gnus-active-hashtb nil - (gnus-read-active-file-p) - nil - 'gnus-group-history))) - - (when (equal group "") - (error "Empty group name")) - - (when (string-match "[\000-\032]" group) - (error "Control characters in group: %s" group)) - - (let ((b (text-property-any - (point-min) (point-max) - 'gnus-group (gnus-intern-safe group gnus-active-hashtb)))) - (unless (gnus-ephemeral-group-p group) - (if b - ;; Either go to the line in the group buffer... - (goto-char b) - ;; ... or insert the line. - (or - t ;; Don't activate group. - (gnus-active group) - (gnus-activate-group group) - (error "%s error: %s" group (gnus-status-message group))) - - (gnus-group-update-group group) - (goto-char (text-property-any - (point-min) (point-max) - 'gnus-group (gnus-intern-safe group gnus-active-hashtb))))) - ;; Adjust cursor point. - (gnus-group-position-point))) - -(defun gnus-group-goto-group (group) - "Goto to newsgroup GROUP." - (when group - ;; It's quite likely that we are on the right line, so - ;; we check the current line first. - (beginning-of-line) - (if (eq (get-text-property (point) 'gnus-group) - (gnus-intern-safe group gnus-active-hashtb)) - (point) - ;; Search through the entire buffer. - (let ((b (text-property-any - (point-min) (point-max) - 'gnus-group (gnus-intern-safe group gnus-active-hashtb)))) - (when b - (goto-char b)))))) - -(defun gnus-group-next-group (n &optional silent) - "Go to next N'th newsgroup. -If N is negative, search backward instead. -Returns the difference between N and the number of skips actually -done." - (interactive "p") - (gnus-group-next-unread-group n t nil silent)) - -(defun gnus-group-next-unread-group (n &optional all level silent) - "Go to next N'th unread newsgroup. -If N is negative, search backward instead. -If ALL is non-nil, choose any newsgroup, unread or not. -If LEVEL is non-nil, choose the next group with level LEVEL, or, if no -such group can be found, the next group with a level higher than -LEVEL. -Returns the difference between N and the number of skips actually -made." - (interactive "p") - (let ((backward (< n 0)) - (n (abs n))) - (while (and (> n 0) - (gnus-group-search-forward - backward (or (not gnus-group-goto-unread) all) level)) - (setq n (1- n))) - (when (and (/= 0 n) - (not silent)) - (gnus-message 7 "No more%s newsgroups%s" (if all "" " unread") - (if level " on this level or higher" ""))) - n)) - -(defun gnus-group-prev-group (n) - "Go to previous N'th newsgroup. -Returns the difference between N and the number of skips actually -done." - (interactive "p") - (gnus-group-next-unread-group (- n) t)) - -(defun gnus-group-prev-unread-group (n) - "Go to previous N'th unread newsgroup. -Returns the difference between N and the number of skips actually -done." - (interactive "p") - (gnus-group-next-unread-group (- n))) - -(defun gnus-group-next-unread-group-same-level (n) - "Go to next N'th unread newsgroup on the same level. -If N is negative, search backward instead. -Returns the difference between N and the number of skips actually -done." - (interactive "p") - (gnus-group-next-unread-group n t (gnus-group-group-level)) - (gnus-group-position-point)) - -(defun gnus-group-prev-unread-group-same-level (n) - "Go to next N'th unread newsgroup on the same level. -Returns the difference between N and the number of skips actually -done." - (interactive "p") - (gnus-group-next-unread-group (- n) t (gnus-group-group-level)) - (gnus-group-position-point)) - -(defun gnus-group-best-unread-group (&optional exclude-group) - "Go to the group with the highest level. -If EXCLUDE-GROUP, do not go to that group." - (interactive) - (goto-char (point-min)) - (let ((best 100000) - unread best-point) - (while (not (eobp)) - (setq unread (get-text-property (point) 'gnus-unread)) - (if (and (numberp unread) (> unread 0)) - (progn - (if (and (get-text-property (point) 'gnus-level) - (< (get-text-property (point) 'gnus-level) best) - (or (not exclude-group) - (not (equal exclude-group (gnus-group-group-name))))) - (progn - (setq best (get-text-property (point) 'gnus-level)) - (setq best-point (point)))))) - (forward-line 1)) - (if best-point (goto-char best-point)) - (gnus-summary-position-point) - (and best-point (gnus-group-group-name)))) - -(defun gnus-group-first-unread-group () - "Go to the first group with unread articles." - (interactive) - (prog1 - (let ((opoint (point)) - unread) - (goto-char (point-min)) - (if (or (eq (setq unread (gnus-group-group-unread)) t) ; Not active. - (and (numberp unread) ; Not a topic. - (not (zerop unread))) ; Has unread articles. - (zerop (gnus-group-next-unread-group 1))) ; Next unread group. - (point) ; Success. - (goto-char opoint) - nil)) ; Not success. - (gnus-group-position-point))) - -(defun gnus-group-enter-server-mode () - "Jump to the server buffer." - (interactive) - (gnus-enter-server-buffer)) - -(defun gnus-group-make-group (name &optional method address) - "Add a new newsgroup. -The user will be prompted for a NAME, for a select METHOD, and an -ADDRESS." - (interactive - (cons - (read-string "Group name: ") - (let ((method - (completing-read - "Method: " (append gnus-valid-select-methods gnus-server-alist) - nil t nil 'gnus-method-history))) - (cond - ((equal method "") - (setq method gnus-select-method)) - ((assoc method gnus-valid-select-methods) - (list method - (if (memq 'prompt-address - (assoc method gnus-valid-select-methods)) - (read-string "Address: ") - ""))) - ((assoc method gnus-server-alist) - (list method)) - (t - (list method "")))))) - - (let* ((meth (when (and method - (not (gnus-server-equal method gnus-select-method))) - (if address (list (intern method) address) - method))) - (nname (if method (gnus-group-prefixed-name name meth) name)) - backend info) - (when (gnus-gethash nname gnus-newsrc-hashtb) - (error "Group %s already exists" nname)) - ;; Subscribe to the new group. - (gnus-group-change-level - (setq info (list t nname gnus-level-default-subscribed nil nil meth)) - gnus-level-default-subscribed gnus-level-killed - (and (gnus-group-group-name) - (gnus-gethash (gnus-group-group-name) - gnus-newsrc-hashtb)) - t) - ;; Make it active. - (gnus-set-active nname (cons 1 0)) - (or (gnus-ephemeral-group-p name) - (gnus-dribble-enter - (concat "(gnus-group-set-info '" (prin1-to-string (cdr info)) ")"))) - ;; Insert the line. - (gnus-group-insert-group-line-info nname) - (forward-line -1) - (gnus-group-position-point) - - ;; Load the backend and try to make the backend create - ;; the group as well. - (when (assoc (symbol-name (setq backend (car (gnus-server-get-method - nil meth)))) - gnus-valid-select-methods) - (require backend)) - (gnus-check-server meth) - (and (gnus-check-backend-function 'request-create-group nname) - (gnus-request-create-group nname)) - t)) - -(defun gnus-group-delete-group (group &optional force) - "Delete the current group. Only meaningful with mail groups. -If FORCE (the prefix) is non-nil, all the articles in the group will -be deleted. This is \"deleted\" as in \"removed forever from the face -of the Earth\". There is no undo. The user will be prompted before -doing the deletion." - (interactive - (list (gnus-group-group-name) - current-prefix-arg)) - (or group (error "No group to rename")) - (or (gnus-check-backend-function 'request-delete-group group) - (error "This backend does not support group deletion")) - (prog1 - (if (not (gnus-yes-or-no-p - (format - "Do you really want to delete %s%s? " - group (if force " and all its contents" "")))) - () ; Whew! - (gnus-message 6 "Deleting group %s..." group) - (if (not (gnus-request-delete-group group force)) - (gnus-error 3 "Couldn't delete group %s" group) - (gnus-message 6 "Deleting group %s...done" group) - (gnus-group-goto-group group) - (gnus-group-kill-group 1 t) - (gnus-sethash group nil gnus-active-hashtb) - t)) - (gnus-group-position-point))) - -(defun gnus-group-rename-group (group new-name) - (interactive - (list - (gnus-group-group-name) - (progn - (or (gnus-check-backend-function - 'request-rename-group (gnus-group-group-name)) - (error "This backend does not support renaming groups")) - (read-string "New group name: ")))) - - (or (gnus-check-backend-function 'request-rename-group group) - (error "This backend does not support renaming groups")) - - (or group (error "No group to rename")) - (and (string-match "^[ \t]*$" new-name) - (error "Not a valid group name")) - - ;; We find the proper prefixed name. - (setq new-name - (if (equal (gnus-group-real-name new-name) new-name) - ;; Native group. - new-name - ;; Foreign group. - (gnus-group-prefixed-name - (gnus-group-real-name new-name) - (gnus-info-method (gnus-get-info group))))) - - (gnus-message 6 "Renaming group %s to %s..." group new-name) - (prog1 - (if (not (gnus-request-rename-group group new-name)) - (gnus-error 3 "Couldn't rename group %s to %s" group new-name) - ;; We rename the group internally by killing it... - (gnus-group-goto-group group) - (gnus-group-kill-group) - ;; ... changing its name ... - (setcar (cdar gnus-list-of-killed-groups) new-name) - ;; ... and then yanking it. Magic! - (gnus-group-yank-group) - (gnus-set-active new-name (gnus-active group)) - (gnus-message 6 "Renaming group %s to %s...done" group new-name) - new-name) - (gnus-group-position-point))) - -(defun gnus-group-edit-group (group &optional part) - "Edit the group on the current line." - (interactive (list (gnus-group-group-name))) - (let* ((part (or part 'info)) - (done-func `(lambda () - "Exit editing mode and update the information." - (interactive) - (gnus-group-edit-group-done ',part ,group))) - (winconf (current-window-configuration)) - info) - (or group (error "No group on current line")) - (or (setq info (gnus-get-info group)) - (error "Killed group; can't be edited")) - (set-buffer (setq gnus-group-edit-buffer - (get-buffer-create - (format "*Gnus edit %s*" group)))) - (gnus-configure-windows 'edit-group) - (gnus-add-current-to-buffer-list) - (emacs-lisp-mode) - ;; Suggested by Hallvard B Furuseth . - (use-local-map (copy-keymap emacs-lisp-mode-map)) - (local-set-key "\C-c\C-c" done-func) - (make-local-variable 'gnus-prev-winconf) - (setq gnus-prev-winconf winconf) - (erase-buffer) - (insert - (cond - ((eq part 'method) - ";; Type `C-c C-c' after editing the select method.\n\n") - ((eq part 'params) - ";; Type `C-c C-c' after editing the group parameters.\n\n") - ((eq part 'info) - ";; Type `C-c C-c' after editing the group info.\n\n"))) - (insert - (pp-to-string - (cond ((eq part 'method) - (or (gnus-info-method info) "native")) - ((eq part 'params) - (gnus-info-params info)) - (t info))) - "\n"))) - -(defun gnus-group-edit-group-method (group) - "Edit the select method of GROUP." - (interactive (list (gnus-group-group-name))) - (gnus-group-edit-group group 'method)) - -(defun gnus-group-edit-group-parameters (group) - "Edit the group parameters of GROUP." - (interactive (list (gnus-group-group-name))) - (gnus-group-edit-group group 'params)) - -(defun gnus-group-edit-group-done (part group) - "Get info from buffer, update variables and jump to the group buffer." - (when (and gnus-group-edit-buffer - (buffer-name gnus-group-edit-buffer)) - (set-buffer gnus-group-edit-buffer) - (goto-char (point-min)) - (let* ((form (read (current-buffer))) - (winconf gnus-prev-winconf) - (method (cond ((eq part 'info) (nth 4 form)) - ((eq part 'method) form) - (t nil))) - (info (cond ((eq part 'info) form) - ((eq part 'method) (gnus-get-info group)) - (t nil))) - (new-group (if info - (if (or (not method) - (gnus-server-equal - gnus-select-method method)) - (gnus-group-real-name (car info)) - (gnus-group-prefixed-name - (gnus-group-real-name (car info)) method)) - nil))) - (when (and new-group - (not (equal new-group group))) - (when (gnus-group-goto-group group) - (gnus-group-kill-group 1)) - (gnus-activate-group new-group)) - ;; Set the info. - (if (and info new-group) - (progn - (setq info (gnus-copy-sequence info)) - (setcar info new-group) - (unless (gnus-server-equal method "native") - (unless (nthcdr 3 info) - (nconc info (list nil nil))) - (unless (nthcdr 4 info) - (nconc info (list nil))) - (gnus-info-set-method info method)) - (gnus-group-set-info info)) - (gnus-group-set-info form (or new-group group) part)) - (kill-buffer (current-buffer)) - (and winconf (set-window-configuration winconf)) - (set-buffer gnus-group-buffer) - (gnus-group-update-group (or new-group group)) - (gnus-group-position-point)))) - -(defun gnus-group-make-help-group () - "Create the Gnus documentation group." - (interactive) - (let ((path load-path) - (name (gnus-group-prefixed-name "gnus-help" '(nndoc "gnus-help"))) - file dir) - (and (gnus-gethash name gnus-newsrc-hashtb) - (error "Documentation group already exists")) - (while path - (setq dir (file-name-as-directory (expand-file-name (pop path))) - file nil) - (when (or (file-exists-p (setq file (concat dir "gnus-tut.txt"))) - (file-exists-p - (setq file (concat (file-name-directory - (directory-file-name dir)) - "etc/gnus-tut.txt")))) - (setq path nil))) - (if (not file) - (gnus-message 1 "Couldn't find doc group") - (gnus-group-make-group - (gnus-group-real-name name) - (list 'nndoc "gnus-help" - (list 'nndoc-address file) - (list 'nndoc-article-type 'mbox))))) - (gnus-group-position-point)) - -(defun gnus-group-make-doc-group (file type) - "Create a group that uses a single file as the source." - (interactive - (list (read-file-name "File name: ") - (and current-prefix-arg 'ask))) - (when (eq type 'ask) - (let ((err "") - char found) - (while (not found) - (message - "%sFile type (mbox, babyl, digest, forward, mmfd, guess) [mbdfag]: " - err) - (setq found (cond ((= (setq char (read-char)) ?m) 'mbox) - ((= char ?b) 'babyl) - ((= char ?d) 'digest) - ((= char ?f) 'forward) - ((= char ?a) 'mmfd) - (t (setq err (format "%c unknown. " char)) - nil)))) - (setq type found))) - (let* ((file (expand-file-name file)) - (name (gnus-generate-new-group-name - (gnus-group-prefixed-name - (file-name-nondirectory file) '(nndoc ""))))) - (gnus-group-make-group - (gnus-group-real-name name) - (list 'nndoc (file-name-nondirectory file) - (list 'nndoc-address file) - (list 'nndoc-article-type (or type 'guess)))))) - -(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." - (interactive "P") - (let ((group (gnus-group-prefixed-name - (if all "ding.archives" "ding.recent") '(nndir "")))) - (when (gnus-gethash group gnus-newsrc-hashtb) - (error "Archive group already exists")) - (gnus-group-make-group - (gnus-group-real-name group) - (list 'nndir (if all "hpc" "edu") - (list 'nndir-directory - (if all gnus-group-archive-directory - gnus-group-recent-archive-directory)))) - (gnus-group-add-parameter group (cons 'to-address "ding@ifi.uio.no")))) - -(defun gnus-group-make-directory-group (dir) - "Create an nndir group. -The user will be prompted for a directory. The contents of this -directory will be used as a newsgroup. The directory should contain -mail messages or news articles in files that have numeric names." - (interactive - (list (read-file-name "Create group from directory: "))) - (or (file-exists-p dir) (error "No such directory")) - (or (file-directory-p dir) (error "Not a directory")) - (let ((ext "") - (i 0) - group) - (while (or (not group) (gnus-gethash group gnus-newsrc-hashtb)) - (setq group - (gnus-group-prefixed-name - (concat (file-name-as-directory (directory-file-name dir)) - ext) - '(nndir ""))) - (setq ext (format "<%d>" (setq i (1+ i))))) - (gnus-group-make-group - (gnus-group-real-name group) - (list 'nndir (gnus-group-real-name group) (list 'nndir-directory dir))))) - -(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 (lambda (group) (list group)) - '("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 (string): " - header))))) - (setq regexps (cons (list regexp nil nil 'r) regexps))) - (setq scores (cons (cons header regexps) scores))) - scores))) - (gnus-group-make-group group "nnkiboze" address) - (nnheader-temp-write (gnus-score-file-name (concat "nnkiboze:" group)) - (let (emacs-lisp-mode-hook) - (pp scores (current-buffer))))) - -(defun gnus-group-add-to-virtual (n vgroup) - "Add the current group to a virtual group." - (interactive - (list current-prefix-arg - (completing-read "Add to virtual group: " gnus-newsrc-hashtb nil t - "nnvirtual:"))) - (or (eq (car (gnus-find-method-for-group vgroup)) 'nnvirtual) - (error "%s is not an nnvirtual group" vgroup)) - (let* ((groups (gnus-group-process-prefix n)) - (method (gnus-info-method (gnus-get-info vgroup)))) - (setcar (cdr method) - (concat - (nth 1 method) "\\|" - (mapconcat - (lambda (s) - (gnus-group-remove-mark s) - (concat "\\(^" (regexp-quote s) "$\\)")) - groups "\\|")))) - (gnus-group-position-point)) - -(defun gnus-group-make-empty-virtual (group) - "Create a new, fresh, empty virtual group." - (interactive "sCreate new, empty virtual group: ") - (let* ((method (list 'nnvirtual "^$")) - (pgroup (gnus-group-prefixed-name group method))) - ;; Check whether it exists already. - (and (gnus-gethash pgroup gnus-newsrc-hashtb) - (error "Group %s already exists." pgroup)) - ;; Subscribe the new group after the group on the current line. - (gnus-subscribe-group pgroup (gnus-group-group-name) method) - (gnus-group-update-group pgroup) - (forward-line -1) - (gnus-group-position-point))) - -(defun gnus-group-enter-directory (dir) - "Enter an ephemeral nneething group." - (interactive "DDirectory to read: ") - (let* ((method (list 'nneething dir '(nneething-read-only t))) - (leaf (gnus-group-prefixed-name - (file-name-nondirectory (directory-file-name dir)) - method)) - (name (gnus-generate-new-group-name leaf))) - (unless (gnus-group-read-ephemeral-group - name method t - (cons (current-buffer) - (if (eq major-mode 'gnus-summary-mode) - 'summary 'group))) - (error "Couldn't enter %s" dir)))) - -;; Group sorting commands -;; Suggested by Joe Hildebrand . - -(defun gnus-group-sort-groups (func &optional reverse) - "Sort the group buffer according to FUNC. -If REVERSE, reverse the sorting order." - (interactive (list gnus-group-sort-function - current-prefix-arg)) - (let ((func (cond - ((not (listp func)) func) - ((null func) func) - ((= 1 (length func)) (car func)) - (t `(lambda (t1 t2) - ,(gnus-make-sort-function - (reverse func))))))) - ;; We peel off the dummy group from the alist. - (when func - (when (equal (car (gnus-info-group gnus-newsrc-alist)) "dummy.group") - (pop gnus-newsrc-alist)) - ;; Do the sorting. - (setq gnus-newsrc-alist - (sort gnus-newsrc-alist func)) - (when reverse - (setq gnus-newsrc-alist (nreverse gnus-newsrc-alist))) - ;; Regenerate the hash table. - (gnus-make-hashtable-from-newsrc-alist) - (gnus-group-list-groups)))) - -(defun gnus-group-sort-groups-by-alphabet (&optional reverse) - "Sort the group buffer alphabetically by group name. -If REVERSE, sort in reverse order." - (interactive "P") - (gnus-group-sort-groups 'gnus-group-sort-by-alphabet reverse)) - -(defun gnus-group-sort-groups-by-unread (&optional reverse) - "Sort the group buffer by number of unread articles. -If REVERSE, sort in reverse order." - (interactive "P") - (gnus-group-sort-groups 'gnus-group-sort-by-unread reverse)) - -(defun gnus-group-sort-groups-by-level (&optional reverse) - "Sort the group buffer by group level. -If REVERSE, sort in reverse order." - (interactive "P") - (gnus-group-sort-groups 'gnus-group-sort-by-level reverse)) - -(defun gnus-group-sort-groups-by-score (&optional reverse) - "Sort the group buffer by group score. -If REVERSE, sort in reverse order." - (interactive "P") - (gnus-group-sort-groups 'gnus-group-sort-by-score reverse)) - -(defun gnus-group-sort-groups-by-rank (&optional reverse) - "Sort the group buffer by group rank. -If REVERSE, sort in reverse order." - (interactive "P") - (gnus-group-sort-groups 'gnus-group-sort-by-rank reverse)) - -(defun gnus-group-sort-groups-by-method (&optional reverse) - "Sort the group buffer alphabetically by backend name. -If REVERSE, sort in reverse order." - (interactive "P") - (gnus-group-sort-groups 'gnus-group-sort-by-method reverse)) - -(defun gnus-group-sort-by-alphabet (info1 info2) - "Sort alphabetically." - (string< (gnus-info-group info1) (gnus-info-group info2))) - -(defun gnus-group-sort-by-unread (info1 info2) - "Sort by number of unread articles." - (let ((n1 (car (gnus-gethash (gnus-info-group info1) gnus-newsrc-hashtb))) - (n2 (car (gnus-gethash (gnus-info-group info2) gnus-newsrc-hashtb)))) - (< (or (and (numberp n1) n1) 0) - (or (and (numberp n2) n2) 0)))) - -(defun gnus-group-sort-by-level (info1 info2) - "Sort by level." - (< (gnus-info-level info1) (gnus-info-level info2))) - -(defun gnus-group-sort-by-method (info1 info2) - "Sort alphabetically by backend name." - (string< (symbol-name (car (gnus-find-method-for-group - (gnus-info-group info1) info1))) - (symbol-name (car (gnus-find-method-for-group - (gnus-info-group info2) info2))))) - -(defun gnus-group-sort-by-score (info1 info2) - "Sort by group score." - (< (gnus-info-score info1) (gnus-info-score info2))) - -(defun gnus-group-sort-by-rank (info1 info2) - "Sort by level and score." - (let ((level1 (gnus-info-level info1)) - (level2 (gnus-info-level info2))) - (or (< level1 level2) - (and (= level1 level2) - (> (gnus-info-score info1) (gnus-info-score info2)))))) - -;; Group catching up. - -(defun gnus-group-clear-data (n) - "Clear all marks and read ranges from the current group." - (interactive "P") - (let ((groups (gnus-group-process-prefix n)) - group info) - (while (setq group (pop groups)) - (setq info (gnus-get-info group)) - (gnus-info-set-read info nil) - (when (gnus-info-marks info) - (gnus-info-set-marks info nil)) - (gnus-get-unread-articles-in-group info (gnus-active group) t) - (when (gnus-group-goto-group group) - (gnus-group-remove-mark group) - (gnus-group-update-group-line))))) - -(defun gnus-group-catchup-current (&optional n all) - "Mark all articles not marked as unread in current newsgroup as read. -If prefix argument N is numeric, the ARG next newsgroups will be -caught up. If ALL is non-nil, marked articles will also be marked as -read. Cross references (Xref: header) of articles are ignored. -The difference between N and actual number of newsgroups that were -caught up is returned." - (interactive "P") - (unless (gnus-group-group-name) - (error "No group on the current line")) - (if (not (or (not gnus-interactive-catchup) ;Without confirmation? - gnus-expert-user - (gnus-y-or-n-p - (if all - "Do you really want to mark all articles as read? " - "Mark all unread articles as read? ")))) - n - (let ((groups (gnus-group-process-prefix n)) - (ret 0)) - (while groups - ;; Virtual groups have to be given special treatment. - (let ((method (gnus-find-method-for-group (car groups)))) - (if (eq 'nnvirtual (car method)) - (nnvirtual-catchup-group - (gnus-group-real-name (car groups)) (nth 1 method) all))) - (gnus-group-remove-mark (car groups)) - (if (>= (gnus-group-group-level) gnus-level-zombie) - (gnus-message 2 "Dead groups can't be caught up") - (if (prog1 - (gnus-group-goto-group (car groups)) - (gnus-group-catchup (car groups) all)) - (gnus-group-update-group-line) - (setq ret (1+ ret)))) - (setq groups (cdr groups))) - (gnus-group-next-unread-group 1) - ret))) - -(defun gnus-group-catchup-current-all (&optional n) - "Mark all articles in current newsgroup as read. -Cross references (Xref: header) of articles are ignored." - (interactive "P") - (gnus-group-catchup-current n 'all)) - -(defun gnus-group-catchup (group &optional all) - "Mark all articles in GROUP as read. -If ALL is non-nil, all articles are marked as read. -The return value is the number of articles that were marked as read, -or nil if no action could be taken." - (let* ((entry (gnus-gethash group gnus-newsrc-hashtb)) - (num (car entry))) - ;; Do the updating only if the newsgroup isn't killed. - (if (not (numberp (car entry))) - (gnus-message 1 "Can't catch up; non-active group") - ;; Do auto-expirable marks if that's required. - (when (gnus-group-auto-expirable-p group) - (gnus-add-marked-articles - group 'expire (gnus-list-of-unread-articles group)) - (when all - (let ((marks (nth 3 (nth 2 entry)))) - (gnus-add-marked-articles - group 'expire (gnus-uncompress-range (cdr (assq 'tick marks)))) - (gnus-add-marked-articles - group 'expire (gnus-uncompress-range (cdr (assq 'tick marks))))))) - (when entry - (gnus-update-read-articles group nil) - ;; Also nix out the lists of marks and dormants. - (when all - (gnus-add-marked-articles group 'tick nil nil 'force) - (gnus-add-marked-articles group 'dormant nil nil 'force)) - (run-hooks 'gnus-group-catchup-group-hook) - num)))) - -(defun gnus-group-expire-articles (&optional n) - "Expire all expirable articles in the current newsgroup." - (interactive "P") - (let ((groups (gnus-group-process-prefix n)) - group) - (unless groups - (error "No groups to expire")) - (while (setq group (pop groups)) - (gnus-group-remove-mark group) - (when (gnus-check-backend-function 'request-expire-articles group) - (gnus-message 6 "Expiring articles in %s..." group) - (let* ((info (gnus-get-info group)) - (expirable (if (gnus-group-total-expirable-p group) - (cons nil (gnus-list-of-read-articles group)) - (assq 'expire (gnus-info-marks info)))) - (expiry-wait (gnus-group-get-parameter group 'expiry-wait))) - (when expirable - (setcdr - expirable - (gnus-compress-sequence - (if expiry-wait - ;; We set the expiry variables to the groupp - ;; parameter. - (let ((nnmail-expiry-wait-function nil) - (nnmail-expiry-wait expiry-wait)) - (gnus-request-expire-articles - (gnus-uncompress-sequence (cdr expirable)) group)) - ;; Just expire using the normal expiry values. - (gnus-request-expire-articles - (gnus-uncompress-sequence (cdr expirable)) group)))) - (gnus-close-group group)) - (gnus-message 6 "Expiring articles in %s...done" group))) - (gnus-group-position-point)))) - -(defun gnus-group-expire-all-groups () - "Expire all expirable articles in all newsgroups." - (interactive) - (save-excursion - (gnus-message 5 "Expiring...") - (let ((gnus-group-marked (mapcar (lambda (info) (gnus-info-group info)) - (cdr gnus-newsrc-alist)))) - (gnus-group-expire-articles nil))) - (gnus-group-position-point) - (gnus-message 5 "Expiring...done")) - -(defun gnus-group-set-current-level (n level) - "Set the level of the next N groups to LEVEL." - (interactive - (list - current-prefix-arg - (string-to-int - (let ((s (read-string - (format "Level (default %s): " - (or (gnus-group-group-level) - gnus-level-default-subscribed))))) - (if (string-match "^\\s-*$" s) - (int-to-string (or (gnus-group-group-level) - gnus-level-default-subscribed)) - s))))) - (or (and (>= level 1) (<= level gnus-level-killed)) - (error "Illegal level: %d" level)) - (let ((groups (gnus-group-process-prefix n)) - group) - (while (setq group (pop groups)) - (gnus-group-remove-mark group) - (gnus-message 6 "Changed level of %s from %d to %d" - group (or (gnus-group-group-level) gnus-level-killed) - level) - (gnus-group-change-level - group level (or (gnus-group-group-level) gnus-level-killed)) - (gnus-group-update-group-line))) - (gnus-group-position-point)) - -(defun gnus-group-unsubscribe-current-group (&optional n) - "Toggle subscription of the current group. -If given numerical prefix, toggle the N next groups." - (interactive "P") - (let ((groups (gnus-group-process-prefix n)) - group) - (while groups - (setq group (car groups) - groups (cdr groups)) - (gnus-group-remove-mark group) - (gnus-group-unsubscribe-group - group (if (<= (gnus-group-group-level) gnus-level-subscribed) - gnus-level-default-unsubscribed - gnus-level-default-subscribed) t) - (gnus-group-update-group-line)) - (gnus-group-next-group 1))) - -(defun gnus-group-unsubscribe-group (group &optional level silent) - "Toggle subscription to GROUP. -Killed newsgroups are subscribed. If SILENT, don't try to update the -group line." - (interactive - (list (completing-read - "Group: " gnus-active-hashtb nil - (gnus-read-active-file-p) - nil - 'gnus-group-history))) - (let ((newsrc (gnus-gethash group gnus-newsrc-hashtb))) - (cond - ((string-match "^[ \t]$" group) - (error "Empty group name")) - (newsrc - ;; Toggle subscription flag. - (gnus-group-change-level - newsrc (if level level (if (<= (nth 1 (nth 2 newsrc)) - gnus-level-subscribed) - (1+ gnus-level-subscribed) - gnus-level-default-subscribed))) - (unless silent - (gnus-group-update-group group))) - ((and (stringp group) - (or (not (gnus-read-active-file-p)) - (gnus-active group))) - ;; Add new newsgroup. - (gnus-group-change-level - group - (if level level gnus-level-default-subscribed) - (or (and (member group gnus-zombie-list) - gnus-level-zombie) - gnus-level-killed) - (and (gnus-group-group-name) - (gnus-gethash (gnus-group-group-name) gnus-newsrc-hashtb))) - (unless silent - (gnus-group-update-group group))) - (t (error "No such newsgroup: %s" group))) - (gnus-group-position-point))) - -(defun gnus-group-transpose-groups (n) - "Move the current newsgroup up N places. -If given a negative prefix, move down instead. The difference between -N and the number of steps taken is returned." - (interactive "p") - (or (gnus-group-group-name) - (error "No group on current line")) - (gnus-group-kill-group 1) - (prog1 - (forward-line (- n)) - (gnus-group-yank-group) - (gnus-group-position-point))) - -(defun gnus-group-kill-all-zombies () - "Kill all zombie newsgroups." - (interactive) - (setq gnus-killed-list (nconc gnus-zombie-list gnus-killed-list)) - (setq gnus-zombie-list nil) - (gnus-group-list-groups)) - -(defun gnus-group-kill-region (begin end) - "Kill newsgroups in current region (excluding current point). -The killed newsgroups can be yanked by using \\[gnus-group-yank-group]." - (interactive "r") - (let ((lines - ;; Count lines. - (save-excursion - (count-lines - (progn - (goto-char begin) - (beginning-of-line) - (point)) - (progn - (goto-char end) - (beginning-of-line) - (point)))))) - (goto-char begin) - (beginning-of-line) ;Important when LINES < 1 - (gnus-group-kill-group lines))) - -(defun gnus-group-kill-group (&optional n discard) - "Kill the next N groups. -The killed newsgroups can be yanked by using \\[gnus-group-yank-group]. -However, only groups that were alive can be yanked; already killed -groups or zombie groups can't be yanked. -The return value is the name of the group that was killed, or a list -of groups killed." - (interactive "P") - (let ((buffer-read-only nil) - (groups (gnus-group-process-prefix n)) - group entry level out) - (if (< (length groups) 10) - ;; This is faster when there are few groups. - (while groups - (push (setq group (pop groups)) out) - (gnus-group-remove-mark group) - (setq level (gnus-group-group-level)) - (gnus-delete-line) - (when (and (not discard) - (setq entry (gnus-gethash group gnus-newsrc-hashtb))) - (push (cons (car entry) (nth 2 entry)) - gnus-list-of-killed-groups)) - (gnus-group-change-level - (if entry entry group) gnus-level-killed (if entry nil level))) - ;; If there are lots and lots of groups to be killed, we use - ;; this thing instead. - (let (entry) - (setq groups (nreverse groups)) - (while groups - (gnus-group-remove-mark (setq group (pop groups))) - (gnus-delete-line) - (push group gnus-killed-list) - (setq gnus-newsrc-alist - (delq (assoc group gnus-newsrc-alist) - gnus-newsrc-alist)) - (when gnus-group-change-level-function - (funcall gnus-group-change-level-function group 9 3)) - (cond - ((setq entry (gnus-gethash group gnus-newsrc-hashtb)) - (push (cons (car entry) (nth 2 entry)) - gnus-list-of-killed-groups) - (setcdr (cdr entry) (cdddr entry))) - ((member group gnus-zombie-list) - (setq gnus-zombie-list (delete group gnus-zombie-list))))) - (gnus-make-hashtable-from-newsrc-alist))) - - (gnus-group-position-point) - (if (< (length out) 2) (car out) (nreverse out)))) - -(defun gnus-group-yank-group (&optional arg) - "Yank the last newsgroups killed with \\[gnus-group-kill-group], -inserting it before the current newsgroup. The numeric ARG specifies -how many newsgroups are to be yanked. The name of the newsgroup yanked -is returned, or (if several groups are yanked) a list of yanked groups -is returned." - (interactive "p") - (setq arg (or arg 1)) - (let (info group prev out) - (while (>= (decf arg) 0) - (if (not (setq info (pop gnus-list-of-killed-groups))) - (error "No more newsgroups to yank")) - (push (setq group (nth 1 info)) out) - ;; Find which newsgroup to insert this one before - search - ;; backward until something suitable is found. If there are no - ;; other newsgroups in this buffer, just make this newsgroup the - ;; first newsgroup. - (setq prev (gnus-group-group-name)) - (gnus-group-change-level - info (gnus-info-level (cdr info)) gnus-level-killed - (and prev (gnus-gethash prev gnus-newsrc-hashtb)) - t) - (gnus-group-insert-group-line-info group)) - (forward-line -1) - (gnus-group-position-point) - (if (< (length out) 2) (car out) (nreverse out)))) - -(defun gnus-group-kill-level (level) - "Kill all groups that is on a certain LEVEL." - (interactive "nKill all groups on level: ") - (cond - ((= level gnus-level-zombie) - (setq gnus-killed-list - (nconc gnus-zombie-list gnus-killed-list)) - (setq gnus-zombie-list nil)) - ((and (< level gnus-level-zombie) - (> level 0) - (or gnus-expert-user - (gnus-yes-or-no-p - (format - "Do you really want to kill all groups on level %d? " - level)))) - (let* ((prev gnus-newsrc-alist) - (alist (cdr prev))) - (while alist - (if (= (gnus-info-level (car alist)) level) - (progn - (push (gnus-info-group (car alist)) gnus-killed-list) - (setcdr prev (cdr alist))) - (setq prev alist)) - (setq alist (cdr alist))) - (gnus-make-hashtable-from-newsrc-alist) - (gnus-group-list-groups))) - (t - (error "Can't kill; illegal level: %d" level)))) - -(defun gnus-group-list-all-groups (&optional arg) - "List all newsgroups with level ARG or lower. -Default is gnus-level-unsubscribed, which lists all subscribed and most -unsubscribed groups." - (interactive "P") - (gnus-group-list-groups (or arg gnus-level-unsubscribed) t)) - -;; Redefine this to list ALL killed groups if prefix arg used. -;; Rewritten by engstrom@src.honeywell.com (Eric Engstrom). -(defun gnus-group-list-killed (&optional arg) - "List all killed newsgroups in the group buffer. -If ARG is non-nil, list ALL killed groups known to Gnus. This may -entail asking the server for the groups." - (interactive "P") - ;; Find all possible killed newsgroups if arg. - (when arg - (gnus-get-killed-groups)) - (if (not gnus-killed-list) - (gnus-message 6 "No killed groups") - (let (gnus-group-list-mode) - (funcall gnus-group-prepare-function - gnus-level-killed t gnus-level-killed)) - (goto-char (point-min))) - (gnus-group-position-point)) - -(defun gnus-group-list-zombies () - "List all zombie newsgroups in the group buffer." - (interactive) - (if (not gnus-zombie-list) - (gnus-message 6 "No zombie groups") - (let (gnus-group-list-mode) - (funcall gnus-group-prepare-function - gnus-level-zombie t gnus-level-zombie)) - (goto-char (point-min))) - (gnus-group-position-point)) - -(defun gnus-group-list-active () - "List all groups that are available from the server(s)." - (interactive) - ;; First we make sure that we have really read the active file. - (unless (gnus-read-active-file-p) - (let ((gnus-read-active-file t)) - (gnus-read-active-file))) - ;; Find all groups and sort them. - (let ((groups - (sort - (let (list) - (mapatoms - (lambda (sym) - (and (boundp sym) - (symbol-value sym) - (setq list (cons (symbol-name sym) list)))) - gnus-active-hashtb) - list) - 'string<)) - (buffer-read-only nil)) - (erase-buffer) - (while groups - (gnus-group-insert-group-line-info (pop groups))) - (goto-char (point-min)))) - -(defun gnus-activate-all-groups (level) - "Activate absolutely all groups." - (interactive (list 7)) - (let ((gnus-activate-level level) - (gnus-activate-foreign-newsgroups level)) - (gnus-group-get-new-news))) - -(defun gnus-group-get-new-news (&optional arg) - "Get newly arrived articles. -If ARG is a number, it specifies which levels you are interested in -re-scanning. If ARG is non-nil and not a number, this will force -\"hard\" re-reading of the active files from all servers." - (interactive "P") - (run-hooks 'gnus-get-new-news-hook) - ;; We might read in new NoCeM messages here. - (when (and gnus-use-nocem - (null 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)) - - (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))) - (run-hooks 'gnus-after-getting-new-news-hook) - (gnus-group-list-groups)) - -(defun gnus-group-get-new-news-this-group (&optional n) - "Check for newly arrived news in the current group (and the N-1 next groups). -The difference between N and the number of newsgroup checked is returned. -If N is negative, this group and the N-1 previous groups will be checked." - (interactive "P") - (let* ((groups (gnus-group-process-prefix n)) - (ret (if (numberp n) (- n (length groups)) 0)) - (beg (unless n (point))) - group) - (while (setq group (pop groups)) - (gnus-group-remove-mark group) - (if (gnus-activate-group group 'scan) - (progn - (gnus-get-unread-articles-in-group - (gnus-get-info group) (gnus-active group) t) - (unless (gnus-virtual-group-p group) - (gnus-close-group group)) - (gnus-group-update-group group)) - (if (eq (gnus-server-status (gnus-find-method-for-group group)) - 'denied) - (gnus-error 3 "Server denied access") - (gnus-error 3 "%s error: %s" group (gnus-status-message group))))) - (when beg (goto-char beg)) - (when gnus-goto-next-group-when-activating - (gnus-group-next-unread-group 1 t)) - (gnus-summary-position-point) - ret)) - -(defun gnus-group-fetch-faq (group &optional faq-dir) - "Fetch the FAQ for the current group." - (interactive - (list - (and (gnus-group-group-name) - (gnus-group-real-name (gnus-group-group-name))) - (cond (current-prefix-arg - (completing-read - "Faq dir: " (and (listp gnus-group-faq-directory) - (mapcar (lambda (file) (list file)) - gnus-group-faq-directory))))))) - (or faq-dir - (setq faq-dir (if (listp gnus-group-faq-directory) - (car gnus-group-faq-directory) - gnus-group-faq-directory))) - (or group (error "No group name given")) - (let ((file (concat (file-name-as-directory faq-dir) - (gnus-group-real-name group)))) - (if (not (file-exists-p file)) - (error "No such file: %s" file) - (find-file file)))) - -(defun gnus-group-describe-group (force &optional group) - "Display a description of the current newsgroup." - (interactive (list current-prefix-arg (gnus-group-group-name))) - (let* ((method (gnus-find-method-for-group group)) - (mname (gnus-group-prefixed-name "" method)) - desc) - (when (and force - gnus-description-hashtb) - (gnus-sethash mname nil gnus-description-hashtb)) - (or group (error "No group name given")) - (and (or (and gnus-description-hashtb - ;; We check whether this group's method has been - ;; queried for a description file. - (gnus-gethash mname gnus-description-hashtb)) - (setq desc (gnus-group-get-description group)) - (gnus-read-descriptions-file method)) - (gnus-message 1 - (or desc (gnus-gethash group gnus-description-hashtb) - "No description available"))))) - -;; Suggested by Per Abrahamsen . -(defun gnus-group-describe-all-groups (&optional force) - "Pop up a buffer with descriptions of all newsgroups." - (interactive "P") - (and force (setq gnus-description-hashtb nil)) - (if (not (or gnus-description-hashtb - (gnus-read-all-descriptions-files))) - (error "Couldn't request descriptions file")) - (let ((buffer-read-only nil) - b) - (erase-buffer) - (mapatoms - (lambda (group) - (setq b (point)) - (insert (format " *: %-20s %s\n" (symbol-name group) - (symbol-value group))) - (gnus-add-text-properties - b (1+ b) (list 'gnus-group group - 'gnus-unread t 'gnus-marked nil - 'gnus-level (1+ gnus-level-subscribed)))) - gnus-description-hashtb) - (goto-char (point-min)) - (gnus-group-position-point))) - -;; Suggested by Daniel Quinlan . -(defun gnus-group-apropos (regexp &optional search-description) - "List all newsgroups that have names that match a regexp." - (interactive "sGnus apropos (regexp): ") - (let ((prev "") - (obuf (current-buffer)) - groups des) - ;; Go through all newsgroups that are known to Gnus. - (mapatoms - (lambda (group) - (and (symbol-name group) - (string-match regexp (symbol-name group)) - (setq groups (cons (symbol-name group) groups)))) - gnus-active-hashtb) - ;; Also go through all descriptions that are known to Gnus. - (when search-description - (mapatoms - (lambda (group) - (and (string-match regexp (symbol-value group)) - (gnus-active (symbol-name group)) - (setq groups (cons (symbol-name group) groups)))) - gnus-description-hashtb)) - (if (not groups) - (gnus-message 3 "No groups matched \"%s\"." regexp) - ;; Print out all the groups. - (save-excursion - (pop-to-buffer "*Gnus Help*") - (buffer-disable-undo (current-buffer)) - (erase-buffer) - (setq groups (sort groups 'string<)) - (while groups - ;; Groups may be entered twice into the list of groups. - (if (not (string= (car groups) prev)) - (progn - (insert (setq prev (car groups)) "\n") - (if (and gnus-description-hashtb - (setq des (gnus-gethash (car groups) - gnus-description-hashtb))) - (insert " " des "\n")))) - (setq groups (cdr groups))) - (goto-char (point-min)))) - (pop-to-buffer obuf))) - -(defun gnus-group-description-apropos (regexp) - "List all newsgroups that have names or descriptions that match a regexp." - (interactive "sGnus description apropos (regexp): ") - (if (not (or gnus-description-hashtb - (gnus-read-all-descriptions-files))) - (error "Couldn't request descriptions file")) - (gnus-group-apropos regexp t)) - -;; Suggested by Per Abrahamsen . -(defun gnus-group-list-matching (level regexp &optional all lowest) - "List all groups with unread articles that match REGEXP. -If the prefix LEVEL is non-nil, it should be a number that says which -level to cut off listing groups. -If ALL, also list groups with no unread articles. -If LOWEST, don't list groups with level lower than LOWEST. - -This command may read the active file." - (interactive "P\nsList newsgroups matching: ") - ;; First make sure active file has been read. - (when (and level - (> (prefix-numeric-value level) gnus-level-killed)) - (gnus-get-killed-groups)) - (gnus-group-prepare-flat (or level gnus-level-subscribed) - all (or lowest 1) regexp) - (goto-char (point-min)) - (gnus-group-position-point)) - -(defun gnus-group-list-all-matching (level regexp &optional lowest) - "List all groups that match REGEXP. -If the prefix LEVEL is non-nil, it should be a number that says which -level to cut off listing groups. -If LOWEST, don't list groups with level lower than LOWEST." - (interactive "P\nsList newsgroups matching: ") - (gnus-group-list-matching (or level gnus-level-killed) regexp t lowest)) - -;; Suggested by Jack Vinson . -(defun gnus-group-save-newsrc (&optional force) - "Save the Gnus startup files. -If FORCE, force saving whether it is necessary or not." - (interactive "P") - (gnus-save-newsrc-file force)) - -(defun gnus-group-restart (&optional arg) - "Force Gnus to read the .newsrc file." - (interactive "P") - (when (gnus-yes-or-no-p - (format "Are you sure you want to read %s? " - gnus-current-startup-file)) - (gnus-save-newsrc-file) - (gnus-setup-news 'force) - (gnus-group-list-groups arg))) - -(defun gnus-group-read-init-file () - "Read the Gnus elisp init file." - (interactive) - (gnus-read-init-file)) - -(defun gnus-group-check-bogus-groups (&optional silent) - "Check bogus newsgroups. -If given a prefix, don't ask for confirmation before removing a bogus -group." - (interactive "P") - (gnus-check-bogus-newsgroups (and (not silent) (not gnus-expert-user))) - (gnus-group-list-groups)) - -(defun gnus-group-edit-global-kill (&optional article group) - "Edit the global kill file. -If GROUP, edit that local kill file instead." - (interactive "P") - (setq gnus-current-kill-article article) - (gnus-kill-file-edit-file group) - (gnus-message - 6 - (substitute-command-keys - (format "Editing a %s kill file (Type \\[gnus-kill-file-exit] to exit)" - (if group "local" "global"))))) - -(defun gnus-group-edit-local-kill (article group) - "Edit a local kill file." - (interactive (list nil (gnus-group-group-name))) - (gnus-group-edit-global-kill article group)) - -(defun gnus-group-force-update () - "Update `.newsrc' file." - (interactive) - (gnus-save-newsrc-file)) - -(defun gnus-group-suspend () - "Suspend the current Gnus session. -In fact, cleanup buffers except for group mode buffer. -The hook gnus-suspend-gnus-hook is called before actually suspending." - (interactive) - (run-hooks 'gnus-suspend-gnus-hook) - ;; Kill Gnus buffers except for group mode buffer. - (let* ((group-buf (get-buffer gnus-group-buffer)) - ;; Do this on a separate list in case the user does a ^G before we finish - (gnus-buffer-list - (delete group-buf (delete gnus-dribble-buffer - (append gnus-buffer-list nil))))) - (while gnus-buffer-list - (gnus-kill-buffer (pop gnus-buffer-list))) - (gnus-kill-gnus-frames) - (when group-buf - (setq gnus-buffer-list (list group-buf)) - (bury-buffer group-buf) - (delete-windows-on group-buf t)))) - -(defun gnus-group-clear-dribble () - "Clear all information from the dribble buffer." - (interactive) - (gnus-dribble-clear) - (gnus-message 7 "Cleared dribble buffer")) - -(defun gnus-group-exit () - "Quit reading news after updating .newsrc.eld and .newsrc. -The hook `gnus-exit-gnus-hook' is called before actually exiting." - (interactive) - (when - (or noninteractive ;For gnus-batch-kill - (not gnus-interactive-exit) ;Without confirmation - gnus-expert-user - (gnus-y-or-n-p "Are you sure you want to quit reading news? ")) - (run-hooks 'gnus-exit-gnus-hook) - ;; Offer to save data from non-quitted summary buffers. - (gnus-offer-save-summaries) - ;; Save the newsrc file(s). - (gnus-save-newsrc-file) - ;; Kill-em-all. - (gnus-close-backends) - ;; Reset everything. - (gnus-clear-system) - ;; Allow the user to do things after cleaning up. - (run-hooks 'gnus-after-exiting-gnus-hook))) - -(defun gnus-close-backends () - ;; Send a close request to all backends that support such a request. - (let ((methods gnus-valid-select-methods) - func) - (while methods - (if (fboundp (setq func (intern (concat (caar methods) - "-request-close")))) - (funcall func)) - (setq methods (cdr methods))))) - -(defun gnus-group-quit () - "Quit reading news without updating .newsrc.eld or .newsrc. -The hook `gnus-exit-gnus-hook' is called before actually exiting." - (interactive) - (when (or noninteractive ;For gnus-batch-kill - (zerop (buffer-size)) - (not (gnus-server-opened gnus-select-method)) - gnus-expert-user - (not gnus-current-startup-file) - (gnus-yes-or-no-p - (format "Quit reading news without saving %s? " - (file-name-nondirectory gnus-current-startup-file)))) - (run-hooks 'gnus-exit-gnus-hook) - (if gnus-use-full-window - (delete-other-windows) - (gnus-remove-some-windows)) - (gnus-dribble-save) - (gnus-close-backends) - (gnus-clear-system) - ;; Allow the user to do things after cleaning up. - (run-hooks 'gnus-after-exiting-gnus-hook))) - -(defun gnus-offer-save-summaries () - "Offer to save all active summary buffers." - (save-excursion - (let ((buflist (buffer-list)) - buffers bufname) - ;; Go through all buffers and find all summaries. - (while buflist - (and (setq bufname (buffer-name (car buflist))) - (string-match "Summary" bufname) - (save-excursion - (set-buffer bufname) - ;; We check that this is, indeed, a summary buffer. - (and (eq major-mode 'gnus-summary-mode) - ;; Also make sure this isn't bogus. - gnus-newsgroup-prepared)) - (push bufname buffers)) - (setq buflist (cdr buflist))) - ;; Go through all these summary buffers and offer to save them. - (when buffers - (map-y-or-n-p - "Update summary buffer %s? " - (lambda (buf) (set-buffer buf) (gnus-summary-exit)) - buffers))))) - -(defun gnus-group-describe-briefly () - "Give a one line description of the group mode commands." - (interactive) - (gnus-message 7 (substitute-command-keys "\\\\[gnus-group-read-group]:Select \\[gnus-group-next-unread-group]:Forward \\[gnus-group-prev-unread-group]:Backward \\[gnus-group-exit]:Exit \\[gnus-info-find-node]:Run Info \\[gnus-group-describe-briefly]:This help"))) - -(defun gnus-group-browse-foreign-server (method) - "Browse a foreign news server. -If called interactively, this function will ask for a select method - (nntp, nnspool, etc.) and a server address (eg. nntp.some.where). -If not, METHOD should be a list where the first element is the method -and the second element is the address." - (interactive - (list (let ((how (completing-read - "Which backend: " - (append gnus-valid-select-methods gnus-server-alist) - nil t (cons "nntp" 0) 'gnus-method-history))) - ;; We either got a backend name or a virtual server name. - ;; If the first, we also need an address. - (if (assoc how gnus-valid-select-methods) - (list (intern how) - ;; Suggested by mapjph@bath.ac.uk. - (completing-read - "Address: " - (mapcar (lambda (server) (list server)) - gnus-secondary-servers))) - ;; We got a server name, so we find the method. - (gnus-server-to-method how))))) - (gnus-browse-foreign-server method)) - - -;;; -;;; Gnus summary mode -;;; - -(defvar gnus-summary-mode-map nil) - -(put 'gnus-summary-mode 'mode-class 'special) - -(unless gnus-summary-mode-map - (setq gnus-summary-mode-map (make-keymap)) - (suppress-keymap gnus-summary-mode-map) - - ;; Non-orthogonal keys - - (gnus-define-keys gnus-summary-mode-map - " " gnus-summary-next-page - "\177" gnus-summary-prev-page - [delete] gnus-summary-prev-page - "\r" gnus-summary-scroll-up - "n" gnus-summary-next-unread-article - "p" gnus-summary-prev-unread-article - "N" gnus-summary-next-article - "P" gnus-summary-prev-article - "\M-\C-n" gnus-summary-next-same-subject - "\M-\C-p" gnus-summary-prev-same-subject - "\M-n" gnus-summary-next-unread-subject - "\M-p" gnus-summary-prev-unread-subject - "." gnus-summary-first-unread-article - "," gnus-summary-best-unread-article - "\M-s" gnus-summary-search-article-forward - "\M-r" gnus-summary-search-article-backward - "<" gnus-summary-beginning-of-article - ">" gnus-summary-end-of-article - "j" gnus-summary-goto-article - "^" gnus-summary-refer-parent-article - "\M-^" gnus-summary-refer-article - "u" gnus-summary-tick-article-forward - "!" gnus-summary-tick-article-forward - "U" gnus-summary-tick-article-backward - "d" gnus-summary-mark-as-read-forward - "D" gnus-summary-mark-as-read-backward - "E" gnus-summary-mark-as-expirable - "\M-u" gnus-summary-clear-mark-forward - "\M-U" gnus-summary-clear-mark-backward - "k" gnus-summary-kill-same-subject-and-select - "\C-k" gnus-summary-kill-same-subject - "\M-\C-k" gnus-summary-kill-thread - "\M-\C-l" gnus-summary-lower-thread - "e" gnus-summary-edit-article - "#" gnus-summary-mark-as-processable - "\M-#" gnus-summary-unmark-as-processable - "\M-\C-t" gnus-summary-toggle-threads - "\M-\C-s" gnus-summary-show-thread - "\M-\C-h" gnus-summary-hide-thread - "\M-\C-f" gnus-summary-next-thread - "\M-\C-b" gnus-summary-prev-thread - "\M-\C-u" gnus-summary-up-thread - "\M-\C-d" gnus-summary-down-thread - "&" gnus-summary-execute-command - "c" gnus-summary-catchup-and-exit - "\C-w" gnus-summary-mark-region-as-read - "\C-t" gnus-summary-toggle-truncation - "?" gnus-summary-mark-as-dormant - "\C-c\M-\C-s" gnus-summary-limit-include-expunged - "\C-c\C-s\C-n" gnus-summary-sort-by-number - "\C-c\C-s\C-a" gnus-summary-sort-by-author - "\C-c\C-s\C-s" gnus-summary-sort-by-subject - "\C-c\C-s\C-d" gnus-summary-sort-by-date - "\C-c\C-s\C-i" gnus-summary-sort-by-score - "=" 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 - "\M-t" gnus-summary-toggle-mime - "f" gnus-summary-followup - "F" gnus-summary-followup-with-original - "C" gnus-summary-cancel-article - "r" gnus-summary-reply - "R" gnus-summary-reply-with-original - "\C-c\C-f" gnus-summary-mail-forward - "o" gnus-summary-save-article - "\C-o" gnus-summary-save-article-mail - "|" gnus-summary-pipe-output - "\M-k" gnus-summary-edit-local-kill - "\M-K" gnus-summary-edit-global-kill - "V" gnus-version - "\C-c\C-d" gnus-summary-describe-group - "q" gnus-summary-exit - "Q" gnus-summary-exit-no-update - "\C-c\C-i" gnus-info-find-node - gnus-mouse-2 gnus-mouse-pick-article - "m" gnus-summary-mail-other-window - "a" gnus-summary-post-news - "x" gnus-summary-limit-to-unread - "s" gnus-summary-isearch-article - "t" gnus-article-hide-headers - "g" gnus-summary-show-article - "l" gnus-summary-goto-last-article - "\C-c\C-v\C-v" gnus-uu-decode-uu-view - "\C-d" gnus-summary-enter-digest-group - "\C-c\C-b" gnus-bug - "*" gnus-cache-enter-article - "\M-*" gnus-cache-remove-article - "\M-&" gnus-summary-universal-argument - "\C-l" gnus-recenter - "I" gnus-summary-increase-score - "L" gnus-summary-lower-score - - "V" gnus-summary-score-map - "X" gnus-uu-extract-map - "S" gnus-summary-send-map) - - ;; Sort of orthogonal keymap - (gnus-define-keys (gnus-summary-mark-map "M" gnus-summary-mode-map) - "t" gnus-summary-tick-article-forward - "!" gnus-summary-tick-article-forward - "d" gnus-summary-mark-as-read-forward - "r" gnus-summary-mark-as-read-forward - "c" gnus-summary-clear-mark-forward - " " gnus-summary-clear-mark-forward - "e" gnus-summary-mark-as-expirable - "x" gnus-summary-mark-as-expirable - "?" gnus-summary-mark-as-dormant - "b" gnus-summary-set-bookmark - "B" gnus-summary-remove-bookmark - "#" gnus-summary-mark-as-processable - "\M-#" gnus-summary-unmark-as-processable - "S" gnus-summary-limit-include-expunged - "C" gnus-summary-catchup - "H" gnus-summary-catchup-to-here - "\C-c" gnus-summary-catchup-all - "k" gnus-summary-kill-same-subject-and-select - "K" gnus-summary-kill-same-subject - "P" gnus-uu-mark-map) - - (gnus-define-keys (gnus-summary-mscore-map "V" gnus-summary-mode-map) - "c" gnus-summary-clear-above - "u" gnus-summary-tick-above - "m" gnus-summary-mark-above - "k" gnus-summary-kill-below) - - (gnus-define-keys (gnus-summary-limit-map "/" gnus-summary-mode-map) - "/" gnus-summary-limit-to-subject - "n" gnus-summary-limit-to-articles - "w" gnus-summary-pop-limit - "s" gnus-summary-limit-to-subject - "a" gnus-summary-limit-to-author - "u" gnus-summary-limit-to-unread - "m" gnus-summary-limit-to-marks - "v" gnus-summary-limit-to-score - "D" gnus-summary-limit-include-dormant - "d" gnus-summary-limit-exclude-dormant - ;; "t" gnus-summary-limit-exclude-thread - "E" gnus-summary-limit-include-expunged - "c" gnus-summary-limit-exclude-childless-dormant - "C" gnus-summary-limit-mark-excluded-as-read) - - (gnus-define-keys (gnus-summary-goto-map "G" gnus-summary-mode-map) - "n" gnus-summary-next-unread-article - "p" gnus-summary-prev-unread-article - "N" gnus-summary-next-article - "P" gnus-summary-prev-article - "\C-n" gnus-summary-next-same-subject - "\C-p" gnus-summary-prev-same-subject - "\M-n" gnus-summary-next-unread-subject - "\M-p" gnus-summary-prev-unread-subject - "f" gnus-summary-first-unread-article - "b" gnus-summary-best-unread-article - "j" gnus-summary-goto-article - "g" gnus-summary-goto-subject - "l" gnus-summary-goto-last-article - "p" gnus-summary-pop-article) - - (gnus-define-keys (gnus-summary-thread-map "T" gnus-summary-mode-map) - "k" gnus-summary-kill-thread - "l" gnus-summary-lower-thread - "i" gnus-summary-raise-thread - "T" gnus-summary-toggle-threads - "t" gnus-summary-rethread-current - "^" gnus-summary-reparent-thread - "s" gnus-summary-show-thread - "S" gnus-summary-show-all-threads - "h" gnus-summary-hide-thread - "H" gnus-summary-hide-all-threads - "n" gnus-summary-next-thread - "p" gnus-summary-prev-thread - "u" gnus-summary-up-thread - "o" gnus-summary-top-thread - "d" gnus-summary-down-thread - "#" gnus-uu-mark-thread - "\M-#" gnus-uu-unmark-thread) - - (gnus-define-keys (gnus-summary-exit-map "Z" gnus-summary-mode-map) - "c" gnus-summary-catchup-and-exit - "C" gnus-summary-catchup-all-and-exit - "E" gnus-summary-exit-no-update - "Q" gnus-summary-exit - "Z" gnus-summary-exit - "n" gnus-summary-catchup-and-goto-next-group - "R" gnus-summary-reselect-current-group - "G" gnus-summary-rescan-group - "N" gnus-summary-next-group - "P" gnus-summary-prev-group) - - (gnus-define-keys (gnus-summary-article-map "A" gnus-summary-mode-map) - " " gnus-summary-next-page - "n" gnus-summary-next-page - "\177" gnus-summary-prev-page - [delete] gnus-summary-prev-page - "p" gnus-summary-prev-page - "\r" gnus-summary-scroll-up - "<" gnus-summary-beginning-of-article - ">" gnus-summary-end-of-article - "b" gnus-summary-beginning-of-article - "e" gnus-summary-end-of-article - "^" gnus-summary-refer-parent-article - "r" gnus-summary-refer-parent-article - "R" gnus-summary-refer-references - "g" gnus-summary-show-article - "s" gnus-summary-isearch-article) - - (gnus-define-keys (gnus-summary-wash-map "W" gnus-summary-mode-map) - "b" gnus-article-add-buttons - "B" gnus-article-add-buttons-to-head - "o" gnus-article-treat-overstrike - ;; "w" gnus-article-word-wrap - "w" gnus-article-fill-cited-article - "c" gnus-article-remove-cr - "L" gnus-article-remove-trailing-blank-lines - "q" gnus-article-de-quoted-unreadable - "f" gnus-article-display-x-face - "l" gnus-summary-stop-page-breaking - "r" gnus-summary-caesar-message - "t" gnus-article-hide-headers - "v" gnus-summary-verbose-headers - "m" gnus-summary-toggle-mime) - - (gnus-define-keys (gnus-summary-wash-hide-map "W" gnus-summary-wash-map) - "a" gnus-article-hide - "h" gnus-article-hide-headers - "b" gnus-article-hide-boring-headers - "s" gnus-article-hide-signature - "c" gnus-article-hide-citation - "p" gnus-article-hide-pgp - "P" gnus-article-hide-pem - "\C-c" gnus-article-hide-citation-maybe) - - (gnus-define-keys (gnus-summary-wash-highlight-map "H" gnus-summary-wash-map) - "a" gnus-article-highlight - "h" gnus-article-highlight-headers - "c" gnus-article-highlight-citation - "s" gnus-article-highlight-signature) - - (gnus-define-keys (gnus-summary-wash-time-map "T" gnus-summary-wash-map) - "z" gnus-article-date-ut - "u" gnus-article-date-ut - "l" gnus-article-date-local - "e" gnus-article-date-lapsed - "o" gnus-article-date-original) - - (gnus-define-keys (gnus-summary-help-map "H" gnus-summary-mode-map) - "v" gnus-version - "f" gnus-summary-fetch-faq - "d" gnus-summary-describe-group - "h" gnus-summary-describe-briefly - "i" gnus-info-find-node) - - (gnus-define-keys (gnus-summary-backend-map "B" gnus-summary-mode-map) - "e" gnus-summary-expire-articles - "\M-\C-e" gnus-summary-expire-articles-now - "\177" gnus-summary-delete-article - [delete] gnus-summary-delete-article - "m" gnus-summary-move-article - "r" gnus-summary-respool-article - "w" gnus-summary-edit-article - "c" gnus-summary-copy-article - "B" gnus-summary-crosspost-article - "q" gnus-summary-respool-query - "i" gnus-summary-import-article) - - (gnus-define-keys (gnus-summary-save-map "O" gnus-summary-mode-map) - "o" gnus-summary-save-article - "m" gnus-summary-save-article-mail - "r" gnus-summary-save-article-rmail - "f" gnus-summary-save-article-file - "b" gnus-summary-save-article-body-file - "h" gnus-summary-save-article-folder - "v" gnus-summary-save-article-vm - "p" gnus-summary-pipe-output - "s" gnus-soup-add-article) - ) - - - -(defun gnus-summary-mode (&optional group) - "Major mode for reading articles. - -All normal editing commands are switched off. -\\ -Each line in this buffer represents one article. To read an -article, you can, for instance, type `\\[gnus-summary-next-page]'. To move forwards -and backwards while displaying articles, type `\\[gnus-summary-next-unread-article]' and `\\[gnus-summary-prev-unread-article]', -respectively. - -You can also post articles and send mail from this buffer. To -follow up an article, type `\\[gnus-summary-followup]'. To mail a reply to the author -of an article, type `\\[gnus-summary-reply]'. - -There are approx. one gazillion commands you can execute in this -buffer; read the info pages for more information (`\\[gnus-info-find-node]'). - -The following commands are available: - -\\{gnus-summary-mode-map}" - (interactive) - (when (and menu-bar-mode - (gnus-visual-p 'summary-menu 'menu)) - (gnus-summary-make-menu-bar)) - (kill-all-local-variables) - (gnus-summary-make-local-variables) - (gnus-make-thread-indent-array) - (gnus-simplify-mode-line) - (setq major-mode 'gnus-summary-mode) - (setq mode-name "Summary") - (make-local-variable 'minor-mode-alist) - (use-local-map gnus-summary-mode-map) - (buffer-disable-undo (current-buffer)) - (setq buffer-read-only t) ;Disable modification - (setq truncate-lines t) - (setq selective-display t) - (setq selective-display-ellipses t) ;Display `...' - (setq buffer-display-table gnus-summary-display-table) - (setq gnus-newsgroup-name group) - (make-local-variable 'gnus-summary-line-format) - (make-local-variable 'gnus-summary-line-format-spec) - (make-local-variable 'gnus-summary-mark-positions) - (gnus-make-local-hook 'post-command-hook) - (gnus-add-hook 'post-command-hook 'gnus-clear-inboxes-moved nil t) - (run-hooks 'gnus-summary-mode-hook)) - -(defun gnus-summary-make-local-variables () - "Make all the local summary buffer variables." - (let ((locals gnus-summary-local-variables) - global local) - (while (setq local (pop locals)) - (if (consp local) - (progn - (if (eq (cdr local) 'global) - ;; Copy the global value of the variable. - (setq global (symbol-value (car local))) - ;; Use the value from the list. - (setq global (eval (cdr local)))) - (make-local-variable (car local)) - (set (car local) global)) - ;; Simple nil-valued local variable. - (make-local-variable local) - (set local nil))))) - -(defun gnus-summary-make-display-table () - ;; Change the display table. Odd characters have a tendency to mess - ;; up nicely formatted displays - we make all possible glyphs - ;; display only a single character. - - ;; We start from the standard display table, if any. - (setq gnus-summary-display-table - (or (copy-sequence standard-display-table) - (make-display-table))) - ;; Nix out all the control chars... - (let ((i 32)) - (while (>= (setq i (1- i)) 0) - (aset gnus-summary-display-table i [??]))) - ;; ... but not newline and cr, of course. (cr is necessary for the - ;; selective display). - (aset gnus-summary-display-table ?\n nil) - (aset gnus-summary-display-table ?\r nil) - ;; We nix out any glyphs over 126 that are not set already. - (let ((i 256)) - (while (>= (setq i (1- i)) 127) - ;; Only modify if the entry is nil. - (or (aref gnus-summary-display-table i) - (aset gnus-summary-display-table i [??]))))) - -(defun gnus-summary-clear-local-variables () - (let ((locals gnus-summary-local-variables)) - (while locals - (if (consp (car locals)) - (and (vectorp (caar locals)) - (set (caar locals) nil)) - (and (vectorp (car locals)) - (set (car locals) nil))) - (setq locals (cdr locals))))) - -;; Summary data functions. - -(defmacro gnus-data-number (data) - `(car ,data)) - -(defmacro gnus-data-set-number (data number) - `(setcar ,data ,number)) - -(defmacro gnus-data-mark (data) - `(nth 1 ,data)) - -(defmacro gnus-data-set-mark (data mark) - `(setcar (nthcdr 1 ,data) ,mark)) - -(defmacro gnus-data-pos (data) - `(nth 2 ,data)) - -(defmacro gnus-data-set-pos (data pos) - `(setcar (nthcdr 2 ,data) ,pos)) - -(defmacro gnus-data-header (data) - `(nth 3 ,data)) - -(defmacro gnus-data-level (data) - `(nth 4 ,data)) - -(defmacro gnus-data-unread-p (data) - `(= (nth 1 ,data) gnus-unread-mark)) - -(defmacro gnus-data-pseudo-p (data) - `(consp (nth 3 ,data))) - -(defmacro gnus-data-find (number) - `(assq ,number gnus-newsgroup-data)) - -(defmacro gnus-data-find-list (number &optional data) - `(let ((bdata ,(or data 'gnus-newsgroup-data))) - (memq (assq ,number bdata) - bdata))) - -(defmacro gnus-data-make (number mark pos header level) - `(list ,number ,mark ,pos ,header ,level)) - -(defun gnus-data-enter (after-article number mark pos header level offset) - (let ((data (gnus-data-find-list after-article))) - (or data (error "No such article: %d" after-article)) - (setcdr data (cons (gnus-data-make number mark pos header level) - (cdr data))) - (setq gnus-newsgroup-data-reverse nil) - (gnus-data-update-list (cddr data) offset))) - -(defun gnus-data-enter-list (after-article list &optional offset) - (when list - (let ((data (and after-article (gnus-data-find-list after-article))) - (ilist list)) - (or data (not after-article) (error "No such article: %d" after-article)) - ;; Find the last element in the list to be spliced into the main - ;; list. - (while (cdr list) - (setq list (cdr list))) - (if (not data) - (progn - (setcdr list gnus-newsgroup-data) - (setq gnus-newsgroup-data ilist) - (and offset (gnus-data-update-list (cdr list) offset))) - (setcdr list (cdr data)) - (setcdr data ilist) - (and offset (gnus-data-update-list (cdr data) offset))) - (setq gnus-newsgroup-data-reverse nil)))) - -(defun gnus-data-remove (article &optional offset) - (let ((data gnus-newsgroup-data)) - (if (= (gnus-data-number (car data)) article) - (setq gnus-newsgroup-data (cdr gnus-newsgroup-data) - gnus-newsgroup-data-reverse nil) - (while (cdr data) - (and (= (gnus-data-number (cadr data)) article) - (progn - (setcdr data (cddr data)) - (and offset (gnus-data-update-list (cdr data) offset)) - (setq data nil - gnus-newsgroup-data-reverse nil))) - (setq data (cdr data)))))) - -(defmacro gnus-data-list (backward) - `(if ,backward - (or gnus-newsgroup-data-reverse - (setq gnus-newsgroup-data-reverse - (reverse gnus-newsgroup-data))) - gnus-newsgroup-data)) - -(defun gnus-data-update-list (data offset) - "Add OFFSET to the POS of all data entries in DATA." - (while data - (setcar (nthcdr 2 (car data)) (+ offset (nth 2 (car data)))) - (setq data (cdr data)))) - -(defun gnus-data-compute-positions () - "Compute the positions of all articles." - (let ((data gnus-newsgroup-data) - pos) - (while data - (when (setq pos (text-property-any - (point-min) (point-max) - 'gnus-number (gnus-data-number (car data)))) - (gnus-data-set-pos (car data) (+ pos 3))) - (setq data (cdr data))))) - -(defun gnus-summary-article-pseudo-p (article) - "Say whether this article is a pseudo article or not." - (not (vectorp (gnus-data-header (gnus-data-find article))))) - -(defun gnus-article-parent-p (number) - "Say whether this article is a parent or not." - (let ((data (gnus-data-find-list number))) - (and (cdr data) ; There has to be an article after... - (< (gnus-data-level (car data)) ; And it has to have a higher level. - (gnus-data-level (nth 1 data)))))) - -(defun gnus-article-children (number) - "Return a list of all children to NUMBER." - (let* ((data (gnus-data-find-list number)) - (level (gnus-data-level (car data))) - children) - (setq data (cdr data)) - (while (and data - (= (gnus-data-level (car data)) (1+ level))) - (push (gnus-data-number (car data)) children) - (setq data (cdr data))) - children)) - -(defmacro gnus-summary-skip-intangible () - "If the current article is intangible, then jump to a different article." - '(let ((to (get-text-property (point) 'gnus-intangible))) - (and to (gnus-summary-goto-subject to)))) - -(defmacro gnus-summary-article-intangible-p () - "Say whether this article is intangible or not." - '(get-text-property (point) 'gnus-intangible)) - -;; Some summary mode macros. - -(defmacro gnus-summary-article-number () - "The article number of the article on the current line. -If there isn's an article number here, then we return the current -article number." - '(progn - (gnus-summary-skip-intangible) - (or (get-text-property (point) 'gnus-number) - (gnus-summary-last-subject)))) - -(defmacro gnus-summary-article-header (&optional number) - `(gnus-data-header (gnus-data-find - ,(or number '(gnus-summary-article-number))))) - -(defmacro gnus-summary-thread-level (&optional number) - `(if (and (eq gnus-summary-make-false-root 'dummy) - (get-text-property (point) 'gnus-intangible)) - 0 - (gnus-data-level (gnus-data-find - ,(or number '(gnus-summary-article-number)))))) - -(defmacro gnus-summary-article-mark (&optional number) - `(gnus-data-mark (gnus-data-find - ,(or number '(gnus-summary-article-number))))) - -(defmacro gnus-summary-article-pos (&optional number) - `(gnus-data-pos (gnus-data-find - ,(or number '(gnus-summary-article-number))))) - -(defalias 'gnus-summary-subject-string 'gnus-summary-article-subject) -(defmacro gnus-summary-article-subject (&optional number) - "Return current subject string or nil if nothing." - `(let ((headers - ,(if number - `(gnus-data-header (assq ,number gnus-newsgroup-data)) - '(gnus-data-header (assq (gnus-summary-article-number) - gnus-newsgroup-data))))) - (and headers - (vectorp headers) - (mail-header-subject headers)))) - -(defmacro gnus-summary-article-score (&optional number) - "Return current article score." - `(or (cdr (assq ,(or number '(gnus-summary-article-number)) - gnus-newsgroup-scored)) - gnus-summary-default-score 0)) - -(defun gnus-summary-article-children (&optional number) - (let* ((data (gnus-data-find-list (or number (gnus-summary-article-number)))) - (level (gnus-data-level (car data))) - l children) - (while (and (setq data (cdr data)) - (> (setq l (gnus-data-level (car data))) level)) - (and (= (1+ level) l) - (setq children (cons (gnus-data-number (car data)) - children)))) - (nreverse children))) - -(defun gnus-summary-article-parent (&optional number) - (let* ((data (gnus-data-find-list (or number (gnus-summary-article-number)) - (gnus-data-list t))) - (level (gnus-data-level (car data)))) - (if (zerop level) - () ; This is a root. - ;; We search until we find an article with a level less than - ;; this one. That function has to be the parent. - (while (and (setq data (cdr data)) - (not (< (gnus-data-level (car data)) level)))) - (and data (gnus-data-number (car data)))))) - -(defun gnus-unread-mark-p (mark) - "Say whether MARK is the unread mark." - (= mark gnus-unread-mark)) - -(defun gnus-read-mark-p (mark) - "Say whether MARK is one of the marks that mark as read. -This is all marks except unread, ticked, dormant, and expirable." - (not (or (= mark gnus-unread-mark) - (= mark gnus-ticked-mark) - (= mark gnus-dormant-mark) - (= mark gnus-expirable-mark)))) - -;; Saving hidden threads. - -(put 'gnus-save-hidden-threads 'lisp-indent-function 0) -(put 'gnus-save-hidden-threads 'lisp-indent-hook 0) -(put 'gnus-save-hidden-threads 'edebug-form-spec '(body)) - -(defmacro gnus-save-hidden-threads (&rest forms) - "Save hidden threads, eval FORMS, and restore the hidden threads." - (let ((config (make-symbol "config"))) - `(let ((,config (gnus-hidden-threads-configuration))) - (unwind-protect - (progn - ,@forms) - (gnus-restore-hidden-threads-configuration ,config))))) - -(defun gnus-hidden-threads-configuration () - "Return the current hidden threads configuration." - (save-excursion - (let (config) - (goto-char (point-min)) - (while (search-forward "\r" nil t) - (push (1- (point)) config)) - config))) - -(defun gnus-restore-hidden-threads-configuration (config) - "Restore hidden threads configuration from CONFIG." - (let (point buffer-read-only) - (while (setq point (pop config)) - (when (and (< point (point-max)) - (goto-char point) - (= (following-char) ?\n)) - (subst-char-in-region point (1+ point) ?\n ?\r))))) - -;; Various summary mode internalish functions. - -(defun gnus-mouse-pick-article (e) - (interactive "e") - (mouse-set-point e) - (gnus-summary-next-page nil t)) - -(defun gnus-summary-setup-buffer (group) - "Initialize summary buffer." - (let ((buffer (concat "*Summary " group "*"))) - (if (get-buffer buffer) - (progn - (set-buffer buffer) - (setq gnus-summary-buffer (current-buffer)) - (not gnus-newsgroup-prepared)) - ;; Fix by Sudish Joseph - (setq gnus-summary-buffer (set-buffer (get-buffer-create buffer))) - (gnus-add-current-to-buffer-list) - (gnus-summary-mode group) - (when gnus-carpal - (gnus-carpal-setup-buffer 'summary)) - (unless gnus-single-article-buffer - (make-local-variable 'gnus-article-buffer) - (make-local-variable 'gnus-article-current) - (make-local-variable 'gnus-original-article-buffer)) - (setq gnus-newsgroup-name group) - t))) - -(defun gnus-set-global-variables () - ;; Set the global equivalents of the summary buffer-local variables - ;; to the latest values they had. These reflect the summary buffer - ;; that was in action when the last article was fetched. - (when (eq major-mode 'gnus-summary-mode) - (setq gnus-summary-buffer (current-buffer)) - (let ((name gnus-newsgroup-name) - (marked gnus-newsgroup-marked) - (unread gnus-newsgroup-unreads) - (headers gnus-current-headers) - (data gnus-newsgroup-data) - (summary gnus-summary-buffer) - (article-buffer gnus-article-buffer) - (original gnus-original-article-buffer) - (gac gnus-article-current) - (reffed gnus-reffed-article-number) - (score-file gnus-current-score-file)) - (save-excursion - (set-buffer gnus-group-buffer) - (setq gnus-newsgroup-name name) - (setq gnus-newsgroup-marked marked) - (setq gnus-newsgroup-unreads unread) - (setq gnus-current-headers headers) - (setq gnus-newsgroup-data data) - (setq gnus-article-current gac) - (setq gnus-summary-buffer summary) - (setq gnus-article-buffer article-buffer) - (setq gnus-original-article-buffer original) - (setq gnus-reffed-article-number reffed) - (setq gnus-current-score-file score-file))))) - -(defun gnus-summary-last-article-p (&optional article) - "Return whether ARTICLE is the last article in the buffer." - (if (not (setq article (or article (gnus-summary-article-number)))) - t ; All non-existant numbers are the last article. :-) - (not (cdr (gnus-data-find-list article))))) - -(defun gnus-summary-insert-dummy-line (gnus-tmp-subject gnus-tmp-number) - "Insert a dummy root in the summary buffer." - (beginning-of-line) - (gnus-add-text-properties - (point) (progn (eval gnus-summary-dummy-line-format-spec) (point)) - (list 'gnus-number gnus-tmp-number 'gnus-intangible gnus-tmp-number))) - -(defun gnus-make-thread-indent-array () - (let ((n 200)) - (unless (and gnus-thread-indent-array - (= gnus-thread-indent-level gnus-thread-indent-array-level)) - (setq gnus-thread-indent-array (make-vector 201 "") - gnus-thread-indent-array-level gnus-thread-indent-level) - (while (>= n 0) - (aset gnus-thread-indent-array n - (make-string (* n gnus-thread-indent-level) ? )) - (setq n (1- n)))))) - -(defun gnus-summary-insert-line - (gnus-tmp-header gnus-tmp-level gnus-tmp-current gnus-tmp-unread - gnus-tmp-replied gnus-tmp-expirable gnus-tmp-subject-or-nil - &optional gnus-tmp-dummy gnus-tmp-score gnus-tmp-process) - (let* ((gnus-tmp-indentation (aref gnus-thread-indent-array gnus-tmp-level)) - (gnus-tmp-lines (mail-header-lines gnus-tmp-header)) - (gnus-tmp-score (or gnus-tmp-score gnus-summary-default-score 0)) - (gnus-tmp-score-char - (if (or (null gnus-summary-default-score) - (<= (abs (- gnus-tmp-score gnus-summary-default-score)) - gnus-summary-zcore-fuzz)) ? - (if (< gnus-tmp-score gnus-summary-default-score) - gnus-score-below-mark gnus-score-over-mark))) - (gnus-tmp-replied (cond (gnus-tmp-process gnus-process-mark) - ((memq gnus-tmp-current gnus-newsgroup-cached) - gnus-cached-mark) - (gnus-tmp-replied gnus-replied-mark) - ((memq gnus-tmp-current gnus-newsgroup-saved) - gnus-saved-mark) - (t gnus-unread-mark))) - (gnus-tmp-from (mail-header-from gnus-tmp-header)) - (gnus-tmp-name - (cond - ((string-match "(.+)" gnus-tmp-from) - (substring gnus-tmp-from - (1+ (match-beginning 0)) (1- (match-end 0)))) - ((string-match "<[^>]+> *$" gnus-tmp-from) - (let ((beg (match-beginning 0))) - (or (and (string-match "^\"[^\"]*\"" gnus-tmp-from) - (substring gnus-tmp-from (1+ (match-beginning 0)) - (1- (match-end 0)))) - (substring gnus-tmp-from 0 beg)))) - (t gnus-tmp-from))) - (gnus-tmp-subject (mail-header-subject gnus-tmp-header)) - (gnus-tmp-number (mail-header-number gnus-tmp-header)) - (gnus-tmp-opening-bracket (if gnus-tmp-dummy ?\< ?\[)) - (gnus-tmp-closing-bracket (if gnus-tmp-dummy ?\> ?\])) - (buffer-read-only nil)) - (when (string= gnus-tmp-name "") - (setq gnus-tmp-name gnus-tmp-from)) - (or (numberp gnus-tmp-lines) (setq gnus-tmp-lines 0)) - (gnus-put-text-property - (point) - (progn (eval gnus-summary-line-format-spec) (point)) - 'gnus-number gnus-tmp-number) - (when (gnus-visual-p 'summary-highlight 'highlight) - (forward-line -1) - (run-hooks 'gnus-summary-update-hook) - (forward-line 1)))) - -(defun gnus-summary-update-line (&optional dont-update) - ;; Update summary line after change. - (when (and gnus-summary-default-score - (not gnus-summary-inhibit-highlight)) - (let* ((gnus-summary-inhibit-highlight t) ; Prevent recursion. - (article (gnus-summary-article-number)) - (score (gnus-summary-article-score article))) - (unless dont-update - (if (and gnus-summary-mark-below - (< (gnus-summary-article-score) - gnus-summary-mark-below)) - ;; This article has a low score, so we mark it as read. - (when (memq article gnus-newsgroup-unreads) - (gnus-summary-mark-article-as-read gnus-low-score-mark)) - (when (eq (gnus-summary-article-mark) gnus-low-score-mark) - ;; This article was previously marked as read on account - ;; of a low score, but now it has risen, so we mark it as - ;; unread. - (gnus-summary-mark-article-as-unread gnus-unread-mark))) - (gnus-summary-update-mark - (if (or (null gnus-summary-default-score) - (<= (abs (- score gnus-summary-default-score)) - gnus-summary-zcore-fuzz)) ? - (if (< score gnus-summary-default-score) - gnus-score-below-mark gnus-score-over-mark)) 'score)) - ;; Do visual highlighting. - (when (gnus-visual-p 'summary-highlight 'highlight) - (run-hooks 'gnus-summary-update-hook))))) - -(defvar gnus-tmp-new-adopts nil) - -(defun gnus-summary-number-of-articles-in-thread (thread &optional level char) - ;; Sum up all elements (and sub-elements) in a list. - (let* ((number - ;; Fix by Luc Van Eycken . - (cond - ((and (consp thread) (cdr thread)) - (apply - '+ 1 (mapcar - 'gnus-summary-number-of-articles-in-thread (cdr thread)))) - ((null thread) - 1) - ((memq (mail-header-number (car thread)) gnus-newsgroup-limit) - 1) - (t 0)))) - (when (and level (zerop level) gnus-tmp-new-adopts) - (incf number - (apply '+ (mapcar - 'gnus-summary-number-of-articles-in-thread - gnus-tmp-new-adopts)))) - (if char - (if (> number 1) gnus-not-empty-thread-mark - gnus-empty-thread-mark) - number))) - -(defun gnus-summary-set-local-parameters (group) - "Go through the local params of GROUP and set all variable specs in that list." - (let ((params (gnus-info-params (gnus-get-info group))) - elem) - (while params - (setq elem (car params) - params (cdr params)) - (and (consp elem) ; Has to be a cons. - (consp (cdr elem)) ; The cdr has to be a list. - (symbolp (car elem)) ; Has to be a symbol in there. - (not (memq (car elem) - '(quit-config to-address to-list to-group))) - (progn ; So we set it. - (make-local-variable (car elem)) - (set (car elem) (eval (nth 1 elem)))))))) - -(defun gnus-summary-read-group (group &optional show-all no-article - kill-buffer no-display) - "Start reading news in newsgroup GROUP. -If SHOW-ALL is non-nil, already read articles are also listed. -If NO-ARTICLE is non-nil, no article is selected initially. -If NO-DISPLAY, don't generate a summary buffer." - (gnus-message 5 "Retrieving newsgroup: %s..." group) - (let* ((new-group (gnus-summary-setup-buffer group)) - (quit-config (gnus-group-quit-config group)) - (did-select (and new-group (gnus-select-newsgroup group show-all)))) - (cond - ;; This summary buffer exists already, so we just select it. - ((not new-group) - (gnus-set-global-variables) - (when kill-buffer - (gnus-kill-or-deaden-summary kill-buffer)) - (gnus-configure-windows 'summary 'force) - (gnus-set-mode-line 'summary) - (gnus-summary-position-point) - (message "") - t) - ;; We couldn't select this group. - ((null did-select) - (when (and (eq major-mode 'gnus-summary-mode) - (not (equal (current-buffer) kill-buffer))) - (kill-buffer (current-buffer)) - (if (not quit-config) - (progn - (set-buffer gnus-group-buffer) - (gnus-group-jump-to-group group) - (gnus-group-next-unread-group 1)) - (if (not (buffer-name (car quit-config))) - (gnus-configure-windows 'group 'force) - (set-buffer (car quit-config)) - (and (eq major-mode 'gnus-summary-mode) - (gnus-set-global-variables)) - (gnus-configure-windows (cdr quit-config))))) - (gnus-message 3 "Can't select group") - nil) - ;; The user did a `C-g' while prompting for number of articles, - ;; so we exit this group. - ((eq did-select 'quit) - (and (eq major-mode 'gnus-summary-mode) - (not (equal (current-buffer) kill-buffer)) - (kill-buffer (current-buffer))) - (when kill-buffer - (gnus-kill-or-deaden-summary kill-buffer)) - (if (not quit-config) - (progn - (set-buffer gnus-group-buffer) - (gnus-group-jump-to-group group) - (gnus-group-next-unread-group 1) - (gnus-configure-windows 'group 'force)) - (if (not (buffer-name (car quit-config))) - (gnus-configure-windows 'group 'force) - (set-buffer (car quit-config)) - (and (eq major-mode 'gnus-summary-mode) - (gnus-set-global-variables)) - (gnus-configure-windows (cdr quit-config)))) - ;; Finally signal the quit. - (signal 'quit nil)) - ;; The group was successfully selected. - (t - (gnus-set-global-variables) - ;; Save the active value in effect when the group was entered. - (setq gnus-newsgroup-active - (gnus-copy-sequence - (gnus-active gnus-newsgroup-name))) - ;; You can change the summary buffer in some way with this hook. - (run-hooks 'gnus-select-group-hook) - ;; Set any local variables in the group parameters. - (gnus-summary-set-local-parameters gnus-newsgroup-name) - (gnus-update-format-specifications) - ;; Do score processing. - (when gnus-use-scoring - (gnus-possibly-score-headers)) - ;; Check whether to fill in the gaps in the threads. - (when gnus-build-sparse-threads - (gnus-build-sparse-threads)) - ;; Find the initial limit. - (if gnus-show-threads - (if show-all - (let ((gnus-newsgroup-dormant nil)) - (gnus-summary-initial-limit show-all)) - (gnus-summary-initial-limit show-all)) - (setq gnus-newsgroup-limit - (mapcar - (lambda (header) (mail-header-number header)) - gnus-newsgroup-headers))) - ;; Generate the summary buffer. - (unless no-display - (gnus-summary-prepare)) - (when gnus-use-trees - (gnus-tree-open group) - (setq gnus-summary-highlight-line-function - 'gnus-tree-highlight-article)) - ;; If the summary buffer is empty, but there are some low-scored - ;; articles or some excluded dormants, we include these in the - ;; buffer. - (when (and (zerop (buffer-size)) - (not no-display)) - (cond (gnus-newsgroup-dormant - (gnus-summary-limit-include-dormant)) - ((and gnus-newsgroup-scored show-all) - (gnus-summary-limit-include-expunged t)))) - ;; Function `gnus-apply-kill-file' must be called in this hook. - (run-hooks 'gnus-apply-kill-hook) - (if (and (zerop (buffer-size)) - (not no-display)) - (progn - ;; This newsgroup is empty. - (gnus-summary-catchup-and-exit nil t) ;Without confirmations. - (gnus-message 6 "No unread news") - (when kill-buffer - (gnus-kill-or-deaden-summary kill-buffer)) - ;; Return nil from this function. - nil) - ;; Hide conversation thread subtrees. We cannot do this in - ;; gnus-summary-prepare-hook since kill processing may not - ;; work with hidden articles. - (and gnus-show-threads - gnus-thread-hide-subtree - (gnus-summary-hide-all-threads)) - ;; Show first unread article if requested. - (if (and (not no-article) - (not no-display) - gnus-newsgroup-unreads - gnus-auto-select-first) - (unless (if (eq gnus-auto-select-first 'best) - (gnus-summary-best-unread-article) - (gnus-summary-first-unread-article)) - (gnus-configure-windows 'summary)) - ;; Don't select any articles, just move point to the first - ;; article in the group. - (goto-char (point-min)) - (gnus-summary-position-point) - (gnus-set-mode-line 'summary) - (gnus-configure-windows 'summary 'force)) - ;; If we are in async mode, we send some info to the backend. - (when gnus-newsgroup-async - (gnus-request-asynchronous gnus-newsgroup-name gnus-newsgroup-data)) - (when kill-buffer - (gnus-kill-or-deaden-summary kill-buffer)) - (when (get-buffer-window gnus-group-buffer t) - ;; Gotta use windows, because recenter does wierd stuff if - ;; the current buffer ain't the displayed window. - (let ((owin (selected-window))) - (select-window (get-buffer-window gnus-group-buffer t)) - (when (gnus-group-goto-group group) - (recenter)) - (select-window owin)))) - ;; Mark this buffer as "prepared". - (setq gnus-newsgroup-prepared t) - t)))) - -(defun gnus-summary-prepare () - "Generate the summary buffer." - (let ((buffer-read-only nil)) - (erase-buffer) - (setq gnus-newsgroup-data nil - gnus-newsgroup-data-reverse nil) - (run-hooks 'gnus-summary-generate-hook) - ;; Generate the buffer, either with threads or without. - (when gnus-newsgroup-headers - (gnus-summary-prepare-threads - (if gnus-show-threads - (gnus-sort-gathered-threads - (funcall gnus-summary-thread-gathering-function - (gnus-sort-threads - (gnus-cut-threads (gnus-make-threads))))) - ;; Unthreaded display. - (gnus-sort-articles gnus-newsgroup-headers)))) - (setq gnus-newsgroup-data (nreverse gnus-newsgroup-data)) - ;; Call hooks for modifying summary buffer. - (goto-char (point-min)) - (run-hooks 'gnus-summary-prepare-hook))) - -(defun gnus-gather-threads-by-subject (threads) - "Gather threads by looking at Subject headers." - (if (not gnus-summary-make-false-root) - threads - (let ((hashtb (gnus-make-hashtable 1023)) - (prev threads) - (result threads) - subject hthread whole-subject) - (while threads - (setq whole-subject (mail-header-subject (caar threads))) - (setq subject - (cond - ;; Truncate the subject. - ((numberp gnus-summary-gather-subject-limit) - (setq subject (gnus-simplify-subject-re whole-subject)) - (if (> (length subject) gnus-summary-gather-subject-limit) - (substring subject 0 gnus-summary-gather-subject-limit) - subject)) - ;; Fuzzily simplify it. - ((eq 'fuzzy gnus-summary-gather-subject-limit) - (gnus-simplify-subject-fuzzy whole-subject)) - ;; Just remove the leading "Re:". - (t - (gnus-simplify-subject-re whole-subject)))) - - (if (and gnus-summary-gather-exclude-subject - (string-match gnus-summary-gather-exclude-subject - subject)) - () ; We don't want to do anything with this article. - ;; We simplify the subject before looking it up in the - ;; hash table. - - (if (setq hthread (gnus-gethash subject hashtb)) - (progn - ;; We enter a dummy root into the thread, if we - ;; haven't done that already. - (unless (stringp (caar hthread)) - (setcar hthread (list whole-subject (car hthread)))) - ;; We add this new gathered thread to this gathered - ;; thread. - (setcdr (car hthread) - (nconc (cdar hthread) (list (car threads)))) - ;; Remove it from the list of threads. - (setcdr prev (cdr threads)) - (setq threads prev)) - ;; Enter this thread into the hash table. - (gnus-sethash subject threads hashtb))) - (setq prev threads) - (setq threads (cdr threads))) - result))) - -(defun gnus-gather-threads-by-references (threads) - "Gather threads by looking at References headers." - (let ((idhashtb (gnus-make-hashtable 1023)) - (thhashtb (gnus-make-hashtable 1023)) - (prev threads) - (result threads) - ids references id gthread gid entered) - (while threads - (when (setq references (mail-header-references (caar threads))) - (setq id (mail-header-id (caar threads))) - (setq ids (gnus-split-references references)) - (setq entered nil) - (while ids - (if (not (setq gid (gnus-gethash (car ids) idhashtb))) - (progn - (gnus-sethash (car ids) id idhashtb) - (gnus-sethash id threads thhashtb)) - (setq gthread (gnus-gethash gid thhashtb)) - (unless entered - ;; We enter a dummy root into the thread, if we - ;; haven't done that already. - (unless (stringp (caar gthread)) - (setcar gthread (list (mail-header-subject (caar gthread)) - (car gthread)))) - ;; We add this new gathered thread to this gathered - ;; thread. - (setcdr (car gthread) - (nconc (cdar gthread) (list (car threads))))) - ;; Add it into the thread hash table. - (gnus-sethash id gthread thhashtb) - (setq entered t) - ;; Remove it from the list of threads. - (setcdr prev (cdr threads)) - (setq threads prev)) - (setq ids (cdr ids)))) - (setq prev threads) - (setq threads (cdr threads))) - result)) - -(defun gnus-sort-gathered-threads (threads) - "Sort subtreads inside each gathered thread by article number." - (let ((result threads)) - (while threads - (when (stringp (caar threads)) - (setcdr (car threads) - (sort (cdar threads) 'gnus-thread-sort-by-number))) - (setq threads (cdr threads))) - result)) - -(defun gnus-make-threads () - "Go through the dependency hashtb and find the roots. Return all threads." - (let (threads) - (mapatoms - (lambda (refs) - (unless (car (symbol-value refs)) - ;; These threads do not refer back to any other articles, - ;; so they're roots. - (setq threads (append (cdr (symbol-value refs)) threads)))) - gnus-newsgroup-dependencies) - threads)) - -(defun gnus-build-sparse-threads () - (let ((headers gnus-newsgroup-headers) - (deps gnus-newsgroup-dependencies) - header references generation relations - cthread subject child end pthread relation) - ;; First we create an alist of generations/relations, where - ;; generations is how much we trust the ralation, and the relation - ;; is parent/child. - (gnus-message 7 "Making sparse threads...") - (save-excursion - (nnheader-set-temp-buffer " *gnus sparse threads*") - (while (setq header (pop headers)) - (when (and (setq references (mail-header-references header)) - (not (string= references ""))) - (insert references) - (setq child (mail-header-id header) - subject (mail-header-subject header)) - (setq generation 0) - (while (search-backward ">" nil t) - (setq end (1+ (point))) - (when (search-backward "<" nil t) - (push (list (incf generation) - child (setq child (buffer-substring (point) end)) - subject) - relations))) - (push (list (1+ generation) child nil subject) relations) - (erase-buffer))) - (kill-buffer (current-buffer))) - ;; Sort over trustworthiness. - (setq relations (sort relations (lambda (r1 r2) (< (car r1) (car r2))))) - (while (setq relation (pop relations)) - (when (if (boundp (setq cthread (intern (cadr relation) deps))) - (unless (car (symbol-value cthread)) - ;; Make this article the parent of these threads. - (setcar (symbol-value cthread) - (vector gnus-reffed-article-number - (cadddr relation) - "" "" - (cadr relation) - (or (caddr relation) "") 0 0 ""))) - (set cthread (list (vector gnus-reffed-article-number - (cadddr relation) - "" "" (cadr relation) - (or (caddr relation) "") 0 0 "")))) - (push gnus-reffed-article-number gnus-newsgroup-limit) - (push gnus-reffed-article-number gnus-newsgroup-sparse) - (push (cons gnus-reffed-article-number gnus-sparse-mark) - gnus-newsgroup-reads) - (decf gnus-reffed-article-number) - ;; Make this new thread the child of its parent. - (if (boundp (setq pthread (intern (or (caddr relation) "none") deps))) - (setcdr (symbol-value pthread) - (nconc (cdr (symbol-value pthread)) - (list (symbol-value cthread)))) - (set pthread (list nil (symbol-value cthread)))))) - (gnus-message 7 "Making sparse threads...done"))) - -(defun gnus-build-old-threads () - ;; Look at all the articles that refer back to old articles, and - ;; fetch the headers for the articles that aren't there. This will - ;; build complete threads - if the roots haven't been expired by the - ;; server, that is. - (let (id heads) - (mapatoms - (lambda (refs) - (when (not (car (symbol-value refs))) - (setq heads (cdr (symbol-value refs))) - (while heads - (if (memq (mail-header-number (caar heads)) - gnus-newsgroup-dormant) - (setq heads (cdr heads)) - (setq id (symbol-name refs)) - (while (and (setq id (gnus-build-get-header id)) - (not (car (gnus-gethash - id gnus-newsgroup-dependencies))))) - (setq heads nil))))) - gnus-newsgroup-dependencies))) - -(defun gnus-build-get-header (id) - ;; Look through the buffer of NOV lines and find the header to - ;; ID. Enter this line into the dependencies hash table, and return - ;; the id of the parent article (if any). - (let ((deps gnus-newsgroup-dependencies) - found header) - (prog1 - (save-excursion - (set-buffer nntp-server-buffer) - (goto-char (point-min)) - (while (and (not found) (search-forward id nil t)) - (beginning-of-line) - (setq found (looking-at - (format "^[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t%s" - (regexp-quote id)))) - (or found (beginning-of-line 2))) - (when found - (beginning-of-line) - (and - (setq header (gnus-nov-parse-line - (read (current-buffer)) deps)) - (gnus-parent-id (mail-header-references header))))) - (when header - (let ((number (mail-header-number header))) - (push number gnus-newsgroup-limit) - (push header gnus-newsgroup-headers) - (if (memq number gnus-newsgroup-unselected) - (progn - (push number gnus-newsgroup-unreads) - (setq gnus-newsgroup-unselected - (delq number gnus-newsgroup-unselected))) - (push number gnus-newsgroup-ancient))))))) - -(defun gnus-summary-update-article (article &optional iheader) - "Update ARTICLE in the summary buffer." - (set-buffer gnus-summary-buffer) - (let* ((header (or iheader (gnus-summary-article-header article))) - (id (mail-header-id header)) - (data (gnus-data-find article)) - (thread (gnus-id-to-thread id)) - (references (mail-header-references header)) - (parent - (gnus-id-to-thread - (or (gnus-parent-id - (if (and references - (not (equal "" references))) - references)) - "none"))) - (buffer-read-only nil) - (old (car thread)) - (number (mail-header-number header)) - pos) - (when thread - ;; !!! Should this be in or not? - (unless iheader - (setcar thread nil)) - (when parent - (delq thread parent)) - (if (gnus-summary-insert-subject id header iheader) - ;; Set the (possibly) new article number in the data structure. - (gnus-data-set-number data (gnus-id-to-article id)) - (setcar thread old) - nil)))) - -(defun gnus-rebuild-thread (id) - "Rebuild the thread containing ID." - (let ((buffer-read-only nil) - current thread data) - (if (not gnus-show-threads) - (setq thread (list (car (gnus-id-to-thread id)))) - ;; Get the thread this article is part of. - (setq thread (gnus-remove-thread id))) - (setq current (save-excursion - (and (zerop (forward-line -1)) - (gnus-summary-article-number)))) - ;; If this is a gathered thread, we have to go some re-gathering. - (when (stringp (car thread)) - (let ((subject (car thread)) - roots thr) - (setq thread (cdr thread)) - (while thread - (unless (memq (setq thr (gnus-id-to-thread - (gnus-root-id - (mail-header-id (caar thread))))) - roots) - (push thr roots)) - (setq thread (cdr thread))) - ;; We now have all (unique) roots. - (if (= (length roots) 1) - ;; All the loose roots are now one solid root. - (setq thread (car roots)) - (setq thread (cons subject (gnus-sort-threads roots)))))) - (let (threads) - ;; We then insert this thread into the summary buffer. - (let (gnus-newsgroup-data gnus-newsgroup-threads) - (gnus-summary-prepare-threads (gnus-cut-threads (list thread))) - (setq data (nreverse gnus-newsgroup-data)) - (setq threads gnus-newsgroup-threads)) - ;; We splice the new data into the data structure. - (gnus-data-enter-list current data) - (gnus-data-compute-positions) - (setq gnus-newsgroup-threads (nconc threads gnus-newsgroup-threads))))) - -(defun gnus-number-to-header (number) - "Return the header for article NUMBER." - (let ((headers gnus-newsgroup-headers)) - (while (and headers - (not (= number (mail-header-number (car headers))))) - (pop headers)) - (when headers - (car headers)))) - -(defun gnus-id-to-thread (id) - "Return the (sub-)thread where ID appears." - (gnus-gethash id gnus-newsgroup-dependencies)) - -(defun gnus-id-to-article (id) - "Return the article number of ID." - (let ((thread (gnus-id-to-thread id))) - (when (and thread - (car thread)) - (mail-header-number (car thread))))) - -(defun gnus-id-to-header (id) - "Return the article headers of ID." - (car (gnus-id-to-thread id))) - -(defun gnus-article-displayed-root-p (article) - "Say whether ARTICLE is a root(ish) article." - (let ((level (gnus-summary-thread-level article)) - (refs (mail-header-references (gnus-summary-article-header article))) - particle) - (cond - ((null level) nil) - ((zerop level) t) - ((null refs) t) - ((null (gnus-parent-id refs)) t) - ((and (= 1 level) - (null (setq particle (gnus-id-to-article - (gnus-parent-id refs)))) - (null (gnus-summary-thread-level particle))))))) - -(defun gnus-root-id (id) - "Return the id of the root of the thread where ID appears." - (let (last-id prev) - (while (and id (setq prev (car (gnus-gethash - id gnus-newsgroup-dependencies)))) - (setq last-id id - id (gnus-parent-id (mail-header-references prev)))) - last-id)) - -(defun gnus-remove-thread (id &optional dont-remove) - "Remove the thread that has ID in it." - (let ((dep gnus-newsgroup-dependencies) - headers thread last-id) - ;; First go up in this thread until we find the root. - (setq last-id (gnus-root-id id)) - (setq headers (list (car (gnus-id-to-thread last-id)) - (caadr (gnus-id-to-thread last-id)))) - ;; We have now found the real root of this thread. It might have - ;; been gathered into some loose thread, so we have to search - ;; through the threads to find the thread we wanted. - (let ((threads gnus-newsgroup-threads) - sub) - (while threads - (setq sub (car threads)) - (if (stringp (car sub)) - ;; This is a gathered thread, so we look at the roots - ;; below it to find whether this article is in this - ;; gathered root. - (progn - (setq sub (cdr sub)) - (while sub - (when (member (caar sub) headers) - (setq thread (car threads) - threads nil - sub nil)) - (setq sub (cdr sub)))) - ;; It's an ordinary thread, so we check it. - (when (eq (car sub) (car headers)) - (setq thread sub - threads nil))) - (setq threads (cdr threads))) - ;; If this article is in no thread, then it's a root. - (if thread - (unless dont-remove - (setq gnus-newsgroup-threads (delq thread gnus-newsgroup-threads))) - (setq thread (gnus-gethash last-id dep))) - (when thread - (prog1 - thread ; We return this thread. - (unless dont-remove - (if (stringp (car thread)) - (progn - ;; If we use dummy roots, then we have to remove the - ;; dummy root as well. - (when (eq gnus-summary-make-false-root 'dummy) - ;; Uhm. - ) - (setq thread (cdr thread)) - (while thread - (gnus-remove-thread-1 (car thread)) - (setq thread (cdr thread)))) - (gnus-remove-thread-1 thread)))))))) - -(defun gnus-remove-thread-1 (thread) - "Remove the thread THREAD recursively." - (let ((number (mail-header-number (car thread))) - pos) - (when (setq pos (text-property-any - (point-min) (point-max) 'gnus-number number)) - (goto-char pos) - (gnus-delete-line) - (gnus-data-remove number)) - (setq thread (cdr thread)) - (while thread - (gnus-remove-thread-1 (pop thread))))) - -(defun gnus-sort-threads (threads) - "Sort THREADS." - (if (not gnus-thread-sort-functions) - threads - (let ((func (if (= 1 (length gnus-thread-sort-functions)) - (car gnus-thread-sort-functions) - `(lambda (t1 t2) - ,(gnus-make-sort-function - (reverse gnus-thread-sort-functions)))))) - (gnus-message 7 "Sorting threads...") - (prog1 - (sort threads func) - (gnus-message 7 "Sorting threads...done"))))) - -(defun gnus-sort-articles (articles) - "Sort ARTICLES." - (when gnus-article-sort-functions - (let ((func (if (= 1 (length gnus-article-sort-functions)) - (car gnus-article-sort-functions) - `(lambda (t1 t2) - ,(gnus-make-sort-function - (reverse gnus-article-sort-functions)))))) - (gnus-message 7 "Sorting articles...") - (prog1 - (setq gnus-newsgroup-headers (sort articles func)) - (gnus-message 7 "Sorting articles...done"))))) - -(defun gnus-make-sort-function (funs) - "Return a composite sort condition based on the functions in FUNC." - (if (cdr funs) - `(or (,(car funs) t1 t2) - (and (not (,(car funs) t2 t1)) - ,(gnus-make-sort-function (cdr funs)))) - `(,(car funs) t1 t2))) - -;; Written by Hallvard B Furuseth . -(defmacro gnus-thread-header (thread) - ;; Return header of first article in THREAD. - ;; Note that THREAD must never, ever be anything else than a variable - - ;; using some other form will lead to serious barfage. - (or (symbolp thread) (signal 'wrong-type-argument '(symbolp thread))) - ;; (8% speedup to gnus-summary-prepare, just for fun :-) - (list 'byte-code "\10\211:\203\17\0\211@;\203\16\0A@@\207" ; - (vector thread) 2)) - -(defsubst gnus-article-sort-by-number (h1 h2) - "Sort articles by article number." - (< (mail-header-number h1) - (mail-header-number h2))) - -(defun gnus-thread-sort-by-number (h1 h2) - "Sort threads by root article number." - (gnus-article-sort-by-number - (gnus-thread-header h1) (gnus-thread-header h2))) - -(defsubst gnus-article-sort-by-author (h1 h2) - "Sort articles by root author." - (string-lessp - (let ((extract (funcall - gnus-extract-address-components - (mail-header-from h1)))) - (or (car extract) (cdr extract))) - (let ((extract (funcall - gnus-extract-address-components - (mail-header-from h2)))) - (or (car extract) (cdr extract))))) - -(defun gnus-thread-sort-by-author (h1 h2) - "Sort threads by root author." - (gnus-article-sort-by-author - (gnus-thread-header h1) (gnus-thread-header h2))) - -(defsubst gnus-article-sort-by-subject (h1 h2) - "Sort articles by root subject." - (string-lessp - (downcase (gnus-simplify-subject-re (mail-header-subject h1))) - (downcase (gnus-simplify-subject-re (mail-header-subject h2))))) - -(defun gnus-thread-sort-by-subject (h1 h2) - "Sort threads by root subject." - (gnus-article-sort-by-subject - (gnus-thread-header h1) (gnus-thread-header h2))) - -(defsubst gnus-article-sort-by-date (h1 h2) - "Sort articles by root article date." - (string-lessp - (inline (gnus-sortable-date (mail-header-date h1))) - (inline (gnus-sortable-date (mail-header-date h2))))) - -(defun gnus-thread-sort-by-date (h1 h2) - "Sort threads by root article date." - (gnus-article-sort-by-date - (gnus-thread-header h1) (gnus-thread-header h2))) - -(defsubst gnus-article-sort-by-score (h1 h2) - "Sort articles by root article score. -Unscored articles will be counted as having a score of zero." - (> (or (cdr (assq (mail-header-number h1) - gnus-newsgroup-scored)) - gnus-summary-default-score 0) - (or (cdr (assq (mail-header-number h2) - gnus-newsgroup-scored)) - gnus-summary-default-score 0))) - -(defun gnus-thread-sort-by-score (h1 h2) - "Sort threads by root article score." - (gnus-article-sort-by-score - (gnus-thread-header h1) (gnus-thread-header h2))) - -(defun gnus-thread-sort-by-total-score (h1 h2) - "Sort threads by the sum of all scores in the thread. -Unscored articles will be counted as having a score of zero." - (> (gnus-thread-total-score h1) (gnus-thread-total-score h2))) - -(defun gnus-thread-total-score (thread) - ;; This function find the total score of THREAD. - (cond ((null thread) - 0) - ((consp thread) - (if (stringp (car thread)) - (apply gnus-thread-score-function 0 - (mapcar 'gnus-thread-total-score-1 (cdr thread))) - (gnus-thread-total-score-1 thread))) - (t - (gnus-thread-total-score-1 (list thread))))) - -(defun gnus-thread-total-score-1 (root) - ;; This function find the total score of the thread below ROOT. - (setq root (car root)) - (apply gnus-thread-score-function - (or (append - (mapcar 'gnus-thread-total-score - (cdr (gnus-gethash (mail-header-id root) - gnus-newsgroup-dependencies))) - (if (> (mail-header-number root) 0) - (list (or (cdr (assq (mail-header-number root) - gnus-newsgroup-scored)) - gnus-summary-default-score 0)))) - (list gnus-summary-default-score) - '(0)))) - -;; Added by Per Abrahamsen . -(defvar gnus-tmp-prev-subject nil) -(defvar gnus-tmp-false-parent nil) -(defvar gnus-tmp-root-expunged nil) -(defvar gnus-tmp-dummy-line nil) - -(defun gnus-summary-prepare-threads (threads) - "Prepare summary buffer from THREADS and indentation LEVEL. -THREADS is either a list of `(PARENT [(CHILD1 [(GRANDCHILD ...]...) ...])' -or a straight list of headers." - (gnus-message 7 "Generating summary...") - - (setq gnus-newsgroup-threads threads) - (beginning-of-line) - - (let ((gnus-tmp-level 0) - (default-score (or gnus-summary-default-score 0)) - (gnus-visual-p (gnus-visual-p 'summary-highlight 'highlight)) - thread number subject stack state gnus-tmp-gathered beg-match - new-roots gnus-tmp-new-adopts thread-end - gnus-tmp-header gnus-tmp-unread - gnus-tmp-replied gnus-tmp-subject-or-nil - gnus-tmp-dummy gnus-tmp-indentation gnus-tmp-lines gnus-tmp-score - gnus-tmp-score-char gnus-tmp-from gnus-tmp-name - gnus-tmp-number gnus-tmp-opening-bracket gnus-tmp-closing-bracket) - - (setq gnus-tmp-prev-subject nil) - - (if (vectorp (car threads)) - ;; If this is a straight (sic) list of headers, then a - ;; threaded summary display isn't required, so we just create - ;; an unthreaded one. - (gnus-summary-prepare-unthreaded threads) - - ;; Do the threaded display. - - (while (or threads stack gnus-tmp-new-adopts new-roots) - - (if (and (= gnus-tmp-level 0) - (not (setq gnus-tmp-dummy-line nil)) - (or (not stack) - (= (caar stack) 0)) - (not gnus-tmp-false-parent) - (or gnus-tmp-new-adopts new-roots)) - (if gnus-tmp-new-adopts - (setq gnus-tmp-level (if gnus-tmp-root-expunged 0 1) - thread (list (car gnus-tmp-new-adopts)) - gnus-tmp-header (caar thread) - gnus-tmp-new-adopts (cdr gnus-tmp-new-adopts)) - (if new-roots - (setq thread (list (car new-roots)) - gnus-tmp-header (caar thread) - new-roots (cdr new-roots)))) - - (if threads - ;; If there are some threads, we do them before the - ;; threads on the stack. - (setq thread threads - gnus-tmp-header (caar thread)) - ;; There were no current threads, so we pop something off - ;; the stack. - (setq state (car stack) - gnus-tmp-level (car state) - thread (cdr state) - stack (cdr stack) - gnus-tmp-header (caar thread)))) - - (setq gnus-tmp-false-parent nil) - (setq gnus-tmp-root-expunged nil) - (setq thread-end nil) - - (if (stringp gnus-tmp-header) - ;; The header is a dummy root. - (cond - ((eq gnus-summary-make-false-root 'adopt) - ;; We let the first article adopt the rest. - (setq gnus-tmp-new-adopts (nconc gnus-tmp-new-adopts - (cddar thread))) - (setq gnus-tmp-gathered - (nconc (mapcar - (lambda (h) (mail-header-number (car h))) - (cddar thread)) - gnus-tmp-gathered)) - (setq thread (cons (list (caar thread) - (cadar thread)) - (cdr thread))) - (setq gnus-tmp-level -1 - gnus-tmp-false-parent t)) - ((eq gnus-summary-make-false-root 'empty) - ;; We print adopted articles with empty subject fields. - (setq gnus-tmp-gathered - (nconc (mapcar - (lambda (h) (mail-header-number (car h))) - (cddar thread)) - gnus-tmp-gathered)) - (setq gnus-tmp-level -1)) - ((eq gnus-summary-make-false-root 'dummy) - ;; We remember that we probably want to output a dummy - ;; root. - (setq gnus-tmp-dummy-line gnus-tmp-header) - (setq gnus-tmp-prev-subject gnus-tmp-header)) - (t - ;; We do not make a root for the gathered - ;; sub-threads at all. - (setq gnus-tmp-level -1))) - - (setq number (mail-header-number gnus-tmp-header) - subject (mail-header-subject gnus-tmp-header)) - - (cond - ;; If the thread has changed subject, we might want to make - ;; this subthread into a root. - ((and (null gnus-thread-ignore-subject) - (not (zerop gnus-tmp-level)) - gnus-tmp-prev-subject - (not (inline - (gnus-subject-equal gnus-tmp-prev-subject subject)))) - (setq new-roots (nconc new-roots (list (car thread))) - thread-end t - gnus-tmp-header nil)) - ;; If the article lies outside the current limit, - ;; then we do not display it. - ((and (not (memq number gnus-newsgroup-limit)) - (not gnus-tmp-dummy-line)) - (setq gnus-tmp-gathered - (nconc (mapcar - (lambda (h) (mail-header-number (car h))) - (cdar thread)) - gnus-tmp-gathered)) - (setq gnus-tmp-new-adopts (if (cdar thread) - (append gnus-tmp-new-adopts - (cdar thread)) - gnus-tmp-new-adopts) - thread-end t - gnus-tmp-header nil) - (when (zerop gnus-tmp-level) - (setq gnus-tmp-root-expunged t))) - ;; Perhaps this article is to be marked as read? - ((and gnus-summary-mark-below - (< (or (cdr (assq number gnus-newsgroup-scored)) - default-score) - gnus-summary-mark-below) - ;; Don't touch sparse articles. - (not (memq number gnus-newsgroup-sparse)) - (not (memq number gnus-newsgroup-ancient))) - (setq gnus-newsgroup-unreads - (delq number gnus-newsgroup-unreads)) - (if gnus-newsgroup-auto-expire - (push number gnus-newsgroup-expirable) - (push (cons number gnus-low-score-mark) - gnus-newsgroup-reads)))) - - (when gnus-tmp-header - ;; We may have an old dummy line to output before this - ;; article. - (when gnus-tmp-dummy-line - (gnus-summary-insert-dummy-line - gnus-tmp-dummy-line (mail-header-number gnus-tmp-header)) - (setq gnus-tmp-dummy-line nil)) - - ;; Compute the mark. - (setq - gnus-tmp-unread - (cond - ((memq number gnus-newsgroup-unreads) gnus-unread-mark) - ((memq number gnus-newsgroup-marked) gnus-ticked-mark) - ((memq number gnus-newsgroup-dormant) gnus-dormant-mark) - ((memq number gnus-newsgroup-expirable) gnus-expirable-mark) - (t (or (cdr (assq number gnus-newsgroup-reads)) - gnus-ancient-mark)))) - - (push (gnus-data-make number gnus-tmp-unread (1+ (point)) - gnus-tmp-header gnus-tmp-level) - gnus-newsgroup-data) - - ;; Actually insert the line. - (setq - gnus-tmp-subject-or-nil - (cond - ((and gnus-thread-ignore-subject - gnus-tmp-prev-subject - (not (inline (gnus-subject-equal - gnus-tmp-prev-subject subject)))) - subject) - ((zerop gnus-tmp-level) - (if (and (eq gnus-summary-make-false-root 'empty) - (memq number gnus-tmp-gathered) - gnus-tmp-prev-subject - (inline (gnus-subject-equal - gnus-tmp-prev-subject subject))) - gnus-summary-same-subject - subject)) - (t gnus-summary-same-subject))) - (if (and (eq gnus-summary-make-false-root 'adopt) - (= gnus-tmp-level 1) - (memq number gnus-tmp-gathered)) - (setq gnus-tmp-opening-bracket ?\< - gnus-tmp-closing-bracket ?\>) - (setq gnus-tmp-opening-bracket ?\[ - gnus-tmp-closing-bracket ?\])) - (setq - gnus-tmp-indentation - (aref gnus-thread-indent-array gnus-tmp-level) - gnus-tmp-lines (mail-header-lines gnus-tmp-header) - gnus-tmp-score (or (cdr (assq number gnus-newsgroup-scored)) - gnus-summary-default-score 0) - gnus-tmp-score-char - (if (or (null gnus-summary-default-score) - (<= (abs (- gnus-tmp-score gnus-summary-default-score)) - gnus-summary-zcore-fuzz)) ? - (if (< gnus-tmp-score gnus-summary-default-score) - gnus-score-below-mark gnus-score-over-mark)) - gnus-tmp-replied - (cond ((memq number gnus-newsgroup-processable) - gnus-process-mark) - ((memq number gnus-newsgroup-cached) - gnus-cached-mark) - ((memq number gnus-newsgroup-replied) - gnus-replied-mark) - ((memq number gnus-newsgroup-saved) - gnus-saved-mark) - (t gnus-unread-mark)) - gnus-tmp-from (mail-header-from gnus-tmp-header) - gnus-tmp-name - (cond - ((string-match "(.+)" gnus-tmp-from) - (substring gnus-tmp-from - (1+ (match-beginning 0)) (1- (match-end 0)))) - ((string-match "<[^>]+> *$" gnus-tmp-from) - (setq beg-match (match-beginning 0)) - (or (and (string-match "^\"[^\"]*\"" gnus-tmp-from) - (substring gnus-tmp-from (1+ (match-beginning 0)) - (1- (match-end 0)))) - (substring gnus-tmp-from 0 beg-match))) - (t gnus-tmp-from))) - (when (string= gnus-tmp-name "") - (setq gnus-tmp-name gnus-tmp-from)) - (or (numberp gnus-tmp-lines) (setq gnus-tmp-lines 0)) - (gnus-put-text-property - (point) - (progn (eval gnus-summary-line-format-spec) (point)) - 'gnus-number number) - (when gnus-visual-p - (forward-line -1) - (run-hooks 'gnus-summary-update-hook) - (forward-line 1)) - - (setq gnus-tmp-prev-subject subject))) - - (when (nth 1 thread) - (push (cons (max 0 gnus-tmp-level) (nthcdr 1 thread)) stack)) - (incf gnus-tmp-level) - (setq threads (if thread-end nil (cdar thread))) - (unless threads - (setq gnus-tmp-level 0))))) - (gnus-message 7 "Generating summary...done")) - -(defun gnus-summary-prepare-unthreaded (headers) - "Generate an unthreaded summary buffer based on HEADERS." - (let (header number mark) - - (while headers - ;; We may have to root out some bad articles... - (when (memq (setq number (mail-header-number - (setq header (pop headers)))) - gnus-newsgroup-limit) - ;; Mark article as read when it has a low score. - (when (and gnus-summary-mark-below - (< (or (cdr (assq number gnus-newsgroup-scored)) - gnus-summary-default-score 0) - gnus-summary-mark-below) - (not (memq number gnus-newsgroup-ancient))) - (setq gnus-newsgroup-unreads - (delq number gnus-newsgroup-unreads)) - (if gnus-newsgroup-auto-expire - (push number gnus-newsgroup-expirable) - (push (cons number gnus-low-score-mark) - gnus-newsgroup-reads))) - - (setq mark - (cond - ((memq number gnus-newsgroup-marked) gnus-ticked-mark) - ((memq number gnus-newsgroup-dormant) gnus-dormant-mark) - ((memq number gnus-newsgroup-unreads) gnus-unread-mark) - ((memq number gnus-newsgroup-expirable) gnus-expirable-mark) - (t (or (cdr (assq number gnus-newsgroup-reads)) - gnus-ancient-mark)))) - (setq gnus-newsgroup-data - (cons (gnus-data-make number mark (1+ (point)) header 0) - gnus-newsgroup-data)) - (gnus-summary-insert-line - header 0 nil mark (memq number gnus-newsgroup-replied) - (memq number gnus-newsgroup-expirable) - (mail-header-subject header) nil - (cdr (assq number gnus-newsgroup-scored)) - (memq number gnus-newsgroup-processable)))))) - -(defun gnus-select-newsgroup (group &optional read-all) - "Select newsgroup GROUP. -If READ-ALL is non-nil, all articles in the group are selected." - (let* ((entry (gnus-gethash group gnus-newsrc-hashtb)) - (info (nth 2 entry)) - articles fetched-articles cached) - - (or (gnus-check-server - (setq gnus-current-select-method (gnus-find-method-for-group group))) - (error "Couldn't open server")) - - (or (and entry (not (eq (car entry) t))) ; Either it's active... - (gnus-activate-group group) ; Or we can activate it... - (progn ; Or we bug out. - (when (equal major-mode 'gnus-summary-mode) - (kill-buffer (current-buffer))) - (error "Couldn't request group %s: %s" - group (gnus-status-message group)))) - - (unless (gnus-request-group group t) - (when (equal major-mode 'gnus-summary-mode) - (kill-buffer (current-buffer))) - (error "Couldn't request group %s: %s" - group (gnus-status-message group))) - - (setq gnus-newsgroup-name group) - (setq gnus-newsgroup-unselected nil) - (setq gnus-newsgroup-unreads (gnus-list-of-unread-articles group)) - - (and gnus-asynchronous - (gnus-check-backend-function - 'request-asynchronous gnus-newsgroup-name) - (setq gnus-newsgroup-async - (gnus-request-asynchronous gnus-newsgroup-name))) - - ;; Adjust and set lists of article marks. - (when info - (gnus-adjust-marked-articles info)) - - ;; Kludge to avoid having cached articles nixed out in virtual groups. - (when (gnus-virtual-group-p group) - (setq cached gnus-newsgroup-cached)) - - (setq gnus-newsgroup-unreads - (gnus-set-difference - (gnus-set-difference gnus-newsgroup-unreads gnus-newsgroup-marked) - gnus-newsgroup-dormant)) - - (setq gnus-newsgroup-processable nil) - - (setq articles (gnus-articles-to-read group read-all)) - - (cond - ((null articles) - ;;(gnus-message 3 "Couldn't select newsgroup -- no articles to display") - 'quit) - ((eq articles 0) nil) - (t - ;; Init the dependencies hash table. - (setq gnus-newsgroup-dependencies - (gnus-make-hashtable (length articles))) - ;; Retrieve the headers and read them in. - (gnus-message 5 "Fetching headers for %s..." gnus-newsgroup-name) - (setq gnus-newsgroup-headers - (if (eq 'nov - (setq gnus-headers-retrieved-by - (gnus-retrieve-headers - articles gnus-newsgroup-name - ;; We might want to fetch old headers, but - ;; not if there is only 1 article. - (and gnus-fetch-old-headers - (or (and - (not (eq gnus-fetch-old-headers 'some)) - (not (numberp gnus-fetch-old-headers))) - (> (length articles) 1)))))) - (gnus-get-newsgroup-headers-xover articles) - (gnus-get-newsgroup-headers))) - (gnus-message 5 "Fetching headers for %s...done" gnus-newsgroup-name) - - ;; Kludge to avoid having cached articles nixed out in virtual groups. - (when cached - (setq gnus-newsgroup-cached cached)) - - ;; Set the initial limit. - (setq gnus-newsgroup-limit (copy-sequence articles)) - ;; Remove canceled articles from the list of unread articles. - (setq gnus-newsgroup-unreads - (gnus-set-sorted-intersection - gnus-newsgroup-unreads - (setq fetched-articles - (mapcar (lambda (headers) (mail-header-number headers)) - gnus-newsgroup-headers)))) - ;; Removed marked articles that do not exist. - (gnus-update-missing-marks - (gnus-sorted-complement fetched-articles articles)) - ;; We might want to build some more threads first. - (and gnus-fetch-old-headers - (eq gnus-headers-retrieved-by 'nov) - (gnus-build-old-threads)) - ;; Check whether auto-expire is to be done in this group. - (setq gnus-newsgroup-auto-expire - (gnus-group-auto-expirable-p group)) - ;; Set up the article buffer now, if necessary. - (unless gnus-single-article-buffer - (gnus-article-setup-buffer)) - ;; First and last article in this newsgroup. - (when gnus-newsgroup-headers - (setq gnus-newsgroup-begin - (mail-header-number (car gnus-newsgroup-headers)) - gnus-newsgroup-end - (mail-header-number - (gnus-last-element gnus-newsgroup-headers)))) - ;; GROUP is successfully selected. - (or gnus-newsgroup-headers t))))) - -(defun gnus-articles-to-read (group read-all) - ;; Find out what articles the user wants to read. - (let* ((articles - ;; Select all articles if `read-all' is non-nil, or if there - ;; are no unread articles. - (if (or read-all - (and (zerop (length gnus-newsgroup-marked)) - (zerop (length gnus-newsgroup-unreads)))) - (gnus-uncompress-range (gnus-active group)) - (sort (append gnus-newsgroup-dormant gnus-newsgroup-marked - (copy-sequence gnus-newsgroup-unreads)) - '<))) - (scored-list (gnus-killed-articles gnus-newsgroup-killed articles)) - (scored (length scored-list)) - (number (length articles)) - (marked (+ (length gnus-newsgroup-marked) - (length gnus-newsgroup-dormant))) - (select - (cond - ((numberp read-all) - read-all) - (t - (condition-case () - (cond - ((and (or (<= scored marked) (= scored number)) - (numberp gnus-large-newsgroup) - (> number gnus-large-newsgroup)) - (let ((input - (read-string - (format - "How many articles from %s (default %d): " - gnus-newsgroup-name number)))) - (if (string-match "^[ \t]*$" input) number input))) - ((and (> scored marked) (< scored number) - (> (- scored number) 20)) - (let ((input - (read-string - (format "%s %s (%d scored, %d total): " - "How many articles from" - group scored number)))) - (if (string-match "^[ \t]*$" input) - number input))) - (t number)) - (quit nil)))))) - (setq select (if (stringp select) (string-to-number select) select)) - (if (or (null select) (zerop select)) - select - (if (and (not (zerop scored)) (<= (abs select) scored)) - (progn - (setq articles (sort scored-list '<)) - (setq number (length articles))) - (setq articles (copy-sequence articles))) - - (if (< (abs select) number) - (if (< select 0) - ;; Select the N oldest articles. - (setcdr (nthcdr (1- (abs select)) articles) nil) - ;; Select the N most recent articles. - (setq articles (nthcdr (- number select) articles)))) - (setq gnus-newsgroup-unselected - (gnus-sorted-intersection - gnus-newsgroup-unreads - (gnus-sorted-complement gnus-newsgroup-unreads articles))) - articles))) - -(defun gnus-killed-articles (killed articles) - (let (out) - (while articles - (if (inline (gnus-member-of-range (car articles) killed)) - (setq out (cons (car articles) out))) - (setq articles (cdr articles))) - out)) - -(defun gnus-uncompress-marks (marks) - "Uncompress the mark ranges in MARKS." - (let ((uncompressed '(score bookmark)) - out) - (while marks - (if (memq (caar marks) uncompressed) - (push (car marks) out) - (push (cons (caar marks) (gnus-uncompress-range (cdar marks))) out)) - (setq marks (cdr marks))) - out)) - -(defun gnus-adjust-marked-articles (info) - "Set all article lists and remove all marks that are no longer legal." - (let* ((marked-lists (gnus-info-marks info)) - (active (gnus-active (gnus-info-group info))) - (min (car active)) - (max (cdr active)) - (types gnus-article-mark-lists) - (uncompressed '(score bookmark killed)) - marks var articles article mark) - - (while marked-lists - (setq marks (pop marked-lists)) - (set (setq var (intern (format "gnus-newsgroup-%s" - (car (rassq (setq mark (car marks)) - types))))) - (if (memq (car marks) uncompressed) (cdr marks) - (gnus-uncompress-range (cdr marks)))) - - (setq articles (symbol-value var)) - - ;; All articles have to be subsets of the active articles. - (cond - ;; Adjust "simple" lists. - ((memq mark '(tick dormant expirable reply save)) - (while articles - (when (or (< (setq article (pop articles)) min) (> article max)) - (set var (delq article (symbol-value var)))))) - ;; Adjust assocs. - ((memq mark uncompressed) - (while articles - (when (or (not (consp (setq article (pop articles)))) - (< (car article) min) - (> (car article) max)) - (set var (delq article (symbol-value var)))))))))) - -(defun gnus-update-missing-marks (missing) - "Go through the list of MISSING articles and remove them mark lists." - (when missing - (let ((types gnus-article-mark-lists) - var m) - ;; Go through all types. - (while types - (setq var (intern (format "gnus-newsgroup-%s" (car (pop types))))) - (when (symbol-value var) - ;; This list has articles. So we delete all missing articles - ;; from it. - (setq m missing) - (while m - (set var (delq (pop m) (symbol-value var))))))))) - -(defun gnus-update-marks () - "Enter the various lists of marked articles into the newsgroup info list." - (let ((types gnus-article-mark-lists) - (info (gnus-get-info gnus-newsgroup-name)) - (uncompressed '(score bookmark killed)) - type list newmarked symbol) - (when info - ;; Add all marks lists that are non-nil to the list of marks lists. - (while types - (setq type (pop types)) - (when (setq list (symbol-value - (setq symbol - (intern (format "gnus-newsgroup-%s" - (car type)))))) - (push (cons (cdr type) - (if (memq (cdr type) uncompressed) list - (gnus-compress-sequence - (set symbol (sort list '<)) t))) - newmarked))) - - ;; Enter these new marks into the info of the group. - (if (nthcdr 3 info) - (setcar (nthcdr 3 info) newmarked) - ;; Add the marks lists to the end of the info. - (when newmarked - (setcdr (nthcdr 2 info) (list newmarked)))) - - ;; Cut off the end of the info if there's nothing else there. - (let ((i 5)) - (while (and (> i 2) - (not (nth i info))) - (when (nthcdr (decf i) info) - (setcdr (nthcdr i info) nil))))))) - -(defun gnus-add-marked-articles (group type articles &optional info force) - ;; Add ARTICLES of TYPE to the info of GROUP. - ;; If INFO is non-nil, use that info. If FORCE is non-nil, don't - ;; add, but replace marked articles of TYPE with ARTICLES. - (let ((info (or info (gnus-get-info group))) - (uncompressed '(score bookmark killed)) - marked m) - (or (not info) - (and (not (setq marked (nthcdr 3 info))) - (or (null articles) - (setcdr (nthcdr 2 info) - (list (list (cons type (gnus-compress-sequence - articles t))))))) - (and (not (setq m (assq type (car marked)))) - (or (null articles) - (setcar marked - (cons (cons type (gnus-compress-sequence articles t) ) - (car marked))))) - (if force - (if (null articles) - (setcar (nthcdr 3 info) - (delq (assq type (car marked)) (car marked))) - (setcdr m (gnus-compress-sequence articles t))) - (setcdr m (gnus-compress-sequence - (sort (nconc (gnus-uncompress-range (cdr m)) - (copy-sequence articles)) '<) t)))))) - -(defun gnus-set-mode-line (where) - "This function sets the mode line of the article or summary buffers. -If WHERE is `summary', the summary mode line format will be used." - ;; Is this mode line one we keep updated? - (when (memq where gnus-updated-mode-lines) - (let (mode-string) - (save-excursion - ;; We evaluate this in the summary buffer since these - ;; variables are buffer-local to that buffer. - (set-buffer gnus-summary-buffer) - ;; We bind all these variables that are used in the `eval' form - ;; below. - (let* ((mformat (symbol-value - (intern - (format "gnus-%s-mode-line-format-spec" where)))) - (gnus-tmp-group-name gnus-newsgroup-name) - (gnus-tmp-article-number (or gnus-current-article 0)) - (gnus-tmp-unread gnus-newsgroup-unreads) - (gnus-tmp-unread-and-unticked (length gnus-newsgroup-unreads)) - (gnus-tmp-unselected (length gnus-newsgroup-unselected)) - (gnus-tmp-unread-and-unselected - (cond ((and (zerop gnus-tmp-unread-and-unticked) - (zerop gnus-tmp-unselected)) "") - ((zerop gnus-tmp-unselected) - (format "{%d more}" gnus-tmp-unread-and-unticked)) - (t (format "{%d(+%d) more}" - gnus-tmp-unread-and-unticked - gnus-tmp-unselected)))) - (gnus-tmp-subject - (if (and gnus-current-headers - (vectorp gnus-current-headers)) - (gnus-mode-string-quote - (mail-header-subject gnus-current-headers)) "")) - max-len - gnus-tmp-header);; passed as argument to any user-format-funcs - (setq mode-string (eval mformat)) - (setq max-len (max 4 (if gnus-mode-non-string-length - (- (window-width) - gnus-mode-non-string-length) - (length mode-string)))) - ;; We might have to chop a bit of the string off... - (when (> (length mode-string) max-len) - (setq mode-string - (concat (gnus-truncate-string 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))) - (set-buffer-modified-p t)))) - -(defun gnus-create-xref-hashtb (from-newsgroup headers unreads) - "Go through the HEADERS list and add all Xrefs to a hash table. -The resulting hash table is returned, or nil if no Xrefs were found." - (let* ((virtual (gnus-virtual-group-p from-newsgroup)) - (prefix (if virtual "" (gnus-group-real-prefix from-newsgroup))) - (xref-hashtb (make-vector 63 0)) - start group entry number xrefs header) - (while headers - (setq header (pop headers)) - (when (and (setq xrefs (mail-header-xref header)) - (not (memq (setq number (mail-header-number header)) - unreads))) - (setq start 0) - (while (string-match "\\([^ ]+\\)[:/]\\([0-9]+\\)" xrefs start) - (setq start (match-end 0)) - (setq group (if prefix - (concat prefix (substring xrefs (match-beginning 1) - (match-end 1))) - (substring xrefs (match-beginning 1) (match-end 1)))) - (setq number - (string-to-int (substring xrefs (match-beginning 2) - (match-end 2)))) - (if (setq entry (gnus-gethash group xref-hashtb)) - (setcdr entry (cons number (cdr entry))) - (gnus-sethash group (cons number nil) xref-hashtb))))) - (and start xref-hashtb))) - -(defun gnus-mark-xrefs-as-read (from-newsgroup headers unreads) - "Look through all the headers and mark the Xrefs as read." - (let ((virtual (gnus-virtual-group-p from-newsgroup)) - name entry info xref-hashtb idlist method nth4) - (save-excursion - (set-buffer gnus-group-buffer) - (when (setq xref-hashtb - (gnus-create-xref-hashtb from-newsgroup headers unreads)) - (mapatoms - (lambda (group) - (unless (string= from-newsgroup (setq name (symbol-name group))) - (setq idlist (symbol-value group)) - ;; Dead groups are not updated. - (and (prog1 - (setq entry (gnus-gethash name gnus-newsrc-hashtb) - info (nth 2 entry)) - (if (stringp (setq nth4 (gnus-info-method info))) - (setq nth4 (gnus-server-to-method nth4)))) - ;; Only do the xrefs if the group has the same - ;; select method as the group we have just read. - (or (gnus-methods-equal-p - nth4 (gnus-find-method-for-group from-newsgroup)) - virtual - (equal nth4 (setq method (gnus-find-method-for-group - from-newsgroup))) - (and (equal (car nth4) (car method)) - (equal (nth 1 nth4) (nth 1 method)))) - gnus-use-cross-reference - (or (not (eq gnus-use-cross-reference t)) - virtual - ;; Only do cross-references on subscribed - ;; groups, if that is what is wanted. - (<= (gnus-info-level info) gnus-level-subscribed)) - (gnus-group-make-articles-read name idlist)))) - xref-hashtb))))) - -(defun gnus-group-make-articles-read (group articles) - (let* ((num 0) - (entry (gnus-gethash group gnus-newsrc-hashtb)) - (info (nth 2 entry)) - (active (gnus-active group)) - range) - ;; First peel off all illegal article numbers. - (when active - (let ((ids articles) - id first) - (while (setq id (pop ids)) - (when (and first (> id (cdr active))) - ;; We'll end up in this situation in one particular - ;; obscure situation. If you re-scan a group and get - ;; a new article that is cross-posted to a different - ;; group that has not been re-scanned, you might get - ;; crossposted article that has a higher number than - ;; Gnus believes possible. So we re-activate this - ;; group as well. This might mean doing the - ;; crossposting thingy will *increase* the number - ;; of articles in some groups. Tsk, tsk. - (setq active (or (gnus-activate-group group) active))) - (when (or (> id (cdr active)) - (< id (car active))) - (setq articles (delq id articles)))))) - ;; If the read list is nil, we init it. - (and active - (null (gnus-info-read info)) - (> (car active) 1) - (gnus-info-set-read info (cons 1 (1- (car active))))) - ;; Then we add the read articles to the range. - (gnus-info-set-read - info - (setq range - (gnus-add-to-range - (gnus-info-read info) (setq articles (sort articles '<))))) - ;; Then we have to re-compute how many unread - ;; articles there are in this group. - (if active - (progn - (cond - ((not range) - (setq num (- (1+ (cdr active)) (car active)))) - ((not (listp (cdr range))) - (setq num (- (cdr active) (- (1+ (cdr range)) - (car range))))) - (t - (while range - (if (numberp (car range)) - (setq num (1+ num)) - (setq num (+ num (- (1+ (cdar range)) (caar range))))) - (setq range (cdr range))) - (setq num (- (cdr active) num)))) - ;; Update the number of unread articles. - (setcar entry num) - ;; Update the group buffer. - (gnus-group-update-group group t))))) - -(defun gnus-methods-equal-p (m1 m2) - (let ((m1 (or m1 gnus-select-method)) - (m2 (or m2 gnus-select-method))) - (or (equal m1 m2) - (and (eq (car m1) (car m2)) - (or (not (memq 'address (assoc (symbol-name (car m1)) - gnus-valid-select-methods))) - (equal (nth 1 m1) (nth 1 m2))))))) - -(defsubst gnus-header-value () - (buffer-substring (match-end 0) (gnus-point-at-eol))) - -(defvar gnus-newsgroup-none-id 0) - -(defun gnus-get-newsgroup-headers (&optional dependencies force-new) - (let ((cur nntp-server-buffer) - (dependencies - (or dependencies - (save-excursion (set-buffer gnus-summary-buffer) - gnus-newsgroup-dependencies))) - headers id id-dep ref-dep end ref) - (save-excursion - (set-buffer nntp-server-buffer) - (run-hooks 'gnus-parse-headers-hook) - (let ((case-fold-search t) - in-reply-to header p lines) - (goto-char (point-min)) - ;; Search to the beginning of the next header. Error messages - ;; do not begin with 2 or 3. - (while (re-search-forward "^[23][0-9]+ " nil t) - (setq id nil - ref nil) - ;; This implementation of this function, with nine - ;; search-forwards instead of the one re-search-forward and - ;; a case (which basically was the old function) is actually - ;; about twice as fast, even though it looks messier. You - ;; can't have everything, I guess. Speed and elegance - ;; doesn't always go hand in hand. - (setq - header - (vector - ;; Number. - (prog1 - (read cur) - (end-of-line) - (setq p (point)) - (narrow-to-region (point) - (or (and (search-forward "\n.\n" nil t) - (- (point) 2)) - (point)))) - ;; Subject. - (progn - (goto-char p) - (if (search-forward "\nsubject: " nil t) - (gnus-header-value) "(none)")) - ;; From. - (progn - (goto-char p) - (if (search-forward "\nfrom: " nil t) - (gnus-header-value) "(nobody)")) - ;; Date. - (progn - (goto-char p) - (if (search-forward "\ndate: " nil t) - (gnus-header-value) "")) - ;; Message-ID. - (progn - (goto-char p) - (if (search-forward "\nmessage-id: " nil t) - (setq id (gnus-header-value)) - ;; If there was no message-id, we just fake one to make - ;; subsequent routines simpler. - (setq id (concat "none+" - (int-to-string - (setq gnus-newsgroup-none-id - (1+ gnus-newsgroup-none-id))))))) - ;; References. - (progn - (goto-char p) - (if (search-forward "\nreferences: " nil t) - (progn - (setq end (point)) - (prog1 - (gnus-header-value) - (setq ref - (buffer-substring - (progn - (end-of-line) - (search-backward ">" end t) - (1+ (point))) - (progn - (search-backward "<" end t) - (point)))))) - ;; Get the references from the in-reply-to header if there - ;; were no references and the in-reply-to header looks - ;; promising. - (if (and (search-forward "\nin-reply-to: " nil t) - (setq in-reply-to (gnus-header-value)) - (string-match "<[^>]+>" in-reply-to)) - (setq ref (substring in-reply-to (match-beginning 0) - (match-end 0))) - (setq ref "")))) - ;; Chars. - 0 - ;; Lines. - (progn - (goto-char p) - (if (search-forward "\nlines: " nil t) - (if (numberp (setq lines (read cur))) - lines 0) - 0)) - ;; Xref. - (progn - (goto-char p) - (and (search-forward "\nxref: " nil t) - (gnus-header-value))))) - ;; We do the threading while we read the headers. The - ;; message-id and the last reference are both entered into - ;; the same hash table. Some tippy-toeing around has to be - ;; done in case an article has arrived before the article - ;; which it refers to. - (if (boundp (setq id-dep (intern id dependencies))) - (if (and (car (symbol-value id-dep)) - (not force-new)) - ;; An article with this Message-ID has already - ;; been seen, so we ignore this one, except we add - ;; any additional Xrefs (in case the two articles - ;; came from different servers). - (progn - (mail-header-set-xref - (car (symbol-value id-dep)) - (concat (or (mail-header-xref - (car (symbol-value id-dep))) "") - (or (mail-header-xref header) ""))) - (setq header nil)) - (setcar (symbol-value id-dep) header)) - (set id-dep (list header))) - (when header - (if (boundp (setq ref-dep (intern ref dependencies))) - (setcdr (symbol-value ref-dep) - (nconc (cdr (symbol-value ref-dep)) - (list (symbol-value id-dep)))) - (set ref-dep (list nil (symbol-value id-dep)))) - (setq headers (cons header headers))) - (goto-char (point-max)) - (widen)) - (nreverse headers))))) - -;; The following macros and functions were written by Felix Lee -;; . - -(defmacro gnus-nov-read-integer () - '(prog1 - (if (= (following-char) ?\t) - 0 - (let ((num (condition-case nil (read buffer) (error nil)))) - (if (numberp num) num 0))) - (or (eobp) (forward-char 1)))) - -(defmacro gnus-nov-skip-field () - '(search-forward "\t" eol 'move)) - -(defmacro gnus-nov-field () - '(buffer-substring (point) (if (gnus-nov-skip-field) (1- (point)) eol))) - -;; Goes through the xover lines and returns a list of vectors -(defun gnus-get-newsgroup-headers-xover (sequence &optional - force-new dependencies) - "Parse the news overview data in the server buffer, and return a -list of headers that match SEQUENCE (see `nntp-retrieve-headers')." - ;; Get the Xref when the users reads the articles since most/some - ;; NNTP servers do not include Xrefs when using XOVER. - (setq gnus-article-internal-prepare-hook '(gnus-article-get-xrefs)) - (let ((cur nntp-server-buffer) - (dependencies (or dependencies gnus-newsgroup-dependencies)) - number headers header) - (save-excursion - (set-buffer nntp-server-buffer) - ;; Allow the user to mangle the headers before parsing them. - (run-hooks 'gnus-parse-headers-hook) - (goto-char (point-min)) - (while (and sequence (not (eobp))) - (setq number (read cur)) - (while (and sequence (< (car sequence) number)) - (setq sequence (cdr sequence))) - (and sequence - (eq number (car sequence)) - (progn - (setq sequence (cdr sequence)) - (if (setq header - (inline (gnus-nov-parse-line - number dependencies force-new))) - (setq headers (cons header headers))))) - (forward-line 1)) - (setq headers (nreverse headers))) - headers)) - -;; This function has to be called with point after the article number -;; on the beginning of the line. -(defun gnus-nov-parse-line (number dependencies &optional force-new) - (let ((none 0) - (eol (gnus-point-at-eol)) - (buffer (current-buffer)) - header ref id id-dep ref-dep) - - ;; overview: [num subject from date id refs chars lines misc] - (narrow-to-region (point) eol) - (or (eobp) (forward-char)) - - (condition-case nil - (setq header - (vector - number ; number - (gnus-nov-field) ; subject - (gnus-nov-field) ; from - (gnus-nov-field) ; date - (setq id (or (gnus-nov-field) - (concat "none+" - (int-to-string - (setq none (1+ none)))))) ; id - (progn - (save-excursion - (let ((beg (point))) - (search-forward "\t" eol) - (if (search-backward ">" beg t) - (setq ref - (buffer-substring - (1+ (point)) - (search-backward "<" beg t))) - (setq ref nil)))) - (gnus-nov-field)) ; refs - (gnus-nov-read-integer) ; chars - (gnus-nov-read-integer) ; lines - (if (= (following-char) ?\n) - nil - (gnus-nov-field)) ; misc - )) - (error (progn - (gnus-error 4 "Strange nov line") - (setq header nil) - (goto-char eol)))) - - (widen) - - ;; We build the thread tree. - (when header - (if (boundp (setq id-dep (intern id dependencies))) - (if (and (car (symbol-value id-dep)) - (not force-new)) - ;; An article with this Message-ID has already been seen, - ;; so we ignore this one, except we add any additional - ;; Xrefs (in case the two articles came from different - ;; servers. - (progn - (mail-header-set-xref - (car (symbol-value id-dep)) - (concat (or (mail-header-xref - (car (symbol-value id-dep))) "") - (or (mail-header-xref header) ""))) - (setq header nil)) - (setcar (symbol-value id-dep) header)) - (set id-dep (list header)))) - (when header - (if (boundp (setq ref-dep (intern (or ref "none") dependencies))) - (setcdr (symbol-value ref-dep) - (nconc (cdr (symbol-value ref-dep)) - (list (symbol-value id-dep)))) - (set ref-dep (list nil (symbol-value id-dep))))) - header)) - -(defun gnus-article-get-xrefs () - "Fill in the Xref value in `gnus-current-headers', if necessary. -This is meant to be called in `gnus-article-internal-prepare-hook'." - (let ((headers (save-excursion (set-buffer gnus-summary-buffer) - gnus-current-headers))) - (or (not gnus-use-cross-reference) - (not headers) - (and (mail-header-xref headers) - (not (string= (mail-header-xref headers) ""))) - (let ((case-fold-search t) - xref) - (save-restriction - (nnheader-narrow-to-headers) - (goto-char (point-min)) - (if (or (and (eq (downcase (following-char)) ?x) - (looking-at "Xref:")) - (search-forward "\nXref:" nil t)) - (progn - (goto-char (1+ (match-end 0))) - (setq xref (buffer-substring (point) - (progn (end-of-line) (point)))) - (mail-header-set-xref headers xref)))))))) - -(defun gnus-summary-insert-subject (id &optional old-header use-old-header) - "Find article ID and insert the summary line for that article." - (let ((header (if (and old-header use-old-header) - old-header (gnus-read-header id))) - (number (and (numberp id) id)) - pos) - (when header - ;; Rebuild the thread that this article is part of and go to the - ;; article we have fetched. - (when (and (not gnus-show-threads) - old-header) - (when (setq pos (text-property-any - (point-min) (point-max) 'gnus-number - (mail-header-number old-header))) - (goto-char pos) - (gnus-delete-line) - (gnus-data-remove (mail-header-number old-header)))) - (when old-header - (mail-header-set-number header (mail-header-number old-header))) - (setq gnus-newsgroup-sparse - (delq (setq number (mail-header-number header)) - gnus-newsgroup-sparse)) - (setq gnus-newsgroup-ancient (delq number gnus-newsgroup-ancient)) - (gnus-rebuild-thread (mail-header-id header)) - (gnus-summary-goto-subject number nil t)) - (when (and (numberp number) - (> number 0)) - ;; We have to update the boundaries even if we can't fetch the - ;; article if ID is a number -- so that the next `P' or `N' - ;; command will fetch the previous (or next) article even - ;; if the one we tried to fetch this time has been canceled. - (and (> number gnus-newsgroup-end) - (setq gnus-newsgroup-end number)) - (and (< number gnus-newsgroup-begin) - (setq gnus-newsgroup-begin number)) - (setq gnus-newsgroup-unselected - (delq number gnus-newsgroup-unselected))) - ;; Report back a success? - (and header (mail-header-number header)))) - -(defun gnus-summary-work-articles (n) - "Return a list of articles to be worked upon. The prefix argument, -the list of process marked articles, and the current article will be -taken into consideration." - (cond - (n - ;; A numerical prefix has been given. - (let ((backward (< n 0)) - (n (abs (prefix-numeric-value n))) - articles article) - (save-excursion - (while - (and (> n 0) - (push (setq article (gnus-summary-article-number)) - articles) - (if backward - (gnus-summary-find-prev nil article) - (gnus-summary-find-next nil article))) - (decf n))) - (nreverse articles))) - ((and (boundp 'transient-mark-mode) - transient-mark-mode - mark-active) - ;; Work on the region between point and mark. - (let ((max (max (point) (mark))) - articles article) - (save-excursion - (goto-char (min (point) (mark))) - (while - (and - (push (setq article (gnus-summary-article-number)) articles) - (gnus-summary-find-next nil article) - (< (point) max))) - (nreverse articles)))) - (gnus-newsgroup-processable - ;; There are process-marked articles present. - (reverse gnus-newsgroup-processable)) - (t - ;; Just return the current article. - (list (gnus-summary-article-number))))) - -(defun gnus-summary-search-group (&optional backward use-level) - "Search for next unread newsgroup. -If optional argument BACKWARD is non-nil, search backward instead." - (save-excursion - (set-buffer gnus-group-buffer) - (if (gnus-group-search-forward - backward nil (if use-level (gnus-group-group-level) nil)) - (gnus-group-group-name)))) - -(defun gnus-summary-best-group (&optional exclude-group) - "Find the name of the best unread group. -If EXCLUDE-GROUP, do not go to this group." - (save-excursion - (set-buffer gnus-group-buffer) - (save-excursion - (gnus-group-best-unread-group exclude-group)))) - -(defun gnus-summary-find-next (&optional unread article backward) - (if backward (gnus-summary-find-prev) - (let* ((dummy (gnus-summary-article-intangible-p)) - (article (or article (gnus-summary-article-number))) - (arts (gnus-data-find-list article)) - result) - (when (and (not dummy) - (or (not gnus-summary-check-current) - (not unread) - (not (gnus-data-unread-p (car arts))))) - (setq arts (cdr arts))) - (when (setq result - (if unread - (progn - (while arts - (when (gnus-data-unread-p (car arts)) - (setq result (car arts) - arts nil)) - (setq arts (cdr arts))) - result) - (car arts))) - (goto-char (gnus-data-pos result)) - (gnus-data-number result))))) - -(defun gnus-summary-find-prev (&optional unread article) - (let* ((eobp (eobp)) - (article (or article (gnus-summary-article-number))) - (arts (gnus-data-find-list article (gnus-data-list 'rev))) - result) - (when (and (not eobp) - (or (not gnus-summary-check-current) - (not unread) - (not (gnus-data-unread-p (car arts))))) - (setq arts (cdr arts))) - (if (setq result - (if unread - (progn - (while arts - (and (gnus-data-unread-p (car arts)) - (setq result (car arts) - arts nil)) - (setq arts (cdr arts))) - result) - (car arts))) - (progn - (goto-char (gnus-data-pos result)) - (gnus-data-number result))))) - -(defun gnus-summary-find-subject (subject &optional unread backward article) - (let* ((simp-subject (gnus-simplify-subject-fully subject)) - (article (or article (gnus-summary-article-number))) - (articles (gnus-data-list backward)) - (arts (gnus-data-find-list article articles)) - result) - (when (or (not gnus-summary-check-current) - (not unread) - (not (gnus-data-unread-p (car arts)))) - (setq arts (cdr arts))) - (while arts - (and (or (not unread) - (gnus-data-unread-p (car arts))) - (vectorp (gnus-data-header (car arts))) - (gnus-subject-equal - simp-subject (mail-header-subject (gnus-data-header (car arts))) t) - (setq result (car arts) - arts nil)) - (setq arts (cdr arts))) - (and result - (goto-char (gnus-data-pos result)) - (gnus-data-number result)))) - -(defun gnus-summary-search-forward (&optional unread subject backward) - "Search forward for an article. -If UNREAD, look for unread articles. If SUBJECT, look for -articles with that subject. If BACKWARD, search backward instead." - (cond (subject (gnus-summary-find-subject subject unread backward)) - (backward (gnus-summary-find-prev unread)) - (t (gnus-summary-find-next unread)))) - -(defun gnus-recenter (&optional n) - "Center point in window and redisplay frame. -Also do horizontal recentering." - (interactive "P") - (when (and gnus-auto-center-summary - (not (eq gnus-auto-center-summary 'vertical))) - (gnus-horizontal-recenter)) - (recenter n)) - -(defun gnus-summary-recenter () - "Center point in the summary window. -If `gnus-auto-center-summary' is nil, or the article buffer isn't -displayed, no centering will be performed." - ;; Suggested by earle@mahendo.JPL.NASA.GOV (Greg Earle). - ;; Recenter only when requested. Suggested by popovich@park.cs.columbia.edu. - (let* ((top (cond ((< (window-height) 4) 0) - ((< (window-height) 7) 1) - (t 2))) - (height (1- (window-height))) - (bottom (save-excursion (goto-char (point-max)) - (forward-line (- height)) - (point))) - (window (get-buffer-window (current-buffer)))) - ;; The user has to want it. - (when gnus-auto-center-summary - (when (get-buffer-window gnus-article-buffer) - ;; Only do recentering when the article buffer is displayed, - ;; Set the window start to either `bottom', which is the biggest - ;; possible valid number, or the second line from the top, - ;; whichever is the least. - (set-window-start - window (min bottom (save-excursion - (forward-line (- top)) (point))))) - ;; Do horizontal recentering while we're at it. - (when (and (get-buffer-window (current-buffer) t) - (not (eq gnus-auto-center-summary 'vertical))) - (let ((selected (selected-window))) - (select-window (get-buffer-window (current-buffer) t)) - (gnus-summary-position-point) - (gnus-horizontal-recenter) - (select-window selected)))))) - -(defun gnus-horizontal-recenter () - "Recenter the current buffer horizontally." - (if (< (current-column) (/ (window-width) 2)) - (set-window-hscroll (get-buffer-window (current-buffer) t) 0) - (let* ((orig (point)) - (end (window-end (get-buffer-window (current-buffer) t))) - (max 0)) - ;; Find the longest line currently displayed in the window. - (goto-char (window-start)) - (while (and (not (eobp)) - (< (point) end)) - (end-of-line) - (setq max (max max (current-column))) - (forward-line 1)) - (goto-char orig) - ;; Scroll horizontally to center (sort of) the point. - (if (> max (window-width)) - (set-window-hscroll - (get-buffer-window (current-buffer) t) - (min (- (current-column) (/ (window-width) 3)) - (+ 2 (- max (window-width))))) - (set-window-hscroll (get-buffer-window (current-buffer) t) 0)) - max))) - -;; Function written by Stainless Steel Rat . +;; Function written by Stainless Steel Rat (defun gnus-short-group-name (group &optional levels) - "Collapse GROUP name LEVELS." - (let* ((name "") - (foreign "") - (depth 0) - (skip 1) + "Collapse GROUP name LEVELS. +Select methods are stripped and any remote host name is stripped down to +just the host name." + (let* ((name "") (foreign "") (depth -1) (skip 1) (levels (or levels (progn (while (string-match "\\." group skip) (setq skip (match-end 0) depth (+ depth 1))) depth)))) - (if (string-match ":" group) - (setq foreign (substring group 0 (match-end 0)) - group (substring group (match-end 0)))) + ;; separate foreign select method from group name and collapse. + ;; if method contains a server, collapse to non-domain server name, + ;; otherwise collapse to select method + (when (string-match ":" group) + (cond ((string-match "+" group) + (let* ((plus (string-match "+" group)) + (colon (string-match ":" group (or plus 0))) + (dot (string-match "\\." group))) + (setq foreign (concat + (substring group (+ 1 plus) + (cond ((null dot) colon) + ((< colon dot) colon) + ((< dot colon) dot))) + ":") + group (substring group (+ 1 colon))))) + (t + (let* ((colon (string-match ":" group))) + (setq foreign (concat (substring group 0 (+ 1 colon))) + group (substring group (+ 1 colon))))))) + ;; collapse group name leaving LEVELS uncollapsed elements (while group - (if (and (string-match "\\." group) - (> levels (- gnus-group-uncollapsed-levels 1))) + (if (and (string-match "\\." group) (> levels 0)) (setq name (concat name (substring group 0 1)) group (substring group (match-end 0)) levels (- levels 1) @@ -9890,5117 +2283,11 @@ group nil))) name)) -(defun gnus-summary-jump-to-group (newsgroup) - "Move point to NEWSGROUP in group mode buffer." - ;; Keep update point of group mode buffer if visible. - (if (eq (current-buffer) (get-buffer gnus-group-buffer)) - (save-window-excursion - ;; Take care of tree window mode. - (if (get-buffer-window gnus-group-buffer) - (pop-to-buffer gnus-group-buffer)) - (gnus-group-jump-to-group newsgroup)) - (save-excursion - ;; Take care of tree window mode. - (if (get-buffer-window gnus-group-buffer) - (pop-to-buffer gnus-group-buffer) - (set-buffer gnus-group-buffer)) - (gnus-group-jump-to-group newsgroup)))) - -;; This function returns a list of article numbers based on the -;; difference between the ranges of read articles in this group and -;; the range of active articles. -(defun gnus-list-of-unread-articles (group) - (let* ((read (gnus-info-read (gnus-get-info group))) - (active (gnus-active group)) - (last (cdr active)) - first nlast unread) - ;; If none are read, then all are unread. - (if (not read) - (setq first (car active)) - ;; If the range of read articles is a single range, then the - ;; first unread article is the article after the last read - ;; article. Sounds logical, doesn't it? - (if (not (listp (cdr read))) - (setq first (1+ (cdr read))) - ;; `read' is a list of ranges. - (if (/= (setq nlast (or (and (numberp (car read)) (car read)) - (caar read))) 1) - (setq first 1)) - (while read - (if first - (while (< first nlast) - (setq unread (cons first unread)) - (setq first (1+ first)))) - (setq first (1+ (if (atom (car read)) (car read) (cdar read)))) - (setq nlast (if (atom (cadr read)) (cadr read) (caadr read))) - (setq read (cdr read))))) - ;; And add the last unread articles. - (while (<= first last) - (setq unread (cons first unread)) - (setq first (1+ first))) - ;; Return the list of unread articles. - (nreverse unread))) - -(defun gnus-list-of-read-articles (group) - "Return a list of unread, unticked and non-dormant articles." - (let* ((info (gnus-get-info group)) - (marked (gnus-info-marks info)) - (active (gnus-active group))) - (and info active - (gnus-set-difference - (gnus-sorted-complement - (gnus-uncompress-range active) - (gnus-list-of-unread-articles group)) - (append - (gnus-uncompress-range (cdr (assq 'dormant marked))) - (gnus-uncompress-range (cdr (assq 'tick marked)))))))) - -;; Various summary commands - -(defun gnus-summary-universal-argument (arg) - "Perform any operation on all articles that are process/prefixed." - (interactive "P") - (gnus-set-global-variables) - (let ((articles (gnus-summary-work-articles arg)) - func article) - (if (eq - (setq - func - (key-binding - (read-key-sequence - (substitute-command-keys - "\\\\[gnus-summary-universal-argument]" - )))) - 'undefined) - (gnus-error 1 "Undefined key") - (save-excursion - (while articles - (gnus-summary-goto-subject (setq article (pop articles))) - (command-execute func) - (gnus-summary-remove-process-mark article))))) - (gnus-summary-position-point)) - -(defun gnus-summary-toggle-truncation (&optional arg) - "Toggle truncation of summary lines. -With arg, turn line truncation on iff arg is positive." - (interactive "P") - (setq truncate-lines - (if (null arg) (not truncate-lines) - (> (prefix-numeric-value arg) 0))) - (redraw-display)) - -(defun gnus-summary-reselect-current-group (&optional all rescan) - "Exit and then reselect the current newsgroup. -The prefix argument ALL means to select all articles." - (interactive "P") - (gnus-set-global-variables) - (when (gnus-ephemeral-group-p gnus-newsgroup-name) - (error "Ephemeral groups can't be reselected")) - (let ((current-subject (gnus-summary-article-number)) - (group gnus-newsgroup-name)) - (setq gnus-newsgroup-begin nil) - (gnus-summary-exit) - ;; We have to adjust the point of group mode buffer because the - ;; current point was moved to the next unread newsgroup by - ;; exiting. - (gnus-summary-jump-to-group group) - (when rescan - (save-excursion - (gnus-group-get-new-news-this-group 1))) - (gnus-group-read-group all t) - (gnus-summary-goto-subject current-subject nil t))) - -(defun gnus-summary-rescan-group (&optional all) - "Exit the newsgroup, ask for new articles, and select the newsgroup." - (interactive "P") - (gnus-summary-reselect-current-group all t)) - -(defun gnus-summary-update-info () - (let* ((group gnus-newsgroup-name)) - (when gnus-newsgroup-kill-headers - (setq gnus-newsgroup-killed - (gnus-compress-sequence - (nconc - (gnus-set-sorted-intersection - (gnus-uncompress-range gnus-newsgroup-killed) - (setq gnus-newsgroup-unselected - (sort gnus-newsgroup-unselected '<))) - (setq gnus-newsgroup-unreads - (sort gnus-newsgroup-unreads '<))) t))) - (unless (listp (cdr gnus-newsgroup-killed)) - (setq gnus-newsgroup-killed (list gnus-newsgroup-killed))) - (let ((headers gnus-newsgroup-headers)) - (run-hooks 'gnus-exit-group-hook) - (unless gnus-save-score - (setq gnus-newsgroup-scored nil)) - ;; Set the new ranges of read articles. - (gnus-update-read-articles - group (append gnus-newsgroup-unreads gnus-newsgroup-unselected)) - ;; Set the current article marks. - (gnus-update-marks) - ;; Do the cross-ref thing. - (when gnus-use-cross-reference - (gnus-mark-xrefs-as-read group headers gnus-newsgroup-unreads)) - ;; Do adaptive scoring, and possibly save score files. - (when gnus-newsgroup-adaptive - (gnus-score-adaptive)) - (when gnus-use-scoring - (gnus-score-save)) - ;; Do not switch windows but change the buffer to work. - (set-buffer gnus-group-buffer) - (or (gnus-ephemeral-group-p gnus-newsgroup-name) - (gnus-group-update-group group))))) - -(defun gnus-summary-exit (&optional temporary) - "Exit reading current newsgroup, and then return to group selection mode. -gnus-exit-group-hook is called with no arguments if that value is non-nil." - (interactive) - (gnus-set-global-variables) - (gnus-kill-save-kill-buffer) - (let* ((group gnus-newsgroup-name) - (quit-config (gnus-group-quit-config gnus-newsgroup-name)) - (mode major-mode) - (buf (current-buffer))) - (run-hooks 'gnus-summary-prepare-exit-hook) - ;; If we have several article buffers, we kill them at exit. - (unless gnus-single-article-buffer - (gnus-kill-buffer gnus-original-article-buffer) - (setq gnus-article-current nil)) - (when gnus-use-cache - (gnus-cache-possibly-remove-articles) - (gnus-cache-save-buffers)) - (when gnus-use-trees - (gnus-tree-close group)) - ;; Make all changes in this group permanent. - (unless quit-config - (gnus-summary-update-info)) - (gnus-close-group group) - ;; Make sure where I was, and go to next newsgroup. - (set-buffer gnus-group-buffer) - (unless quit-config - (gnus-group-jump-to-group group)) - (run-hooks 'gnus-summary-exit-hook) - (unless quit-config - (gnus-group-next-unread-group 1)) - (if temporary - nil ;Nothing to do. - ;; If we have several article buffers, we kill them at exit. - (unless gnus-single-article-buffer - (gnus-kill-buffer gnus-article-buffer) - (gnus-kill-buffer gnus-original-article-buffer) - (setq gnus-article-current nil)) - (set-buffer buf) - (if (not gnus-kill-summary-on-exit) - (gnus-deaden-summary) - ;; We set all buffer-local variables to nil. It is unclear why - ;; this is needed, but if we don't, buffer-local variables are - ;; not garbage-collected, it seems. This would the lead to en - ;; ever-growing Emacs. - (gnus-summary-clear-local-variables) - (when (get-buffer gnus-article-buffer) - (bury-buffer gnus-article-buffer)) - ;; We clear the global counterparts of the buffer-local - ;; variables as well, just to be on the safe side. - (gnus-configure-windows 'group 'force) - (gnus-summary-clear-local-variables) - ;; Return to group mode buffer. - (if (eq mode 'gnus-summary-mode) - (gnus-kill-buffer buf))) - (setq gnus-current-select-method gnus-select-method) - (pop-to-buffer gnus-group-buffer) - ;; Clear the current group name. - (if (not quit-config) - (progn - (gnus-group-jump-to-group group) - (gnus-group-next-unread-group 1) - (gnus-configure-windows 'group 'force)) - (if (not (buffer-name (car quit-config))) - (gnus-configure-windows 'group 'force) - (set-buffer (car quit-config)) - (and (eq major-mode 'gnus-summary-mode) - (gnus-set-global-variables)) - (gnus-configure-windows (cdr quit-config)))) - (unless quit-config - (setq gnus-newsgroup-name nil))))) - -(defalias 'gnus-summary-quit 'gnus-summary-exit-no-update) -(defun gnus-summary-exit-no-update (&optional no-questions) - "Quit reading current newsgroup without updating read article info." - (interactive) - (gnus-set-global-variables) - (let* ((group gnus-newsgroup-name) - (quit-config (gnus-group-quit-config group))) - (when (or no-questions - gnus-expert-user - (gnus-y-or-n-p "Do you really wanna quit reading this group? ")) - ;; If we have several article buffers, we kill them at exit. - (unless gnus-single-article-buffer - (gnus-kill-buffer gnus-article-buffer) - (gnus-kill-buffer gnus-original-article-buffer) - (setq gnus-article-current nil)) - (if (not gnus-kill-summary-on-exit) - (gnus-deaden-summary) - (gnus-close-group group) - (gnus-summary-clear-local-variables) - (set-buffer gnus-group-buffer) - (gnus-summary-clear-local-variables) - (when (get-buffer gnus-summary-buffer) - (kill-buffer gnus-summary-buffer))) - (unless gnus-single-article-buffer - (setq gnus-article-current nil)) - (when gnus-use-trees - (gnus-tree-close group)) - (when (get-buffer gnus-article-buffer) - (bury-buffer gnus-article-buffer)) - ;; Return to the group buffer. - (gnus-configure-windows 'group 'force) - ;; Clear the current group name. - (setq gnus-newsgroup-name nil) - (when (equal (gnus-group-group-name) group) - (gnus-group-next-unread-group 1)) - (when quit-config - (if (not (buffer-name (car quit-config))) - (gnus-configure-windows 'group 'force) - (set-buffer (car quit-config)) - (when (eq major-mode 'gnus-summary-mode) - (gnus-set-global-variables)) - (gnus-configure-windows (cdr quit-config))))))) - -;;; Dead summaries. - -(defvar gnus-dead-summary-mode-map nil) - -(if gnus-dead-summary-mode-map - nil - (setq gnus-dead-summary-mode-map (make-keymap)) - (suppress-keymap gnus-dead-summary-mode-map) - (substitute-key-definition - 'undefined 'gnus-summary-wake-up-the-dead gnus-dead-summary-mode-map) - (let ((keys '("\C-d" "\r" "\177"))) - (while keys - (define-key gnus-dead-summary-mode-map - (pop keys) 'gnus-summary-wake-up-the-dead)))) - -(defvar gnus-dead-summary-mode nil - "Minor mode for Gnus summary buffers.") - -(defun gnus-dead-summary-mode (&optional arg) - "Minor mode for Gnus summary buffers." - (interactive "P") - (when (eq major-mode 'gnus-summary-mode) - (make-local-variable 'gnus-dead-summary-mode) - (setq gnus-dead-summary-mode - (if (null arg) (not gnus-dead-summary-mode) - (> (prefix-numeric-value arg) 0))) - (when gnus-dead-summary-mode - (unless (assq 'gnus-dead-summary-mode minor-mode-alist) - (push '(gnus-dead-summary-mode " Dead") minor-mode-alist)) - (unless (assq 'gnus-dead-summary-mode minor-mode-map-alist) - (push (cons 'gnus-dead-summary-mode gnus-dead-summary-mode-map) - minor-mode-map-alist))))) - -(defun gnus-deaden-summary () - "Make the current summary buffer into a dead summary buffer." - ;; Kill any previous dead summary buffer. - (when (and gnus-dead-summary - (buffer-name gnus-dead-summary)) - (save-excursion - (set-buffer gnus-dead-summary) - (when gnus-dead-summary-mode - (kill-buffer (current-buffer))))) - ;; Make this the current dead summary. - (setq gnus-dead-summary (current-buffer)) - (gnus-dead-summary-mode 1) - (let ((name (buffer-name))) - (when (string-match "Summary" name) - (rename-buffer - (concat (substring name 0 (match-beginning 0)) "Dead " - (substring name (match-beginning 0))) t)))) - -(defun gnus-kill-or-deaden-summary (buffer) - "Kill or deaden the summary BUFFER." - (when (and (buffer-name buffer) - (not gnus-single-article-buffer)) - (save-excursion - (set-buffer buffer) - (gnus-kill-buffer gnus-article-buffer) - (gnus-kill-buffer gnus-original-article-buffer))) - (cond (gnus-kill-summary-on-exit - (when (and gnus-use-trees - (and (get-buffer buffer) - (buffer-name (get-buffer buffer)))) - (save-excursion - (set-buffer (get-buffer buffer)) - (gnus-tree-close gnus-newsgroup-name))) - (gnus-kill-buffer buffer)) - ((and (get-buffer buffer) - (buffer-name (get-buffer buffer))) - (save-excursion - (set-buffer buffer) - (gnus-deaden-summary))))) - -(defun gnus-summary-wake-up-the-dead (&rest args) - "Wake up the dead summary buffer." - (interactive) - (gnus-dead-summary-mode -1) - (let ((name (buffer-name))) - (when (string-match "Dead " name) - (rename-buffer - (concat (substring name 0 (match-beginning 0)) - (substring name (match-end 0))) t))) - (gnus-message 3 "This dead summary is now alive again")) - -;; Suggested by Andrew Eskilsson . -(defun gnus-summary-fetch-faq (&optional faq-dir) - "Fetch the FAQ for the current group. -If FAQ-DIR (the prefix), prompt for a directory to search for the faq -in." - (interactive - (list - (if current-prefix-arg - (completing-read - "Faq dir: " (and (listp gnus-group-faq-directory) - gnus-group-faq-directory))))) - (let (gnus-faq-buffer) - (and (setq gnus-faq-buffer - (gnus-group-fetch-faq gnus-newsgroup-name faq-dir)) - (gnus-configure-windows 'summary-faq)))) - -;; Suggested by Per Abrahamsen . -(defun gnus-summary-describe-group (&optional force) - "Describe the current newsgroup." - (interactive "P") - (gnus-group-describe-group force gnus-newsgroup-name)) - -(defun gnus-summary-describe-briefly () - "Describe summary mode commands briefly." - (interactive) - (gnus-message 6 - (substitute-command-keys "\\\\[gnus-summary-next-page]:Select \\[gnus-summary-next-unread-article]:Forward \\[gnus-summary-prev-unread-article]:Backward \\[gnus-summary-exit]:Exit \\[gnus-info-find-node]:Run Info \\[gnus-summary-describe-briefly]:This help"))) - -;; Walking around group mode buffer from summary mode. - -(defun gnus-summary-next-group (&optional no-article target-group backward) - "Exit current newsgroup and then select next unread newsgroup. -If prefix argument NO-ARTICLE is non-nil, no article is selected -initially. If NEXT-GROUP, go to this group. If BACKWARD, go to -previous group instead." - (interactive "P") - (gnus-set-global-variables) - (let ((current-group gnus-newsgroup-name) - (current-buffer (current-buffer)) - entered) - ;; First we semi-exit this group to update Xrefs and all variables. - ;; We can't do a real exit, because the window conf must remain - ;; the same in case the user is prompted for info, and we don't - ;; want the window conf to change before that... - (gnus-summary-exit t) - (while (not entered) - ;; Then we find what group we are supposed to enter. - (set-buffer gnus-group-buffer) - (gnus-group-jump-to-group current-group) - (setq target-group - (or target-group - (if (eq gnus-keep-same-level 'best) - (gnus-summary-best-group gnus-newsgroup-name) - (gnus-summary-search-group backward gnus-keep-same-level)))) - (if (not target-group) - ;; There are no further groups, so we return to the group - ;; buffer. - (progn - (gnus-message 5 "Returning to the group buffer") - (setq entered t) - (set-buffer current-buffer) - (gnus-summary-exit)) - ;; We try to enter the target group. - (gnus-group-jump-to-group target-group) - (let ((unreads (gnus-group-group-unread))) - (if (and (or (eq t unreads) - (and unreads (not (zerop unreads)))) - (gnus-summary-read-group - target-group nil no-article current-buffer)) - (setq entered t) - (setq current-group target-group - target-group nil))))))) - -(defun gnus-summary-prev-group (&optional no-article) - "Exit current newsgroup and then select previous unread newsgroup. -If prefix argument NO-ARTICLE is non-nil, no article is selected initially." - (interactive "P") - (gnus-summary-next-group no-article nil t)) - -;; Walking around summary lines. - -(defun gnus-summary-first-subject (&optional unread) - "Go to the first unread subject. -If UNREAD is non-nil, go to the first unread article. -Returns the article selected or nil if there are no unread articles." - (interactive "P") - (prog1 - (cond - ;; Empty summary. - ((null gnus-newsgroup-data) - (gnus-message 3 "No articles in the group") - nil) - ;; Pick the first article. - ((not unread) - (goto-char (gnus-data-pos (car gnus-newsgroup-data))) - (gnus-data-number (car gnus-newsgroup-data))) - ;; No unread articles. - ((null gnus-newsgroup-unreads) - (gnus-message 3 "No more unread articles") - nil) - ;; Find the first unread article. - (t - (let ((data gnus-newsgroup-data)) - (while (and data - (not (gnus-data-unread-p (car data)))) - (setq data (cdr data))) - (if data - (progn - (goto-char (gnus-data-pos (car data))) - (gnus-data-number (car data))))))) - (gnus-summary-position-point))) - -(defun gnus-summary-next-subject (n &optional unread dont-display) - "Go to next N'th summary line. -If N is negative, go to the previous N'th subject line. -If UNREAD is non-nil, only unread articles are selected. -The difference between N and the actual number of steps taken is -returned." - (interactive "p") - (let ((backward (< n 0)) - (n (abs n))) - (while (and (> n 0) - (if backward - (gnus-summary-find-prev unread) - (gnus-summary-find-next unread))) - (setq n (1- n))) - (if (/= 0 n) (gnus-message 7 "No more%s articles" - (if unread " unread" ""))) - (unless dont-display - (gnus-summary-recenter) - (gnus-summary-position-point)) - n)) - -(defun gnus-summary-next-unread-subject (n) - "Go to next N'th unread summary line." - (interactive "p") - (gnus-summary-next-subject n t)) - -(defun gnus-summary-prev-subject (n &optional unread) - "Go to previous N'th summary line. -If optional argument UNREAD is non-nil, only unread article is selected." - (interactive "p") - (gnus-summary-next-subject (- n) unread)) - -(defun gnus-summary-prev-unread-subject (n) - "Go to previous N'th unread summary line." - (interactive "p") - (gnus-summary-next-subject (- n) t)) - -(defun gnus-summary-goto-subject (article &optional force silent) - "Go the subject line of ARTICLE. -If FORCE, also allow jumping to articles not currently shown." - (let ((b (point)) - (data (gnus-data-find article))) - ;; We read in the article if we have to. - (and (not data) - force - (gnus-summary-insert-subject article (and (vectorp force) force) t) - (setq data (gnus-data-find article))) - (goto-char b) - (if (not data) - (progn - (unless silent - (gnus-message 3 "Can't find article %d" article)) - nil) - (goto-char (gnus-data-pos data)) - article))) - -;; Walking around summary lines with displaying articles. - -(defun gnus-summary-expand-window (&optional arg) - "Make the summary buffer take up the entire Emacs frame. -Given a prefix, will force an `article' buffer configuration." - (interactive "P") - (gnus-set-global-variables) - (if arg - (gnus-configure-windows 'article 'force) - (gnus-configure-windows 'summary 'force))) - -(defun gnus-summary-display-article (article &optional all-header) - "Display ARTICLE in article buffer." - (gnus-set-global-variables) - (if (null article) - nil - (prog1 - (if gnus-summary-display-article-function - (funcall gnus-summary-display-article-function article all-header) - (gnus-article-prepare article all-header)) - (run-hooks 'gnus-select-article-hook) - (unless (zerop gnus-current-article) - (gnus-summary-goto-subject gnus-current-article)) - (gnus-summary-recenter) - (when gnus-use-trees - (gnus-possibly-generate-tree article) - (gnus-highlight-selected-tree article)) - ;; Successfully display article. - (gnus-article-set-window-start - (cdr (assq article gnus-newsgroup-bookmarks)))))) - -(defun gnus-summary-select-article (&optional all-headers force pseudo article) - "Select the current article. -If ALL-HEADERS is non-nil, show all header fields. If FORCE is -non-nil, the article will be re-fetched even if it already present in -the article buffer. If PSEUDO is non-nil, pseudo-articles will also -be displayed." - ;; Make sure we are in the summary buffer to work around bbdb bug. - (unless (eq major-mode 'gnus-summary-mode) - (set-buffer gnus-summary-buffer)) - (let ((article (or article (gnus-summary-article-number))) - (all-headers (not (not all-headers))) ;Must be T or NIL. - gnus-summary-display-article-function - did) - (and (not pseudo) - (gnus-summary-article-pseudo-p article) - (error "This is a pseudo-article.")) - (prog1 - (save-excursion - (set-buffer gnus-summary-buffer) - (if (or (and gnus-single-article-buffer - (or (null gnus-current-article) - (null gnus-article-current) - (null (get-buffer gnus-article-buffer)) - (not (eq article (cdr gnus-article-current))) - (not (equal (car gnus-article-current) - gnus-newsgroup-name)))) - (and (not gnus-single-article-buffer) - (or (null gnus-current-article) - (not (eq gnus-current-article article)))) - force) - ;; The requested article is different from the current article. - (prog1 - (gnus-summary-display-article article all-headers) - (setq did article)) - (if (or all-headers gnus-show-all-headers) - (gnus-article-show-all-headers)) - 'old)) - (if did - (gnus-article-set-window-start - (cdr (assq article gnus-newsgroup-bookmarks))))))) - -(defun gnus-summary-set-current-mark (&optional current-mark) - "Obsolete function." - nil) - -(defun gnus-summary-next-article (&optional unread subject backward push) - "Select the next article. -If UNREAD, only unread articles are selected. -If SUBJECT, only articles with SUBJECT are selected. -If BACKWARD, the previous article is selected instead of the next." - (interactive "P") - (gnus-set-global-variables) - (cond - ;; Is there such an article? - ((and (gnus-summary-search-forward unread subject backward) - (or (gnus-summary-display-article (gnus-summary-article-number)) - (eq (gnus-summary-article-mark) gnus-canceled-mark))) - (gnus-summary-position-point)) - ;; If not, we try the first unread, if that is wanted. - ((and subject - gnus-auto-select-same - (gnus-summary-first-unread-article)) - (gnus-summary-position-point) - (gnus-message 6 "Wrapped")) - ;; Try to get next/previous article not displayed in this group. - ((and gnus-auto-extend-newsgroup - (not unread) (not subject)) - (gnus-summary-goto-article - (if backward (1- gnus-newsgroup-begin) (1+ gnus-newsgroup-end)) - nil t)) - ;; Go to next/previous group. - (t - (or (gnus-ephemeral-group-p gnus-newsgroup-name) - (gnus-summary-jump-to-group gnus-newsgroup-name)) - (let ((cmd last-command-char) - (group - (if (eq gnus-keep-same-level 'best) - (gnus-summary-best-group gnus-newsgroup-name) - (gnus-summary-search-group backward gnus-keep-same-level)))) - ;; For some reason, the group window gets selected. We change - ;; it back. - (select-window (get-buffer-window (current-buffer))) - ;; Select next unread newsgroup automagically. - (cond - ((or (not gnus-auto-select-next) - (not cmd)) - (gnus-message 7 "No more%s articles" (if unread " unread" ""))) - ((or (eq gnus-auto-select-next 'quietly) - (and (eq gnus-auto-select-next 'slightly-quietly) - push) - (and (eq gnus-auto-select-next 'almost-quietly) - (gnus-summary-last-article-p))) - ;; Select quietly. - (if (gnus-ephemeral-group-p gnus-newsgroup-name) - (gnus-summary-exit) - (gnus-message 7 "No more%s articles (%s)..." - (if unread " unread" "") - (if group (concat "selecting " group) - "exiting")) - (gnus-summary-next-group nil group backward))) - (t - (gnus-summary-walk-group-buffer - gnus-newsgroup-name cmd unread backward))))))) - -(defun gnus-summary-walk-group-buffer (from-group cmd unread backward) - (let ((keystrokes '((?\C-n (gnus-group-next-unread-group 1)) - (?\C-p (gnus-group-prev-unread-group 1)))) - keve key group ended) - (save-excursion - (set-buffer gnus-group-buffer) - (gnus-summary-jump-to-group from-group) - (setq group - (if (eq gnus-keep-same-level 'best) - (gnus-summary-best-group gnus-newsgroup-name) - (gnus-summary-search-group backward gnus-keep-same-level)))) - (while (not ended) - (gnus-message - 5 "No more%s articles%s" (if unread " unread" "") - (if (and group - (not (gnus-ephemeral-group-p gnus-newsgroup-name))) - (format " (Type %s for %s [%s])" - (single-key-description cmd) group - (car (gnus-gethash group gnus-newsrc-hashtb))) - (format " (Type %s to exit %s)" - (single-key-description cmd) - gnus-newsgroup-name))) - ;; Confirm auto selection. - (setq key (car (setq keve (gnus-read-event-char)))) - (setq ended t) - (cond - ((assq key keystrokes) - (let ((obuf (current-buffer))) - (switch-to-buffer gnus-group-buffer) - (and group - (gnus-group-jump-to-group group)) - (eval (cadr (assq key keystrokes))) - (setq group (gnus-group-group-name)) - (switch-to-buffer obuf)) - (setq ended nil)) - ((equal key cmd) - (if (or (not group) - (gnus-ephemeral-group-p gnus-newsgroup-name)) - (gnus-summary-exit) - (gnus-summary-next-group nil group backward))) - (t - (push (cdr keve) unread-command-events)))))) - -(defun gnus-read-event-char () - "Get the next event." - (let ((event (read-event))) - (cons (and (numberp event) event) event))) - -(defun gnus-summary-next-unread-article () - "Select unread article after current one." - (interactive) - (gnus-summary-next-article t (and gnus-auto-select-same - (gnus-summary-article-subject)))) - -(defun gnus-summary-prev-article (&optional unread subject) - "Select the article after the current one. -If UNREAD is non-nil, only unread articles are selected." - (interactive "P") - (gnus-summary-next-article unread subject t)) - -(defun gnus-summary-prev-unread-article () - "Select unred article before current one." - (interactive) - (gnus-summary-prev-article t (and gnus-auto-select-same - (gnus-summary-article-subject)))) - -(defun gnus-summary-next-page (&optional lines circular) - "Show next page of the selected article. -If at the end of the current article, select the next article. -LINES says how many lines should be scrolled up. - -If CIRCULAR is non-nil, go to the start of the article instead of -selecting the next article when reaching the end of the current -article." - (interactive "P") - (setq gnus-summary-buffer (current-buffer)) - (gnus-set-global-variables) - (let ((article (gnus-summary-article-number)) - (endp nil)) - (gnus-configure-windows 'article) - (if (eq (cdr (assq article gnus-newsgroup-reads)) gnus-canceled-mark) - (if (and (eq gnus-summary-goto-unread 'never) - (not (gnus-summary-last-article-p article))) - (gnus-summary-next-article) - (gnus-summary-next-unread-article)) - (if (or (null gnus-current-article) - (null gnus-article-current) - (/= article (cdr gnus-article-current)) - (not (equal (car gnus-article-current) gnus-newsgroup-name))) - ;; Selected subject is different from current article's. - (gnus-summary-display-article article) - (gnus-eval-in-buffer-window gnus-article-buffer - (setq endp (gnus-article-next-page lines))) - (if endp - (cond (circular - (gnus-summary-beginning-of-article)) - (lines - (gnus-message 3 "End of message")) - ((null lines) - (if (and (eq gnus-summary-goto-unread 'never) - (not (gnus-summary-last-article-p article))) - (gnus-summary-next-article) - (gnus-summary-next-unread-article))))))) - (gnus-summary-recenter) - (gnus-summary-position-point))) - -(defun gnus-summary-prev-page (&optional lines) - "Show previous page of selected article. -Argument LINES specifies lines to be scrolled down." - (interactive "P") - (gnus-set-global-variables) - (let ((article (gnus-summary-article-number))) - (gnus-configure-windows 'article) - (if (or (null gnus-current-article) - (null gnus-article-current) - (/= article (cdr gnus-article-current)) - (not (equal (car gnus-article-current) gnus-newsgroup-name))) - ;; Selected subject is different from current article's. - (gnus-summary-display-article article) - (gnus-summary-recenter) - (gnus-eval-in-buffer-window gnus-article-buffer - (gnus-article-prev-page lines)))) - (gnus-summary-position-point)) - -(defun gnus-summary-scroll-up (lines) - "Scroll up (or down) one line current article. -Argument LINES specifies lines to be scrolled up (or down if negative)." - (interactive "p") - (gnus-set-global-variables) - (gnus-configure-windows 'article) - (gnus-summary-show-thread) - (when (eq (gnus-summary-select-article nil nil 'pseudo) 'old) - (gnus-eval-in-buffer-window gnus-article-buffer - (cond ((> lines 0) - (if (gnus-article-next-page lines) - (gnus-message 3 "End of message"))) - ((< lines 0) - (gnus-article-prev-page (- lines)))))) - (gnus-summary-recenter) - (gnus-summary-position-point)) - -(defun gnus-summary-next-same-subject () - "Select next article which has the same subject as current one." - (interactive) - (gnus-set-global-variables) - (gnus-summary-next-article nil (gnus-summary-article-subject))) - -(defun gnus-summary-prev-same-subject () - "Select previous article which has the same subject as current one." - (interactive) - (gnus-set-global-variables) - (gnus-summary-prev-article nil (gnus-summary-article-subject))) - -(defun gnus-summary-next-unread-same-subject () - "Select next unread article which has the same subject as current one." - (interactive) - (gnus-set-global-variables) - (gnus-summary-next-article t (gnus-summary-article-subject))) - -(defun gnus-summary-prev-unread-same-subject () - "Select previous unread article which has the same subject as current one." - (interactive) - (gnus-set-global-variables) - (gnus-summary-prev-article t (gnus-summary-article-subject))) - -(defun gnus-summary-first-unread-article () - "Select the first unread article. -Return nil if there are no unread articles." - (interactive) - (gnus-set-global-variables) - (prog1 - (if (gnus-summary-first-subject t) - (progn - (gnus-summary-show-thread) - (gnus-summary-first-subject t) - (gnus-summary-display-article (gnus-summary-article-number)))) - (gnus-summary-position-point))) - -(defun gnus-summary-best-unread-article () - "Select the unread article with the highest score." - (interactive) - (gnus-set-global-variables) - (let ((best -1000000) - (data gnus-newsgroup-data) - article score) - (while data - (and (gnus-data-unread-p (car data)) - (> (setq score - (gnus-summary-article-score (gnus-data-number (car data)))) - best) - (setq best score - article (gnus-data-number (car data)))) - (setq data (cdr data))) - (prog1 - (if article - (gnus-summary-goto-article article) - (error "No unread articles")) - (gnus-summary-position-point)))) - -(defun gnus-summary-last-subject () - "Go to the last displayed subject line in the group." - (let ((article (gnus-data-number (car (gnus-data-list t))))) - (when article - (gnus-summary-goto-subject article)))) - -(defun gnus-summary-goto-article (article &optional all-headers force) - "Fetch ARTICLE and display it if it exists. -If ALL-HEADERS is non-nil, no header lines are hidden." - (interactive - (list - (string-to-int - (completing-read - "Article number: " - (mapcar (lambda (number) (list (int-to-string number))) - gnus-newsgroup-limit))) - current-prefix-arg - t)) - (prog1 - (if (gnus-summary-goto-subject article force) - (gnus-summary-display-article article all-headers) - (gnus-message 4 "Couldn't go to article %s" article) nil) - (gnus-summary-position-point))) - -(defun gnus-summary-goto-last-article () - "Go to the previously read article." - (interactive) - (prog1 - (and gnus-last-article - (gnus-summary-goto-article gnus-last-article)) - (gnus-summary-position-point))) - -(defun gnus-summary-pop-article (number) - "Pop one article off the history and go to the previous. -NUMBER articles will be popped off." - (interactive "p") - (let (to) - (setq gnus-newsgroup-history - (cdr (setq to (nthcdr number gnus-newsgroup-history)))) - (if to - (gnus-summary-goto-article (car to)) - (error "Article history empty"))) - (gnus-summary-position-point)) - -;; Summary commands and functions for limiting the summary buffer. - -(defun gnus-summary-limit-to-articles (n) - "Limit the summary buffer to the next N articles. -If not given a prefix, use the process marked articles instead." - (interactive "P") - (gnus-set-global-variables) - (prog1 - (let ((articles (gnus-summary-work-articles n))) - (setq gnus-newsgroup-processable nil) - (gnus-summary-limit articles)) - (gnus-summary-position-point))) - -(defun gnus-summary-pop-limit (&optional total) - "Restore the previous limit. -If given a prefix, remove all limits." - (interactive "P") - (gnus-set-global-variables) - (when total - (setq gnus-newsgroup-limits - (list (mapcar (lambda (h) (mail-header-number h)) - gnus-newsgroup-headers)))) - (unless gnus-newsgroup-limits - (error "No limit to pop")) - (prog1 - (gnus-summary-limit nil 'pop) - (gnus-summary-position-point))) - -(defun gnus-summary-limit-to-subject (subject &optional header) - "Limit the summary buffer to articles that have subjects that match a regexp." - (interactive "sRegexp: ") - (unless header - (setq header "subject")) - (when (not (equal "" subject)) - (prog1 - (let ((articles (gnus-summary-find-matching - (or header "subject") subject 'all))) - (or articles (error "Found no matches for \"%s\"" subject)) - (gnus-summary-limit articles)) - (gnus-summary-position-point)))) - -(defun gnus-summary-limit-to-author (from) - "Limit the summary buffer to articles that have authors that match a regexp." - (interactive "sRegexp: ") - (gnus-summary-limit-to-subject from "from")) - -(defalias 'gnus-summary-delete-marked-as-read 'gnus-summary-limit-to-unread) -(make-obsolete - 'gnus-summary-delete-marked-as-read 'gnus-summary-limit-to-unread) - -(defun gnus-summary-limit-to-unread (&optional all) - "Limit the summary buffer to articles that are not marked as read. -If ALL is non-nil, limit strictly to unread articles." - (interactive "P") - (if all - (gnus-summary-limit-to-marks (char-to-string gnus-unread-mark)) - (gnus-summary-limit-to-marks - ;; Concat all the marks that say that an article is read and have - ;; those removed. - (list gnus-del-mark gnus-read-mark gnus-ancient-mark - gnus-killed-mark gnus-kill-file-mark - gnus-low-score-mark gnus-expirable-mark - gnus-canceled-mark gnus-catchup-mark gnus-sparse-mark) - 'reverse))) - -(defalias 'gnus-summary-delete-marked-with 'gnus-summary-limit-to-marks) -(make-obsolete 'gnus-summary-delete-marked-with 'gnus-summary-limit-to-marks) - -(defun gnus-summary-limit-to-marks (marks &optional reverse) - "Limit the summary buffer to articles that are marked with MARKS (e.g. \"DK\"). -If REVERSE, limit the summary buffer to articles that are not marked -with MARKS. MARKS can either be a string of marks or a list of marks. -Returns how many articles were removed." - (interactive "sMarks: ") - (gnus-set-global-variables) - (prog1 - (let ((data gnus-newsgroup-data) - (marks (if (listp marks) marks - (append marks nil))) ; Transform to list. - articles) - (while data - (and (if reverse (not (memq (gnus-data-mark (car data)) marks)) - (memq (gnus-data-mark (car data)) marks)) - (setq articles (cons (gnus-data-number (car data)) articles))) - (setq data (cdr data))) - (gnus-summary-limit articles)) - (gnus-summary-position-point))) - -(defun gnus-summary-limit-to-score (&optional score) - "Limit to articles with score at or above SCORE." - (interactive "P") - (gnus-set-global-variables) - (setq score (if score - (prefix-numeric-value score) - (or gnus-summary-default-score 0))) - (let ((data gnus-newsgroup-data) - articles) - (while data - (when (>= (gnus-summary-article-score (gnus-data-number (car data))) - score) - (push (gnus-data-number (car data)) articles)) - (setq data (cdr data))) - (prog1 - (gnus-summary-limit articles) - (gnus-summary-position-point)))) - -(defun gnus-summary-limit-include-dormant () - "Display all the hidden articles that are marked as dormant." - (interactive) - (gnus-set-global-variables) - (or gnus-newsgroup-dormant - (error "There are no dormant articles in this group")) - (prog1 - (gnus-summary-limit (append gnus-newsgroup-dormant gnus-newsgroup-limit)) - (gnus-summary-position-point))) - -(defun gnus-summary-limit-exclude-dormant () - "Hide all dormant articles." - (interactive) - (gnus-set-global-variables) - (prog1 - (gnus-summary-limit-to-marks (list gnus-dormant-mark) 'reverse) - (gnus-summary-position-point))) - -(defun gnus-summary-limit-exclude-childless-dormant () - "Hide all dormant articles that have no children." - (interactive) - (gnus-set-global-variables) - (let ((data (gnus-data-list t)) - articles d children) - ;; Find all articles that are either not dormant or have - ;; children. - (while (setq d (pop data)) - (when (or (not (= (gnus-data-mark d) gnus-dormant-mark)) - (and (setq children - (gnus-article-children (gnus-data-number d))) - (let (found) - (while children - (when (memq (car children) articles) - (setq children nil - found t)) - (pop children)) - found))) - (push (gnus-data-number d) articles))) - ;; Do the limiting. - (prog1 - (gnus-summary-limit articles) - (gnus-summary-position-point)))) - -(defun gnus-summary-limit-mark-excluded-as-read (&optional all) - "Mark all unread excluded articles as read. -If ALL, mark even excluded ticked and dormants as read." - (interactive "P") - (let ((articles (gnus-sorted-complement - (sort - (mapcar (lambda (h) (mail-header-number h)) - gnus-newsgroup-headers) - '<) - (sort gnus-newsgroup-limit '<))) - article) - (setq gnus-newsgroup-unreads nil) - (if all - (setq gnus-newsgroup-dormant nil - gnus-newsgroup-marked nil - gnus-newsgroup-reads - (nconc - (mapcar (lambda (n) (cons n gnus-catchup-mark)) articles) - gnus-newsgroup-reads)) - (while (setq article (pop articles)) - (unless (or (memq article gnus-newsgroup-dormant) - (memq article gnus-newsgroup-marked)) - (push (cons article gnus-catchup-mark) gnus-newsgroup-reads)))))) - -(defun gnus-summary-limit (articles &optional pop) - (if pop - ;; We pop the previous limit off the stack and use that. - (setq articles (car gnus-newsgroup-limits) - gnus-newsgroup-limits (cdr gnus-newsgroup-limits)) - ;; We use the new limit, so we push the old limit on the stack. - (setq gnus-newsgroup-limits - (cons gnus-newsgroup-limit gnus-newsgroup-limits))) - ;; Set the limit. - (setq gnus-newsgroup-limit articles) - (let ((total (length gnus-newsgroup-data)) - (data (gnus-data-find-list (gnus-summary-article-number))) - (gnus-summary-mark-below nil) ; Inhibit this. - found) - ;; This will do all the work of generating the new summary buffer - ;; according to the new limit. - (gnus-summary-prepare) - ;; Hide any threads, possibly. - (and gnus-show-threads - gnus-thread-hide-subtree - (gnus-summary-hide-all-threads)) - ;; Try to return to the article you were at, or one in the - ;; neighborhood. - (if data - ;; We try to find some article after the current one. - (while data - (and (gnus-summary-goto-subject - (gnus-data-number (car data)) nil t) - (setq data nil - found t)) - (setq data (cdr data)))) - (or found - ;; If there is no data, that means that we were after the last - ;; article. The same goes when we can't find any articles - ;; after the current one. - (progn - (goto-char (point-max)) - (gnus-summary-find-prev))) - ;; We return how many articles were removed from the summary - ;; buffer as a result of the new limit. - (- total (length gnus-newsgroup-data)))) - -(defsubst gnus-invisible-cut-children (threads) - (let ((num 0)) - (while threads - (when (memq (mail-header-number (caar threads)) gnus-newsgroup-limit) - (incf num)) - (pop threads)) - (< num 2))) - -(defsubst gnus-cut-thread (thread) - "Go forwards in the thread until we find an article that we want to display." - (when (or (eq gnus-fetch-old-headers 'some) - (eq gnus-build-sparse-threads 'some) - (eq gnus-build-sparse-threads 'more)) - ;; Deal with old-fetched headers and sparse threads. - (while (and - thread - (or - (memq (mail-header-number (car thread)) gnus-newsgroup-sparse) - (memq (mail-header-number (car thread)) gnus-newsgroup-ancient)) - (or (<= (length (cdr thread)) 1) - (gnus-invisible-cut-children (cdr thread)))) - (setq thread (cadr thread)))) - thread) - -(defun gnus-cut-threads (threads) - "Cut off all uninteresting articles from the beginning of threads." - (when (or (eq gnus-fetch-old-headers 'some) - (eq gnus-build-sparse-threads 'some) - (eq gnus-build-sparse-threads 'more)) - (let ((th threads)) - (while th - (setcar th (gnus-cut-thread (car th))) - (setq th (cdr th))))) - ;; Remove nixed out threads. - (delq nil threads)) - -(defun gnus-summary-initial-limit (&optional show-if-empty) - "Figure out what the initial limit is supposed to be on group entry. -This entails weeding out unwanted dormants, low-scored articles, -fetch-old-headers verbiage, and so on." - ;; Most groups have nothing to remove. - (if (or gnus-inhibit-limiting - (and (null gnus-newsgroup-dormant) - (not (eq gnus-fetch-old-headers 'some)) - (null gnus-summary-expunge-below) - (not (eq gnus-build-sparse-threads 'some)) - (not (eq gnus-build-sparse-threads 'more)) - (null gnus-thread-expunge-below) - (not gnus-use-nocem))) - () ; Do nothing. - (push gnus-newsgroup-limit gnus-newsgroup-limits) - (setq gnus-newsgroup-limit nil) - (mapatoms - (lambda (node) - (unless (car (symbol-value node)) - ;; These threads have no parents -- they are roots. - (let ((nodes (cdr (symbol-value node))) - thread) - (while nodes - (if (and gnus-thread-expunge-below - (< (gnus-thread-total-score (car nodes)) - gnus-thread-expunge-below)) - (gnus-expunge-thread (pop nodes)) - (setq thread (pop nodes)) - (gnus-summary-limit-children thread)))))) - gnus-newsgroup-dependencies) - ;; If this limitation resulted in an empty group, we might - ;; pop the previous limit and use it instead. - (when (and (not gnus-newsgroup-limit) - show-if-empty) - (setq gnus-newsgroup-limit (pop gnus-newsgroup-limits))) - gnus-newsgroup-limit)) - -(defun gnus-summary-limit-children (thread) - "Return 1 if this subthread is visible and 0 if it is not." - ;; First we get the number of visible children to this thread. This - ;; is done by recursing down the thread using this function, so this - ;; will really go down to a leaf article first, before slowly - ;; working its way up towards the root. - (when thread - (let ((children - (if (cdr thread) - (apply '+ (mapcar 'gnus-summary-limit-children - (cdr thread))) - 0)) - (number (mail-header-number (car thread))) - score) - (if (or - ;; If this article is dormant and has absolutely no visible - ;; children, then this article isn't visible. - (and (memq number gnus-newsgroup-dormant) - (= children 0)) - ;; If this is "fetch-old-headered" and there is only one - ;; visible child (or less), then we don't want this article. - (and (eq gnus-fetch-old-headers 'some) - (memq number gnus-newsgroup-ancient) - (zerop children)) - ;; If this is a sparsely inserted article with no children, - ;; we don't want it. - (and (eq gnus-build-sparse-threads 'some) - (memq number gnus-newsgroup-sparse) - (zerop children)) - ;; If we use expunging, and this article is really - ;; low-scored, then we don't want this article. - (when (and gnus-summary-expunge-below - (< (setq score - (or (cdr (assq number gnus-newsgroup-scored)) - gnus-summary-default-score)) - gnus-summary-expunge-below)) - ;; We increase the expunge-tally here, but that has - ;; nothing to do with the limits, really. - (incf gnus-newsgroup-expunged-tally) - ;; We also mark as read here, if that's wanted. - (when (and gnus-summary-mark-below - (< score gnus-summary-mark-below)) - (setq gnus-newsgroup-unreads - (delq number gnus-newsgroup-unreads)) - (if gnus-newsgroup-auto-expire - (push number gnus-newsgroup-expirable) - (push (cons number gnus-low-score-mark) - gnus-newsgroup-reads))) - t) - (and gnus-use-nocem - (gnus-nocem-unwanted-article-p (mail-header-id (car thread))))) - ;; Nope, invisible article. - 0 - ;; Ok, this article is to be visible, so we add it to the limit - ;; and return 1. - (setq gnus-newsgroup-limit (cons number gnus-newsgroup-limit)) - 1)))) - -(defun gnus-expunge-thread (thread) - "Mark all articles in THREAD as read." - (let* ((number (mail-header-number (car thread)))) - (incf gnus-newsgroup-expunged-tally) - ;; We also mark as read here, if that's wanted. - (setq gnus-newsgroup-unreads - (delq number gnus-newsgroup-unreads)) - (if gnus-newsgroup-auto-expire - (push number gnus-newsgroup-expirable) - (push (cons number gnus-low-score-mark) - gnus-newsgroup-reads))) - ;; Go recursively through all subthreads. - (mapcar 'gnus-expunge-thread (cdr thread))) - -;; Summary article oriented commands - -(defun gnus-summary-refer-parent-article (n) - "Refer parent article N times. -The difference between N and the number of articles fetched is returned." - (interactive "p") - (gnus-set-global-variables) - (while - (and - (> n 0) - (let* ((header (gnus-summary-article-header)) - (ref - ;; If we try to find the parent of the currently - ;; displayed article, then we take a look at the actual - ;; References header, since this is slightly more - ;; reliable than the References field we got from the - ;; server. - (if (and (eq (mail-header-number header) - (cdr gnus-article-current)) - (equal gnus-newsgroup-name - (car gnus-article-current))) - (save-excursion - (set-buffer gnus-original-article-buffer) - (nnheader-narrow-to-headers) - (prog1 - (message-fetch-field "references") - (widen))) - ;; It's not the current article, so we take a bet on - ;; the value we got from the server. - (mail-header-references header)))) - (if (setq ref (or ref (mail-header-references header))) - (or (gnus-summary-refer-article (gnus-parent-id ref)) - (gnus-message 1 "Couldn't find parent")) - (gnus-message 1 "No references in article %d" - (gnus-summary-article-number)) - nil))) - (setq n (1- n))) - (gnus-summary-position-point) - n) - -(defun gnus-summary-refer-references () - "Fetch all articles mentioned in the References header. -Return how many articles were fetched." - (interactive) - (gnus-set-global-variables) - (let ((ref (mail-header-references (gnus-summary-article-header))) - (current (gnus-summary-article-number)) - (n 0)) - ;; For each Message-ID in the References header... - (while (string-match "<[^>]*>" ref) - (incf n) - ;; ... fetch that article. - (gnus-summary-refer-article - (prog1 (match-string 0 ref) - (setq ref (substring ref (match-end 0)))))) - (gnus-summary-goto-subject current) - (gnus-summary-position-point) - n)) - -(defun gnus-summary-refer-article (message-id) - "Fetch an article specified by MESSAGE-ID." - (interactive "sMessage-ID: ") - (when (and (stringp message-id) - (not (zerop (length message-id)))) - ;; Construct the correct Message-ID if necessary. - ;; Suggested by tale@pawl.rpi.edu. - (unless (string-match "^<" message-id) - (setq message-id (concat "<" message-id))) - (unless (string-match ">$" message-id) - (setq message-id (concat message-id ">"))) - (let* ((header (gnus-id-to-header message-id)) - (sparse (and header - (memq (mail-header-number header) - gnus-newsgroup-sparse)))) - (if header - (prog1 - ;; The article is present in the buffer, to we just go to it. - (gnus-summary-goto-article - (mail-header-number header) nil header) - (when sparse - (gnus-summary-update-article (mail-header-number header)))) - ;; We fetch the article - (let ((gnus-override-method - (and (gnus-news-group-p gnus-newsgroup-name) - gnus-refer-article-method)) - number) - ;; Start the special refer-article method, if necessary. - (when (and gnus-refer-article-method - (gnus-news-group-p gnus-newsgroup-name)) - (gnus-check-server gnus-refer-article-method)) - ;; Fetch the header, and display the article. - (if (setq number (gnus-summary-insert-subject message-id)) - (gnus-summary-select-article nil nil nil number) - (gnus-message 3 "Couldn't fetch article %s" message-id))))))) - -(defun gnus-summary-enter-digest-group (&optional force) - "Enter a digest group based on the current article." - (interactive "P") - (gnus-set-global-variables) - (gnus-summary-select-article) - (let ((name (format "%s-%d" - (gnus-group-prefixed-name - gnus-newsgroup-name (list 'nndoc "")) - gnus-current-article)) - (ogroup gnus-newsgroup-name) - (case-fold-search t) - (buf (current-buffer)) - dig) - (save-excursion - (setq dig (nnheader-set-temp-buffer " *gnus digest buffer*")) - (insert-buffer-substring gnus-original-article-buffer) - (narrow-to-region - (goto-char (point-min)) - (or (search-forward "\n\n" nil t) (point))) - (goto-char (point-min)) - (delete-matching-lines "^\\(Path\\):\\|^From ") - (widen)) - (unwind-protect - (if (gnus-group-read-ephemeral-group - name `(nndoc ,name (nndoc-address - ,(get-buffer dig)) - (nndoc-article-type ,(if force 'digest 'guess))) t) - ;; Make all postings to this group go to the parent group. - (nconc (gnus-info-params (gnus-get-info name)) - (list (cons 'to-group ogroup))) - ;; Couldn't select this doc group. - (switch-to-buffer buf) - (gnus-set-global-variables) - (gnus-configure-windows 'summary) - (gnus-message 3 "Article couldn't be entered?")) - (kill-buffer dig)))) - -(defun gnus-summary-isearch-article (&optional regexp-p) - "Do incremental search forward on the current article. -If REGEXP-P (the prefix) is non-nil, do regexp isearch." - (interactive "P") - (gnus-set-global-variables) - (gnus-summary-select-article) - (gnus-configure-windows 'article) - (gnus-eval-in-buffer-window gnus-article-buffer - ;;(goto-char (point-min)) - (isearch-forward regexp-p))) - -(defun gnus-summary-search-article-forward (regexp &optional backward) - "Search for an article containing REGEXP forward. -If BACKWARD, search backward instead." - (interactive - (list (read-string - (format "Search article %s (regexp%s): " - (if current-prefix-arg "backward" "forward") - (if gnus-last-search-regexp - (concat ", default " gnus-last-search-regexp) - ""))) - current-prefix-arg)) - (gnus-set-global-variables) - (if (string-equal regexp "") - (setq regexp (or gnus-last-search-regexp "")) - (setq gnus-last-search-regexp regexp)) - (unless (gnus-summary-search-article regexp backward) - (error "Search failed: \"%s\"" regexp))) - -(defun gnus-summary-search-article-backward (regexp) - "Search for an article containing REGEXP backward." - (interactive - (list (read-string - (format "Search article backward (regexp%s): " - (if gnus-last-search-regexp - (concat ", default " gnus-last-search-regexp) - ""))))) - (gnus-summary-search-article-forward regexp 'backward)) - -(defun gnus-summary-search-article (regexp &optional backward) - "Search for an article containing REGEXP. -Optional argument BACKWARD means do search for backward. -`gnus-select-article-hook' is not called during the search." - (let ((gnus-select-article-hook nil) ;Disable hook. - (gnus-article-display-hook nil) - (gnus-mark-article-hook nil) ;Inhibit marking as read. - (re-search - (if backward - 're-search-backward 're-search-forward)) - (sum (current-buffer)) - (found nil)) - (gnus-save-hidden-threads - (gnus-summary-select-article) - (set-buffer gnus-article-buffer) - (when backward - (forward-line -1)) - (while (not found) - (gnus-message 7 "Searching article: %d..." (cdr gnus-article-current)) - (if (if backward - (re-search-backward regexp nil t) - (re-search-forward regexp nil t)) - ;; We found the regexp. - (progn - (setq found 'found) - (beginning-of-line) - (set-window-start - (get-buffer-window (current-buffer)) - (point)) - (forward-line 1) - (set-buffer sum)) - ;; We didn't find it, so we go to the next article. - (set-buffer sum) - (if (not (if backward (gnus-summary-find-prev) - (gnus-summary-find-next))) - ;; No more articles. - (setq found t) - ;; Select the next article and adjust point. - (gnus-summary-select-article) - (set-buffer gnus-article-buffer) - (widen) - (goto-char (if backward (point-max) (point-min)))))) - (gnus-message 7 "")) - ;; Return whether we found the regexp. - (when (eq found 'found) - (gnus-summary-show-thread) - (gnus-summary-goto-subject gnus-current-article) - (gnus-summary-position-point) - t))) - -(defun gnus-summary-find-matching (header regexp &optional backward unread - not-case-fold) - "Return a list of all articles that match REGEXP on HEADER. -The search stars on the current article and goes forwards unless -BACKWARD is non-nil. If BACKWARD is `all', do all articles. -If UNREAD is non-nil, only unread articles will -be taken into consideration. If NOT-CASE-FOLD, case won't be folded -in the comparisons." - (let ((data (if (eq backward 'all) gnus-newsgroup-data - (gnus-data-find-list - (gnus-summary-article-number) (gnus-data-list backward)))) - (func `(lambda (h) (,(intern (concat "mail-header-" header)) h))) - (case-fold-search (not not-case-fold)) - articles d) - (or (fboundp (intern (concat "mail-header-" header))) - (error "%s is not a valid header" header)) - (while data - (setq d (car data)) - (and (or (not unread) ; We want all articles... - (gnus-data-unread-p d)) ; Or just unreads. - (vectorp (gnus-data-header d)) ; It's not a pseudo. - (string-match regexp (funcall func (gnus-data-header d))) ; Match. - (setq articles (cons (gnus-data-number d) articles))) ; Success! - (setq data (cdr data))) - (nreverse articles))) - -(defun gnus-summary-execute-command (header regexp command &optional backward) - "Search forward for an article whose HEADER matches REGEXP and execute COMMAND. -If HEADER is an empty string (or nil), the match is done on the entire -article. If BACKWARD (the prefix) is non-nil, search backward instead." - (interactive - (list (let ((completion-ignore-case t)) - (completing-read - "Header name: " - (mapcar (lambda (string) (list string)) - '("Number" "Subject" "From" "Lines" "Date" - "Message-ID" "Xref" "References" "Body")) - nil 'require-match)) - (read-string "Regexp: ") - (read-key-sequence "Command: ") - current-prefix-arg)) - (when (equal header "Body") - (setq header "")) - (gnus-set-global-variables) - ;; Hidden thread subtrees must be searched as well. - (gnus-summary-show-all-threads) - ;; We don't want to change current point nor window configuration. - (save-excursion - (save-window-excursion - (gnus-message 6 "Executing %s..." (key-description command)) - ;; We'd like to execute COMMAND interactively so as to give arguments. - (gnus-execute header regexp - `(lambda () (call-interactively ',(key-binding command))) - backward) - (gnus-message 6 "Executing %s...done" (key-description command))))) - -(defun gnus-summary-beginning-of-article () - "Scroll the article back to the beginning." - (interactive) - (gnus-set-global-variables) - (gnus-summary-select-article) - (gnus-configure-windows 'article) - (gnus-eval-in-buffer-window gnus-article-buffer - (widen) - (goto-char (point-min)) - (and gnus-break-pages (gnus-narrow-to-page)))) - -(defun gnus-summary-end-of-article () - "Scroll to the end of the article." - (interactive) - (gnus-set-global-variables) - (gnus-summary-select-article) - (gnus-configure-windows 'article) - (gnus-eval-in-buffer-window gnus-article-buffer - (widen) - (goto-char (point-max)) - (recenter -3) - (and gnus-break-pages (gnus-narrow-to-page)))) - -(defun gnus-summary-show-article (&optional arg) - "Force re-fetching of the current article. -If ARG (the prefix) is non-nil, show the raw article without any -article massaging functions being run." - (interactive "P") - (gnus-set-global-variables) - (if (not arg) - ;; Select the article the normal way. - (gnus-summary-select-article nil 'force) - ;; Bind the article treatment functions to nil. - (let ((gnus-have-all-headers t) - gnus-article-display-hook - gnus-article-prepare-hook - gnus-break-pages - gnus-visual) - (gnus-summary-select-article nil 'force))) - (gnus-summary-goto-subject gnus-current-article) -; (gnus-configure-windows 'article) - (gnus-summary-position-point)) - -(defun gnus-summary-verbose-headers (&optional arg) - "Toggle permanent full header display. -If ARG is a positive number, turn header display on. -If ARG is a negative number, turn header display off." - (interactive "P") - (gnus-set-global-variables) - (gnus-summary-toggle-header arg) - (setq gnus-show-all-headers - (cond ((or (not (numberp arg)) - (zerop arg)) - (not gnus-show-all-headers)) - ((natnump arg) - t)))) - -(defun gnus-summary-toggle-header (&optional arg) - "Show the headers if they are hidden, or hide them if they are shown. -If ARG is a positive number, show the entire header. -If ARG is a negative number, hide the unwanted header lines." - (interactive "P") - (gnus-set-global-variables) - (save-excursion - (set-buffer gnus-article-buffer) - (let* ((buffer-read-only nil) - (inhibit-point-motion-hooks t) - (hidden (text-property-any - (goto-char (point-min)) (search-forward "\n\n") - 'invisible t)) - e) - (goto-char (point-min)) - (when (search-forward "\n\n" nil t) - (delete-region (point-min) (1- (point)))) - (goto-char (point-min)) - (save-excursion - (set-buffer gnus-original-article-buffer) - (goto-char (point-min)) - (setq e (1- (or (search-forward "\n\n" nil t) (point-max))))) - (insert-buffer-substring gnus-original-article-buffer 1 e) - (let ((gnus-inhibit-hiding t)) - (run-hooks 'gnus-article-display-hook)) - (if (or (not hidden) (and (numberp arg) (< arg 0))) - (gnus-article-hide-headers))))) - -(defun gnus-summary-show-all-headers () - "Make all header lines visible." - (interactive) - (gnus-set-global-variables) - (gnus-article-show-all-headers)) - -(defun gnus-summary-toggle-mime (&optional arg) - "Toggle MIME processing. -If ARG is a positive number, turn MIME processing on." - (interactive "P") - (gnus-set-global-variables) - (setq gnus-show-mime - (if (null arg) (not gnus-show-mime) - (> (prefix-numeric-value arg) 0))) - (gnus-summary-select-article t 'force)) - -(defun gnus-summary-caesar-message (&optional arg) - "Caesar rotate the current article by 13. -The numerical prefix specifies how manu places to rotate each letter -forward." - (interactive "P") - (gnus-set-global-variables) - (gnus-summary-select-article) - (let ((mail-header-separator "")) - (gnus-eval-in-buffer-window gnus-article-buffer - (save-restriction - (widen) - (let ((start (window-start)) - buffer-read-only) - (message-caesar-buffer-body arg) - (set-window-start (get-buffer-window (current-buffer)) start)))))) - -(defun gnus-summary-stop-page-breaking () - "Stop page breaking in the current article." - (interactive) - (gnus-set-global-variables) - (gnus-summary-select-article) - (gnus-eval-in-buffer-window gnus-article-buffer - (widen))) - -(defun gnus-summary-move-article (&optional n to-newsgroup select-method action) - "Move the current article to a different newsgroup. -If N is a positive number, move the N next articles. -If N is a negative number, move the N previous articles. -If N is nil and any articles have been marked with the process mark, -move those articles instead. -If TO-NEWSGROUP is string, do not prompt for a newsgroup to move to. -If SELECT-METHOD is non-nil, do not move to a specific newsgroup, but -re-spool using this method. - -For this function to work, both the current newsgroup and the -newsgroup that you want to move to have to support the `request-move' -and `request-accept' functions." - (interactive "P") - (unless action (setq action 'move)) - (gnus-set-global-variables) - ;; Check whether the source group supports the required functions. - (cond ((and (eq action 'move) - (not (gnus-check-backend-function - 'request-move-article gnus-newsgroup-name))) - (error "The current group does not support article moving")) - ((and (eq action 'crosspost) - (not (gnus-check-backend-function - 'request-replace-article gnus-newsgroup-name))) - (error "The current group does not support article editing"))) - (let ((articles (gnus-summary-work-articles n)) - (prefix (gnus-group-real-prefix gnus-newsgroup-name)) - (names '((move "Move" "Moving") - (copy "Copy" "Copying") - (crosspost "Crosspost" "Crossposting"))) - (copy-buf (save-excursion - (nnheader-set-temp-buffer " *copy article*"))) - art-group to-method new-xref article to-groups) - (unless (assq action names) - (error "Unknown action %s" action)) - ;; Read the newsgroup name. - (when (and (not to-newsgroup) - (not select-method)) - (setq to-newsgroup - (gnus-read-move-group-name - (cadr (assq action names)) - (symbol-value (intern (format "gnus-current-%s-group" action))) - articles prefix)) - (set (intern (format "gnus-current-%s-group" action)) to-newsgroup)) - (setq to-method (or select-method - (gnus-group-name-to-method to-newsgroup))) - ;; Check the method we are to move this article to... - (or (gnus-check-backend-function 'request-accept-article (car to-method)) - (error "%s does not support article copying" (car to-method))) - (or (gnus-check-server to-method) - (error "Can't open server %s" (car to-method))) - (gnus-message 6 "%s to %s: %s..." - (caddr (assq action names)) - (or (car select-method) to-newsgroup) articles) - (while articles - (setq article (pop articles)) - (setq - art-group - (cond - ;; Move the article. - ((eq action 'move) - (gnus-request-move-article - article ; Article to move - gnus-newsgroup-name ; From newsgrouo - (nth 1 (gnus-find-method-for-group - gnus-newsgroup-name)) ; Server - (list 'gnus-request-accept-article - to-newsgroup (list 'quote select-method) - (not articles)) ; Accept form - (not articles))) ; Only save nov last time - ;; Copy the article. - ((eq action 'copy) - (save-excursion - (set-buffer copy-buf) - (gnus-request-article-this-buffer article gnus-newsgroup-name) - (gnus-request-accept-article - to-newsgroup select-method (not articles)))) - ;; Crosspost the article. - ((eq action 'crosspost) - (let ((xref (mail-header-xref (gnus-summary-article-header article)))) - (setq new-xref (concat gnus-newsgroup-name ":" article)) - (if (and xref (not (string= xref ""))) - (progn - (when (string-match "^Xref: " xref) - (setq xref (substring xref (match-end 0)))) - (setq new-xref (concat xref " " new-xref))) - (setq new-xref (concat (system-name) " " new-xref))) - (save-excursion - (set-buffer copy-buf) - (gnus-request-article-this-buffer article gnus-newsgroup-name) - (nnheader-replace-header "xref" new-xref) - (gnus-request-accept-article - to-newsgroup select-method (not articles))))))) - (if (not art-group) - (gnus-message 1 "Couldn't %s article %s" - (cadr (assq action names)) article) - (let* ((entry - (or - (gnus-gethash (car art-group) gnus-newsrc-hashtb) - (gnus-gethash - (gnus-group-prefixed-name - (car art-group) - (or select-method - (gnus-find-method-for-group to-newsgroup))) - gnus-newsrc-hashtb))) - (info (nth 2 entry)) - (to-group (gnus-info-group info))) - ;; Update the group that has been moved to. - (when (and info - (memq action '(move copy))) - (unless (member to-group to-groups) - (push to-group to-groups)) - - (unless (memq article gnus-newsgroup-unreads) - (gnus-info-set-read - info (gnus-add-to-range (gnus-info-read info) - (list (cdr art-group))))) - - ;; Copy any marks over to the new group. - (let ((marks gnus-article-mark-lists) - (to-article (cdr art-group))) - - ;; See whether the article is to be put in the cache. - (when gnus-use-cache - (gnus-cache-possibly-enter-article - to-group to-article - (let ((header (copy-sequence - (gnus-summary-article-header article)))) - (mail-header-set-number header to-article) - header) - (memq article gnus-newsgroup-marked) - (memq article gnus-newsgroup-dormant) - (memq article gnus-newsgroup-unreads))) - - (while marks - (when (memq article (symbol-value - (intern (format "gnus-newsgroup-%s" - (caar marks))))) - ;; If the other group is the same as this group, - ;; then we have to add the mark to the list. - (when (equal to-group gnus-newsgroup-name) - (set (intern (format "gnus-newsgroup-%s" (caar marks))) - (cons to-article - (symbol-value - (intern (format "gnus-newsgroup-%s" - (caar marks))))))) - ;; Copy mark to other group. - (gnus-add-marked-articles - to-group (cdar marks) (list to-article) info)) - (setq marks (cdr marks))))) - - ;; Update the Xref header in this article to point to - ;; the new crossposted article we have just created. - (when (eq action 'crosspost) - (save-excursion - (set-buffer copy-buf) - (gnus-request-article-this-buffer article gnus-newsgroup-name) - (nnheader-replace-header - "xref" (concat new-xref " " (gnus-group-prefixed-name - (car art-group) to-method) - ":" (cdr art-group))) - (gnus-request-replace-article - article gnus-newsgroup-name (current-buffer))))) - - (gnus-summary-goto-subject article) - (when (eq action 'move) - (gnus-summary-mark-article article gnus-canceled-mark))) - (gnus-summary-remove-process-mark article)) - ;; Re-activate all groups that have been moved to. - (while to-groups - (gnus-activate-group (pop to-groups))) - - (gnus-kill-buffer copy-buf) - (gnus-summary-position-point) - (gnus-set-mode-line 'summary))) - -(defun gnus-summary-copy-article (&optional n to-newsgroup select-method) - "Move the current article to a different newsgroup. -If TO-NEWSGROUP is string, do not prompt for a newsgroup to move to. -If SELECT-METHOD is non-nil, do not move to a specific newsgroup, but -re-spool using this method." - (interactive "P") - (gnus-summary-move-article n nil select-method 'copy)) - -(defun gnus-summary-crosspost-article (&optional n) - "Crosspost the current article to some other group." - (interactive "P") - (gnus-summary-move-article n nil nil 'crosspost)) - -(defvar gnus-summary-respool-default-method nil - "Default method for respooling an article. -If nil, use to the current newsgroup method.") - -(defun gnus-summary-respool-article (&optional n method) - "Respool the current article. -The article will be squeezed through the mail spooling process again, -which means that it will be put in some mail newsgroup or other -depending on `nnmail-split-methods'. -If N is a positive number, respool the N next articles. -If N is a negative number, respool the N previous articles. -If N is nil and any articles have been marked with the process mark, -respool those articles instead. - -Respooling can be done both from mail groups and \"real\" newsgroups. -In the former case, the articles in question will be moved from the -current group into whatever groups they are destined to. In the -latter case, they will be copied into the relevant groups." - (interactive - (list current-prefix-arg - (let* ((methods (gnus-methods-using 'respool)) - (methname - (symbol-name (or gnus-summary-respool-default-method - (car (gnus-find-method-for-group - gnus-newsgroup-name))))) - (method - (gnus-completing-read - methname "What backend do you want to use when respooling?" - methods nil t nil 'gnus-method-history)) - ms) - (cond - ((zerop (length (setq ms (gnus-servers-using-backend method)))) - (list (intern method) "")) - ((= 1 (length ms)) - (car ms)) - (t - (cdr (completing-read - "Server name: " - (mapcar (lambda (m) (cons (cadr m) m)) ms) nil t))))))) - (gnus-set-global-variables) - (unless method - (error "No method given for respooling")) - (if (assoc (symbol-name - (car (gnus-find-method-for-group gnus-newsgroup-name))) - (gnus-methods-using 'respool)) - (gnus-summary-move-article n nil method) - (gnus-summary-copy-article n nil method))) - -(defun gnus-summary-import-article (file) - "Import a random file into a mail newsgroup." - (interactive "fImport file: ") - (gnus-set-global-variables) - (let ((group gnus-newsgroup-name) - (now (current-time)) - atts lines) - (or (gnus-check-backend-function 'request-accept-article group) - (error "%s does not support article importing" group)) - (or (file-readable-p file) - (not (file-regular-p file)) - (error "Can't read %s" file)) - (save-excursion - (set-buffer (get-buffer-create " *import file*")) - (buffer-disable-undo (current-buffer)) - (erase-buffer) - (insert-file-contents file) - (goto-char (point-min)) - (unless (nnheader-article-p) - ;; This doesn't look like an article, so we fudge some headers. - (setq atts (file-attributes file) - lines (count-lines (point-min) (point-max))) - (insert "From: " (read-string "From: ") "\n" - "Subject: " (read-string "Subject: ") "\n" - "Date: " (timezone-make-date-arpa-standard - (current-time-string (nth 5 atts)) - (current-time-zone now) - (current-time-zone now)) "\n" - "Message-ID: " (message-make-message-id) "\n" - "Lines: " (int-to-string lines) "\n" - "Chars: " (int-to-string (nth 7 atts)) "\n\n")) - (gnus-request-accept-article group nil t) - (kill-buffer (current-buffer))))) - -(defun gnus-summary-expire-articles (&optional now) - "Expire all articles that are marked as expirable in the current group." - (interactive) - (gnus-set-global-variables) - (when (gnus-check-backend-function - 'request-expire-articles gnus-newsgroup-name) - ;; This backend supports expiry. - (let* ((total (gnus-group-total-expirable-p gnus-newsgroup-name)) - (expirable (if total - (gnus-list-of-read-articles gnus-newsgroup-name) - (setq gnus-newsgroup-expirable - (sort gnus-newsgroup-expirable '<)))) - (expiry-wait (if now 'immediate - (gnus-group-get-parameter - gnus-newsgroup-name 'expiry-wait))) - es) - (when expirable - ;; There are expirable articles in this group, so we run them - ;; through the expiry process. - (gnus-message 6 "Expiring articles...") - ;; The list of articles that weren't expired is returned. - (if expiry-wait - (let ((nnmail-expiry-wait-function nil) - (nnmail-expiry-wait expiry-wait)) - (setq es (gnus-request-expire-articles - expirable gnus-newsgroup-name))) - (setq es (gnus-request-expire-articles - expirable gnus-newsgroup-name))) - (or total (setq gnus-newsgroup-expirable es)) - ;; We go through the old list of expirable, and mark all - ;; really expired articles as nonexistent. - (unless (eq es expirable) ;If nothing was expired, we don't mark. - (let ((gnus-use-cache nil)) - (while expirable - (unless (memq (car expirable) es) - (when (gnus-data-find (car expirable)) - (gnus-summary-mark-article - (car expirable) gnus-canceled-mark))) - (setq expirable (cdr expirable))))) - (gnus-message 6 "Expiring articles...done"))))) - -(defun gnus-summary-expire-articles-now () - "Expunge all expirable articles in the current group. -This means that *all* articles that are marked as expirable will be -deleted forever, right now." - (interactive) - (gnus-set-global-variables) - (or gnus-expert-user - (gnus-y-or-n-p - "Are you really, really, really sure you want to delete all these messages? ") - (error "Phew!")) - (gnus-summary-expire-articles t)) - -;; Suggested by Jack Vinson . -(defun gnus-summary-delete-article (&optional n) - "Delete the N next (mail) articles. -This command actually deletes articles. This is not a marking -command. The article will disappear forever from your life, never to -return. -If N is negative, delete backwards. -If N is nil and articles have been marked with the process mark, -delete these instead." - (interactive "P") - (gnus-set-global-variables) - (or (gnus-check-backend-function 'request-expire-articles - gnus-newsgroup-name) - (error "The current newsgroup does not support article deletion.")) - ;; Compute the list of articles to delete. - (let ((articles (gnus-summary-work-articles n)) - not-deleted) - (if (and gnus-novice-user - (not (gnus-y-or-n-p - (format "Do you really want to delete %s forever? " - (if (> (length articles) 1) - (format "these %s articles" (length articles)) - "this article"))))) - () - ;; Delete the articles. - (setq not-deleted (gnus-request-expire-articles - articles gnus-newsgroup-name 'force)) - (while articles - (gnus-summary-remove-process-mark (car articles)) - ;; The backend might not have been able to delete the article - ;; after all. - (or (memq (car articles) not-deleted) - (gnus-summary-mark-article (car articles) gnus-canceled-mark)) - (setq articles (cdr articles)))) - (gnus-summary-position-point) - (gnus-set-mode-line 'summary) - not-deleted)) - -(defun gnus-summary-edit-article (&optional force) - "Enter into a buffer and edit the current article. -This will have permanent effect only in mail groups. -If FORCE is non-nil, allow editing of articles even in read-only -groups." - (interactive "P") - (save-excursion - (set-buffer gnus-summary-buffer) - (gnus-set-global-variables) - (when (and (not force) - (gnus-group-read-only-p)) - (error "The current newsgroup does not support article editing.")) - (gnus-summary-select-article t nil t) - (gnus-configure-windows 'article) - (select-window (get-buffer-window gnus-article-buffer)) - (gnus-message 6 "C-c C-c to end edits") - (setq buffer-read-only nil) - (text-mode) - (use-local-map (copy-keymap (current-local-map))) - (local-set-key "\C-c\C-c" 'gnus-summary-edit-article-done) - (buffer-enable-undo) - (widen) - (goto-char (point-min)) - (search-forward "\n\n" nil t))) - -(defun gnus-summary-edit-article-done () - "Make edits to the current article permanent." - (interactive) - (if (gnus-group-read-only-p) - (progn - (let ((beep (not (eq major-mode 'text-mode)))) - (gnus-summary-edit-article-postpone) - (when beep - (gnus-error - 3 "The current newsgroup does not support article editing.")))) - (let ((buf (format "%s" (buffer-string)))) - (erase-buffer) - (insert buf) - (if (not (gnus-request-replace-article - (cdr gnus-article-current) (car gnus-article-current) - (current-buffer))) - (error "Couldn't replace article.") - (gnus-article-mode) - (use-local-map gnus-article-mode-map) - (setq buffer-read-only t) - (buffer-disable-undo (current-buffer)) - (gnus-configure-windows 'summary) - (gnus-summary-update-article (cdr gnus-article-current)) - (when gnus-use-cache - (gnus-cache-update-article - (car gnus-article-current) (cdr gnus-article-current))) - (when gnus-keep-backlog - (gnus-backlog-remove-article - (car gnus-article-current) (cdr gnus-article-current)))) - (save-excursion - (when (get-buffer gnus-original-article-buffer) - (set-buffer gnus-original-article-buffer) - (setq gnus-original-article nil))) - (setq gnus-article-current nil - gnus-current-article nil) - (run-hooks 'gnus-article-display-hook) - (and (gnus-visual-p 'summary-highlight 'highlight) - (run-hooks 'gnus-visual-mark-article-hook))))) - -(defun gnus-summary-edit-article-postpone () - "Postpone changes to the current article." - (interactive) - (gnus-article-mode) - (use-local-map gnus-article-mode-map) - (setq buffer-read-only t) - (buffer-disable-undo (current-buffer)) - (gnus-configure-windows 'summary) - (and (gnus-visual-p 'summary-highlight 'highlight) - (run-hooks 'gnus-visual-mark-article-hook))) - -(defun gnus-summary-respool-query () - "Query where the respool algorithm would put this article." - (interactive) - (gnus-set-global-variables) - (gnus-summary-select-article) - (save-excursion - (set-buffer gnus-article-buffer) - (save-restriction - (goto-char (point-min)) - (search-forward "\n\n") - (narrow-to-region (point-min) (point)) - (pp-eval-expression - (list 'quote (mapcar 'car (nnmail-article-group 'identity))))))) - -;; Summary marking commands. - -(defun gnus-summary-kill-same-subject-and-select (&optional unmark) - "Mark articles which has the same subject as read, and then select the next. -If UNMARK is positive, remove any kind of mark. -If UNMARK is negative, tick articles." - (interactive "P") - (gnus-set-global-variables) - (if unmark - (setq unmark (prefix-numeric-value unmark))) - (let ((count - (gnus-summary-mark-same-subject - (gnus-summary-article-subject) unmark))) - ;; Select next unread article. If auto-select-same mode, should - ;; select the first unread article. - (gnus-summary-next-article t (and gnus-auto-select-same - (gnus-summary-article-subject))) - (gnus-message 7 "%d article%s marked as %s" - count (if (= count 1) " is" "s are") - (if unmark "unread" "read")))) - -(defun gnus-summary-kill-same-subject (&optional unmark) - "Mark articles which has the same subject as read. -If UNMARK is positive, remove any kind of mark. -If UNMARK is negative, tick articles." - (interactive "P") - (gnus-set-global-variables) - (if unmark - (setq unmark (prefix-numeric-value unmark))) - (let ((count - (gnus-summary-mark-same-subject - (gnus-summary-article-subject) unmark))) - ;; If marked as read, go to next unread subject. - (if (null unmark) - ;; Go to next unread subject. - (gnus-summary-next-subject 1 t)) - (gnus-message 7 "%d articles are marked as %s" - count (if unmark "unread" "read")))) - -(defun gnus-summary-mark-same-subject (subject &optional unmark) - "Mark articles with same SUBJECT as read, and return marked number. -If optional argument UNMARK is positive, remove any kinds of marks. -If optional argument UNMARK is negative, mark articles as unread instead." - (let ((count 1)) - (save-excursion - (cond - ((null unmark) ; Mark as read. - (while (and - (progn - (gnus-summary-mark-article-as-read gnus-killed-mark) - (gnus-summary-show-thread) t) - (gnus-summary-find-subject subject)) - (setq count (1+ count)))) - ((> unmark 0) ; Tick. - (while (and - (progn - (gnus-summary-mark-article-as-unread gnus-ticked-mark) - (gnus-summary-show-thread) t) - (gnus-summary-find-subject subject)) - (setq count (1+ count)))) - (t ; Mark as unread. - (while (and - (progn - (gnus-summary-mark-article-as-unread gnus-unread-mark) - (gnus-summary-show-thread) t) - (gnus-summary-find-subject subject)) - (setq count (1+ count))))) - (gnus-set-mode-line 'summary) - ;; Return the number of marked articles. - count))) - -(defun gnus-summary-mark-as-processable (n &optional unmark) - "Set the process mark on the next N articles. -If N is negative, mark backward instead. If UNMARK is non-nil, remove -the process mark instead. The difference between N and the actual -number of articles marked is returned." - (interactive "p") - (gnus-set-global-variables) - (let ((backward (< n 0)) - (n (abs n))) - (while (and - (> n 0) - (if unmark - (gnus-summary-remove-process-mark - (gnus-summary-article-number)) - (gnus-summary-set-process-mark (gnus-summary-article-number))) - (zerop (gnus-summary-next-subject (if backward -1 1) nil t))) - (setq n (1- n))) - (if (/= 0 n) (gnus-message 7 "No more articles")) - (gnus-summary-recenter) - (gnus-summary-position-point) - n)) - -(defun gnus-summary-unmark-as-processable (n) - "Remove the process mark from the next N articles. -If N is negative, mark backward instead. The difference between N and -the actual number of articles marked is returned." - (interactive "p") - (gnus-set-global-variables) - (gnus-summary-mark-as-processable n t)) - -(defun gnus-summary-unmark-all-processable () - "Remove the process mark from all articles." - (interactive) - (gnus-set-global-variables) - (save-excursion - (while gnus-newsgroup-processable - (gnus-summary-remove-process-mark (car gnus-newsgroup-processable)))) - (gnus-summary-position-point)) - -(defun gnus-summary-mark-as-expirable (n) - "Mark N articles forward as expirable. -If N is negative, mark backward instead. The difference between N and -the actual number of articles marked is returned." - (interactive "p") - (gnus-set-global-variables) - (gnus-summary-mark-forward n gnus-expirable-mark)) - -(defun gnus-summary-mark-article-as-replied (article) - "Mark ARTICLE replied and update the summary line." - (setq gnus-newsgroup-replied (cons article gnus-newsgroup-replied)) - (let ((buffer-read-only nil)) - (when (gnus-summary-goto-subject article) - (gnus-summary-update-secondary-mark article)))) - -(defun gnus-summary-set-bookmark (article) - "Set a bookmark in current article." - (interactive (list (gnus-summary-article-number))) - (gnus-set-global-variables) - (if (or (not (get-buffer gnus-article-buffer)) - (not gnus-current-article) - (not gnus-article-current) - (not (equal gnus-newsgroup-name (car gnus-article-current)))) - (error "No current article selected")) - ;; Remove old bookmark, if one exists. - (let ((old (assq article gnus-newsgroup-bookmarks))) - (if old (setq gnus-newsgroup-bookmarks - (delq old gnus-newsgroup-bookmarks)))) - ;; Set the new bookmark, which is on the form - ;; (article-number . line-number-in-body). - (setq gnus-newsgroup-bookmarks - (cons - (cons article - (save-excursion - (set-buffer gnus-article-buffer) - (count-lines - (min (point) - (save-excursion - (goto-char (point-min)) - (search-forward "\n\n" nil t) - (point))) - (point)))) - gnus-newsgroup-bookmarks)) - (gnus-message 6 "A bookmark has been added to the current article.")) - -(defun gnus-summary-remove-bookmark (article) - "Remove the bookmark from the current article." - (interactive (list (gnus-summary-article-number))) - (gnus-set-global-variables) - ;; Remove old bookmark, if one exists. - (let ((old (assq article gnus-newsgroup-bookmarks))) - (if old - (progn - (setq gnus-newsgroup-bookmarks - (delq old gnus-newsgroup-bookmarks)) - (gnus-message 6 "Removed bookmark.")) - (gnus-message 6 "No bookmark in current article.")))) - -;; Suggested by Daniel Quinlan . -(defun gnus-summary-mark-as-dormant (n) - "Mark N articles forward as dormant. -If N is negative, mark backward instead. The difference between N and -the actual number of articles marked is returned." - (interactive "p") - (gnus-set-global-variables) - (gnus-summary-mark-forward n gnus-dormant-mark)) - -(defun gnus-summary-set-process-mark (article) - "Set the process mark on ARTICLE and update the summary line." - (setq gnus-newsgroup-processable - (cons article - (delq article gnus-newsgroup-processable))) - (when (gnus-summary-goto-subject article) - (gnus-summary-show-thread) - (gnus-summary-update-secondary-mark article))) - -(defun gnus-summary-remove-process-mark (article) - "Remove the process mark from ARTICLE and update the summary line." - (setq gnus-newsgroup-processable (delq article gnus-newsgroup-processable)) - (when (gnus-summary-goto-subject article) - (gnus-summary-show-thread) - (gnus-summary-update-secondary-mark article))) - -(defun gnus-summary-set-saved-mark (article) - "Set the process mark on ARTICLE and update the summary line." - (push article gnus-newsgroup-saved) - (when (gnus-summary-goto-subject article) - (gnus-summary-update-secondary-mark article))) - -(defun gnus-summary-mark-forward (n &optional mark no-expire) - "Mark N articles as read forwards. -If N is negative, mark backwards instead. Mark with MARK, ?r by default. -The difference between N and the actual number of articles marked is -returned." - (interactive "p") - (gnus-set-global-variables) - (let ((backward (< n 0)) - (gnus-summary-goto-unread - (and gnus-summary-goto-unread - (not (eq gnus-summary-goto-unread 'never)) - (not (memq mark (list gnus-unread-mark - gnus-ticked-mark gnus-dormant-mark))))) - (n (abs n)) - (mark (or mark gnus-del-mark))) - (while (and (> n 0) - (gnus-summary-mark-article nil mark no-expire) - (zerop (gnus-summary-next-subject - (if backward -1 1) - (and gnus-summary-goto-unread - (not (eq gnus-summary-goto-unread 'never))) - t))) - (setq n (1- n))) - (if (/= 0 n) (gnus-message 7 "No more %sarticles" (if mark "" "unread "))) - (gnus-summary-recenter) - (gnus-summary-position-point) - (gnus-set-mode-line 'summary) - n)) - -(defun gnus-summary-mark-article-as-read (mark) - "Mark the current article quickly as read with MARK." - (let ((article (gnus-summary-article-number))) - (setq gnus-newsgroup-unreads (delq article gnus-newsgroup-unreads)) - (setq gnus-newsgroup-marked (delq article gnus-newsgroup-marked)) - (setq gnus-newsgroup-dormant (delq article gnus-newsgroup-dormant)) - (setq gnus-newsgroup-reads - (cons (cons article mark) gnus-newsgroup-reads)) - ;; Possibly remove from cache, if that is used. - (and gnus-use-cache (gnus-cache-enter-remove-article article)) - ;; Allow the backend to change the mark. - (setq mark (gnus-request-update-mark gnus-newsgroup-name article mark)) - ;; Check for auto-expiry. - (when (and gnus-newsgroup-auto-expire - (or (= mark gnus-killed-mark) (= mark gnus-del-mark) - (= mark gnus-catchup-mark) (= mark gnus-low-score-mark) - (= mark gnus-ancient-mark) - (= mark gnus-read-mark) (= mark gnus-souped-mark))) - (setq mark gnus-expirable-mark) - (push article gnus-newsgroup-expirable)) - ;; Set the mark in the buffer. - (gnus-summary-update-mark mark 'unread) - t)) - -(defun gnus-summary-mark-article-as-unread (mark) - "Mark the current article quickly as unread with MARK." - (let ((article (gnus-summary-article-number))) - (if (< article 0) - (gnus-error 1 "Unmarkable article") - (setq gnus-newsgroup-marked (delq article gnus-newsgroup-marked)) - (setq gnus-newsgroup-dormant (delq article gnus-newsgroup-dormant)) - (setq gnus-newsgroup-expirable (delq article gnus-newsgroup-expirable)) - (setq gnus-newsgroup-reads (delq article gnus-newsgroup-reads)) - (cond ((= mark gnus-ticked-mark) - (push article gnus-newsgroup-marked)) - ((= mark gnus-dormant-mark) - (push article gnus-newsgroup-dormant)) - (t - (push article gnus-newsgroup-unreads))) - (setq gnus-newsgroup-reads - (delq (assq article gnus-newsgroup-reads) - gnus-newsgroup-reads)) - - ;; See whether the article is to be put in the cache. - (and gnus-use-cache - (vectorp (gnus-summary-article-header article)) - (save-excursion - (gnus-cache-possibly-enter-article - gnus-newsgroup-name article - (gnus-summary-article-header article) - (= mark gnus-ticked-mark) - (= mark gnus-dormant-mark) (= mark gnus-unread-mark)))) - - ;; Fix the mark. - (gnus-summary-update-mark mark 'unread)) - t)) - -(defun gnus-summary-mark-article (&optional article mark no-expire) - "Mark ARTICLE with MARK. MARK can be any character. -Four MARK strings are reserved: `? ' (unread), `?!' (ticked), -`??' (dormant) and `?E' (expirable). -If MARK is nil, then the default character `?D' is used. -If ARTICLE is nil, then the article on the current line will be -marked." - ;; The mark might be a string. - (and (stringp mark) - (setq mark (aref mark 0))) - ;; If no mark is given, then we check auto-expiring. - (and (not no-expire) - gnus-newsgroup-auto-expire - (or (not mark) - (and (numberp mark) - (or (= mark gnus-killed-mark) (= mark gnus-del-mark) - (= mark gnus-catchup-mark) (= mark gnus-low-score-mark) - (= mark gnus-read-mark) (= mark gnus-souped-mark)))) - (setq mark gnus-expirable-mark)) - (let* ((mark (or mark gnus-del-mark)) - (article (or article (gnus-summary-article-number)))) - (or article (error "No article on current line")) - (if (or (= mark gnus-unread-mark) - (= mark gnus-ticked-mark) - (= mark gnus-dormant-mark)) - (gnus-mark-article-as-unread article mark) - (gnus-mark-article-as-read article mark)) - - ;; See whether the article is to be put in the cache. - (and gnus-use-cache - (not (= mark gnus-canceled-mark)) - (vectorp (gnus-summary-article-header article)) - (save-excursion - (gnus-cache-possibly-enter-article - gnus-newsgroup-name article - (gnus-summary-article-header article) - (= mark gnus-ticked-mark) - (= mark gnus-dormant-mark) (= mark gnus-unread-mark)))) - - (if (gnus-summary-goto-subject article nil t) - (let ((buffer-read-only nil)) - (gnus-summary-show-thread) - ;; Fix the mark. - (gnus-summary-update-mark mark 'unread) - t)))) - -(defun gnus-summary-update-secondary-mark (article) - "Update the secondary (read, process, cache) mark." - (gnus-summary-update-mark - (cond ((memq article gnus-newsgroup-processable) - gnus-process-mark) - ((memq article gnus-newsgroup-cached) - gnus-cached-mark) - ((memq article gnus-newsgroup-replied) - gnus-replied-mark) - ((memq article gnus-newsgroup-saved) - gnus-saved-mark) - (t gnus-unread-mark)) - 'replied) - (when (gnus-visual-p 'summary-highlight 'highlight) - (run-hooks 'gnus-summary-update-hook)) - t) - -(defun gnus-summary-update-mark (mark type) - (beginning-of-line) - (let ((forward (cdr (assq type gnus-summary-mark-positions))) - (buffer-read-only nil)) - (when (and forward - (<= (+ forward (point)) (point-max))) - ;; Go to the right position on the line. - (goto-char (+ forward (point))) - ;; Replace the old mark with the new mark. - (subst-char-in-region (point) (1+ (point)) (following-char) mark) - ;; Optionally update the marks by some user rule. - (when (eq type 'unread) - (gnus-data-set-mark - (gnus-data-find (gnus-summary-article-number)) mark) - (gnus-summary-update-line (eq mark gnus-unread-mark)))))) - -(defun gnus-mark-article-as-read (article &optional mark) - "Enter ARTICLE in the pertinent lists and remove it from others." - ;; Make the article expirable. - (let ((mark (or mark gnus-del-mark))) - (if (= mark gnus-expirable-mark) - (setq gnus-newsgroup-expirable (cons article gnus-newsgroup-expirable)) - (setq gnus-newsgroup-expirable (delq article gnus-newsgroup-expirable))) - ;; Remove from unread and marked lists. - (setq gnus-newsgroup-unreads (delq article gnus-newsgroup-unreads)) - (setq gnus-newsgroup-marked (delq article gnus-newsgroup-marked)) - (setq gnus-newsgroup-dormant (delq article gnus-newsgroup-dormant)) - (push (cons article mark) gnus-newsgroup-reads) - ;; Possibly remove from cache, if that is used. - (when gnus-use-cache - (gnus-cache-enter-remove-article article)))) - -(defun gnus-mark-article-as-unread (article &optional mark) - "Enter ARTICLE in the pertinent lists and remove it from others." - (let ((mark (or mark gnus-ticked-mark))) - (setq gnus-newsgroup-marked (delq article gnus-newsgroup-marked)) - (setq gnus-newsgroup-dormant (delq article gnus-newsgroup-dormant)) - (setq gnus-newsgroup-expirable (delq article gnus-newsgroup-expirable)) - (setq gnus-newsgroup-unreads (delq article gnus-newsgroup-unreads)) - (cond ((= mark gnus-ticked-mark) - (push article gnus-newsgroup-marked)) - ((= mark gnus-dormant-mark) - (push article gnus-newsgroup-dormant)) - (t - (push article gnus-newsgroup-unreads))) - (setq gnus-newsgroup-reads - (delq (assq article gnus-newsgroup-reads) - gnus-newsgroup-reads)))) - -(defalias 'gnus-summary-mark-as-unread-forward - 'gnus-summary-tick-article-forward) -(make-obsolete 'gnus-summary-mark-as-unread-forward - 'gnus-summary-tick-article-forward) -(defun gnus-summary-tick-article-forward (n) - "Tick N articles forwards. -If N is negative, tick backwards instead. -The difference between N and the number of articles ticked is returned." - (interactive "p") - (gnus-summary-mark-forward n gnus-ticked-mark)) - -(defalias 'gnus-summary-mark-as-unread-backward - 'gnus-summary-tick-article-backward) -(make-obsolete 'gnus-summary-mark-as-unread-backward - 'gnus-summary-tick-article-backward) -(defun gnus-summary-tick-article-backward (n) - "Tick N articles backwards. -The difference between N and the number of articles ticked is returned." - (interactive "p") - (gnus-summary-mark-forward (- n) gnus-ticked-mark)) - -(defalias 'gnus-summary-mark-as-unread 'gnus-summary-tick-article) -(make-obsolete 'gnus-summary-mark-as-unread 'gnus-summary-tick-article) -(defun gnus-summary-tick-article (&optional article clear-mark) - "Mark current article as unread. -Optional 1st argument ARTICLE specifies article number to be marked as unread. -Optional 2nd argument CLEAR-MARK remove any kinds of mark." - (interactive) - (gnus-summary-mark-article article (if clear-mark gnus-unread-mark - gnus-ticked-mark))) - -(defun gnus-summary-mark-as-read-forward (n) - "Mark N articles as read forwards. -If N is negative, mark backwards instead. -The difference between N and the actual number of articles marked is -returned." - (interactive "p") - (gnus-summary-mark-forward n gnus-del-mark t)) - -(defun gnus-summary-mark-as-read-backward (n) - "Mark the N articles as read backwards. -The difference between N and the actual number of articles marked is -returned." - (interactive "p") - (gnus-summary-mark-forward (- n) gnus-del-mark t)) - -(defun gnus-summary-mark-as-read (&optional article mark) - "Mark current article as read. -ARTICLE specifies the article to be marked as read. -MARK specifies a string to be inserted at the beginning of the line." - (gnus-summary-mark-article article mark)) - -(defun gnus-summary-clear-mark-forward (n) - "Clear marks from N articles forward. -If N is negative, clear backward instead. -The difference between N and the number of marks cleared is returned." - (interactive "p") - (gnus-summary-mark-forward n gnus-unread-mark)) - -(defun gnus-summary-clear-mark-backward (n) - "Clear marks from N articles backward. -The difference between N and the number of marks cleared is returned." - (interactive "p") - (gnus-summary-mark-forward (- n) gnus-unread-mark)) - -(defun gnus-summary-mark-unread-as-read () - "Intended to be used by `gnus-summary-mark-article-hook'." - (when (memq gnus-current-article gnus-newsgroup-unreads) - (gnus-summary-mark-article gnus-current-article gnus-read-mark))) - -(defun gnus-summary-mark-read-and-unread-as-read () - "Intended to be used by `gnus-summary-mark-article-hook'." - (let ((mark (gnus-summary-article-mark))) - (when (or (gnus-unread-mark-p mark) - (gnus-read-mark-p mark)) - (gnus-summary-mark-article gnus-current-article gnus-read-mark)))) - -(defun gnus-summary-mark-region-as-read (point mark all) - "Mark all unread articles between point and mark as read. -If given a prefix, mark all articles between point and mark as read, -even ticked and dormant ones." - (interactive "r\nP") - (save-excursion - (let (article) - (goto-char point) - (beginning-of-line) - (while (and - (< (point) mark) - (progn - (when (or all - (memq (setq article (gnus-summary-article-number)) - gnus-newsgroup-unreads)) - (gnus-summary-mark-article article gnus-del-mark)) - t) - (gnus-summary-find-next)))))) - -(defun gnus-summary-mark-below (score mark) - "Mark articles with score less than SCORE with MARK." - (interactive "P\ncMark: ") - (gnus-set-global-variables) - (setq score (if score - (prefix-numeric-value score) - (or gnus-summary-default-score 0))) - (save-excursion - (set-buffer gnus-summary-buffer) - (goto-char (point-min)) - (while - (progn - (and (< (gnus-summary-article-score) score) - (gnus-summary-mark-article nil mark)) - (gnus-summary-find-next))))) - -(defun gnus-summary-kill-below (&optional score) - "Mark articles with score below SCORE as read." - (interactive "P") - (gnus-set-global-variables) - (gnus-summary-mark-below score gnus-killed-mark)) - -(defun gnus-summary-clear-above (&optional score) - "Clear all marks from articles with score above SCORE." - (interactive "P") - (gnus-set-global-variables) - (gnus-summary-mark-above score gnus-unread-mark)) - -(defun gnus-summary-tick-above (&optional score) - "Tick all articles with score above SCORE." - (interactive "P") - (gnus-set-global-variables) - (gnus-summary-mark-above score gnus-ticked-mark)) - -(defun gnus-summary-mark-above (score mark) - "Mark articles with score over SCORE with MARK." - (interactive "P\ncMark: ") - (gnus-set-global-variables) - (setq score (if score - (prefix-numeric-value score) - (or gnus-summary-default-score 0))) - (save-excursion - (set-buffer gnus-summary-buffer) - (goto-char (point-min)) - (while (and (progn - (if (> (gnus-summary-article-score) score) - (gnus-summary-mark-article nil mark)) - t) - (gnus-summary-find-next))))) - -;; Suggested by Daniel Quinlan . -(defalias 'gnus-summary-show-all-expunged 'gnus-summary-limit-include-expunged) -(defun gnus-summary-limit-include-expunged (&optional no-error) - "Display all the hidden articles that were expunged for low scores." - (interactive) - (gnus-set-global-variables) - (let ((buffer-read-only nil)) - (let ((scored gnus-newsgroup-scored) - headers h) - (while scored - (or (gnus-summary-goto-subject (caar scored)) - (and (setq h (gnus-summary-article-header (caar scored))) - (< (cdar scored) gnus-summary-expunge-below) - (setq headers (cons h headers)))) - (setq scored (cdr scored))) - (if (not headers) - (when (not no-error) - (error "No expunged articles hidden.")) - (goto-char (point-min)) - (gnus-summary-prepare-unthreaded (nreverse headers)) - (goto-char (point-min)) - (gnus-summary-position-point) - t)))) - -(defun gnus-summary-catchup (&optional all quietly to-here not-mark) - "Mark all articles not marked as unread in this newsgroup as read. -If prefix argument ALL is non-nil, all articles are marked as read. -If QUIETLY is non-nil, no questions will be asked. -If TO-HERE is non-nil, it should be a point in the buffer. All -articles before this point will be marked as read. -The number of articles marked as read is returned." - (interactive "P") - (gnus-set-global-variables) - (prog1 - (if (or quietly - (not gnus-interactive-catchup) ;Without confirmation? - gnus-expert-user - (gnus-y-or-n-p - (if all - "Mark absolutely all articles as read? " - "Mark all unread articles as read? "))) - (if (and not-mark - (not gnus-newsgroup-adaptive) - (not gnus-newsgroup-auto-expire)) - (progn - (when all - (setq gnus-newsgroup-marked nil - gnus-newsgroup-dormant nil)) - (setq gnus-newsgroup-unreads nil)) - ;; We actually mark all articles as canceled, which we - ;; have to do when using auto-expiry or adaptive scoring. - (gnus-summary-show-all-threads) - (if (gnus-summary-first-subject (not all)) - (while (and - (if to-here (< (point) to-here) t) - (gnus-summary-mark-article-as-read gnus-catchup-mark) - (gnus-summary-find-next (not all))))) - (unless to-here - (setq gnus-newsgroup-unreads nil)) - (gnus-set-mode-line 'summary))) - (let ((method (gnus-find-method-for-group gnus-newsgroup-name))) - (if (and (not to-here) (eq 'nnvirtual (car method))) - (nnvirtual-catchup-group - (gnus-group-real-name gnus-newsgroup-name) (nth 1 method) all))) - (gnus-summary-position-point))) - -(defun gnus-summary-catchup-to-here (&optional all) - "Mark all unticked articles before the current one as read. -If ALL is non-nil, also mark ticked and dormant articles as read." - (interactive "P") - (gnus-set-global-variables) - (save-excursion - (gnus-save-hidden-threads - (let ((beg (point))) - ;; We check that there are unread articles. - (when (or all (gnus-summary-find-prev)) - (gnus-summary-catchup all t beg))))) - (gnus-summary-position-point)) - -(defun gnus-summary-catchup-all (&optional quietly) - "Mark all articles in this newsgroup as read." - (interactive "P") - (gnus-set-global-variables) - (gnus-summary-catchup t quietly)) - -(defun gnus-summary-catchup-and-exit (&optional all quietly) - "Mark all articles not marked as unread in this newsgroup as read, then exit. -If prefix argument ALL is non-nil, all articles are marked as read." - (interactive "P") - (gnus-set-global-variables) - (gnus-summary-catchup all quietly nil 'fast) - ;; Select next newsgroup or exit. - (if (eq gnus-auto-select-next 'quietly) - (gnus-summary-next-group nil) - (gnus-summary-exit))) - -(defun gnus-summary-catchup-all-and-exit (&optional quietly) - "Mark all articles in this newsgroup as read, and then exit." - (interactive "P") - (gnus-set-global-variables) - (gnus-summary-catchup-and-exit t quietly)) - -;; Suggested by "Arne Eofsson" . -(defun gnus-summary-catchup-and-goto-next-group (&optional all) - "Mark all articles in this group as read and select the next group. -If given a prefix, mark all articles, unread as well as ticked, as -read." - (interactive "P") - (gnus-set-global-variables) - (save-excursion - (gnus-summary-catchup all)) - (gnus-summary-next-article t nil nil t)) - -;; Thread-based commands. - -(defun gnus-summary-articles-in-thread (&optional article) - "Return a list of all articles in the current thread. -If ARTICLE is non-nil, return all articles in the thread that starts -with that article." - (let* ((article (or article (gnus-summary-article-number))) - (data (gnus-data-find-list article)) - (top-level (gnus-data-level (car data))) - (top-subject - (cond ((null gnus-thread-operation-ignore-subject) - (gnus-simplify-subject-re - (mail-header-subject (gnus-data-header (car data))))) - ((eq gnus-thread-operation-ignore-subject 'fuzzy) - (gnus-simplify-subject-fuzzy - (mail-header-subject (gnus-data-header (car data))))) - (t nil))) - (end-point (save-excursion - (if (gnus-summary-go-to-next-thread) - (point) (point-max)))) - articles) - (while (and data - (< (gnus-data-pos (car data)) end-point)) - (when (or (not top-subject) - (string= top-subject - (if (eq gnus-thread-operation-ignore-subject 'fuzzy) - (gnus-simplify-subject-fuzzy - (mail-header-subject - (gnus-data-header (car data)))) - (gnus-simplify-subject-re - (mail-header-subject - (gnus-data-header (car data))))))) - (push (gnus-data-number (car data)) articles)) - (unless (and (setq data (cdr data)) - (> (gnus-data-level (car data)) top-level)) - (setq data nil))) - ;; Return the list of articles. - (nreverse articles))) - -(defun gnus-summary-rethread-current () - "Rethread the thread the current article is part of." - (interactive) - (gnus-set-global-variables) - (let* ((gnus-show-threads t) - (article (gnus-summary-article-number)) - (id (mail-header-id (gnus-summary-article-header))) - (gnus-newsgroup-threads (list (gnus-id-to-thread (gnus-root-id id))))) - (unless id - (error "No article on the current line")) - (gnus-rebuild-thread id) - (gnus-summary-goto-subject article))) - -(defun gnus-summary-reparent-thread () - "Make current article child of the marked (or previous) article. - -Note that the re-threading will only work if `gnus-thread-ignore-subject' -is non-nil or the Subject: of both articles are the same." - (interactive) - (or (not (gnus-group-read-only-p)) - (error "The current newsgroup does not support article editing.")) - (or (<= (length gnus-newsgroup-processable) 1) - (error "No more than one article may be marked.")) - (save-window-excursion - (let ((gnus-article-buffer " *reparent*") - (current-article (gnus-summary-article-number)) - ; first grab the marked article, otherwise one line up. - (parent-article (if (not (null gnus-newsgroup-processable)) - (car gnus-newsgroup-processable) - (save-excursion - (if (eq (forward-line -1) 0) - (gnus-summary-article-number) - (error "Beginning of summary buffer.")))))) - (or (not (eq current-article parent-article)) - (error "An article may not be self-referential.")) - (let ((message-id (mail-header-id - (gnus-summary-article-header parent-article)))) - (or (and message-id (not (equal message-id ""))) - (error "No message-id in desired parent.")) - (gnus-summary-select-article t t nil current-article) - (set-buffer gnus-article-buffer) - (setq buffer-read-only nil) - (let ((buf (format "%s" (buffer-string)))) - (erase-buffer) - (insert buf)) - (goto-char (point-min)) - (if (search-forward-regexp "^References: " nil t) - (insert message-id " " ) - (insert "References: " message-id "\n")) - (or (gnus-request-replace-article current-article - (car gnus-article-current) - gnus-article-buffer) - (error "Couldn't replace article.")) - (set-buffer gnus-summary-buffer) - (gnus-summary-unmark-all-processable) - (gnus-summary-rethread-current) - (gnus-message 3 "Article %d is now the child of article %d." - current-article parent-article))))) - -(defun gnus-summary-toggle-threads (&optional arg) - "Toggle showing conversation threads. -If ARG is positive number, turn showing conversation threads on." - (interactive "P") - (gnus-set-global-variables) - (let ((current (or (gnus-summary-article-number) gnus-newsgroup-end))) - (setq gnus-show-threads - (if (null arg) (not gnus-show-threads) - (> (prefix-numeric-value arg) 0))) - (gnus-summary-prepare) - (gnus-summary-goto-subject current) - (gnus-message 6 "Threading is now %s" (if gnus-show-threads "on" "off")) - (gnus-summary-position-point))) - -(defun gnus-summary-show-all-threads () - "Show all threads." - (interactive) - (gnus-set-global-variables) - (save-excursion - (let ((buffer-read-only nil)) - (subst-char-in-region (point-min) (point-max) ?\^M ?\n t))) - (gnus-summary-position-point)) - -(defun gnus-summary-show-thread () - "Show thread subtrees. -Returns nil if no thread was there to be shown." - (interactive) - (gnus-set-global-variables) - (let ((buffer-read-only nil) - (orig (point)) - ;; first goto end then to beg, to have point at beg after let - (end (progn (end-of-line) (point))) - (beg (progn (beginning-of-line) (point)))) - (prog1 - ;; Any hidden lines here? - (search-forward "\r" end t) - (subst-char-in-region beg end ?\^M ?\n t) - (goto-char orig) - (gnus-summary-position-point)))) - -(defun gnus-summary-hide-all-threads () - "Hide all thread subtrees." - (interactive) - (gnus-set-global-variables) - (save-excursion - (goto-char (point-min)) - (gnus-summary-hide-thread) - (while (zerop (gnus-summary-next-thread 1 t)) - (gnus-summary-hide-thread))) - (gnus-summary-position-point)) - -(defun gnus-summary-hide-thread () - "Hide thread subtrees. -Returns nil if no threads were there to be hidden." - (interactive) - (gnus-set-global-variables) - (let ((buffer-read-only nil) - (start (point)) - (article (gnus-summary-article-number))) - (goto-char start) - ;; Go forward until either the buffer ends or the subthread - ;; ends. - (when (and (not (eobp)) - (or (zerop (gnus-summary-next-thread 1 t)) - (goto-char (point-max)))) - (prog1 - (if (and (> (point) start) - (search-backward "\n" start t)) - (progn - (subst-char-in-region start (point) ?\n ?\^M) - (gnus-summary-goto-subject article)) - (goto-char start) - nil) - ;;(gnus-summary-position-point) - )))) - -(defun gnus-summary-go-to-next-thread (&optional previous) - "Go to the same level (or less) next thread. -If PREVIOUS is non-nil, go to previous thread instead. -Return the article number moved to, or nil if moving was impossible." - (let ((level (gnus-summary-thread-level)) - (way (if previous -1 1)) - (beg (point))) - (forward-line way) - (while (and (not (eobp)) - (< level (gnus-summary-thread-level))) - (forward-line way)) - (if (eobp) - (progn - (goto-char beg) - nil) - (setq beg (point)) - (prog1 - (gnus-summary-article-number) - (goto-char beg))))) - -(defun gnus-summary-go-to-next-thread-old (&optional previous) - "Go to the same level (or less) next thread. -If PREVIOUS is non-nil, go to previous thread instead. -Return the article number moved to, or nil if moving was impossible." - (if (and (eq gnus-summary-make-false-root 'dummy) - (gnus-summary-article-intangible-p)) - (let ((beg (point))) - (while (and (zerop (forward-line 1)) - (not (gnus-summary-article-intangible-p)) - (not (zerop (save-excursion - (gnus-summary-thread-level)))))) - (if (eobp) - (progn - (goto-char beg) - nil) - (point))) - (let* ((level (gnus-summary-thread-level)) - (article (gnus-summary-article-number)) - (data (cdr (gnus-data-find-list article (gnus-data-list previous)))) - oart) - (while data - (if (<= (gnus-data-level (car data)) level) - (setq oart (gnus-data-number (car data)) - data nil) - (setq data (cdr data)))) - (and oart - (gnus-summary-goto-subject oart))))) - -(defun gnus-summary-next-thread (n &optional silent) - "Go to the same level next N'th thread. -If N is negative, search backward instead. -Returns the difference between N and the number of skips actually -done. - -If SILENT, don't output messages." - (interactive "p") - (gnus-set-global-variables) - (let ((backward (< n 0)) - (n (abs n)) - old dum int) - (while (and (> n 0) - (gnus-summary-go-to-next-thread backward)) - (decf n)) - (unless silent - (gnus-summary-position-point)) - (when (and (not silent) (/= 0 n)) - (gnus-message 7 "No more threads")) - n)) - -(defun gnus-summary-prev-thread (n) - "Go to the same level previous N'th thread. -Returns the difference between N and the number of skips actually -done." - (interactive "p") - (gnus-set-global-variables) - (gnus-summary-next-thread (- n))) - -(defun gnus-summary-go-down-thread () - "Go down one level in the current thread." - (let ((children (gnus-summary-article-children))) - (and children - (gnus-summary-goto-subject (car children))))) - -(defun gnus-summary-go-up-thread () - "Go up one level in the current thread." - (let ((parent (gnus-summary-article-parent))) - (and parent - (gnus-summary-goto-subject parent)))) - -(defun gnus-summary-down-thread (n) - "Go down thread N steps. -If N is negative, go up instead. -Returns the difference between N and how many steps down that were -taken." - (interactive "p") - (gnus-set-global-variables) - (let ((up (< n 0)) - (n (abs n))) - (while (and (> n 0) - (if up (gnus-summary-go-up-thread) - (gnus-summary-go-down-thread))) - (setq n (1- n))) - (gnus-summary-position-point) - (if (/= 0 n) (gnus-message 7 "Can't go further")) - n)) - -(defun gnus-summary-up-thread (n) - "Go up thread N steps. -If N is negative, go up instead. -Returns the difference between N and how many steps down that were -taken." - (interactive "p") - (gnus-set-global-variables) - (gnus-summary-down-thread (- n))) - -(defun gnus-summary-top-thread () - "Go to the top of the thread." - (interactive) - (gnus-set-global-variables) - (while (gnus-summary-go-up-thread)) - (gnus-summary-article-number)) - -(defun gnus-summary-kill-thread (&optional unmark) - "Mark articles under current thread as read. -If the prefix argument is positive, remove any kinds of marks. -If the prefix argument is negative, tick articles instead." - (interactive "P") - (gnus-set-global-variables) - (when unmark - (setq unmark (prefix-numeric-value unmark))) - (let ((articles (gnus-summary-articles-in-thread))) - (save-excursion - ;; Expand the thread. - (gnus-summary-show-thread) - ;; Mark all the articles. - (while articles - (gnus-summary-goto-subject (car articles)) - (cond ((null unmark) - (gnus-summary-mark-article-as-read gnus-killed-mark)) - ((> unmark 0) - (gnus-summary-mark-article-as-unread gnus-unread-mark)) - (t - (gnus-summary-mark-article-as-unread gnus-ticked-mark))) - (setq articles (cdr articles)))) - ;; Hide killed subtrees. - (and (null unmark) - gnus-thread-hide-killed - (gnus-summary-hide-thread)) - ;; If marked as read, go to next unread subject. - (if (null unmark) - ;; Go to next unread subject. - (gnus-summary-next-subject 1 t))) - (gnus-set-mode-line 'summary)) - -;; Summary sorting commands - -(defun gnus-summary-sort-by-number (&optional reverse) - "Sort summary buffer by article number. -Argument REVERSE means reverse order." - (interactive "P") - (gnus-summary-sort 'number reverse)) - -(defun gnus-summary-sort-by-author (&optional reverse) - "Sort summary buffer by author name alphabetically. -If case-fold-search is non-nil, case of letters is ignored. -Argument REVERSE means reverse order." - (interactive "P") - (gnus-summary-sort 'author reverse)) - -(defun gnus-summary-sort-by-subject (&optional reverse) - "Sort summary buffer by subject alphabetically. `Re:'s are ignored. -If case-fold-search is non-nil, case of letters is ignored. -Argument REVERSE means reverse order." - (interactive "P") - (gnus-summary-sort 'subject reverse)) - -(defun gnus-summary-sort-by-date (&optional reverse) - "Sort summary buffer by date. -Argument REVERSE means reverse order." - (interactive "P") - (gnus-summary-sort 'date reverse)) - -(defun gnus-summary-sort-by-score (&optional reverse) - "Sort summary buffer by score. -Argument REVERSE means reverse order." - (interactive "P") - (gnus-summary-sort 'score reverse)) - -(defun gnus-summary-sort (predicate reverse) - "Sort summary buffer by PREDICATE. REVERSE means reverse order." - (gnus-set-global-variables) - (let* ((thread (intern (format "gnus-thread-sort-by-%s" predicate))) - (article (intern (format "gnus-article-sort-by-%s" predicate))) - (gnus-thread-sort-functions - (list - (if (not reverse) - thread - `(lambda (t1 t2) - (,thread t2 t1))))) - (gnus-article-sort-functions - (list - (if (not reverse) - article - `(lambda (t1 t2) - (,article t2 t1))))) - (buffer-read-only) - (gnus-summary-prepare-hook nil)) - ;; We do the sorting by regenerating the threads. - (gnus-summary-prepare) - ;; Hide subthreads if needed. - (when (and gnus-show-threads gnus-thread-hide-subtree) - (gnus-summary-hide-all-threads))) - ;; If in async mode, we send some info to the backend. - (when gnus-newsgroup-async - (gnus-request-asynchronous - gnus-newsgroup-name gnus-newsgroup-data))) - -(defun gnus-sortable-date (date) - "Make sortable string by string-lessp from DATE. -Timezone package is used." - (condition-case () - (progn - (setq date (inline (timezone-fix-time - date nil - (aref (inline (timezone-parse-date date)) 4)))) - (inline - (timezone-make-sortable-date - (aref date 0) (aref date 1) (aref date 2) - (inline - (timezone-make-time-string - (aref date 3) (aref date 4) (aref date 5)))))) - (error ""))) - -;; Summary saving commands. - -(defun gnus-summary-save-article (&optional n not-saved) - "Save the current article using the default saver function. -If N is a positive number, save the N next articles. -If N is a negative number, save the N previous articles. -If N is nil and any articles have been marked with the process mark, -save those articles instead. -The variable `gnus-default-article-saver' specifies the saver function." - (interactive "P") - (gnus-set-global-variables) - (let ((articles (gnus-summary-work-articles n)) - (save-buffer (save-excursion - (nnheader-set-temp-buffer " *Gnus Save*"))) - file header article) - (while articles - (setq header (gnus-summary-article-header - (setq article (pop articles)))) - (if (not (vectorp header)) - ;; This is a pseudo-article. - (if (assq 'name header) - (gnus-copy-file (cdr (assq 'name header))) - (gnus-message 1 "Article %d is unsaveable" article)) - ;; This is a real article. - (save-window-excursion - (gnus-summary-select-article t nil nil article)) - (save-excursion - (set-buffer save-buffer) - (erase-buffer) - (insert-buffer-substring gnus-original-article-buffer)) - (unless gnus-save-all-headers - ;; Remove headers accoring to `gnus-saved-headers'. - (let ((gnus-visible-headers - (or gnus-saved-headers gnus-visible-headers)) - (gnus-article-buffer save-buffer)) - (gnus-article-hide-headers 1 t))) - (save-window-excursion - (if (not gnus-default-article-saver) - (error "No default saver is defined.") - ;; !!! Magic! The saving functions all save - ;; `gnus-original-article-buffer' (or so they think), - ;; but we bind that variable to our save-buffer. - (set-buffer gnus-article-buffer) - (let ((gnus-original-article-buffer save-buffer)) - (set-buffer gnus-summary-buffer) - (setq file (funcall - gnus-default-article-saver - (cond - ((not gnus-prompt-before-saving) - 'default) - ((eq gnus-prompt-before-saving 'always) - nil) - (t file))))))) - (gnus-summary-remove-process-mark article) - (unless not-saved - (gnus-summary-set-saved-mark article)))) - (gnus-kill-buffer save-buffer) - (gnus-summary-position-point) - n)) - -(defun gnus-summary-pipe-output (&optional arg) - "Pipe the current article to a subprocess. -If N is a positive number, pipe the N next articles. -If N is a negative number, pipe the N previous articles. -If N is nil and any articles have been marked with the process mark, -pipe those articles instead." - (interactive "P") - (gnus-set-global-variables) - (let ((gnus-default-article-saver 'gnus-summary-save-in-pipe)) - (gnus-summary-save-article arg t)) - (gnus-configure-windows 'pipe)) - -(defun gnus-summary-save-article-mail (&optional arg) - "Append the current article to an mail file. -If N is a positive number, save the N next articles. -If N is a negative number, save the N previous articles. -If N is nil and any articles have been marked with the process mark, -save those articles instead." - (interactive "P") - (gnus-set-global-variables) - (let ((gnus-default-article-saver 'gnus-summary-save-in-mail)) - (gnus-summary-save-article arg))) - -(defun gnus-summary-save-article-rmail (&optional arg) - "Append the current article to an rmail file. -If N is a positive number, save the N next articles. -If N is a negative number, save the N previous articles. -If N is nil and any articles have been marked with the process mark, -save those articles instead." - (interactive "P") - (gnus-set-global-variables) - (let ((gnus-default-article-saver 'gnus-summary-save-in-rmail)) - (gnus-summary-save-article arg))) - -(defun gnus-summary-save-article-file (&optional arg) - "Append the current article to a file. -If N is a positive number, save the N next articles. -If N is a negative number, save the N previous articles. -If N is nil and any articles have been marked with the process mark, -save those articles instead." - (interactive "P") - (gnus-set-global-variables) - (let ((gnus-default-article-saver 'gnus-summary-save-in-file)) - (gnus-summary-save-article arg))) - -(defun gnus-summary-save-article-body-file (&optional arg) - "Append the current article body to a file. -If N is a positive number, save the N next articles. -If N is a negative number, save the N previous articles. -If N is nil and any articles have been marked with the process mark, -save those articles instead." - (interactive "P") - (gnus-set-global-variables) - (let ((gnus-default-article-saver 'gnus-summary-save-body-in-file)) - (gnus-summary-save-article arg))) - -(defun gnus-get-split-value (methods) - "Return a value based on the split METHODS." - (let (split-name method result match) - (when methods - (save-excursion - (set-buffer gnus-original-article-buffer) - (save-restriction - (nnheader-narrow-to-headers) - (while methods - (goto-char (point-min)) - (setq method (pop methods)) - (setq match (car method)) - (when (cond - ((stringp match) - ;; Regular expression. - (condition-case () - (re-search-forward match nil t) - (error nil))) - ((gnus-functionp match) - ;; Function. - (save-restriction - (widen) - (setq result (funcall match gnus-newsgroup-name)))) - ((consp match) - ;; Form. - (save-restriction - (widen) - (setq result (eval match))))) - (setq split-name (append (cdr method) split-name)) - (cond ((stringp result) - (push result split-name)) - ((consp result) - (setq split-name (append result split-name))))))))) - split-name)) - -(defun gnus-read-move-group-name (prompt default articles prefix) - "Read a group name." - (let* ((split-name (gnus-get-split-value gnus-move-split-methods)) - (minibuffer-confirm-incomplete nil) ; XEmacs - group-map - (dum (mapatoms - (lambda (g) - (and (boundp g) - (symbol-name g) - (memq 'respool - (assoc (symbol-name - (car (gnus-find-method-for-group - (symbol-name g)))) - gnus-valid-select-methods)) - (push (list (symbol-name g)) group-map))) - gnus-active-hashtb)) - (prom - (format "%s %s to:" - prompt - (if (> (length articles) 1) - (format "these %d articles" (length articles)) - "this article"))) - (to-newsgroup - (cond - ((null split-name) - (gnus-completing-read default prom - group-map nil nil prefix - 'gnus-group-history)) - ((= 1 (length split-name)) - (gnus-completing-read (car split-name) prom group-map - nil nil nil - 'gnus-group-history)) - (t - (gnus-completing-read nil prom - (mapcar (lambda (el) (list el)) - (nreverse split-name)) - nil nil nil - 'gnus-group-history))))) - (when to-newsgroup - (if (or (string= to-newsgroup "") - (string= to-newsgroup prefix)) - (setq to-newsgroup (or default ""))) - (or (gnus-active to-newsgroup) - (gnus-activate-group to-newsgroup) - (if (gnus-y-or-n-p (format "No such group: %s. Create it? " - to-newsgroup)) - (or (and (gnus-request-create-group - to-newsgroup (gnus-group-name-to-method to-newsgroup)) - (gnus-activate-group to-newsgroup nil nil - (gnus-group-name-to-method - to-newsgroup))) - (error "Couldn't create group %s" to-newsgroup))) - (error "No such group: %s" to-newsgroup))) - to-newsgroup)) - -(defun gnus-read-save-file-name (prompt default-name) - (let* ((split-name (gnus-get-split-value gnus-split-methods)) - (file - ;; Let the split methods have their say. - (cond - ;; No split name was found. - ((null split-name) - (read-file-name - (concat prompt " (default " - (file-name-nondirectory default-name) ") ") - (file-name-directory default-name) - default-name)) - ;; A single split name was found - ((= 1 (length split-name)) - (let* ((name (car split-name)) - (dir (cond ((file-directory-p name) - (file-name-as-directory name)) - ((file-exists-p name) name) - (t gnus-article-save-directory)))) - (read-file-name - (concat prompt " (default " name ") ") - dir name))) - ;; A list of splits was found. - (t - (setq split-name (nreverse split-name)) - (let (result) - (let ((file-name-history (nconc split-name file-name-history))) - (setq result - (read-file-name - (concat prompt " (`M-p' for defaults) ") - gnus-article-save-directory - (car split-name)))) - (car (push result file-name-history))))))) - ;; Create the directory. - (unless (equal (directory-file-name file) file) - (make-directory (file-name-directory file) t)) - ;; If we have read a directory, we append the default file name. - (when (file-directory-p file) - (setq file (concat (file-name-as-directory file) - (file-name-nondirectory default-name)))) - ;; Possibly translate some characters. - (nnheader-translate-file-chars file))) - -(defun gnus-article-archive-name (group) - "Return the first instance of an \"Archive-name\" in the current buffer." - (let ((case-fold-search t)) - (when (re-search-forward "archive-name: *\\([^ \n\t]+\\)[ \t]*$" nil t) - (nnheader-concat gnus-article-save-directory - (match-string 1))))) - -(defun gnus-summary-save-in-rmail (&optional filename) - "Append this article to Rmail file. -Optional argument FILENAME specifies file name. -Directory to save to is default to `gnus-article-save-directory'." - (interactive) - (gnus-set-global-variables) - (let ((default-name - (funcall gnus-rmail-save-name gnus-newsgroup-name - gnus-current-headers gnus-newsgroup-last-rmail))) - (setq filename - (cond ((eq filename 'default) - default-name) - (filename filename) - (t (gnus-read-save-file-name - "Save in rmail file:" default-name)))) - (gnus-make-directory (file-name-directory filename)) - (gnus-eval-in-buffer-window gnus-original-article-buffer - (save-excursion - (save-restriction - (widen) - (gnus-output-to-rmail filename)))) - ;; Remember the directory name to save articles - (setq gnus-newsgroup-last-rmail filename))) - -(defun gnus-summary-save-in-mail (&optional filename) - "Append this article to Unix mail file. -Optional argument FILENAME specifies file name. -Directory to save to is default to `gnus-article-save-directory'." - (interactive) - (gnus-set-global-variables) - (let ((default-name - (funcall gnus-mail-save-name gnus-newsgroup-name - gnus-current-headers gnus-newsgroup-last-mail))) - (setq filename - (cond ((eq filename 'default) - default-name) - (filename filename) - (t (gnus-read-save-file-name - "Save in Unix mail file:" default-name)))) - (setq filename - (expand-file-name filename - (and default-name - (file-name-directory default-name)))) - (gnus-make-directory (file-name-directory filename)) - (gnus-eval-in-buffer-window gnus-original-article-buffer - (save-excursion - (save-restriction - (widen) - (if (and (file-readable-p filename) (mail-file-babyl-p filename)) - (gnus-output-to-rmail filename) - (let ((mail-use-rfc822 t)) - (rmail-output filename 1 t t)))))) - ;; Remember the directory name to save articles. - (setq gnus-newsgroup-last-mail filename))) - -(defun gnus-summary-save-in-file (&optional filename) - "Append this article to file. -Optional argument FILENAME specifies file name. -Directory to save to is default to `gnus-article-save-directory'." - (interactive) - (gnus-set-global-variables) - (let ((default-name - (funcall gnus-file-save-name gnus-newsgroup-name - gnus-current-headers gnus-newsgroup-last-file))) - (setq filename - (cond ((eq filename 'default) - default-name) - (filename filename) - (t (gnus-read-save-file-name - "Save in file:" default-name)))) - (gnus-make-directory (file-name-directory filename)) - (gnus-eval-in-buffer-window gnus-original-article-buffer - (save-excursion - (save-restriction - (widen) - (gnus-output-to-file filename)))) - ;; Remember the directory name to save articles. - (setq gnus-newsgroup-last-file filename))) - -(defun gnus-summary-save-body-in-file (&optional filename) - "Append this article body to a file. -Optional argument FILENAME specifies file name. -The directory to save in defaults to `gnus-article-save-directory'." - (interactive) - (gnus-set-global-variables) - (let ((default-name - (funcall gnus-file-save-name gnus-newsgroup-name - gnus-current-headers gnus-newsgroup-last-file))) - (setq filename - (cond ((eq filename 'default) - default-name) - (filename filename) - (t (gnus-read-save-file-name - "Save body in file:" default-name)))) - (gnus-make-directory (file-name-directory filename)) - (gnus-eval-in-buffer-window gnus-original-article-buffer - (save-excursion - (save-restriction - (widen) - (goto-char (point-min)) - (and (search-forward "\n\n" nil t) - (narrow-to-region (point) (point-max))) - (gnus-output-to-file filename)))) - ;; Remember the directory name to save articles. - (setq gnus-newsgroup-last-file filename))) - -(defun gnus-summary-save-in-pipe (&optional command) - "Pipe this article to subprocess." - (interactive) - (gnus-set-global-variables) - (setq command - (cond ((eq command 'default) - gnus-last-shell-command) - (command command) - (t (read-string "Shell command on article: " - gnus-last-shell-command)))) - (if (string-equal command "") - (setq command gnus-last-shell-command)) - (gnus-eval-in-buffer-window gnus-article-buffer - (save-restriction - (widen) - (shell-command-on-region (point-min) (point-max) command nil))) - (setq gnus-last-shell-command command)) - -;; Summary extract commands - -(defun gnus-summary-insert-pseudos (pslist &optional not-view) - (let ((buffer-read-only nil) - (article (gnus-summary-article-number)) - after-article b e) - (or (gnus-summary-goto-subject article) - (error (format "No such article: %d" article))) - (gnus-summary-position-point) - ;; If all commands are to be bunched up on one line, we collect - ;; them here. - (if gnus-view-pseudos-separately - () - (let ((ps (setq pslist (sort pslist 'gnus-pseudos<))) - files action) - (while ps - (setq action (cdr (assq 'action (car ps)))) - (setq files (list (cdr (assq 'name (car ps))))) - (while (and ps (cdr ps) - (string= (or action "1") - (or (cdr (assq 'action (cadr ps))) "2"))) - (setq files (cons (cdr (assq 'name (cadr ps))) files)) - (setcdr ps (cddr ps))) - (if (not files) - () - (if (not (string-match "%s" action)) - (setq files (cons " " files))) - (setq files (cons " " files)) - (and (assq 'execute (car ps)) - (setcdr (assq 'execute (car ps)) - (funcall (if (string-match "%s" action) - 'format 'concat) - action - (mapconcat (lambda (f) f) files " "))))) - (setq ps (cdr ps))))) - (if (and gnus-view-pseudos (not not-view)) - (while pslist - (and (assq 'execute (car pslist)) - (gnus-execute-command (cdr (assq 'execute (car pslist))) - (eq gnus-view-pseudos 'not-confirm))) - (setq pslist (cdr pslist))) - (save-excursion - (while pslist - (setq after-article (or (cdr (assq 'article (car pslist))) - (gnus-summary-article-number))) - (gnus-summary-goto-subject after-article) - (forward-line 1) - (setq b (point)) - (insert " " (file-name-nondirectory - (cdr (assq 'name (car pslist)))) - ": " (or (cdr (assq 'execute (car pslist))) "") "\n") - (setq e (point)) - (forward-line -1) ; back to `b' - (gnus-add-text-properties - b (1- e) (list 'gnus-number gnus-reffed-article-number - gnus-mouse-face-prop gnus-mouse-face)) - (gnus-data-enter - after-article gnus-reffed-article-number - gnus-unread-mark b (car pslist) 0 (- e b)) - (push gnus-reffed-article-number gnus-newsgroup-unreads) - (setq gnus-reffed-article-number (1- gnus-reffed-article-number)) - (setq pslist (cdr pslist))))))) - -(defun gnus-pseudos< (p1 p2) - (let ((c1 (cdr (assq 'action p1))) - (c2 (cdr (assq 'action p2)))) - (and c1 c2 (string< c1 c2)))) - -(defun gnus-request-pseudo-article (props) - (cond ((assq 'execute props) - (gnus-execute-command (cdr (assq 'execute props))))) - (let ((gnus-current-article (gnus-summary-article-number))) - (run-hooks 'gnus-mark-article-hook))) - -(defun gnus-execute-command (command &optional automatic) - (save-excursion - (gnus-article-setup-buffer) - (set-buffer gnus-article-buffer) - (setq buffer-read-only nil) - (let ((command (if automatic command (read-string "Command: " command))) - ;; Just binding this here doesn't help, because there might - ;; be output from the process after exiting the scope of - ;; this `let'. - ;; (buffer-read-only nil) - ) - (erase-buffer) - (insert "$ " command "\n\n") - (if gnus-view-pseudo-asynchronously - (start-process "gnus-execute" nil shell-file-name - shell-command-switch command) - (call-process shell-file-name nil t nil - shell-command-switch command))))) - -(defun gnus-copy-file (file &optional to) - "Copy FILE to TO." - (interactive - (list (read-file-name "Copy file: " default-directory) - (read-file-name "Copy file to: " default-directory))) - (gnus-set-global-variables) - (or to (setq to (read-file-name "Copy file to: " default-directory))) - (and (file-directory-p to) - (setq to (concat (file-name-as-directory to) - (file-name-nondirectory file)))) - (copy-file file to)) - -;; Summary kill commands. - -(defun gnus-summary-edit-global-kill (article) - "Edit the \"global\" kill file." - (interactive (list (gnus-summary-article-number))) - (gnus-set-global-variables) - (gnus-group-edit-global-kill article)) - -(defun gnus-summary-edit-local-kill () - "Edit a local kill file applied to the current newsgroup." - (interactive) - (gnus-set-global-variables) - (setq gnus-current-headers (gnus-summary-article-header)) - (gnus-set-global-variables) - (gnus-group-edit-local-kill - (gnus-summary-article-number) gnus-newsgroup-name)) - - -;;; -;;; Gnus article mode -;;; - -(put 'gnus-article-mode 'mode-class 'special) - -(if gnus-article-mode-map - nil - (setq gnus-article-mode-map (make-keymap)) - (suppress-keymap gnus-article-mode-map) - - (gnus-define-keys gnus-article-mode-map - " " gnus-article-goto-next-page - "\177" gnus-article-goto-prev-page - [delete] gnus-article-goto-prev-page - "\C-c^" gnus-article-refer-article - "h" gnus-article-show-summary - "s" gnus-article-show-summary - "\C-c\C-m" gnus-article-mail - "?" gnus-article-describe-briefly - gnus-mouse-2 gnus-article-push-button - "\r" gnus-article-press-button - "\t" gnus-article-next-button - "\M-\t" gnus-article-prev-button - "<" beginning-of-buffer - ">" end-of-buffer - "\C-c\C-i" gnus-info-find-node - "\C-c\C-b" gnus-bug) - - (substitute-key-definition - 'undefined 'gnus-article-read-summary-keys gnus-article-mode-map)) - -(defun gnus-article-mode () - "Major mode for displaying an article. - -All normal editing commands are switched off. - -The following commands are available: - -\\ -\\[gnus-article-next-page]\t Scroll the article one page forwards -\\[gnus-article-prev-page]\t Scroll the article one page backwards -\\[gnus-article-refer-article]\t Go to the article referred to by an article id near point -\\[gnus-article-show-summary]\t Display the summary buffer -\\[gnus-article-mail]\t Send a reply to the address near point -\\[gnus-article-describe-briefly]\t Describe the current mode briefly -\\[gnus-info-find-node]\t Go to the Gnus info node" - (interactive) - (when (and menu-bar-mode - (gnus-visual-p 'article-menu 'menu)) - (gnus-article-make-menu-bar)) - (kill-all-local-variables) - (gnus-simplify-mode-line) - (setq mode-name "Article") - (setq major-mode 'gnus-article-mode) - (make-local-variable 'minor-mode-alist) - (or (assq 'gnus-show-mime minor-mode-alist) - (setq minor-mode-alist - (cons (list 'gnus-show-mime " MIME") minor-mode-alist))) - (use-local-map gnus-article-mode-map) - (make-local-variable 'page-delimiter) - (setq page-delimiter gnus-page-delimiter) - (buffer-disable-undo (current-buffer)) - (setq buffer-read-only t) ;Disable modification - (run-hooks 'gnus-article-mode-hook)) - -(defun gnus-article-setup-buffer () - "Initialize the article buffer." - (let* ((name (if gnus-single-article-buffer "*Article*" - (concat "*Article " gnus-newsgroup-name "*"))) - (original - (progn (string-match "\\*Article" name) - (concat " *Original Article" - (substring name (match-end 0)))))) - (setq gnus-article-buffer name) - (setq gnus-original-article-buffer original) - ;; This might be a variable local to the summary buffer. - (unless gnus-single-article-buffer - (save-excursion - (set-buffer gnus-summary-buffer) - (setq gnus-article-buffer name) - (setq gnus-original-article-buffer original) - (gnus-set-global-variables)) - (make-local-variable 'gnus-summary-buffer)) - ;; Init original article buffer. - (save-excursion - (set-buffer (get-buffer-create gnus-original-article-buffer)) - (buffer-disable-undo (current-buffer)) - (setq major-mode 'gnus-original-article-mode) - (gnus-add-current-to-buffer-list) - (make-local-variable 'gnus-original-article)) - (if (get-buffer name) - (save-excursion - (set-buffer name) - (buffer-disable-undo (current-buffer)) - (setq buffer-read-only t) - (gnus-add-current-to-buffer-list) - (or (eq major-mode 'gnus-article-mode) - (gnus-article-mode)) - (current-buffer)) - (save-excursion - (set-buffer (get-buffer-create name)) - (gnus-add-current-to-buffer-list) - (gnus-article-mode) - (current-buffer))))) - -;; Set article window start at LINE, where LINE is the number of lines -;; from the head of the article. -(defun gnus-article-set-window-start (&optional line) - (set-window-start - (get-buffer-window gnus-article-buffer t) - (save-excursion - (set-buffer gnus-article-buffer) - (goto-char (point-min)) - (if (not line) - (point-min) - (gnus-message 6 "Moved to bookmark") - (search-forward "\n\n" nil t) - (forward-line line) - (point))))) - -(defun gnus-kill-all-overlays () - "Delete all overlays in the current buffer." - (when (fboundp 'overlay-lists) - (let* ((overlayss (overlay-lists)) - (buffer-read-only nil) - (overlays (nconc (car overlayss) (cdr overlayss)))) - (while overlays - (delete-overlay (pop overlays)))))) - -(defun gnus-request-article-this-buffer (article group) - "Get an article and insert it into this buffer." - (let (do-update-line) - (prog1 - (save-excursion - (erase-buffer) - (gnus-kill-all-overlays) - (setq group (or group gnus-newsgroup-name)) - - ;; Open server if it has closed. - (gnus-check-server (gnus-find-method-for-group group)) - - ;; Using `gnus-request-article' directly will insert the article into - ;; `nntp-server-buffer' - so we'll save some time by not having to - ;; copy it from the server buffer into the article buffer. - - ;; We only request an article by message-id when we do not have the - ;; headers for it, so we'll have to get those. - (when (stringp article) - (let ((gnus-override-method gnus-refer-article-method)) - (gnus-read-header article))) - - ;; If the article number is negative, that means that this article - ;; doesn't belong in this newsgroup (possibly), so we find its - ;; message-id and request it by id instead of number. - (when (and (numberp article) - gnus-summary-buffer - (get-buffer gnus-summary-buffer) - (buffer-name (get-buffer gnus-summary-buffer))) - (save-excursion - (set-buffer gnus-summary-buffer) - (let ((header (gnus-summary-article-header article))) - (if (< article 0) - (cond - ((memq article gnus-newsgroup-sparse) - ;; This is a sparse gap article. - (setq do-update-line article) - (setq article (mail-header-id header)) - (let ((gnus-override-method gnus-refer-article-method)) - (gnus-read-header article)) - (setq gnus-newsgroup-sparse - (delq article gnus-newsgroup-sparse))) - ((vectorp header) - ;; It's a real article. - (setq article (mail-header-id header))) - (t - ;; It is an extracted pseudo-article. - (setq article 'pseudo) - (gnus-request-pseudo-article header)))) - - (let ((method (gnus-find-method-for-group - gnus-newsgroup-name))) - (if (not (eq (car method) 'nneething)) - () - (let ((dir (concat (file-name-as-directory (nth 1 method)) - (mail-header-subject header)))) - (if (file-directory-p dir) - (progn - (setq article 'nneething) - (gnus-group-enter-directory dir))))))))) - - (cond - ;; Refuse to select canceled articles. - ((and (numberp article) - gnus-summary-buffer - (get-buffer gnus-summary-buffer) - (buffer-name (get-buffer gnus-summary-buffer)) - (eq (cdr (save-excursion - (set-buffer gnus-summary-buffer) - (assq article gnus-newsgroup-reads))) - gnus-canceled-mark)) - nil) - ;; We first check `gnus-original-article-buffer'. - ((and (get-buffer gnus-original-article-buffer) - (numberp article) - (save-excursion - (set-buffer gnus-original-article-buffer) - (and (equal (car gnus-original-article) group) - (eq (cdr gnus-original-article) article)))) - (insert-buffer-substring gnus-original-article-buffer) - 'article) - ;; Check the backlog. - ((and gnus-keep-backlog - (gnus-backlog-request-article group article (current-buffer))) - 'article) - ;; Check the cache. - ((and gnus-use-cache - (numberp article) - (gnus-cache-request-article article group)) - 'article) - ;; Get the article and put into the article buffer. - ((or (stringp article) (numberp article)) - (let ((gnus-override-method - (and (stringp article) gnus-refer-article-method)) - (buffer-read-only nil)) - (erase-buffer) - (gnus-kill-all-overlays) - (if (gnus-request-article article group (current-buffer)) - (progn - (and gnus-keep-backlog - (numberp article) - (gnus-backlog-enter-article - group article (current-buffer))) - 'article)))) - ;; It was a pseudo. - (t article))) - - ;; Take the article from the original article buffer - ;; and place it in the buffer it's supposed to be in. - (when (and (get-buffer gnus-article-buffer) - ;;(numberp article) - (equal (buffer-name (current-buffer)) - (buffer-name (get-buffer gnus-article-buffer)))) - (save-excursion - (if (get-buffer gnus-original-article-buffer) - (set-buffer (get-buffer gnus-original-article-buffer)) - (set-buffer (get-buffer-create gnus-original-article-buffer)) - (buffer-disable-undo (current-buffer)) - (setq major-mode 'gnus-original-article-mode) - (setq buffer-read-only t) - (gnus-add-current-to-buffer-list)) - (let (buffer-read-only) - (erase-buffer) - (insert-buffer-substring gnus-article-buffer)) - (setq gnus-original-article (cons group article)))) - - ;; Update sparse articles. - (when (and do-update-line - (or (numberp article) - (stringp article))) - (let ((buf (current-buffer))) - (set-buffer gnus-summary-buffer) - (gnus-summary-update-article do-update-line) - (gnus-summary-goto-subject do-update-line nil t) - (set-window-point (get-buffer-window (current-buffer) t) - (point)) - (set-buffer buf)))))) - -(defun gnus-read-header (id &optional header) - "Read the headers of article ID and enter them into the Gnus system." - (let ((group gnus-newsgroup-name) - (gnus-override-method - (and (gnus-news-group-p gnus-newsgroup-name) - gnus-refer-article-method)) - where) - ;; First we check to see whether the header in question is already - ;; fetched. - (if (stringp id) - ;; This is a Message-ID. - (setq header (or header (gnus-id-to-header id))) - ;; This is an article number. - (setq header (or header (gnus-summary-article-header id)))) - (if (and header - (not (memq (mail-header-number header) gnus-newsgroup-sparse))) - ;; We have found the header. - header - ;; We have to really fetch the header to this article. - (when (setq where (gnus-request-head id group)) - (save-excursion - (set-buffer nntp-server-buffer) - (goto-char (point-max)) - (insert ".\n") - (goto-char (point-min)) - (insert "211 ") - (princ (cond - ((numberp id) id) - ((cdr where) (cdr where)) - (header (mail-header-number header)) - (t gnus-reffed-article-number)) - (current-buffer)) - (insert " Article retrieved.\n")) - ;(when (and header - ; (memq (mail-header-number header) gnus-newsgroup-sparse)) - ; (setcar (gnus-id-to-thread id) nil)) - (if (not (setq header (car (gnus-get-newsgroup-headers)))) - () ; Malformed head. - (unless (memq (mail-header-number header) gnus-newsgroup-sparse) - (if (and (stringp id) - (not (string= (gnus-group-real-name group) - (car where)))) - ;; If we fetched by Message-ID and the article came - ;; from a different group, we fudge some bogus article - ;; numbers for this article. - (mail-header-set-number header gnus-reffed-article-number)) - (decf gnus-reffed-article-number) - (gnus-remove-header (mail-header-number header)) - (push header gnus-newsgroup-headers) - (setq gnus-current-headers header) - (push (mail-header-number header) gnus-newsgroup-limit)) - header))))) - -(defun gnus-remove-header (number) - "Remove header NUMBER from `gnus-newsgroup-headers'." - (if (and gnus-newsgroup-headers - (= number (mail-header-number (car gnus-newsgroup-headers)))) - (pop gnus-newsgroup-headers) - (let ((headers gnus-newsgroup-headers)) - (while (and (cdr headers) - (not (= number (mail-header-number (cadr headers))))) - (pop headers)) - (when (cdr headers) - (setcdr headers (cddr headers)))))) - -(defun gnus-article-prepare (article &optional all-headers header) - "Prepare ARTICLE in article mode buffer. -ARTICLE should either be an article number or a Message-ID. -If ARTICLE is an id, HEADER should be the article headers. -If ALL-HEADERS is non-nil, no headers are hidden." - (save-excursion - ;; Make sure we start in a summary buffer. - (unless (eq major-mode 'gnus-summary-mode) - (set-buffer gnus-summary-buffer)) - (setq gnus-summary-buffer (current-buffer)) - ;; Make sure the connection to the server is alive. - (unless (gnus-server-opened - (gnus-find-method-for-group gnus-newsgroup-name)) - (gnus-check-server (gnus-find-method-for-group gnus-newsgroup-name)) - (gnus-request-group gnus-newsgroup-name t)) - (let* ((article (if header (mail-header-number header) article)) - (summary-buffer (current-buffer)) - (internal-hook gnus-article-internal-prepare-hook) - (group gnus-newsgroup-name) - result) - (save-excursion - (gnus-article-setup-buffer) - (set-buffer gnus-article-buffer) - ;; Deactivate active regions. - (when (and (boundp 'transient-mark-mode) - transient-mark-mode) - (setq mark-active nil)) - (if (not (setq result (let ((buffer-read-only nil)) - (gnus-request-article-this-buffer - article group)))) - ;; There is no such article. - (save-excursion - (when (and (numberp article) - (not (memq article gnus-newsgroup-sparse))) - (setq gnus-article-current - (cons gnus-newsgroup-name article)) - (set-buffer gnus-summary-buffer) - (setq gnus-current-article article) - (gnus-summary-mark-article article gnus-canceled-mark)) - (unless (memq article gnus-newsgroup-sparse) - (gnus-error - 1 "No such article (may have expired or been canceled)"))) - (if (or (eq result 'pseudo) (eq result 'nneething)) - (progn - (save-excursion - (set-buffer summary-buffer) - (setq gnus-last-article gnus-current-article - gnus-newsgroup-history (cons gnus-current-article - gnus-newsgroup-history) - gnus-current-article 0 - gnus-current-headers nil - gnus-article-current nil) - (if (eq result 'nneething) - (gnus-configure-windows 'summary) - (gnus-configure-windows 'article)) - (gnus-set-global-variables)) - (gnus-set-mode-line 'article)) - ;; The result from the `request' was an actual article - - ;; or at least some text that is now displayed in the - ;; article buffer. - (if (and (numberp article) - (not (eq article gnus-current-article))) - ;; Seems like a new article has been selected. - ;; `gnus-current-article' must be an article number. - (save-excursion - (set-buffer summary-buffer) - (setq gnus-last-article gnus-current-article - gnus-newsgroup-history (cons gnus-current-article - gnus-newsgroup-history) - gnus-current-article article - gnus-current-headers - (gnus-summary-article-header gnus-current-article) - gnus-article-current - (cons gnus-newsgroup-name gnus-current-article)) - (unless (vectorp gnus-current-headers) - (setq gnus-current-headers nil)) - (gnus-summary-show-thread) - (run-hooks 'gnus-mark-article-hook) - (gnus-set-mode-line 'summary) - (and (gnus-visual-p 'article-highlight 'highlight) - (run-hooks 'gnus-visual-mark-article-hook)) - ;; Set the global newsgroup variables here. - ;; Suggested by Jim Sisolak - ;; . - (gnus-set-global-variables) - (setq gnus-have-all-headers - (or all-headers gnus-show-all-headers)) - (and gnus-use-cache - (vectorp (gnus-summary-article-header article)) - (gnus-cache-possibly-enter-article - group article - (gnus-summary-article-header article) - (memq article gnus-newsgroup-marked) - (memq article gnus-newsgroup-dormant) - (memq article gnus-newsgroup-unreads))))) - (when (or (numberp article) - (stringp article)) - ;; Hooks for getting information from the article. - ;; This hook must be called before being narrowed. - (let (buffer-read-only) - (run-hooks 'internal-hook) - (run-hooks 'gnus-article-prepare-hook) - ;; Decode MIME message. - (if gnus-show-mime - (if (or (not gnus-strict-mime) - (gnus-fetch-field "Mime-Version")) - (funcall gnus-show-mime-method) - (funcall gnus-decode-encoded-word-method))) - ;; Perform the article display hooks. - (run-hooks 'gnus-article-display-hook)) - ;; Do page break. - (goto-char (point-min)) - (and gnus-break-pages (gnus-narrow-to-page))) - (gnus-set-mode-line 'article) - (gnus-configure-windows 'article) - (goto-char (point-min)) - t)))))) - -(defun gnus-article-show-all-headers () - "Show all article headers in article mode buffer." - (save-excursion - (gnus-article-setup-buffer) - (set-buffer gnus-article-buffer) - (let ((buffer-read-only nil)) - (gnus-unhide-text (point-min) (point-max))))) - -(defun gnus-article-hide-headers-if-wanted () - "Hide unwanted headers if `gnus-have-all-headers' is nil. -Provided for backwards compatibility." - (or (save-excursion (set-buffer gnus-summary-buffer) gnus-have-all-headers) - gnus-inhibit-hiding - (gnus-article-hide-headers))) - -(defsubst gnus-article-header-rank () - "Give the rank of the string HEADER as given by `gnus-sorted-header-list'." - (let ((list gnus-sorted-header-list) - (i 0)) - (while list - (when (looking-at (car list)) - (setq list nil)) - (setq list (cdr list)) - (incf i)) - i)) - -(defun gnus-article-hide-headers (&optional arg delete) - "Toggle whether to hide unwanted headers and possibly sort them as well. -If given a negative prefix, always show; if given a positive prefix, -always hide." - (interactive (gnus-hidden-arg)) - (if (gnus-article-check-hidden-text 'headers arg) - ;; Show boring headers as well. - (gnus-article-show-hidden-text 'boring-headers) - ;; This function might be inhibited. - (unless gnus-inhibit-hiding - (save-excursion - (set-buffer gnus-article-buffer) - (save-restriction - (let ((buffer-read-only nil) - (props (nconc (list 'gnus-type 'headers) - gnus-hidden-properties)) - (max (1+ (length gnus-sorted-header-list))) - (ignored (when (not (stringp gnus-visible-headers)) - (cond ((stringp gnus-ignored-headers) - gnus-ignored-headers) - ((listp gnus-ignored-headers) - (mapconcat 'identity gnus-ignored-headers - "\\|"))))) - (visible - (cond ((stringp gnus-visible-headers) - gnus-visible-headers) - ((and gnus-visible-headers - (listp gnus-visible-headers)) - (mapconcat 'identity gnus-visible-headers "\\|")))) - (inhibit-point-motion-hooks t) - want-list beg) - ;; First we narrow to just the headers. - (widen) - (goto-char (point-min)) - ;; Hide any "From " lines at the beginning of (mail) articles. - (while (looking-at "From ") - (forward-line 1)) - (unless (bobp) - (if delete - (delete-region (point-min) (point)) - (gnus-hide-text (point-min) (point) props))) - ;; Then treat the rest of the header lines. - (narrow-to-region - (point) - (progn (search-forward "\n\n" nil t) (forward-line -1) (point))) - ;; Then we use the two regular expressions - ;; `gnus-ignored-headers' and `gnus-visible-headers' to - ;; select which header lines is to remain visible in the - ;; article buffer. - (goto-char (point-min)) - (while (re-search-forward "^[^ \t]*:" nil t) - (beginning-of-line) - ;; We add the headers we want to keep to a list and delete - ;; them from the buffer. - (gnus-put-text-property - (point) (1+ (point)) 'message-rank - (if (or (and visible (looking-at visible)) - (and ignored - (not (looking-at ignored)))) - (gnus-article-header-rank) - (+ 2 max))) - (forward-line 1)) - (message-sort-headers-1) - (when (setq beg (text-property-any - (point-min) (point-max) 'message-rank (+ 2 max))) - ;; We make the unwanted headers invisible. - (if delete - (delete-region beg (point-max)) - ;; Suggested by Sudish Joseph . - (gnus-hide-text-type beg (point-max) 'headers)) - ;; Work around XEmacs lossage. - (gnus-put-text-property (point-min) beg 'invisible nil)))))))) - -(defun gnus-article-hide-boring-headers (&optional arg) - "Toggle hiding of headers that aren't very interesting. -If given a negative prefix, always show; if given a positive prefix, -always hide." - (interactive (gnus-hidden-arg)) - (unless (gnus-article-check-hidden-text 'boring-headers arg) - (save-excursion - (set-buffer gnus-article-buffer) - (save-restriction - (let ((buffer-read-only nil) - (list gnus-boring-article-headers) - (inhibit-point-motion-hooks t) - elem) - (nnheader-narrow-to-headers) - (while list - (setq elem (pop list)) - (goto-char (point-min)) - (cond - ;; Hide empty headers. - ((eq elem 'empty) - (while (re-search-forward "^[^:]+:[ \t]\n[^ \t]" nil t) - (forward-line -1) - (gnus-hide-text-type - (progn (beginning-of-line) (point)) - (progn - (end-of-line) - (if (re-search-forward "^[^ \t]" nil t) - (match-beginning 0) - (point-max))) - 'boring-headers))) - ;; Hide boring Newsgroups header. - ((eq elem 'newsgroups) - (when (equal (message-fetch-field "newsgroups") - (gnus-group-real-name gnus-newsgroup-name)) - (gnus-article-hide-header "newsgroups"))) - ((eq elem 'followup-to) - (when (equal (message-fetch-field "followup-to") - (message-fetch-field "newsgroups")) - (gnus-article-hide-header "followup-to"))) - ((eq elem 'reply-to) - (let ((from (message-fetch-field "from")) - (reply-to (message-fetch-field "reply-to"))) - (when (and - from reply-to - (equal - (nth 1 (funcall gnus-extract-address-components from)) - (nth 1 (funcall gnus-extract-address-components - reply-to)))) - (gnus-article-hide-header "reply-to")))) - ((eq elem 'date) - (let ((date (message-fetch-field "date"))) - (when (and date - (< (gnus-days-between date (current-time-string)) - 4)) - (gnus-article-hide-header "date"))))))))))) - -(defun gnus-article-hide-header (header) - (save-excursion - (goto-char (point-min)) - (when (re-search-forward (concat "^" header ":") nil t) - (gnus-hide-text-type - (progn (beginning-of-line) (point)) - (progn - (end-of-line) - (if (re-search-forward "^[^ \t]" nil t) - (match-beginning 0) - (point-max))) - 'boring-headers)))) - -;; Written by Per Abrahamsen . -(defun gnus-article-treat-overstrike () - "Translate overstrikes into bold text." - (interactive) - (save-excursion - (set-buffer gnus-article-buffer) - (let ((buffer-read-only nil)) - (while (search-forward "\b" nil t) - (let ((next (following-char)) - (previous (char-after (- (point) 2)))) - (cond - ((eq next previous) - (gnus-put-text-property (- (point) 2) (point) 'invisible t) - (gnus-put-text-property (point) (1+ (point)) 'face 'bold)) - ((eq next ?_) - (gnus-put-text-property (1- (point)) (1+ (point)) 'invisible t) - (gnus-put-text-property - (- (point) 2) (1- (point)) 'face 'underline)) - ((eq previous ?_) - (gnus-put-text-property (- (point) 2) (point) 'invisible t) - (gnus-put-text-property - (point) (1+ (point)) 'face 'underline)))))))) - -(defun gnus-article-word-wrap () - "Format too long lines." - (interactive) - (save-excursion - (set-buffer gnus-article-buffer) - (let ((buffer-read-only nil)) - (widen) - (goto-char (point-min)) - (search-forward "\n\n" nil t) - (end-of-line 1) - (let ((paragraph-start "^[>|#:<;* ]*[ \t]*$") - (adaptive-fill-regexp "[ \t]*\\([|#:<;>*]+ *\\)?") - (adaptive-fill-mode t)) - (while (not (eobp)) - (and (>= (current-column) (min fill-column (window-width))) - (/= (preceding-char) ?:) - (fill-paragraph nil)) - (end-of-line 2)))))) - -(defun gnus-article-remove-cr () - "Remove carriage returns from an article." - (interactive) - (save-excursion - (set-buffer gnus-article-buffer) - (let ((buffer-read-only nil)) - (goto-char (point-min)) - (while (search-forward "\r" nil t) - (replace-match "" t t))))) - -(defun gnus-article-remove-trailing-blank-lines () - "Remove all trailing blank lines from the article." - (interactive) - (save-excursion - (set-buffer gnus-article-buffer) - (let ((buffer-read-only nil)) - (goto-char (point-max)) - (delete-region - (point) - (progn - (while (looking-at "^[ \t]*$") - (forward-line -1)) - (forward-line 1) - (point)))))) - -(defun gnus-article-display-x-face (&optional force) - "Look for an X-Face header and display it if present." - (interactive (list 'force)) - (save-excursion - (set-buffer gnus-article-buffer) - ;; Delete the old process, if any. - (when (process-status "gnus-x-face") - (delete-process "gnus-x-face")) - (let ((inhibit-point-motion-hooks t) - (case-fold-search nil) - from) - (save-restriction - (nnheader-narrow-to-headers) - (setq from (message-fetch-field "from")) - (goto-char (point-min)) - (when (and gnus-article-x-face-command - (or force - ;; Check whether this face is censored. - (not gnus-article-x-face-too-ugly) - (and gnus-article-x-face-too-ugly from - (not (string-match gnus-article-x-face-too-ugly - from)))) - ;; Has to be present. - (re-search-forward "^X-Face: " nil t)) - ;; We now have the area of the buffer where the X-Face is stored. - (let ((beg (point)) - (end (1- (re-search-forward "^\\($\\|[^ \t]\\)" nil t)))) - ;; We display the face. - (if (symbolp gnus-article-x-face-command) - ;; The command is a lisp function, so we call it. - (if (gnus-functionp gnus-article-x-face-command) - (funcall gnus-article-x-face-command beg end) - (error "%s is not a function" gnus-article-x-face-command)) - ;; The command is a string, so we interpret the command - ;; as a, well, command, and fork it off. - (let ((process-connection-type nil)) - (process-kill-without-query - (start-process - "gnus-x-face" nil shell-file-name shell-command-switch - gnus-article-x-face-command)) - (process-send-region "gnus-x-face" beg end) - (process-send-eof "gnus-x-face"))))))))) - -(defalias 'gnus-headers-decode-quoted-printable 'gnus-decode-rfc1522) -(defun gnus-decode-rfc1522 () - "Hack to remove QP encoding from headers." - (let ((case-fold-search t) - (inhibit-point-motion-hooks t) - (buffer-read-only nil) - string) - (save-restriction - (narrow-to-region - (goto-char (point-min)) - (or (search-forward "\n\n" nil t) (point-max))) - - (goto-char (point-min)) - (while (re-search-forward - "=\\?iso-8859-1\\?q\\?\\([^?\t\n]*\\)\\?=" nil t) - (setq string (match-string 1)) - (narrow-to-region (match-beginning 0) (match-end 0)) - (delete-region (point-min) (point-max)) - (insert string) - (gnus-mime-decode-quoted-printable (goto-char (point-min)) (point-max)) - (subst-char-in-region (point-min) (point-max) ?_ ? ) - (widen) - (goto-char (point-min)))))) - -(defun gnus-article-de-quoted-unreadable (&optional force) - "Do a naive translation of a quoted-printable-encoded article. -This is in no way, shape or form meant as a replacement for real MIME -processing, but is simply a stop-gap measure until MIME support is -written. -If FORCE, decode the article whether it is marked as quoted-printable -or not." - (interactive (list 'force)) - (save-excursion - (set-buffer gnus-article-buffer) - (let ((case-fold-search t) - (buffer-read-only nil) - (type (gnus-fetch-field "content-transfer-encoding"))) - (gnus-decode-rfc1522) - (when (or force - (and type (string-match "quoted-printable" (downcase type)))) - (goto-char (point-min)) - (search-forward "\n\n" nil 'move) - (gnus-mime-decode-quoted-printable (point) (point-max)))))) - -(defun gnus-mime-decode-quoted-printable (from to) - "Decode Quoted-Printable in the region between FROM and TO." - (interactive "r") - (goto-char from) - (while (search-forward "=" to t) - (cond ((eq (following-char) ?\n) - (delete-char -1) - (delete-char 1)) - ((looking-at "[0-9A-F][0-9A-F]") - (subst-char-in-region - (1- (point)) (point) ?= - (hexl-hex-string-to-integer - (buffer-substring (point) (+ 2 (point))))) - (delete-char 2)) - ((looking-at "=") - (delete-char 1)) - ((gnus-message 3 "Malformed MIME quoted-printable message"))))) - -(defun gnus-article-hide-pgp (&optional arg) - "Toggle hiding of any PGP headers and signatures in the current article. -If given a negative prefix, always show; if given a positive prefix, -always hide." - (interactive (gnus-hidden-arg)) - (unless (gnus-article-check-hidden-text 'pgp arg) - (save-excursion - (set-buffer gnus-article-buffer) - (let ((props (nconc (list 'gnus-type 'pgp) gnus-hidden-properties)) - buffer-read-only beg end) - (widen) - (goto-char (point-min)) - ;; Hide the "header". - (and (search-forward "\n-----BEGIN PGP SIGNED MESSAGE-----\n" nil t) - (gnus-hide-text (match-beginning 0) (match-end 0) props)) - (setq beg (point)) - ;; Hide the actual signature. - (and (search-forward "\n-----BEGIN PGP SIGNATURE-----\n" nil t) - (setq end (1+ (match-beginning 0))) - (gnus-hide-text - end - (if (search-forward "\n-----END PGP SIGNATURE-----\n" nil t) - (match-end 0) - ;; Perhaps we shouldn't hide to the end of the buffer - ;; if there is no end to the signature? - (point-max)) - props)) - ;; Hide "- " PGP quotation markers. - (when (and beg end) - (narrow-to-region beg end) - (goto-char (point-min)) - (while (re-search-forward "^- " nil t) - (gnus-hide-text (match-beginning 0) (match-end 0) props)) - (widen)))))) - -(defun gnus-article-hide-pem (&optional arg) - "Toggle hiding of any PEM headers and signatures in the current article. -If given a negative prefix, always show; if given a positive prefix, -always hide." - (interactive (gnus-hidden-arg)) - (unless (gnus-article-check-hidden-text 'pem arg) - (save-excursion - (set-buffer gnus-article-buffer) - (let ((props (nconc (list 'gnus-type 'pem) gnus-hidden-properties)) - buffer-read-only end) - (widen) - (goto-char (point-min)) - ;; hide the horrendously ugly "header". - (and (search-forward "\n-----BEGIN PRIVACY-ENHANCED MESSAGE-----\n" - nil - t) - (setq end (1+ (match-beginning 0))) - (gnus-hide-text - end - (if (search-forward "\n\n" nil t) - (match-end 0) - (point-max)) - props)) - ;; hide the trailer as well - (and (search-forward "\n-----END PRIVACY-ENHANCED MESSAGE-----\n" - nil - t) - (gnus-hide-text (match-beginning 0) (match-end 0) props)))))) - -(defun gnus-article-hide-signature (&optional arg) - "Hide the signature in the current article. -If given a negative prefix, always show; if given a positive prefix, -always hide." - (interactive (gnus-hidden-arg)) - (unless (gnus-article-check-hidden-text 'signature arg) - (save-excursion - (set-buffer gnus-article-buffer) - (save-restriction - (let ((buffer-read-only nil)) - (when (gnus-narrow-to-signature) - (gnus-hide-text-type (point-min) (point-max) 'signature))))))) - -(defun gnus-article-strip-leading-blank-lines () - "Remove all blank lines from the beginning of the article." - (interactive) - (save-excursion - (set-buffer gnus-article-buffer) - (let (buffer-read-only) - (goto-char (point-min)) - (when (search-forward "\n\n" nil t) - (while (looking-at "[ \t]$") - (gnus-delete-line)))))) - -(defvar mime::preview/content-list) -(defvar mime::preview-content-info/point-min) -(defun gnus-narrow-to-signature () - "Narrow to the signature." - (widen) - (if (and (boundp 'mime::preview/content-list) - mime::preview/content-list) - (let ((pcinfo (car (last mime::preview/content-list)))) - (condition-case () - (narrow-to-region - (funcall (intern "mime::preview-content-info/point-min") pcinfo) - (point-max)) - (error nil)))) - (goto-char (point-max)) - (when (re-search-backward gnus-signature-separator nil t) - (forward-line 1) - (when (or (null gnus-signature-limit) - (and (numberp gnus-signature-limit) - (< (- (point-max) (point)) gnus-signature-limit)) - (and (gnus-functionp gnus-signature-limit) - (funcall gnus-signature-limit)) - (and (stringp gnus-signature-limit) - (not (re-search-forward gnus-signature-limit nil t)))) - (narrow-to-region (point) (point-max)) - t))) - -(defun gnus-hidden-arg () - "Return the current prefix arg as a number, or 0 if no prefix." - (list (if current-prefix-arg - (prefix-numeric-value current-prefix-arg) - 0))) - -(defun gnus-article-check-hidden-text (type arg) - "Return nil if hiding is necessary. -Arg can be nil or a number. Nil and positive means hide, negative -means show, 0 means toggle." - (save-excursion - (set-buffer gnus-article-buffer) - (let ((hide (gnus-article-hidden-text-p type))) - (cond - ((or (null arg) - (> arg 0)) - nil) - ((< arg 0) - (gnus-article-show-hidden-text type)) - (t - (if (eq hide 'hidden) - (gnus-article-show-hidden-text type) - nil)))))) - -(defun gnus-article-hidden-text-p (type) - "Say whether the current buffer contains hidden text of type TYPE." - (let ((pos (text-property-any (point-min) (point-max) 'gnus-type type))) - (when pos - (if (get-text-property pos 'invisible) - 'hidden - 'shown)))) - -(defun gnus-article-hide (&optional arg force) - "Hide all the gruft in the current article. -This means that PGP stuff, signatures, cited text and (some) -headers will be hidden. -If given a prefix, show the hidden text instead." - (interactive (list current-prefix-arg 'force)) - (gnus-article-hide-headers arg) - (gnus-article-hide-pgp arg) - (gnus-article-hide-citation-maybe arg force) - (gnus-article-hide-signature arg)) - -(defun gnus-article-show-hidden-text (type &optional hide) - "Show all hidden text of type TYPE. -If HIDE, hide the text instead." - (save-excursion - (set-buffer gnus-article-buffer) - (let ((buffer-read-only nil) - (inhibit-point-motion-hooks t) - (beg (point-min))) - (while (gnus-goto-char (text-property-any - beg (point-max) 'gnus-type type)) - (setq beg (point)) - (forward-char) - (if hide - (gnus-hide-text beg (point) gnus-hidden-properties) - (gnus-unhide-text beg (point))) - (setq beg (point))) - t))) - -(defvar gnus-article-time-units - `((year . ,(* 365.25 24 60 60)) - (week . ,(* 7 24 60 60)) - (day . ,(* 24 60 60)) - (hour . ,(* 60 60)) - (minute . 60) - (second . 1)) - "Mapping from time units to seconds.") - -(defun gnus-article-date-ut (&optional type highlight) - "Convert DATE date to universal time in the current article. -If TYPE is `local', convert to local time; if it is `lapsed', output -how much time has lapsed since DATE." - (interactive (list 'ut t)) - (let* ((header (or gnus-current-headers - (gnus-summary-article-header) "")) - (date (and (vectorp header) (mail-header-date header))) - (date-regexp "^Date: \\|^X-Sent: ") - (now (current-time)) - (inhibit-point-motion-hooks t) - bface eface) - (when (and date (not (string= date ""))) - (save-excursion - (set-buffer gnus-article-buffer) - (save-restriction - (nnheader-narrow-to-headers) - (let ((buffer-read-only nil)) - ;; Delete any old Date headers. - (if (re-search-forward date-regexp nil t) - (progn - (setq bface (get-text-property (gnus-point-at-bol) 'face) - eface (get-text-property (1- (gnus-point-at-eol)) - 'face)) - (message-remove-header date-regexp t) - (beginning-of-line)) - (goto-char (point-max))) - (insert (gnus-make-date-line date type)) - ;; Do highlighting. - (forward-line -1) - (when (and (gnus-visual-p 'article-highlight 'highlight) - (looking-at "\\([^:]+\\): *\\(.*\\)$")) - (gnus-put-text-property (match-beginning 1) (match-end 1) - 'face bface) - (gnus-put-text-property (match-beginning 2) (match-end 2) - 'face eface)))))))) - -(defun gnus-make-date-line (date type) - "Return a DATE line of TYPE." - (cond - ;; Convert to the local timezone. We have to slap a - ;; `condition-case' round the calls to the timezone - ;; functions since they aren't particularly resistant to - ;; buggy dates. - ((eq type 'local) - (concat "Date: " (condition-case () - (timezone-make-date-arpa-standard date) - (error date)) - "\n")) - ;; Convert to Universal Time. - ((eq type 'ut) - (concat "Date: " - (condition-case () - (timezone-make-date-arpa-standard date nil "UT") - (error date)) - "\n")) - ;; Get the original date from the article. - ((eq type 'original) - (concat "Date: " date "\n")) - ;; Do an X-Sent lapsed format. - ((eq type 'lapsed) - ;; If the date is seriously mangled, the timezone - ;; functions are liable to bug out, so we condition-case - ;; the entire thing. - (let* ((now (current-time)) - (real-time - (condition-case () - (gnus-time-minus - (gnus-encode-date - (timezone-make-date-arpa-standard - (current-time-string now) - (current-time-zone now) "UT")) - (gnus-encode-date - (timezone-make-date-arpa-standard - date nil "UT"))) - (error '(0 0)))) - (real-sec (+ (* (float (car real-time)) 65536) - (cadr real-time))) - (sec (abs real-sec)) - num prev) - (cond - ((equal real-time '(0 0)) - "X-Sent: Unknown\n") - ((zerop sec) - "X-Sent: Now\n") - (t - (concat - "X-Sent: " - ;; This is a bit convoluted, but basically we go - ;; through the time units for years, weeks, etc, - ;; and divide things to see whether that results - ;; in positive answers. - (mapconcat - (lambda (unit) - (if (zerop (setq num (ffloor (/ sec (cdr unit))))) - ;; The (remaining) seconds are too few to - ;; be divided into this time unit. - "" - ;; It's big enough, so we output it. - (setq sec (- sec (* num (cdr unit)))) - (prog1 - (concat (if prev ", " "") (int-to-string - (floor num)) - " " (symbol-name (car unit)) - (if (> num 1) "s" "")) - (setq prev t)))) - gnus-article-time-units "") - ;; If dates are odd, then it might appear like the - ;; article was sent in the future. - (if (> real-sec 0) - " ago\n" - " in the future\n")))))) - (t - (error "Unknown conversion type: %s" type)))) - -(defun gnus-article-date-local (&optional highlight) - "Convert the current article date to the local timezone." - (interactive (list t)) - (gnus-article-date-ut 'local highlight)) - -(defun gnus-article-date-original (&optional highlight) - "Convert the current article date to what it was originally. -This is only useful if you have used some other date conversion -function and want to see what the date was before converting." - (interactive (list t)) - (gnus-article-date-ut 'original highlight)) - -(defun gnus-article-date-lapsed (&optional highlight) - "Convert the current article date to time lapsed since it was sent." - (interactive (list t)) - (gnus-article-date-ut 'lapsed highlight)) - -(defun gnus-article-maybe-highlight () - "Do some article highlighting if `gnus-visual' is non-nil." - (if (gnus-visual-p 'article-highlight 'highlight) - (gnus-article-highlight-some))) - -;;; Article savers. - -(defun gnus-output-to-rmail (file-name) - "Append the current article to an Rmail file named FILE-NAME." - (require 'rmail) - ;; Most of these codes are borrowed from rmailout.el. - (setq file-name (expand-file-name file-name)) - (setq rmail-default-rmail-file file-name) - (let ((artbuf (current-buffer)) - (tmpbuf (get-buffer-create " *Gnus-output*"))) - (save-excursion - (or (get-file-buffer file-name) - (file-exists-p file-name) - (if (gnus-yes-or-no-p - (concat "\"" file-name "\" does not exist, create it? ")) - (let ((file-buffer (create-file-buffer file-name))) - (save-excursion - (set-buffer file-buffer) - (rmail-insert-rmail-file-header) - (let ((require-final-newline nil)) - (write-region (point-min) (point-max) file-name t 1))) - (kill-buffer file-buffer)) - (error "Output file does not exist"))) - (set-buffer tmpbuf) - (buffer-disable-undo (current-buffer)) - (erase-buffer) - (insert-buffer-substring artbuf) - (gnus-convert-article-to-rmail) - ;; Decide whether to append to a file or to an Emacs buffer. - (let ((outbuf (get-file-buffer file-name))) - (if (not outbuf) - (append-to-file (point-min) (point-max) file-name) - ;; File has been visited, in buffer OUTBUF. - (set-buffer outbuf) - (let ((buffer-read-only nil) - (msg (and (boundp 'rmail-current-message) - (symbol-value 'rmail-current-message)))) - ;; If MSG is non-nil, buffer is in RMAIL mode. - (if msg - (progn (widen) - (narrow-to-region (point-max) (point-max)))) - (insert-buffer-substring tmpbuf) - (if msg - (progn - (goto-char (point-min)) - (widen) - (search-backward "\^_") - (narrow-to-region (point) (point-max)) - (goto-char (1+ (point-min))) - (rmail-count-new-messages t) - (rmail-show-message msg))))))) - (kill-buffer tmpbuf))) - -(defun gnus-output-to-file (file-name) - "Append the current article to a file named FILE-NAME." - (let ((artbuf (current-buffer))) - (nnheader-temp-write nil - (insert-buffer-substring artbuf) - ;; Append newline at end of the buffer as separator, and then - ;; save it to file. - (goto-char (point-max)) - (insert "\n") - (append-to-file (point-min) (point-max) file-name)))) - -(defun gnus-convert-article-to-rmail () - "Convert article in current buffer to Rmail message format." - (let ((buffer-read-only nil)) - ;; Convert article directly into Babyl format. - ;; Suggested by Rob Austein - (goto-char (point-min)) - (insert "\^L\n0, unseen,,\n*** EOOH ***\n") - (while (search-forward "\n\^_" nil t) ;single char - (replace-match "\n^_" t t)) ;2 chars: "^" and "_" - (goto-char (point-max)) - (insert "\^_"))) - -(defun gnus-narrow-to-page (&optional arg) - "Narrow the article buffer to a page. -If given a numerical ARG, move forward ARG pages." - (interactive "P") - (setq arg (if arg (prefix-numeric-value arg) 0)) - (save-excursion - (set-buffer gnus-article-buffer) - (goto-char (point-min)) - (widen) - (when (gnus-visual-p 'page-marker) - (let ((buffer-read-only nil)) - (gnus-remove-text-with-property 'gnus-prev) - (gnus-remove-text-with-property 'gnus-next))) - (when - (cond ((< arg 0) - (re-search-backward page-delimiter nil 'move (1+ (abs arg)))) - ((> arg 0) - (re-search-forward page-delimiter nil 'move arg))) - (goto-char (match-end 0))) - (narrow-to-region - (point) - (if (re-search-forward page-delimiter nil 'move) - (match-beginning 0) - (point))) - (when (and (gnus-visual-p 'page-marker) - (not (= (point-min) 1))) - (save-excursion - (goto-char (point-min)) - (gnus-insert-prev-page-button))) - (when (and (gnus-visual-p 'page-marker) - (not (= (1- (point-max)) (buffer-size)))) - (save-excursion - (goto-char (point-max)) - (gnus-insert-next-page-button))))) - -;; Article mode commands - -(defun gnus-article-goto-next-page () - "Show the next page of the article." - (interactive) - (when (gnus-article-next-page) - (gnus-article-read-summary-keys nil (gnus-character-to-event ?n)))) - -(defun gnus-article-goto-prev-page () - "Show the next page of the article." - (interactive) - (if (bobp) (gnus-article-read-summary-keys nil (gnus-character-to-event ?n)) - (gnus-article-prev-page nil))) - -(defun gnus-article-next-page (&optional lines) - "Show the next page of the current article. -If end of article, return non-nil. Otherwise return nil. -Argument LINES specifies lines to be scrolled up." - (interactive "p") - (move-to-window-line -1) - ;; Fixed by enami@ptgd.sony.co.jp (enami tsugutomo) - (if (save-excursion - (end-of-line) - (and (pos-visible-in-window-p) ;Not continuation line. - (eobp))) - ;; Nothing in this page. - (if (or (not gnus-break-pages) - (save-excursion - (save-restriction - (widen) (forward-line 1) (eobp)))) ;Real end-of-buffer? - t ;Nothing more. - (gnus-narrow-to-page 1) ;Go to next page. - nil) - ;; More in this page. - (condition-case () - (scroll-up lines) - (end-of-buffer - ;; Long lines may cause an end-of-buffer error. - (goto-char (point-max)))) - (move-to-window-line 0) - nil)) - -(defun gnus-article-prev-page (&optional lines) - "Show previous page of current article. -Argument LINES specifies lines to be scrolled down." - (interactive "p") - (move-to-window-line 0) - (if (and gnus-break-pages - (bobp) - (not (save-restriction (widen) (bobp)))) ;Real beginning-of-buffer? - (progn - (gnus-narrow-to-page -1) ;Go to previous page. - (goto-char (point-max)) - (recenter -1)) - (prog1 - (condition-case () - (scroll-down lines) - (error nil)) - (move-to-window-line 0)))) - -(defun gnus-article-refer-article () - "Read article specified by message-id around point." - (interactive) - (let ((point (point))) - (search-forward ">" nil t) ;Move point to end of "<....>". - (if (re-search-backward "\\(<[^<> \t\n]+>\\)" nil t) - (let ((message-id (match-string 1))) - (goto-char point) - (set-buffer gnus-summary-buffer) - (gnus-summary-refer-article message-id)) - (goto-char (point)) - (error "No references around point")))) - -(defun gnus-article-show-summary () - "Reconfigure windows to show summary buffer." - (interactive) - (gnus-configure-windows 'article) - (gnus-summary-goto-subject gnus-current-article)) - -(defun gnus-article-describe-briefly () - "Describe article mode commands briefly." - (interactive) - (gnus-message 6 - (substitute-command-keys "\\\\[gnus-article-goto-next-page]:Next page \\[gnus-article-goto-prev-page]:Prev page \\[gnus-article-show-summary]:Show summary \\[gnus-info-find-node]:Run Info \\[gnus-article-describe-briefly]:This help"))) - -(defun gnus-article-summary-command () - "Execute the last keystroke in the summary buffer." - (interactive) - (let ((obuf (current-buffer)) - (owin (current-window-configuration)) - func) - (switch-to-buffer gnus-summary-buffer 'norecord) - (setq func (lookup-key (current-local-map) (this-command-keys))) - (call-interactively func) - (set-buffer obuf) - (set-window-configuration owin) - (set-window-point (get-buffer-window (current-buffer)) (point)))) - -(defun gnus-article-summary-command-nosave () - "Execute the last keystroke in the summary buffer." - (interactive) - (let (func) - (pop-to-buffer gnus-summary-buffer 'norecord) - (setq func (lookup-key (current-local-map) (this-command-keys))) - (call-interactively func))) - -(defun gnus-article-read-summary-keys (&optional arg key not-restore-window) - "Read a summary buffer key sequence and execute it from the article buffer." - (interactive "P") - (let ((nosaves - '("q" "Q" "c" "r" "R" "\C-c\C-f" "m" "a" "f" "F" - "Zc" "ZC" "ZE" "ZQ" "ZZ" "Zn" "ZR" "ZG" "ZN" "ZP" - "=" "^" "\M-^" "|")) - (nosave-but-article - '("A\r")) - keys) - (save-excursion - (set-buffer gnus-summary-buffer) - (push (or key last-command-event) unread-command-events) - (setq keys (read-key-sequence nil))) - (message "") - - (if (or (member keys nosaves) - (member keys nosave-but-article)) - (let (func) - (save-window-excursion - (pop-to-buffer gnus-summary-buffer 'norecord) - (setq func (lookup-key (current-local-map) keys))) - (if (not func) - (ding) - (set-buffer gnus-summary-buffer) - (call-interactively func)) - (when (member keys nosave-but-article) - (pop-to-buffer gnus-article-buffer 'norecord))) - (let ((obuf (current-buffer)) - (owin (current-window-configuration)) - (opoint (point)) - func in-buffer) - (if not-restore-window - (pop-to-buffer gnus-summary-buffer 'norecord) - (switch-to-buffer gnus-summary-buffer 'norecord)) - (setq in-buffer (current-buffer)) - (if (setq func (lookup-key (current-local-map) keys)) - (call-interactively func) - (ding)) - (when (eq in-buffer (current-buffer)) - (set-buffer obuf) - (unless not-restore-window - (set-window-configuration owin)) - (set-window-point (get-buffer-window (current-buffer)) opoint)))))) - ;;; ;;; Kill file handling. ;;; -;;;###autoload -(defalias 'gnus-batch-kill 'gnus-batch-score) -;;;###autoload -(defun gnus-batch-score () - "Run batched scoring. -Usage: emacs -batch -l gnus -f gnus-batch-score ... -Newsgroups is a list of strings in Bnews format. If you want to score -the comp hierarchy, you'd say \"comp.all\". If you would not like to -score the alt hierarchy, you'd say \"!alt.all\"." - (interactive) - (let* ((yes-and-no - (gnus-newsrc-parse-options - (apply (function concat) - (mapcar (lambda (g) (concat g " ")) - command-line-args-left)))) - (gnus-expert-user t) - (nnmail-spool-file nil) - (gnus-use-dribble-file nil) - (yes (car yes-and-no)) - (no (cdr yes-and-no)) - group newsrc entry - ;; Disable verbose message. - gnus-novice-user gnus-large-newsgroup) - ;; Eat all arguments. - (setq command-line-args-left nil) - ;; Start Gnus. - (gnus) - ;; Apply kills to specified newsgroups in command line arguments. - (setq newsrc (cdr gnus-newsrc-alist)) - (while newsrc - (setq group (caar newsrc)) - (setq entry (gnus-gethash group gnus-newsrc-hashtb)) - (if (and (<= (nth 1 (car newsrc)) gnus-level-subscribed) - (and (car entry) - (or (eq (car entry) t) - (not (zerop (car entry))))) - (if yes (string-match yes group) t) - (or (null no) (not (string-match no group)))) - (progn - (gnus-summary-read-group group nil t nil t) - (and (eq (current-buffer) (get-buffer gnus-summary-buffer)) - (gnus-summary-exit)))) - (setq newsrc (cdr newsrc))) - ;; Exit Emacs. - (switch-to-buffer gnus-group-buffer) - (gnus-group-save-newsrc))) - (defun gnus-apply-kill-file () "Apply a kill file to the current newsgroup. Returns the number of articles marked as read." @@ -15014,11 +2301,15 @@ (when (get-file-buffer file) (save-excursion (set-buffer (get-file-buffer file)) - (and (buffer-modified-p) (save-buffer)) + (when (buffer-modified-p) + (save-buffer)) (kill-buffer (current-buffer)))))) -(defvar gnus-kill-file-name "KILL" - "Suffix of the kill files.") +(defcustom gnus-kill-file-name "KILL" + "Suffix of the kill files." + :group 'gnus-score-kill + :group 'gnus-score-files + :type 'string) (defun gnus-newsgroup-kill-file (newsgroup) "Return the name of a kill file name for NEWSGROUP. @@ -15040,466 +2331,7 @@ "/" gnus-kill-file-name) gnus-kill-files-directory)))) - -;;; -;;; Dribble file -;;; - -(defvar gnus-dribble-ignore nil) -(defvar gnus-dribble-eval-file nil) - -(defun gnus-dribble-file-name () - "Return the dribble file for the current .newsrc." - (concat - (if gnus-dribble-directory - (concat (file-name-as-directory gnus-dribble-directory) - (file-name-nondirectory gnus-current-startup-file)) - gnus-current-startup-file) - "-dribble")) - -(defun gnus-dribble-enter (string) - "Enter STRING into the dribble buffer." - (if (and (not gnus-dribble-ignore) - gnus-dribble-buffer - (buffer-name gnus-dribble-buffer)) - (let ((obuf (current-buffer))) - (set-buffer gnus-dribble-buffer) - (insert string "\n") - (set-window-point (get-buffer-window (current-buffer)) (point-max)) - (bury-buffer gnus-dribble-buffer) - (set-buffer obuf)))) - -(defun gnus-dribble-read-file () - "Read the dribble file from disk." - (let ((dribble-file (gnus-dribble-file-name))) - (save-excursion - (set-buffer (setq gnus-dribble-buffer - (get-buffer-create - (file-name-nondirectory dribble-file)))) - (gnus-add-current-to-buffer-list) - (erase-buffer) - (setq buffer-file-name dribble-file) - (auto-save-mode t) - (buffer-disable-undo (current-buffer)) - (bury-buffer (current-buffer)) - (set-buffer-modified-p nil) - (let ((auto (make-auto-save-file-name)) - (gnus-dribble-ignore t) - modes) - (when (or (file-exists-p auto) (file-exists-p dribble-file)) - ;; Load whichever file is newest -- the auto save file - ;; or the "real" file. - (if (file-newer-than-file-p auto dribble-file) - (insert-file-contents auto) - (insert-file-contents dribble-file)) - (unless (zerop (buffer-size)) - (set-buffer-modified-p t)) - ;; Set the file modes to reflect the .newsrc file modes. - (save-buffer) - (when (and (file-exists-p gnus-current-startup-file) - (setq modes (file-modes gnus-current-startup-file))) - (set-file-modes dribble-file modes)) - ;; Possibly eval the file later. - (when (gnus-y-or-n-p - "Auto-save file exists. Do you want to read it? ") - (setq gnus-dribble-eval-file t))))))) - -(defun gnus-dribble-eval-file () - (when gnus-dribble-eval-file - (setq gnus-dribble-eval-file nil) - (save-excursion - (let ((gnus-dribble-ignore t)) - (set-buffer gnus-dribble-buffer) - (eval-buffer (current-buffer)))))) - -(defun gnus-dribble-delete-file () - (when (file-exists-p (gnus-dribble-file-name)) - (delete-file (gnus-dribble-file-name))) - (when gnus-dribble-buffer - (save-excursion - (set-buffer gnus-dribble-buffer) - (let ((auto (make-auto-save-file-name))) - (if (file-exists-p auto) - (delete-file auto)) - (erase-buffer) - (set-buffer-modified-p nil))))) - -(defun gnus-dribble-save () - (when (and gnus-dribble-buffer - (buffer-name gnus-dribble-buffer)) - (save-excursion - (set-buffer gnus-dribble-buffer) - (save-buffer)))) - -(defun gnus-dribble-clear () - (when (gnus-buffer-exists-p gnus-dribble-buffer) - (save-excursion - (set-buffer gnus-dribble-buffer) - (erase-buffer) - (set-buffer-modified-p nil) - (setq buffer-saved-size (buffer-size))))) - - -;;; -;;; Server Communication -;;; - -(defun gnus-start-news-server (&optional confirm) - "Open a method for getting news. -If CONFIRM is non-nil, the user will be asked for an NNTP server." - (let (how) - (if gnus-current-select-method - ;; Stream is already opened. - nil - ;; Open NNTP server. - (if (null gnus-nntp-service) (setq gnus-nntp-server nil)) - (if confirm - (progn - ;; Read server name with completion. - (setq gnus-nntp-server - (completing-read "NNTP server: " - (mapcar (lambda (server) (list server)) - (cons (list gnus-nntp-server) - gnus-secondary-servers)) - nil nil gnus-nntp-server)))) - - (if (and gnus-nntp-server - (stringp gnus-nntp-server) - (not (string= gnus-nntp-server ""))) - (setq gnus-select-method - (cond ((or (string= gnus-nntp-server "") - (string= gnus-nntp-server "::")) - (list 'nnspool (system-name))) - ((string-match "^:" gnus-nntp-server) - (list 'nnmh gnus-nntp-server - (list 'nnmh-directory - (file-name-as-directory - (expand-file-name - (concat "~/" (substring - gnus-nntp-server 1))))) - (list 'nnmh-get-new-mail nil))) - (t - (list 'nntp gnus-nntp-server))))) - - (setq how (car gnus-select-method)) - (cond ((eq how 'nnspool) - (require 'nnspool) - (gnus-message 5 "Looking up local news spool...")) - ((eq how 'nnmh) - (require 'nnmh) - (gnus-message 5 "Looking up mh spool...")) - (t - (require 'nntp))) - (setq gnus-current-select-method gnus-select-method) - (run-hooks 'gnus-open-server-hook) - (or - ;; gnus-open-server-hook might have opened it - (gnus-server-opened gnus-select-method) - (gnus-open-server gnus-select-method) - (gnus-y-or-n-p - (format - "%s (%s) open error: '%s'. Continue? " - (car gnus-select-method) (cadr gnus-select-method) - (gnus-status-message gnus-select-method))) - (gnus-error 1 "Couldn't open server on %s" - (nth 1 gnus-select-method)))))) - -(defun gnus-check-group (group) - "Try to make sure that the server where GROUP exists is alive." - (let ((method (gnus-find-method-for-group group))) - (or (gnus-server-opened method) - (gnus-open-server method)))) - -(defun gnus-check-server (&optional method silent) - "Check whether the connection to METHOD is down. -If METHOD is nil, use `gnus-select-method'. -If it is down, start it up (again)." - (let ((method (or method gnus-select-method))) - ;; Transform virtual server names into select methods. - (when (stringp method) - (setq method (gnus-server-to-method method))) - (if (gnus-server-opened method) - ;; The stream is already opened. - t - ;; Open the server. - (unless silent - (gnus-message 5 "Opening %s server%s..." (car method) - (if (equal (nth 1 method) "") "" - (format " on %s" (nth 1 method))))) - (run-hooks 'gnus-open-server-hook) - (prog1 - (gnus-open-server method) - (unless silent - (message "")))))) - -(defun gnus-get-function (method function &optional noerror) - "Return a function symbol based on METHOD and FUNCTION." - ;; Translate server names into methods. - (unless method - (error "Attempted use of a nil select method")) - (when (stringp method) - (setq method (gnus-server-to-method method))) - (let ((func (intern (format "%s-%s" (car method) function)))) - ;; If the functions isn't bound, we require the backend in - ;; question. - (unless (fboundp func) - (require (car method)) - (when (and (not (fboundp func)) - (not noerror)) - ;; This backend doesn't implement this function. - (error "No such function: %s" func))) - func)) - - -;;; -;;; Interface functions to the backends. -;;; - -(defun gnus-open-server (method) - "Open a connection to METHOD." - (when (stringp method) - (setq method (gnus-server-to-method method))) - (let ((elem (assoc method gnus-opened-servers))) - ;; If this method was previously denied, we just return nil. - (if (eq (nth 1 elem) 'denied) - (progn - (gnus-message 1 "Denied server") - nil) - ;; Open the server. - (let ((result - (funcall (gnus-get-function method 'open-server) - (nth 1 method) (nthcdr 2 method)))) - ;; If this hasn't been opened before, we add it to the list. - (unless elem - (setq elem (list method nil) - gnus-opened-servers (cons elem gnus-opened-servers))) - ;; Set the status of this server. - (setcar (cdr elem) (if result 'ok 'denied)) - ;; Return the result from the "open" call. - result)))) - -(defun gnus-close-server (method) - "Close the connection to METHOD." - (when (stringp method) - (setq method (gnus-server-to-method method))) - (funcall (gnus-get-function method 'close-server) (nth 1 method))) - -(defun gnus-request-list (method) - "Request the active file from METHOD." - (when (stringp method) - (setq method (gnus-server-to-method method))) - (funcall (gnus-get-function method 'request-list) (nth 1 method))) - -(defun gnus-request-list-newsgroups (method) - "Request the newsgroups file from METHOD." - (when (stringp method) - (setq method (gnus-server-to-method method))) - (funcall (gnus-get-function method 'request-list-newsgroups) (nth 1 method))) - -(defun gnus-request-newgroups (date method) - "Request all new groups since DATE from METHOD." - (when (stringp method) - (setq method (gnus-server-to-method method))) - (funcall (gnus-get-function method 'request-newgroups) - date (nth 1 method))) - -(defun gnus-server-opened (method) - "Check whether a connection to METHOD has been opened." - (when (stringp method) - (setq method (gnus-server-to-method method))) - (funcall (gnus-get-function method 'server-opened) (nth 1 method))) - -(defun gnus-status-message (method) - "Return the status message from METHOD. -If METHOD is a string, it is interpreted as a group name. The method -this group uses will be queried." - (let ((method (if (stringp method) (gnus-find-method-for-group method) - method))) - (funcall (gnus-get-function method 'status-message) (nth 1 method)))) - -(defun gnus-request-group (group &optional dont-check method) - "Request GROUP. If DONT-CHECK, no information is required." - (let ((method (or method (gnus-find-method-for-group group)))) - (when (stringp method) - (setq method (gnus-server-to-method method))) - (funcall (gnus-get-function method 'request-group) - (gnus-group-real-name group) (nth 1 method) dont-check))) - -(defun gnus-request-asynchronous (group &optional articles) - "Request that GROUP behave asynchronously. -ARTICLES is the `data' of the group." - (let ((method (gnus-find-method-for-group group))) - (funcall (gnus-get-function method 'request-asynchronous) - (gnus-group-real-name group) (nth 1 method) articles))) - -(defun gnus-list-active-group (group) - "Request active information on GROUP." - (let ((method (gnus-find-method-for-group group)) - (func 'list-active-group)) - (when (gnus-check-backend-function func group) - (funcall (gnus-get-function method func) - (gnus-group-real-name group) (nth 1 method))))) - -(defun gnus-request-group-description (group) - "Request a description of GROUP." - (let ((method (gnus-find-method-for-group group)) - (func 'request-group-description)) - (when (gnus-check-backend-function func group) - (funcall (gnus-get-function method func) - (gnus-group-real-name group) (nth 1 method))))) - -(defun gnus-close-group (group) - "Request the GROUP be closed." - (let ((method (gnus-find-method-for-group group))) - (funcall (gnus-get-function method 'close-group) - (gnus-group-real-name group) (nth 1 method)))) - -(defun gnus-retrieve-headers (articles group &optional fetch-old) - "Request headers for ARTICLES in GROUP. -If FETCH-OLD, retrieve all headers (or some subset thereof) in the group." - (let ((method (gnus-find-method-for-group group))) - (if (and gnus-use-cache (numberp (car articles))) - (gnus-cache-retrieve-headers articles group fetch-old) - (funcall (gnus-get-function method 'retrieve-headers) - articles (gnus-group-real-name group) (nth 1 method) - fetch-old)))) - -(defun gnus-retrieve-groups (groups method) - "Request active information on GROUPS from METHOD." - (when (stringp method) - (setq method (gnus-server-to-method method))) - (funcall (gnus-get-function method 'retrieve-groups) groups (nth 1 method))) - -(defun gnus-request-type (group &optional article) - "Return the type (`post' or `mail') of GROUP (and ARTICLE)." - (let ((method (gnus-find-method-for-group group))) - (if (not (gnus-check-backend-function 'request-type (car method))) - 'unknown - (funcall (gnus-get-function method 'request-type) - (gnus-group-real-name group) article)))) - -(defun gnus-request-update-mark (group article mark) - "Return the type (`post' or `mail') of GROUP (and ARTICLE)." - (let ((method (gnus-find-method-for-group group))) - (if (not (gnus-check-backend-function 'request-update-mark (car method))) - mark - (funcall (gnus-get-function method 'request-update-mark) - (gnus-group-real-name group) article mark)))) - -(defun gnus-request-article (article group &optional buffer) - "Request the ARTICLE in GROUP. -ARTICLE can either be an article number or an article Message-ID. -If BUFFER, insert the article in that group." - (let ((method (gnus-find-method-for-group group))) - (funcall (gnus-get-function method 'request-article) - article (gnus-group-real-name group) (nth 1 method) buffer))) - -(defun gnus-request-head (article group) - "Request the head of ARTICLE in GROUP." - (let* ((method (gnus-find-method-for-group group)) - (head (gnus-get-function method 'request-head t))) - (if (fboundp head) - (funcall head article (gnus-group-real-name group) (nth 1 method)) - (let ((res (gnus-request-article article group))) - (when res - (save-excursion - (set-buffer nntp-server-buffer) - (goto-char (point-min)) - (when (search-forward "\n\n" nil t) - (delete-region (1- (point)) (point-max))) - (nnheader-fold-continuation-lines))) - res)))) - -(defun gnus-request-body (article group) - "Request the body of ARTICLE in GROUP." - (let ((method (gnus-find-method-for-group group))) - (funcall (gnus-get-function method 'request-body) - article (gnus-group-real-name group) (nth 1 method)))) - -(defun gnus-request-post (method) - "Post the current buffer using METHOD." - (when (stringp method) - (setq method (gnus-server-to-method method))) - (funcall (gnus-get-function method 'request-post) (nth 1 method))) - -(defun gnus-request-scan (group method) - "Request a SCAN being performed in GROUP from METHOD. -If GROUP is nil, all groups on METHOD are scanned." - (let ((method (if group (gnus-find-method-for-group group) method))) - (funcall (gnus-get-function method 'request-scan) - (and group (gnus-group-real-name group)) (nth 1 method)))) - -(defsubst gnus-request-update-info (info method) - "Request that METHOD update INFO." - (when (stringp method) - (setq method (gnus-server-to-method method))) - (when (gnus-check-backend-function 'request-update-info (car method)) - (funcall (gnus-get-function method 'request-update-info) - (gnus-group-real-name (gnus-info-group info)) - info (nth 1 method)))) - -(defun gnus-request-expire-articles (articles group &optional force) - (let ((method (gnus-find-method-for-group group))) - (funcall (gnus-get-function method 'request-expire-articles) - articles (gnus-group-real-name group) (nth 1 method) - force))) - -(defun gnus-request-move-article - (article group server accept-function &optional last) - (let ((method (gnus-find-method-for-group group))) - (funcall (gnus-get-function method 'request-move-article) - article (gnus-group-real-name group) - (nth 1 method) accept-function last))) - -(defun gnus-request-accept-article (group method &optional last) - ;; Make sure there's a newline at the end of the article. - (when (stringp method) - (setq method (gnus-server-to-method method))) - (when (and (not method) - (stringp group)) - (setq method (gnus-group-name-to-method group))) - (goto-char (point-max)) - (unless (bolp) - (insert "\n")) - (let ((func (car (or method (gnus-find-method-for-group group))))) - (funcall (intern (format "%s-request-accept-article" func)) - (if (stringp group) (gnus-group-real-name group) group) - (cadr method) - last))) - -(defun gnus-request-replace-article (article group buffer) - (let ((func (car (gnus-find-method-for-group group)))) - (funcall (intern (format "%s-request-replace-article" func)) - article (gnus-group-real-name group) buffer))) - -(defun gnus-request-associate-buffer (group) - (let ((method (gnus-find-method-for-group group))) - (funcall (gnus-get-function method 'request-associate-buffer) - (gnus-group-real-name group)))) - -(defun gnus-request-restore-buffer (article group) - "Request a new buffer restored to the state of ARTICLE." - (let ((method (gnus-find-method-for-group group))) - (funcall (gnus-get-function method 'request-restore-buffer) - article (gnus-group-real-name group) (nth 1 method)))) - -(defun gnus-request-create-group (group &optional method) - (when (stringp method) - (setq method (gnus-server-to-method method))) - (let ((method (or method (gnus-find-method-for-group group)))) - (funcall (gnus-get-function method 'request-create-group) - (gnus-group-real-name group) (nth 1 method)))) - -(defun gnus-request-delete-group (group &optional force) - (let ((method (gnus-find-method-for-group group))) - (funcall (gnus-get-function method 'request-delete-group) - (gnus-group-real-name group) force (nth 1 method)))) - -(defun gnus-request-rename-group (group new-name) - (let ((method (gnus-find-method-for-group group))) - (funcall (gnus-get-function method 'request-rename-group) - (gnus-group-real-name group) - (gnus-group-real-name new-name) (nth 1 method)))) +;;; Server things. (defun gnus-member-of-valid (symbol group) "Find out if GROUP has SYMBOL as part of its \"valid\" spec." @@ -15521,17 +2353,19 @@ ;; called "hello+alt.alt". (let ((entry (gnus-copy-sequence - (if (equal (car method) "native") gnus-select-method + (if (gnus-server-equal method gnus-select-method) gnus-select-method (cdr (assoc (car method) gnus-server-alist)))))) - (setcar (cdr entry) (concat (nth 1 entry) "+" group)) - (nconc entry (cdr method)))) + (if (not entry) + method + (setcar (cdr entry) (concat (nth 1 entry) "+" group)) + (nconc entry (cdr method))))) (defun gnus-server-status (method) "Return the status of METHOD." (nth 1 (assoc method gnus-opened-servers))) (defun gnus-group-name-to-method (group) - "Return a select method suitable for GROUP." + "Guess a select method based on GROUP." (if (string-match ":" group) (let ((server (substring group 0 (match-beginning 0)))) (if (string-match "\\+" server) @@ -15566,1800 +2400,109 @@ (gnus-server-add-address method))))))) (defun gnus-check-backend-function (func group) - "Check whether GROUP supports function FUNC." - (let ((method (if (stringp group) (car (gnus-find-method-for-group group)) - group))) - (fboundp (intern (format "%s-%s" method func))))) + "Check whether GROUP supports function FUNC. +GROUP can either be a string (a group name) or a select method." + (ignore-errors + (let ((method (if (stringp group) + (car (gnus-find-method-for-group group)) + group))) + (unless (featurep method) + (require method)) + (fboundp (intern (format "%s-%s" method func)))))) (defun gnus-methods-using (feature) "Find all methods that have FEATURE." (let ((valids gnus-valid-select-methods) outs) (while valids - (if (memq feature (car valids)) - (setq outs (cons (car valids) outs))) + (when (memq feature (car valids)) + (push (car valids) outs)) (setq valids (cdr valids))) outs)) - -;;; -;;; Active & Newsrc File Handling -;;; - -(defun gnus-setup-news (&optional rawfile level dont-connect) - "Setup news information. -If RAWFILE is non-nil, the .newsrc file will also be read. -If LEVEL is non-nil, the news will be set up at level LEVEL." - (let ((init (not (and gnus-newsrc-alist gnus-active-hashtb (not rawfile))))) - - (when init - ;; Clear some variables to re-initialize news information. - (setq gnus-newsrc-alist nil - gnus-active-hashtb nil) - ;; Read the newsrc file and create `gnus-newsrc-hashtb'. - (gnus-read-newsrc-file rawfile)) - - (when (and (not (assoc "archive" gnus-server-alist)) - (gnus-archive-server-wanted-p)) - (push (cons "archive" gnus-message-archive-method) - gnus-server-alist)) - - ;; If we don't read the complete active file, we fill in the - ;; hashtb here. - (if (or (null gnus-read-active-file) - (eq gnus-read-active-file 'some)) - (gnus-update-active-hashtb-from-killed)) - - ;; Read the active file and create `gnus-active-hashtb'. - ;; If `gnus-read-active-file' is nil, then we just create an empty - ;; hash table. The partial filling out of the hash table will be - ;; done in `gnus-get-unread-articles'. - (and gnus-read-active-file - (not level) - (gnus-read-active-file)) - - (or gnus-active-hashtb - (setq gnus-active-hashtb (make-vector 4095 0))) - - ;; Initialize the cache. - (when gnus-use-cache - (gnus-cache-open)) - - ;; Possibly eval the dribble file. - (and init (or gnus-use-dribble-file gnus-slave) (gnus-dribble-eval-file)) - - ;; Slave Gnusii should then clear the dribble buffer. - (when (and init gnus-slave) - (gnus-dribble-clear)) - - (gnus-update-format-specifications) - - ;; See whether we need to read the description file. - (if (and (string-match "%[-,0-9]*D" gnus-group-line-format) - (not gnus-description-hashtb) - (not dont-connect) - gnus-read-active-file) - (gnus-read-all-descriptions-files)) - - ;; Find new newsgroups and treat them. - (if (and init gnus-check-new-newsgroups (not level) - (gnus-check-server gnus-select-method)) - (gnus-find-new-newsgroups)) - - ;; We might read in new NoCeM messages here. - (when (and gnus-use-nocem - (not level) - (not dont-connect)) - (gnus-nocem-scan-groups)) - - ;; Find the number of unread articles in each non-dead group. - (let ((gnus-read-active-file (and (not level) gnus-read-active-file))) - (gnus-get-unread-articles level)) - - (if (and init gnus-check-bogus-newsgroups - gnus-read-active-file (not level) - (gnus-server-opened gnus-select-method)) - (gnus-check-bogus-newsgroups)))) - -(defun gnus-find-new-newsgroups (&optional arg) - "Search for new newsgroups and add them. -Each new newsgroup will be treated with `gnus-subscribe-newsgroup-method.' -The `-n' option line from .newsrc is respected. -If ARG (the prefix), use the `ask-server' method to query -the server for new groups." - (interactive "P") - (let ((check (if (or (and arg (not (listp gnus-check-new-newsgroups))) - (null gnus-read-active-file) - (eq gnus-read-active-file 'some)) - 'ask-server gnus-check-new-newsgroups))) - (unless (gnus-check-first-time-used) - (if (or (consp check) - (eq check 'ask-server)) - ;; Ask the server for new groups. - (gnus-ask-server-for-new-groups) - ;; Go through the active hashtb and look for new groups. - (let ((groups 0) - group new-newsgroups) - (gnus-message 5 "Looking for new newsgroups...") - (unless gnus-have-read-active-file - (gnus-read-active-file)) - (setq gnus-newsrc-last-checked-date (current-time-string)) - (unless gnus-killed-hashtb - (gnus-make-hashtable-from-killed)) - ;; Go though every newsgroup in `gnus-active-hashtb' and compare - ;; with `gnus-newsrc-hashtb' and `gnus-killed-hashtb'. - (mapatoms - (lambda (sym) - (if (or (null (setq group (symbol-name sym))) - (not (boundp sym)) - (null (symbol-value sym)) - (gnus-gethash group gnus-killed-hashtb) - (gnus-gethash group gnus-newsrc-hashtb)) - () - (let ((do-sub (gnus-matches-options-n group))) - (cond - ((eq do-sub 'subscribe) - (setq groups (1+ groups)) - (gnus-sethash group group gnus-killed-hashtb) - (funcall gnus-subscribe-options-newsgroup-method group)) - ((eq do-sub 'ignore) - nil) - (t - (setq groups (1+ groups)) - (gnus-sethash group group gnus-killed-hashtb) - (if gnus-subscribe-hierarchical-interactive - (setq new-newsgroups (cons group new-newsgroups)) - (funcall gnus-subscribe-newsgroup-method group))))))) - gnus-active-hashtb) - (when new-newsgroups - (gnus-subscribe-hierarchical-interactive new-newsgroups)) - ;; Suggested by Per Abrahamsen . - (if (> groups 0) - (gnus-message 6 "%d new newsgroup%s arrived." - groups (if (> groups 1) "s have" " has")) - (gnus-message 6 "No new newsgroups."))))))) - -(defun gnus-matches-options-n (group) - ;; Returns `subscribe' if the group is to be unconditionally - ;; subscribed, `ignore' if it is to be ignored, and nil if there is - ;; no match for the group. - - ;; First we check the two user variables. - (cond - ((and gnus-options-subscribe - (string-match gnus-options-subscribe group)) - 'subscribe) - ((and gnus-auto-subscribed-groups - (string-match gnus-auto-subscribed-groups group)) - 'subscribe) - ((and gnus-options-not-subscribe - (string-match gnus-options-not-subscribe group)) - 'ignore) - ;; Then we go through the list that was retrieved from the .newsrc - ;; file. This list has elements on the form - ;; `(REGEXP . {ignore,subscribe})'. The first match found (the list - ;; is in the reverse order of the options line) is returned. - (t - (let ((regs gnus-newsrc-options-n)) - (while (and regs - (not (string-match (caar regs) group))) - (setq regs (cdr regs))) - (and regs (cdar regs)))))) - -(defun gnus-ask-server-for-new-groups () - (let* ((date (or gnus-newsrc-last-checked-date (current-time-string))) - (methods (cons gnus-select-method - (nconc - (when (gnus-archive-server-wanted-p) - (list "archive")) - (append - (and (consp gnus-check-new-newsgroups) - gnus-check-new-newsgroups) - gnus-secondary-select-methods)))) - (groups 0) - (new-date (current-time-string)) - group new-newsgroups got-new method hashtb - gnus-override-subscribe-method) - ;; Go through both primary and secondary select methods and - ;; request new newsgroups. - (while (setq method (gnus-server-get-method nil (pop methods))) - (setq new-newsgroups nil) - (setq gnus-override-subscribe-method method) - (when (and (gnus-check-server method) - (gnus-request-newgroups date method)) - (save-excursion - (setq got-new t) - (setq hashtb (gnus-make-hashtable 100)) - (set-buffer nntp-server-buffer) - ;; Enter all the new groups into a hashtable. - (gnus-active-to-gnus-format method hashtb 'ignore)) - ;; Now all new groups from `method' are in `hashtb'. - (mapatoms - (lambda (group-sym) - (if (or (null (setq group (symbol-name group-sym))) - (not (boundp group-sym)) - (null (symbol-value group-sym)) - (gnus-gethash group gnus-newsrc-hashtb) - (member group gnus-zombie-list) - (member group gnus-killed-list)) - ;; The group is already known. - () - ;; Make this group active. - (when (symbol-value group-sym) - (gnus-set-active group (symbol-value group-sym))) - ;; Check whether we want it or not. - (let ((do-sub (gnus-matches-options-n group))) - (cond - ((eq do-sub 'subscribe) - (incf groups) - (gnus-sethash group group gnus-killed-hashtb) - (funcall gnus-subscribe-options-newsgroup-method group)) - ((eq do-sub 'ignore) - nil) - (t - (incf groups) - (gnus-sethash group group gnus-killed-hashtb) - (if gnus-subscribe-hierarchical-interactive - (push group new-newsgroups) - (funcall gnus-subscribe-newsgroup-method group))))))) - hashtb)) - (when new-newsgroups - (gnus-subscribe-hierarchical-interactive new-newsgroups))) - ;; Suggested by Per Abrahamsen . - (when (> groups 0) - (gnus-message 6 "%d new newsgroup%s arrived." - groups (if (> groups 1) "s have" " has"))) - (and got-new (setq gnus-newsrc-last-checked-date new-date)) - got-new)) - -(defun gnus-check-first-time-used () - (if (or (> (length gnus-newsrc-alist) 1) - (file-exists-p gnus-startup-file) - (file-exists-p (concat gnus-startup-file ".el")) - (file-exists-p (concat gnus-startup-file ".eld"))) - nil - (gnus-message 6 "First time user; subscribing you to default groups") - (unless (gnus-read-active-file-p) - (gnus-read-active-file)) - (setq gnus-newsrc-last-checked-date (current-time-string)) - (let ((groups gnus-default-subscribed-newsgroups) - group) - (if (eq groups t) - nil - (setq groups (or groups gnus-backup-default-subscribed-newsgroups)) - (mapatoms - (lambda (sym) - (if (null (setq group (symbol-name sym))) - () - (let ((do-sub (gnus-matches-options-n group))) - (cond - ((eq do-sub 'subscribe) - (gnus-sethash group group gnus-killed-hashtb) - (funcall gnus-subscribe-options-newsgroup-method group)) - ((eq do-sub 'ignore) - nil) - (t - (setq gnus-killed-list (cons group gnus-killed-list))))))) - gnus-active-hashtb) - (while groups - (if (gnus-active (car groups)) - (gnus-group-change-level - (car groups) gnus-level-default-subscribed gnus-level-killed)) - (setq groups (cdr groups))) - (gnus-group-make-help-group) - (and gnus-novice-user - (gnus-message 7 "`A k' to list killed groups")))))) - -(defun gnus-subscribe-group (group previous &optional method) - (gnus-group-change-level - (if method - (list t group gnus-level-default-subscribed nil nil method) - group) - gnus-level-default-subscribed gnus-level-killed previous t)) - -;; `gnus-group-change-level' is the fundamental function for changing -;; subscription levels of newsgroups. This might mean just changing -;; from level 1 to 2, which is pretty trivial, from 2 to 6 or back -;; again, which subscribes/unsubscribes a group, which is equally -;; trivial. Changing from 1-7 to 8-9 means that you kill a group, and -;; from 8-9 to 1-7 means that you remove the group from the list of -;; killed (or zombie) groups and add them to the (kinda) subscribed -;; groups. And last but not least, moving from 8 to 9 and 9 to 8, -;; which is trivial. -;; ENTRY can either be a string (newsgroup name) or a list (if -;; FROMKILLED is t, it's a list on the format (NUM INFO-LIST), -;; otherwise it's a list in the format of the `gnus-newsrc-hashtb' -;; entries. -;; LEVEL is the new level of the group, OLDLEVEL is the old level and -;; PREVIOUS is the group (in hashtb entry format) to insert this group -;; after. -(defun gnus-group-change-level (entry level &optional oldlevel - previous fromkilled) - (let (group info active num) - ;; Glean what info we can from the arguments - (if (consp entry) - (if fromkilled (setq group (nth 1 entry)) - (setq group (car (nth 2 entry)))) - (setq group entry)) - (if (and (stringp entry) - oldlevel - (< oldlevel gnus-level-zombie)) - (setq entry (gnus-gethash entry gnus-newsrc-hashtb))) - (if (and (not oldlevel) - (consp entry)) - (setq oldlevel (gnus-info-level (nth 2 entry))) - (setq oldlevel (or oldlevel 9))) - (if (stringp previous) - (setq previous (gnus-gethash previous gnus-newsrc-hashtb))) - - (if (and (>= oldlevel gnus-level-zombie) - (gnus-gethash group gnus-newsrc-hashtb)) - ;; We are trying to subscribe a group that is already - ;; subscribed. - () ; Do nothing. - - (or (gnus-ephemeral-group-p group) - (gnus-dribble-enter - (format "(gnus-group-change-level %S %S %S %S %S)" - group level oldlevel (car (nth 2 previous)) fromkilled))) - - ;; Then we remove the newgroup from any old structures, if needed. - ;; If the group was killed, we remove it from the killed or zombie - ;; list. If not, and it is in fact going to be killed, we remove - ;; it from the newsrc hash table and assoc. - (cond - ((>= oldlevel gnus-level-zombie) - (if (= oldlevel gnus-level-zombie) - (setq gnus-zombie-list (delete group gnus-zombie-list)) - (setq gnus-killed-list (delete group gnus-killed-list)))) - (t - (if (and (>= level gnus-level-zombie) - entry) - (progn - (gnus-sethash (car (nth 2 entry)) nil gnus-newsrc-hashtb) - (if (nth 3 entry) - (setcdr (gnus-gethash (car (nth 3 entry)) - gnus-newsrc-hashtb) - (cdr entry))) - (setcdr (cdr entry) (cdddr entry)))))) - - ;; Finally we enter (if needed) the list where it is supposed to - ;; go, and change the subscription level. If it is to be killed, - ;; we enter it into the killed or zombie list. - (cond - ((>= level gnus-level-zombie) - ;; Remove from the hash table. - (gnus-sethash group nil gnus-newsrc-hashtb) - ;; We do not enter foreign groups into the list of dead - ;; groups. - (unless (gnus-group-foreign-p group) - (if (= level gnus-level-zombie) - (setq gnus-zombie-list (cons group gnus-zombie-list)) - (setq gnus-killed-list (cons group gnus-killed-list))))) - (t - ;; If the list is to be entered into the newsrc assoc, and - ;; it was killed, we have to create an entry in the newsrc - ;; hashtb format and fix the pointers in the newsrc assoc. - (if (< oldlevel gnus-level-zombie) - ;; It was alive, and it is going to stay alive, so we - ;; just change the level and don't change any pointers or - ;; hash table entries. - (setcar (cdaddr entry) level) - (if (listp entry) - (setq info (cdr entry) - num (car entry)) - (setq active (gnus-active group)) - (setq num - (if active (- (1+ (cdr active)) (car active)) t)) - ;; Check whether the group is foreign. If so, the - ;; foreign select method has to be entered into the - ;; info. - (let ((method (or gnus-override-subscribe-method - (gnus-group-method group)))) - (if (eq method gnus-select-method) - (setq info (list group level nil)) - (setq info (list group level nil nil method))))) - (unless previous - (setq previous - (let ((p gnus-newsrc-alist)) - (while (cddr p) - (setq p (cdr p))) - p))) - (setq entry (cons info (cddr previous))) - (if (cdr previous) - (progn - (setcdr (cdr previous) entry) - (gnus-sethash group (cons num (cdr previous)) - gnus-newsrc-hashtb)) - (setcdr previous entry) - (gnus-sethash group (cons num previous) - gnus-newsrc-hashtb)) - (when (cdr entry) - (setcdr (gnus-gethash (caadr entry) gnus-newsrc-hashtb) entry))))) - (when gnus-group-change-level-function - (funcall gnus-group-change-level-function group level oldlevel))))) - -(defun gnus-kill-newsgroup (newsgroup) - "Obsolete function. Kills a newsgroup." - (gnus-group-change-level - (gnus-gethash newsgroup gnus-newsrc-hashtb) gnus-level-killed)) +(defun gnus-read-group (prompt &optional default) + "Prompt the user for a group name. +Disallow illegal group names." + (let ((prefix "") + group) + (while (not group) + (when (string-match + "[: `'\"/]\\|^$" + (setq group (read-string (concat prefix prompt) + (cons (or default "") 0) + 'gnus-group-history))) + (setq prefix (format "Illegal group name: \"%s\". " group) + group nil))) + group)) -(defun gnus-check-bogus-newsgroups (&optional confirm) - "Remove bogus newsgroups. -If CONFIRM is non-nil, the user has to confirm the deletion of every -newsgroup." - (let ((newsrc (cdr gnus-newsrc-alist)) - bogus group entry info) - (gnus-message 5 "Checking bogus newsgroups...") - (unless (gnus-read-active-file-p) - (gnus-read-active-file)) - (when (gnus-read-active-file-p) - ;; Find all bogus newsgroup that are subscribed. - (while newsrc - (setq info (pop newsrc) - group (gnus-info-group info)) - (unless (or (gnus-active group) ; Active - (gnus-info-method info) ; Foreign - (and confirm - (not (gnus-y-or-n-p - (format "Remove bogus newsgroup: %s " group))))) - ;; Found a bogus newsgroup. - (push group bogus))) - ;; Remove all bogus subscribed groups by first killing them, and - ;; then removing them from the list of killed groups. - (while bogus - (when (setq entry (gnus-gethash (setq group (pop bogus)) - gnus-newsrc-hashtb)) - (gnus-group-change-level entry gnus-level-killed) - (setq gnus-killed-list (delete group gnus-killed-list)))) - ;; Then we remove all bogus groups from the list of killed and - ;; zombie groups. They are removed without confirmation. - (let ((dead-lists '(gnus-killed-list gnus-zombie-list)) - killed) - (while dead-lists - (setq killed (symbol-value (car dead-lists))) - (while killed - (unless (gnus-active (setq group (pop killed))) - ;; The group is bogus. - ;; !!!Slow as hell. - (set (car dead-lists) - (delete group (symbol-value (car dead-lists)))))) - (setq dead-lists (cdr dead-lists)))) - (run-hooks 'gnus-check-bogus-groups-hook) - (gnus-message 5 "Checking bogus newsgroups...done")))) - -(defun gnus-check-duplicate-killed-groups () - "Remove duplicates from the list of killed groups." - (interactive) - (let ((killed gnus-killed-list)) - (while killed - (gnus-message 9 "%d" (length killed)) - (setcdr killed (delete (car killed) (cdr killed))) - (setq killed (cdr killed))))) - -;; We want to inline a function from gnus-cache, so we cheat here: -(eval-when-compile - (provide 'gnus) - (setq gnus-directory (or (getenv "SAVEDIR") "~/News/")) - (require 'gnus-cache)) - -(defun gnus-get-unread-articles-in-group (info active &optional update) - (when active - ;; Allow the backend to update the info in the group. - (when (and update - (gnus-request-update-info - info (gnus-find-method-for-group (gnus-info-group info)))) - (gnus-activate-group (gnus-info-group info) nil t)) - (let* ((range (gnus-info-read info)) - (num 0)) - ;; If a cache is present, we may have to alter the active info. - (when (and gnus-use-cache info) - (inline (gnus-cache-possibly-alter-active - (gnus-info-group info) active))) - ;; Modify the list of read articles according to what articles - ;; are available; then tally the unread articles and add the - ;; number to the group hash table entry. - (cond - ((zerop (cdr active)) - (setq num 0)) - ((not range) - (setq num (- (1+ (cdr active)) (car active)))) - ((not (listp (cdr range))) - ;; Fix a single (num . num) range according to the - ;; active hash table. - ;; Fix by Carsten Bormann . - (and (< (cdr range) (car active)) (setcdr range (1- (car active)))) - (and (> (cdr range) (cdr active)) (setcdr range (cdr active))) - ;; Compute number of unread articles. - (setq num (max 0 (- (cdr active) (- (1+ (cdr range)) (car range)))))) - (t - ;; The read list is a list of ranges. Fix them according to - ;; the active hash table. - ;; First peel off any elements that are below the lower - ;; active limit. - (while (and (cdr range) - (>= (car active) - (or (and (atom (cadr range)) (cadr range)) - (caadr range)))) - (if (numberp (car range)) - (setcar range - (cons (car range) - (or (and (numberp (cadr range)) - (cadr range)) - (cdadr range)))) - (setcdr (car range) - (or (and (numberp (nth 1 range)) (nth 1 range)) - (cdadr range)))) - (setcdr range (cddr range))) - ;; Adjust the first element to be the same as the lower limit. - (if (and (not (atom (car range))) - (< (cdar range) (car active))) - (setcdr (car range) (1- (car active)))) - ;; Then we want to peel off any elements that are higher - ;; than the upper active limit. - (let ((srange range)) - ;; Go past all legal elements. - (while (and (cdr srange) - (<= (or (and (atom (cadr srange)) - (cadr srange)) - (caadr srange)) (cdr active))) - (setq srange (cdr srange))) - (if (cdr srange) - ;; Nuke all remaining illegal elements. - (setcdr srange nil)) - - ;; Adjust the final element. - (if (and (not (atom (car srange))) - (> (cdar srange) (cdr active))) - (setcdr (car srange) (cdr active)))) - ;; Compute the number of unread articles. - (while range - (setq num (+ num (- (1+ (or (and (atom (car range)) (car range)) - (cdar range))) - (or (and (atom (car range)) (car range)) - (caar range))))) - (setq range (cdr range))) - (setq num (max 0 (- (cdr active) num))))) - ;; Set the number of unread articles. - (when info - (setcar (gnus-gethash (gnus-info-group info) gnus-newsrc-hashtb) num)) - num))) - -;; Go though `gnus-newsrc-alist' and compare with `gnus-active-hashtb' -;; and compute how many unread articles there are in each group. -(defun gnus-get-unread-articles (&optional level) - (let* ((newsrc (cdr gnus-newsrc-alist)) - (level (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)) - level)) - info group active method) - (gnus-message 5 "Checking new news...") - - (while newsrc - (setq active (gnus-active (setq group (gnus-info-group - (setq info (pop newsrc)))))) - - ;; Check newsgroups. If the user doesn't want to check them, or - ;; they can't be checked (for instance, if the news server can't - ;; be reached) we just set the number of unread articles in this - ;; newsgroup to t. This means that Gnus thinks that there are - ;; unread articles, but it has no idea how many. - (if (and (setq method (gnus-info-method info)) - (not (gnus-server-equal - gnus-select-method - (setq method (gnus-server-get-method nil method)))) - (not (gnus-secondary-method-p method))) - ;; These groups are foreign. Check the level. - (when (<= (gnus-info-level info) foreign-level) - (setq active (gnus-activate-group group 'scan)) - (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)))) - ;; These groups are native or secondary. - (when (and (<= (gnus-info-level info) level) - (not gnus-read-active-file)) - (setq active (gnus-activate-group group 'scan)) - (inline (gnus-close-group group)))) - - ;; Get the number of unread articles in the group. - (if active - (inline (gnus-get-unread-articles-in-group info active)) - ;; The group couldn't be reached, so we nix out the number of - ;; unread articles and stuff. - (gnus-set-active group nil) - (setcar (gnus-gethash group gnus-newsrc-hashtb) t))) - - (gnus-message 5 "Checking new news...done"))) +(defun gnus-read-method (prompt) + "Prompt the user for a method. +Allow completion over sensible values." + (let ((method + (completing-read + prompt (append gnus-valid-select-methods gnus-predefined-server-alist + gnus-server-alist) + nil t nil 'gnus-method-history))) + (cond + ((equal method "") + (setq method gnus-select-method)) + ((assoc method gnus-valid-select-methods) + (list (intern method) + (if (memq 'prompt-address + (assoc method gnus-valid-select-methods)) + (read-string "Address: ") + ""))) + ((assoc method gnus-server-alist) + method) + (t + (list (intern method) ""))))) -;; Create a hash table out of the newsrc alist. The `car's of the -;; alist elements are used as keys. -(defun gnus-make-hashtable-from-newsrc-alist () - (let ((alist gnus-newsrc-alist) - (ohashtb gnus-newsrc-hashtb) - prev) - (setq gnus-newsrc-hashtb (gnus-make-hashtable (length alist))) - (setq alist - (setq prev (setq gnus-newsrc-alist - (if (equal (caar gnus-newsrc-alist) - "dummy.group") - gnus-newsrc-alist - (cons (list "dummy.group" 0 nil) alist))))) - (while alist - (gnus-sethash - (caar alist) - (cons (and ohashtb (car (gnus-gethash (caar alist) ohashtb))) - prev) - gnus-newsrc-hashtb) - (setq prev alist - alist (cdr alist))))) - -(defun gnus-make-hashtable-from-killed () - "Create a hash table from the killed and zombie lists." - (let ((lists '(gnus-killed-list gnus-zombie-list)) - list) - (setq gnus-killed-hashtb - (gnus-make-hashtable - (+ (length gnus-killed-list) (length gnus-zombie-list)))) - (while (setq list (pop lists)) - (setq list (symbol-value list)) - (while list - (gnus-sethash (car list) (pop list) gnus-killed-hashtb))))) - -(defun gnus-activate-group (group &optional scan dont-check method) - ;; Check whether a group has been activated or not. - ;; If SCAN, request a scan of that group as well. - (let ((method (or method (gnus-find-method-for-group group))) - active) - (and (gnus-check-server method) - ;; We escape all bugs and quit here to make it possible to - ;; continue if a group is so out-there that it reports bugs - ;; and stuff. - (progn - (and scan - (gnus-check-backend-function 'request-scan (car method)) - (gnus-request-scan group method)) - t) - (condition-case () - (gnus-request-group group dont-check method) - ; (error nil) - (quit nil)) - (save-excursion - (set-buffer nntp-server-buffer) - (goto-char (point-min)) - ;; Parse the result we got from `gnus-request-group'. - (and (looking-at "[0-9]+ [0-9]+ \\([0-9]+\\) [0-9]+") - (progn - (goto-char (match-beginning 1)) - (gnus-set-active - group (setq active (cons (read (current-buffer)) - (read (current-buffer))))) - ;; Return the new active info. - active)))))) - -(defun gnus-update-read-articles (group unread) - "Update the list of read and ticked articles in GROUP using the -UNREAD and TICKED lists. -Note: UNSELECTED has to be sorted over `<'. -Returns whether the updating was successful." - (let* ((active (or gnus-newsgroup-active (gnus-active group))) - (entry (gnus-gethash group gnus-newsrc-hashtb)) - (info (nth 2 entry)) - (prev 1) - (unread (sort (copy-sequence unread) '<)) - read) - (if (or (not info) (not active)) - ;; There is no info on this group if it was, in fact, - ;; killed. Gnus stores no information on killed groups, so - ;; there's nothing to be done. - ;; One could store the information somewhere temporarily, - ;; perhaps... Hmmm... - () - ;; Remove any negative articles numbers. - (while (and unread (< (car unread) 0)) - (setq unread (cdr unread))) - ;; Remove any expired article numbers - (while (and unread (< (car unread) (car active))) - (setq unread (cdr unread))) - ;; Compute the ranges of read articles by looking at the list of - ;; unread articles. - (while unread - (if (/= (car unread) prev) - (setq read (cons (if (= prev (1- (car unread))) prev - (cons prev (1- (car unread)))) read))) - (setq prev (1+ (car unread))) - (setq unread (cdr unread))) - (when (<= prev (cdr active)) - (setq read (cons (cons prev (cdr active)) read))) - ;; Enter this list into the group info. - (gnus-info-set-read - info (if (> (length read) 1) (nreverse read) read)) - ;; Set the number of unread articles in gnus-newsrc-hashtb. - (gnus-get-unread-articles-in-group info (gnus-active group)) - t))) - -(defun gnus-make-articles-unread (group articles) - "Mark ARTICLES in GROUP as unread." - (let* ((info (nth 2 (or (gnus-gethash group gnus-newsrc-hashtb) - (gnus-gethash (gnus-group-real-name group) - gnus-newsrc-hashtb)))) - (ranges (gnus-info-read info)) - news article) - (while articles - (when (gnus-member-of-range - (setq article (pop articles)) ranges) - (setq news (cons article news)))) - (when news - (gnus-info-set-read - info (gnus-remove-from-range (gnus-info-read info) (nreverse news))) - (gnus-group-update-group group t)))) - -;; Enter all dead groups into the hashtb. -(defun gnus-update-active-hashtb-from-killed () - (let ((hashtb (setq gnus-active-hashtb (make-vector 4095 0))) - (lists (list gnus-killed-list gnus-zombie-list)) - killed) - (while lists - (setq killed (car lists)) - (while killed - (gnus-sethash (car killed) nil hashtb) - (setq killed (cdr killed))) - (setq lists (cdr lists))))) - -(defun gnus-get-killed-groups () - "Go through the active hashtb and mark all unknown groups as killed." - ;; First make sure active file has been read. - (unless (gnus-read-active-file-p) - (let ((gnus-read-active-file t)) - (gnus-read-active-file))) - (or gnus-killed-hashtb (gnus-make-hashtable-from-killed)) - ;; Go through all newsgroups that are known to Gnus - enlarge kill list. - (mapatoms - (lambda (sym) - (let ((groups 0) - (group (symbol-name sym))) - (if (or (null group) - (gnus-gethash group gnus-killed-hashtb) - (gnus-gethash group gnus-newsrc-hashtb)) - () - (let ((do-sub (gnus-matches-options-n group))) - (if (or (eq do-sub 'subscribe) (eq do-sub 'ignore)) - () - (setq groups (1+ groups)) - (setq gnus-killed-list - (cons group gnus-killed-list)) - (gnus-sethash group group gnus-killed-hashtb)))))) - gnus-active-hashtb)) - -;; Get the active file(s) from the backend(s). -(defun gnus-read-active-file () - (gnus-group-set-mode-line) - (let ((methods - (append - (if (gnus-check-server gnus-select-method) - ;; The native server is available. - (cons gnus-select-method gnus-secondary-select-methods) - ;; The native server is down, so we just do the - ;; secondary ones. - gnus-secondary-select-methods) - ;; Also read from the archive server. - (when (gnus-archive-server-wanted-p) - (list "archive")))) - list-type) - (setq gnus-have-read-active-file nil) - (save-excursion - (set-buffer nntp-server-buffer) - (while methods - (let* ((method (if (stringp (car methods)) - (gnus-server-get-method nil (car methods)) - (car methods))) - (where (nth 1 method)) - (mesg (format "Reading active file%s via %s..." - (if (and where (not (zerop (length where)))) - (concat " from " where) "") - (car method)))) - (gnus-message 5 mesg) - (when (gnus-check-server method) - ;; Request that the backend scan its incoming messages. - (and (gnus-check-backend-function 'request-scan (car method)) - (gnus-request-scan nil method)) - (cond - ((and (eq gnus-read-active-file 'some) - (gnus-check-backend-function 'retrieve-groups (car method))) - (let ((newsrc (cdr gnus-newsrc-alist)) - (gmethod (gnus-server-get-method nil method)) - groups info) - (while (setq info (pop newsrc)) - (when (gnus-server-equal - (gnus-find-method-for-group - (gnus-info-group info) info) - gmethod) - (push (gnus-group-real-name (gnus-info-group info)) - groups))) - (when groups - (gnus-check-server method) - (setq list-type (gnus-retrieve-groups groups method)) - (cond - ((not list-type) - (gnus-error - 1.2 "Cannot read partial active file from %s server." - (car method))) - ((eq list-type 'active) - (gnus-active-to-gnus-format method gnus-active-hashtb)) - (t - (gnus-groups-to-gnus-format method gnus-active-hashtb)))))) - (t - (if (not (gnus-request-list method)) - (unless (equal method gnus-message-archive-method) - (gnus-error 1 "Cannot read active file from %s server." - (car method))) - (gnus-message 5 mesg) - (gnus-active-to-gnus-format method gnus-active-hashtb) - ;; We mark this active file as read. - (push method gnus-have-read-active-file) - (gnus-message 5 "%sdone" mesg)))))) - (setq methods (cdr methods)))))) +;;; User-level commands. -;; Read an active file and place the results in `gnus-active-hashtb'. -(defun gnus-active-to-gnus-format (&optional method hashtb ignore-errors) - (unless method - (setq method gnus-select-method)) - (let ((cur (current-buffer)) - (hashtb (or hashtb - (if (and gnus-active-hashtb - (not (equal method gnus-select-method))) - gnus-active-hashtb - (setq gnus-active-hashtb - (if (equal method gnus-select-method) - (gnus-make-hashtable - (count-lines (point-min) (point-max))) - (gnus-make-hashtable 4096))))))) - ;; Delete unnecessary lines. - (goto-char (point-min)) - (while (search-forward "\nto." nil t) - (delete-region (1+ (match-beginning 0)) - (progn (forward-line 1) (point)))) - (or (string= gnus-ignored-newsgroups "") - (progn - (goto-char (point-min)) - (delete-matching-lines gnus-ignored-newsgroups))) - ;; Make the group names readable as a lisp expression even if they - ;; contain special characters. - ;; Fix by Luc Van Eycken . - (goto-char (point-max)) - (while (re-search-backward "[][';?()#]" nil t) - (insert ?\\)) - ;; If these are groups from a foreign select method, we insert the - ;; group prefix in front of the group names. - (and method (not (gnus-server-equal - (gnus-server-get-method nil method) - (gnus-server-get-method nil gnus-select-method))) - (let ((prefix (gnus-group-prefixed-name "" method))) - (goto-char (point-min)) - (while (and (not (eobp)) - (progn (insert prefix) - (zerop (forward-line 1))))))) - ;; Store the active file in a hash table. - (goto-char (point-min)) - (if (string-match "%[oO]" gnus-group-line-format) - ;; Suggested by Brian Edmonds . - ;; If we want information on moderated groups, we use this - ;; loop... - (let* ((mod-hashtb (make-vector 7 0)) - (m (intern "m" mod-hashtb)) - group max min) - (while (not (eobp)) - (condition-case nil - (progn - (narrow-to-region (point) (gnus-point-at-eol)) - (setq group (let ((obarray hashtb)) (read cur))) - (if (and (numberp (setq max (read cur))) - (numberp (setq min (read cur))) - (progn - (skip-chars-forward " \t") - (not - (or (= (following-char) ?=) - (= (following-char) ?x) - (= (following-char) ?j))))) - (set group (cons min max)) - (set group nil)) - ;; Enter moderated groups into a list. - (if (eq (let ((obarray mod-hashtb)) (read cur)) m) - (setq gnus-moderated-list - (cons (symbol-name group) gnus-moderated-list)))) - (error - (and group - (symbolp group) - (set group nil)))) - (widen) - (forward-line 1))) - ;; And if we do not care about moderation, we use this loop, - ;; which is faster. - (let (group max min) - (while (not (eobp)) - (condition-case () - (progn - (narrow-to-region (point) (gnus-point-at-eol)) - ;; group gets set to a symbol interned in the hash table - ;; (what a hack!!) - jwz - (setq group (let ((obarray hashtb)) (read cur))) - (if (and (numberp (setq max (read cur))) - (numberp (setq min (read cur))) - (progn - (skip-chars-forward " \t") - (not - (or (= (following-char) ?=) - (= (following-char) ?x) - (= (following-char) ?j))))) - (set group (cons min max)) - (set group nil))) - (error - (progn - (and group - (symbolp group) - (set group nil)) - (or ignore-errors - (gnus-message 3 "Warning - illegal active: %s" - (buffer-substring - (gnus-point-at-bol) (gnus-point-at-eol))))))) - (widen) - (forward-line 1)))))) - -(defun gnus-groups-to-gnus-format (method &optional hashtb) - ;; Parse a "groups" active file. - (let ((cur (current-buffer)) - (hashtb (or hashtb - (if (and method gnus-active-hashtb) - gnus-active-hashtb - (setq gnus-active-hashtb - (gnus-make-hashtable - (count-lines (point-min) (point-max))))))) - (prefix (and method - (not (gnus-server-equal - (gnus-server-get-method nil method) - (gnus-server-get-method nil gnus-select-method))) - (gnus-group-prefixed-name "" method)))) - - (goto-char (point-min)) - ;; We split this into to separate loops, one with the prefix - ;; and one without to speed the reading up somewhat. - (if prefix - (let (min max opoint group) - (while (not (eobp)) - (condition-case () - (progn - (read cur) (read cur) - (setq min (read cur) - max (read cur) - opoint (point)) - (skip-chars-forward " \t") - (insert prefix) - (goto-char opoint) - (set (let ((obarray hashtb)) (read cur)) - (cons min max))) - (error (and group (symbolp group) (set group nil)))) - (forward-line 1))) - (let (min max group) - (while (not (eobp)) - (condition-case () - (if (= (following-char) ?2) - (progn - (read cur) (read cur) - (setq min (read cur) - max (read cur)) - (set (setq group (let ((obarray hashtb)) (read cur))) - (cons min max)))) - (error (and group (symbolp group) (set group nil)))) - (forward-line 1)))))) - -(defun gnus-read-newsrc-file (&optional force) - "Read startup file. -If FORCE is non-nil, the .newsrc file is read." - ;; Reset variables that might be defined in the .newsrc.eld file. - (let ((variables gnus-variable-list)) - (while variables - (set (car variables) nil) - (setq variables (cdr variables)))) - (let* ((newsrc-file gnus-current-startup-file) - (quick-file (concat newsrc-file ".el"))) - (save-excursion - ;; We always load the .newsrc.eld file. If always contains - ;; much information that can not be gotten from the .newsrc - ;; file (ticked articles, killed groups, foreign methods, etc.) - (gnus-read-newsrc-el-file quick-file) - - (if (and (file-exists-p gnus-current-startup-file) - (or force - (and (file-newer-than-file-p newsrc-file quick-file) - (file-newer-than-file-p newsrc-file - (concat quick-file "d"))) - (not gnus-newsrc-alist))) - ;; We read the .newsrc file. Note that if there if a - ;; .newsrc.eld file exists, it has already been read, and - ;; the `gnus-newsrc-hashtb' has been created. While reading - ;; the .newsrc file, Gnus will only use the information it - ;; can find there for changing the data already read - - ;; ie. reading the .newsrc file will not trash the data - ;; already read (except for read articles). - (save-excursion - (gnus-message 5 "Reading %s..." newsrc-file) - (set-buffer (find-file-noselect newsrc-file)) - (buffer-disable-undo (current-buffer)) - (gnus-newsrc-to-gnus-format) - (kill-buffer (current-buffer)) - (gnus-message 5 "Reading %s...done" newsrc-file))) - - ;; Read any slave files. - (unless gnus-slave - (gnus-master-read-slave-newsrc)) - - ;; Convert old to new. - (gnus-convert-old-newsrc)))) - -(defun gnus-continuum-version (version) - "Return VERSION as a floating point number." - (when (or (string-match "^\\([^ ]+\\)? ?Gnus v?\\([0-9.]+\\)$" version) - (string-match "^\\(.?\\)gnus-\\([0-9.]+\\)$" version)) - (let* ((alpha (and (match-beginning 1) (match-string 1 version))) - (number (match-string 2 version)) - major minor least) - (string-match "\\([0-9]\\)\\.\\([0-9]+\\)\\.?\\([0-9]+\\)?" number) - (setq major (string-to-number (match-string 1 number))) - (setq minor (string-to-number (match-string 2 number))) - (setq least (if (match-beginning 3) - (string-to-number (match-string 3 number)) - 0)) - (string-to-number - (if (zerop major) - (format "%s00%02d%02d" - (cond - ((member alpha '("(ding)" "d")) "4.99") - ((member alpha '("September" "s")) "5.01") - ((member alpha '("Red" "r")) "5.03")) - minor least) - (format "%d.%02d%02d" major minor least)))))) +;;;###autoload +(defun gnus-slave-no-server (&optional arg) + "Read network news as a slave, without connecting to local server" + (interactive "P") + (gnus-no-server arg t)) -(defun gnus-convert-old-newsrc () - "Convert old newsrc into the new format, if needed." - (let ((fcv (and gnus-newsrc-file-version - (gnus-continuum-version gnus-newsrc-file-version)))) - (cond - ;; No .newsrc.eld file was loaded. - ((null fcv) nil) - ;; Gnus 5 .newsrc.eld was loaded. - ((< fcv (gnus-continuum-version "September Gnus v0.1")) - (gnus-convert-old-ticks))))) - -(defun gnus-convert-old-ticks () - (let ((newsrc (cdr gnus-newsrc-alist)) - marks info dormant ticked) - (while (setq info (pop newsrc)) - (when (setq marks (gnus-info-marks info)) - (setq dormant (cdr (assq 'dormant marks)) - ticked (cdr (assq 'tick marks))) - (when (or dormant ticked) - (gnus-info-set-read - info - (gnus-add-to-range - (gnus-info-read info) - (nconc (gnus-uncompress-range dormant) - (gnus-uncompress-range ticked))))))))) - -(defun gnus-read-newsrc-el-file (file) - (let ((ding-file (concat file "d"))) - ;; We always, always read the .eld file. - (gnus-message 5 "Reading %s..." ding-file) - (let (gnus-newsrc-assoc) - (condition-case nil - (load ding-file t t t) - (error - (gnus-error 1 "Error in %s" ding-file))) - (when gnus-newsrc-assoc - (setq gnus-newsrc-alist gnus-newsrc-assoc))) - (gnus-make-hashtable-from-newsrc-alist) - (when (file-newer-than-file-p file ding-file) - ;; Old format quick file - (gnus-message 5 "Reading %s..." file) - ;; The .el file is newer than the .eld file, so we read that one - ;; as well. - (gnus-read-old-newsrc-el-file file)))) - -;; Parse the old-style quick startup file -(defun gnus-read-old-newsrc-el-file (file) - (let (newsrc killed marked group m info) - (prog1 - (let ((gnus-killed-assoc nil) - gnus-marked-assoc gnus-newsrc-alist gnus-newsrc-assoc) - (prog1 - (condition-case nil - (load file t t t) - (error nil)) - (setq newsrc gnus-newsrc-assoc - killed gnus-killed-assoc - marked gnus-marked-assoc))) - (setq gnus-newsrc-alist nil) - (while (setq group (pop newsrc)) - (if (setq info (gnus-get-info (car group))) - (progn - (gnus-info-set-read info (cddr group)) - (gnus-info-set-level - info (if (nth 1 group) gnus-level-default-subscribed - gnus-level-default-unsubscribed)) - (setq gnus-newsrc-alist (cons info gnus-newsrc-alist))) - (push (setq info - (list (car group) - (if (nth 1 group) gnus-level-default-subscribed - gnus-level-default-unsubscribed) - (cddr group))) - gnus-newsrc-alist)) - ;; Copy marks into info. - (when (setq m (assoc (car group) marked)) - (unless (nthcdr 3 info) - (nconc info (list nil))) - (gnus-info-set-marks - info (list (cons 'tick (gnus-compress-sequence - (sort (cdr m) '<) t)))))) - (setq newsrc killed) - (while newsrc - (setcar newsrc (caar newsrc)) - (setq newsrc (cdr newsrc))) - (setq gnus-killed-list killed)) - ;; The .el file version of this variable does not begin with - ;; "options", while the .eld version does, so we just add it if it - ;; isn't there. - (and - gnus-newsrc-options - (progn - (and (not (string-match "^ *options" gnus-newsrc-options)) - (setq gnus-newsrc-options (concat "options " gnus-newsrc-options))) - (and (not (string-match "\n$" gnus-newsrc-options)) - (setq gnus-newsrc-options (concat gnus-newsrc-options "\n"))) - ;; Finally, if we read some options lines, we parse them. - (or (string= gnus-newsrc-options "") - (gnus-newsrc-parse-options gnus-newsrc-options)))) - - (setq gnus-newsrc-alist (nreverse gnus-newsrc-alist)) - (gnus-make-hashtable-from-newsrc-alist))) - -(defun gnus-make-newsrc-file (file) - "Make server dependent file name by catenating FILE and server host name." - (let* ((file (expand-file-name file nil)) - (real-file (concat file "-" (nth 1 gnus-select-method)))) - (if (or (file-exists-p real-file) - (file-exists-p (concat real-file ".el")) - (file-exists-p (concat real-file ".eld"))) - real-file file))) - -(defun gnus-newsrc-to-gnus-format () - (setq gnus-newsrc-options "") - (setq gnus-newsrc-options-n nil) - - (or gnus-active-hashtb - (setq gnus-active-hashtb (make-vector 4095 0))) - (let ((buf (current-buffer)) - (already-read (> (length gnus-newsrc-alist) 1)) - group subscribed options-symbol newsrc Options-symbol - symbol reads num1) - (goto-char (point-min)) - ;; We intern the symbol `options' in the active hashtb so that we - ;; can `eq' against it later. - (set (setq options-symbol (intern "options" gnus-active-hashtb)) nil) - (set (setq Options-symbol (intern "Options" gnus-active-hashtb)) nil) - - (while (not (eobp)) - ;; We first read the first word on the line by narrowing and - ;; then reading into `gnus-active-hashtb'. Most groups will - ;; already exist in that hashtb, so this will save some string - ;; space. - (narrow-to-region - (point) - (progn (skip-chars-forward "^ \t!:\n") (point))) - (goto-char (point-min)) - (setq symbol - (and (/= (point-min) (point-max)) - (let ((obarray gnus-active-hashtb)) (read buf)))) - (widen) - ;; Now, the symbol we have read is either `options' or a group - ;; name. If it is an options line, we just add it to a string. - (cond - ((or (eq symbol options-symbol) - (eq symbol Options-symbol)) - (setq gnus-newsrc-options - ;; This concating is quite inefficient, but since our - ;; thorough studies show that approx 99.37% of all - ;; .newsrc files only contain a single options line, we - ;; don't give a damn, frankly, my dear. - (concat gnus-newsrc-options - (buffer-substring - (gnus-point-at-bol) - ;; Options may continue on the next line. - (or (and (re-search-forward "^[^ \t]" nil 'move) - (progn (beginning-of-line) (point))) - (point))))) - (forward-line -1)) - (symbol - ;; Group names can be just numbers. - (when (numberp symbol) - (setq symbol (intern (int-to-string symbol) gnus-active-hashtb))) - (or (boundp symbol) (set symbol nil)) - ;; It was a group name. - (setq subscribed (= (following-char) ?:) - group (symbol-name symbol) - reads nil) - (if (eolp) - ;; If the line ends here, this is clearly a buggy line, so - ;; we put point a the beginning of line and let the cond - ;; below do the error handling. - (beginning-of-line) - ;; We skip to the beginning of the ranges. - (skip-chars-forward "!: \t")) - ;; We are now at the beginning of the list of read articles. - ;; We read them range by range. - (while - (cond - ((looking-at "[0-9]+") - ;; We narrow and read a number instead of buffer-substring/ - ;; string-to-int because it's faster. narrow/widen is - ;; faster than save-restriction/narrow, and save-restriction - ;; produces a garbage object. - (setq num1 (progn - (narrow-to-region (match-beginning 0) (match-end 0)) - (read buf))) - (widen) - ;; If the next character is a dash, then this is a range. - (if (= (following-char) ?-) - (progn - ;; We read the upper bound of the range. - (forward-char 1) - (if (not (looking-at "[0-9]+")) - ;; This is a buggy line, by we pretend that - ;; it's kinda OK. Perhaps the user should be - ;; dinged? - (setq reads (cons num1 reads)) - (setq reads - (cons - (cons num1 - (progn - (narrow-to-region (match-beginning 0) - (match-end 0)) - (read buf))) - reads)) - (widen))) - ;; It was just a simple number, so we add it to the - ;; list of ranges. - (setq reads (cons num1 reads))) - ;; If the next char in ?\n, then we have reached the end - ;; of the line and return nil. - (/= (following-char) ?\n)) - ((= (following-char) ?\n) - ;; End of line, so we end. - nil) - (t - ;; Not numbers and not eol, so this might be a buggy - ;; line... - (or (eobp) - ;; If it was eob instead of ?\n, we allow it. - (progn - ;; The line was buggy. - (setq group nil) - (gnus-error 3.1 "Mangled line: %s" - (buffer-substring (gnus-point-at-bol) - (gnus-point-at-eol))))) - nil)) - ;; Skip past ", ". Spaces are illegal in these ranges, but - ;; we allow them, because it's a common mistake to put a - ;; space after the comma. - (skip-chars-forward ", ")) +;;;###autoload +(defun gnus-no-server (&optional arg slave) + "Read network news. +If ARG is a positive number, Gnus will use that as the +startup level. If ARG is nil, Gnus will be started at level 2. +If ARG is non-nil and not a positive number, Gnus will +prompt the user for the name of an NNTP server to use. +As opposed to `gnus', this command will not connect to the local server." + (interactive "P") + (gnus-no-server-1 arg slave)) - ;; We have already read .newsrc.eld, so we gently update the - ;; data in the hash table with the information we have just - ;; read. - (when group - (let ((info (gnus-get-info group)) - level) - (if info - ;; There is an entry for this file in the alist. - (progn - (gnus-info-set-read info (nreverse reads)) - ;; We update the level very gently. In fact, we - ;; only change it if there's been a status change - ;; from subscribed to unsubscribed, or vice versa. - (setq level (gnus-info-level info)) - (cond ((and (<= level gnus-level-subscribed) - (not subscribed)) - (setq level (if reads - gnus-level-default-unsubscribed - (1+ gnus-level-default-unsubscribed)))) - ((and (> level gnus-level-subscribed) subscribed) - (setq level gnus-level-default-subscribed))) - (gnus-info-set-level info level)) - ;; This is a new group. - (setq info (list group - (if subscribed - gnus-level-default-subscribed - (if reads - (1+ gnus-level-subscribed) - gnus-level-default-unsubscribed)) - (nreverse reads)))) - (setq newsrc (cons info newsrc)))))) - (forward-line 1)) - - (setq newsrc (nreverse newsrc)) - - (if (not already-read) - () - ;; We now have two newsrc lists - `newsrc', which is what we - ;; have read from .newsrc, and `gnus-newsrc-alist', which is - ;; what we've read from .newsrc.eld. We have to merge these - ;; lists. We do this by "attaching" any (foreign) groups in the - ;; gnus-newsrc-alist to the (native) group that precedes them. - (let ((rc (cdr gnus-newsrc-alist)) - (prev gnus-newsrc-alist) - entry mentry) - (while rc - (or (null (nth 4 (car rc))) ; It's a native group. - (assoc (caar rc) newsrc) ; It's already in the alist. - (if (setq entry (assoc (caar prev) newsrc)) - (setcdr (setq mentry (memq entry newsrc)) - (cons (car rc) (cdr mentry))) - (setq newsrc (cons (car rc) newsrc)))) - (setq prev rc - rc (cdr rc))))) - - (setq gnus-newsrc-alist newsrc) - ;; We make the newsrc hashtb. - (gnus-make-hashtable-from-newsrc-alist) - - ;; Finally, if we read some options lines, we parse them. - (or (string= gnus-newsrc-options "") - (gnus-newsrc-parse-options gnus-newsrc-options)))) - -;; Parse options lines to find "options -n !all rec.all" and stuff. -;; The return value will be a list on the form -;; ((regexp1 . ignore) -;; (regexp2 . subscribe)...) -;; When handling new newsgroups, groups that match a `ignore' regexp -;; will be ignored, and groups that match a `subscribe' regexp will be -;; subscribed. A line like -;; options -n !all rec.all -;; will lead to a list that looks like -;; (("^rec\\..+" . subscribe) -;; ("^.+" . ignore)) -;; So all "rec.*" groups will be subscribed, while all the other -;; groups will be ignored. Note that "options -n !all rec.all" is very -;; different from "options -n rec.all !all". -(defun gnus-newsrc-parse-options (options) - (let (out eol) - (save-excursion - (gnus-set-work-buffer) - (insert (regexp-quote options)) - ;; First we treat all continuation lines. - (goto-char (point-min)) - (while (re-search-forward "\n[ \t]+" nil t) - (replace-match " " t t)) - ;; Then we transform all "all"s into ".+"s. - (goto-char (point-min)) - (while (re-search-forward "\\ball\\b" nil t) - (replace-match ".+" t t)) - (goto-char (point-min)) - ;; We remove all other options than the "-n" ones. - (while (re-search-forward "[ \t]-[^n][^-]*" nil t) - (replace-match " ") - (forward-char -1)) - (goto-char (point-min)) - - ;; We are only interested in "options -n" lines - we - ;; ignore the other option lines. - (while (re-search-forward "[ \t]-n" nil t) - (setq eol - (or (save-excursion - (and (re-search-forward "[ \t]-n" (gnus-point-at-eol) t) - (- (point) 2))) - (gnus-point-at-eol))) - ;; Search for all "words"... - (while (re-search-forward "[^ \t,\n]+" eol t) - (if (= (char-after (match-beginning 0)) ?!) - ;; If the word begins with a bang (!), this is a "not" - ;; spec. We put this spec (minus the bang) and the - ;; symbol `ignore' into the list. - (setq out (cons (cons (concat - "^" (buffer-substring - (1+ (match-beginning 0)) - (match-end 0))) - 'ignore) out)) - ;; There was no bang, so this is a "yes" spec. - (setq out (cons (cons (concat "^" (match-string 0)) - 'subscribe) out))))) - - (setq gnus-newsrc-options-n out)))) - -(defun gnus-save-newsrc-file (&optional force) - "Save .newsrc file." - ;; Note: We cannot save .newsrc file if all newsgroups are removed - ;; from the variable gnus-newsrc-alist. - (when (and (or gnus-newsrc-alist gnus-killed-list) - gnus-current-startup-file) - (save-excursion - (if (and (or gnus-use-dribble-file gnus-slave) - (not force) - (or (not gnus-dribble-buffer) - (not (buffer-name gnus-dribble-buffer)) - (zerop (save-excursion - (set-buffer gnus-dribble-buffer) - (buffer-size))))) - (gnus-message 4 "(No changes need to be saved)") - (run-hooks 'gnus-save-newsrc-hook) - (if gnus-slave - (gnus-slave-save-newsrc) - ;; Save .newsrc. - (when gnus-save-newsrc-file - (gnus-message 5 "Saving %s..." gnus-current-startup-file) - (gnus-gnus-to-newsrc-format) - (gnus-message 5 "Saving %s...done" gnus-current-startup-file)) - ;; Save .newsrc.eld. - (set-buffer (get-buffer-create " *Gnus-newsrc*")) - (make-local-variable 'version-control) - (setq version-control 'never) - (setq buffer-file-name - (concat gnus-current-startup-file ".eld")) - (setq default-directory (file-name-directory buffer-file-name)) - (gnus-add-current-to-buffer-list) - (buffer-disable-undo (current-buffer)) - (erase-buffer) - (gnus-message 5 "Saving %s.eld..." gnus-current-startup-file) - (gnus-gnus-to-quick-newsrc-format) - (run-hooks 'gnus-save-quick-newsrc-hook) - (save-buffer) - (kill-buffer (current-buffer)) - (gnus-message - 5 "Saving %s.eld...done" gnus-current-startup-file)) - (gnus-dribble-delete-file) - (gnus-group-set-mode-line))))) - -(defun gnus-gnus-to-quick-newsrc-format () - "Insert Gnus variables such as gnus-newsrc-alist in lisp format." - (insert ";; Gnus startup file.\n") - (insert ";; Never delete this file - touch .newsrc instead to force Gnus\n") - (insert ";; to read .newsrc.\n") - (insert "(setq gnus-newsrc-file-version " - (prin1-to-string gnus-version) ")\n") - (let ((variables - (if gnus-save-killed-list gnus-variable-list - ;; Remove the `gnus-killed-list' from the list of variables - ;; to be saved, if required. - (delq 'gnus-killed-list (copy-sequence gnus-variable-list)))) - ;; Peel off the "dummy" group. - (gnus-newsrc-alist (cdr gnus-newsrc-alist)) - variable) - ;; Insert the variables into the file. - (while variables - (when (and (boundp (setq variable (pop variables))) - (symbol-value variable)) - (insert "(setq " (symbol-name variable) " '") - (prin1 (symbol-value variable) (current-buffer)) - (insert ")\n"))))) - -(defun gnus-gnus-to-newsrc-format () - ;; Generate and save the .newsrc file. - (save-excursion - (set-buffer (create-file-buffer gnus-current-startup-file)) - (let ((newsrc (cdr gnus-newsrc-alist)) - (standard-output (current-buffer)) - info ranges range method) - (setq buffer-file-name gnus-current-startup-file) - (setq default-directory (file-name-directory buffer-file-name)) - (buffer-disable-undo (current-buffer)) - (erase-buffer) - ;; Write options. - (if gnus-newsrc-options (insert gnus-newsrc-options)) - ;; Write subscribed and unsubscribed. - (while (setq info (pop newsrc)) - ;; Don't write foreign groups to .newsrc. - (when (or (null (setq method (gnus-info-method info))) - (equal method "native") - (gnus-server-equal method gnus-select-method)) - (insert (gnus-info-group info) - (if (> (gnus-info-level info) gnus-level-subscribed) - "!" ":")) - (when (setq ranges (gnus-info-read info)) - (insert " ") - (if (not (listp (cdr ranges))) - (if (= (car ranges) (cdr ranges)) - (princ (car ranges)) - (princ (car ranges)) - (insert "-") - (princ (cdr ranges))) - (while (setq range (pop ranges)) - (if (or (atom range) (= (car range) (cdr range))) - (princ (or (and (atom range) range) (car range))) - (princ (car range)) - (insert "-") - (princ (cdr range))) - (if ranges (insert ","))))) - (insert "\n"))) - (make-local-variable 'version-control) - (setq version-control 'never) - ;; It has been reported that sometime the modtime on the .newsrc - ;; file seems to be off. We really do want to overwrite it, so - ;; we clear the modtime here before saving. It's a bit odd, - ;; though... - ;; sometimes the modtime clear isn't sufficient. most brute force: - ;; delete the silly thing entirely first. but this fails to provide - ;; such niceties as .newsrc~ creation. - (if gnus-modtime-botch - (delete-file gnus-startup-file) - (clear-visited-file-modtime)) - (run-hooks 'gnus-save-standard-newsrc-hook) - (save-buffer) - (kill-buffer (current-buffer))))) - - -;;; -;;; Slave functions. -;;; +;;;###autoload +(defun gnus-slave (&optional arg) + "Read news as a slave." + (interactive "P") + (gnus arg nil 'slave)) -(defun gnus-slave-save-newsrc () - (save-excursion - (set-buffer gnus-dribble-buffer) - (let ((slave-name - (make-temp-name (concat gnus-current-startup-file "-slave-")))) - (write-region (point-min) (point-max) slave-name nil 'nomesg)))) - -(defun gnus-master-read-slave-newsrc () - (let ((slave-files - (directory-files - (file-name-directory gnus-current-startup-file) - t (concat - "^" (regexp-quote - (concat - (file-name-nondirectory gnus-current-startup-file) - "-slave-"))) - t)) - file) - (if (not slave-files) - () ; There are no slave files to read. - (gnus-message 7 "Reading slave newsrcs...") - (save-excursion - (set-buffer (get-buffer-create " *gnus slave*")) - (buffer-disable-undo (current-buffer)) - (setq slave-files - (sort (mapcar (lambda (file) - (list (nth 5 (file-attributes file)) file)) - slave-files) - (lambda (f1 f2) - (or (< (caar f1) (caar f2)) - (< (nth 1 (car f1)) (nth 1 (car f2))))))) - (while slave-files - (erase-buffer) - (setq file (nth 1 (car slave-files))) - (insert-file-contents file) - (if (condition-case () - (progn - (eval-buffer (current-buffer)) - t) - (error - (gnus-error 3.2 "Possible error in %s" file) - nil)) - (or gnus-slave ; Slaves shouldn't delete these files. - (condition-case () - (delete-file file) - (error nil)))) - (setq slave-files (cdr slave-files)))) - (gnus-message 7 "Reading slave newsrcs...done")))) - - -;;; -;;; Group description. -;;; - -(defun gnus-read-all-descriptions-files () - (let ((methods (cons gnus-select-method - (nconc - (when (gnus-archive-server-wanted-p) - (list "archive")) - gnus-secondary-select-methods)))) - (while methods - (gnus-read-descriptions-file (car methods)) - (setq methods (cdr methods))) - t)) - -(defun gnus-read-descriptions-file (&optional method) - (let ((method (or method gnus-select-method)) - group) - (when (stringp method) - (setq method (gnus-server-to-method method))) - ;; We create the hashtable whether we manage to read the desc file - ;; to avoid trying to re-read after a failed read. - (or gnus-description-hashtb - (setq gnus-description-hashtb - (gnus-make-hashtable (length gnus-active-hashtb)))) - ;; Mark this method's desc file as read. - (gnus-sethash (gnus-group-prefixed-name "" method) "Has read" - gnus-description-hashtb) - - (gnus-message 5 "Reading descriptions file via %s..." (car method)) - (cond - ((not (gnus-check-server method)) - (gnus-message 1 "Couldn't open server") - nil) - ((not (gnus-request-list-newsgroups method)) - (gnus-message 1 "Couldn't read newsgroups descriptions") - nil) - (t - (save-excursion - (save-restriction - (set-buffer nntp-server-buffer) - (goto-char (point-min)) - (when (or (search-forward "\n.\n" nil t) - (goto-char (point-max))) - (beginning-of-line) - (narrow-to-region (point-min) (point))) - ;; If these are groups from a foreign select method, we insert the - ;; group prefix in front of the group names. - (and method (not (gnus-server-equal - (gnus-server-get-method nil method) - (gnus-server-get-method nil gnus-select-method))) - (let ((prefix (gnus-group-prefixed-name "" method))) - (goto-char (point-min)) - (while (and (not (eobp)) - (progn (insert prefix) - (zerop (forward-line 1))))))) - (goto-char (point-min)) - (while (not (eobp)) - ;; If we get an error, we set group to 0, which is not a - ;; symbol... - (setq group - (condition-case () - (let ((obarray gnus-description-hashtb)) - ;; Group is set to a symbol interned in this - ;; hash table. - (read nntp-server-buffer)) - (error 0))) - (skip-chars-forward " \t") - ;; ... which leads to this line being effectively ignored. - (and (symbolp group) - (set group (buffer-substring - (point) (progn (end-of-line) (point))))) - (forward-line 1)))) - (gnus-message 5 "Reading descriptions file...done") - t)))) +;;;###autoload +(defun gnus-other-frame (&optional arg) + "Pop up a frame to read news." + (interactive "P") + (let ((window (get-buffer-window gnus-group-buffer))) + (cond (window + (select-frame (window-frame window))) + ((= (length (frame-list)) 1) + (select-frame (make-frame))) + (t + (other-frame 1)))) + (gnus arg)) -(defun gnus-group-get-description (group) - "Get the description of a group by sending XGTITLE to the server." - (when (gnus-request-group-description group) - (save-excursion - (set-buffer nntp-server-buffer) - (goto-char (point-min)) - (when (looking-at "[^ \t]+[ \t]+\\(.*\\)") - (match-string 1))))) - - -;;; -;;; Buffering of read articles. -;;; - -(defvar gnus-backlog-buffer " *Gnus Backlog*") -(defvar gnus-backlog-articles nil) -(defvar gnus-backlog-hashtb nil) - -(defun gnus-backlog-buffer () - "Return the backlog buffer." - (or (get-buffer gnus-backlog-buffer) - (save-excursion - (set-buffer (get-buffer-create gnus-backlog-buffer)) - (buffer-disable-undo (current-buffer)) - (setq buffer-read-only t) - (gnus-add-current-to-buffer-list) - (get-buffer gnus-backlog-buffer)))) - -(defun gnus-backlog-setup () - "Initialize backlog variables." - (unless gnus-backlog-hashtb - (setq gnus-backlog-hashtb (make-vector 1023 0)))) - -(gnus-add-shutdown 'gnus-backlog-shutdown 'gnus) - -(defun gnus-backlog-shutdown () - "Clear all backlog variables and buffers." - (when (get-buffer gnus-backlog-buffer) - (kill-buffer gnus-backlog-buffer)) - (setq gnus-backlog-hashtb nil - gnus-backlog-articles nil)) - -(defun gnus-backlog-enter-article (group number buffer) - (gnus-backlog-setup) - (let ((ident (intern (concat group ":" (int-to-string number)) - gnus-backlog-hashtb)) - b) - (if (memq ident gnus-backlog-articles) - () ; It's already kept. - ;; Remove the oldest article, if necessary. - (and (numberp gnus-keep-backlog) - (>= (length gnus-backlog-articles) gnus-keep-backlog) - (gnus-backlog-remove-oldest-article)) - (setq gnus-backlog-articles (cons ident gnus-backlog-articles)) - ;; Insert the new article. - (save-excursion - (set-buffer (gnus-backlog-buffer)) - (let (buffer-read-only) - (goto-char (point-max)) - (or (bolp) (insert "\n")) - (setq b (point)) - (insert-buffer-substring buffer) - ;; Tag the beginning of the article with the ident. - (gnus-put-text-property b (1+ b) 'gnus-backlog ident)))))) - -(defun gnus-backlog-remove-oldest-article () - (save-excursion - (set-buffer (gnus-backlog-buffer)) - (goto-char (point-min)) - (if (zerop (buffer-size)) - () ; The buffer is empty. - (let ((ident (get-text-property (point) 'gnus-backlog)) - buffer-read-only) - ;; Remove the ident from the list of articles. - (when ident - (setq gnus-backlog-articles (delq ident gnus-backlog-articles))) - ;; Delete the article itself. - (delete-region - (point) (next-single-property-change - (1+ (point)) 'gnus-backlog nil (point-max))))))) - -(defun gnus-backlog-remove-article (group number) - "Remove article NUMBER in GROUP from the backlog." - (when (numberp number) - (gnus-backlog-setup) - (let ((ident (intern (concat group ":" (int-to-string number)) - gnus-backlog-hashtb)) - beg end) - (when (memq ident gnus-backlog-articles) - ;; It was in the backlog. - (save-excursion - (set-buffer (gnus-backlog-buffer)) - (let (buffer-read-only) - (when (setq beg (text-property-any - (point-min) (point-max) 'gnus-backlog - ident)) - ;; Find the end (i. e., the beginning of the next article). - (setq end - (next-single-property-change - (1+ beg) 'gnus-backlog (current-buffer) (point-max))) - (delete-region beg end) - ;; Return success. - t))))))) - -(defun gnus-backlog-request-article (group number buffer) - (when (numberp number) - (gnus-backlog-setup) - (let ((ident (intern (concat group ":" (int-to-string number)) - gnus-backlog-hashtb)) - beg end) - (when (memq ident gnus-backlog-articles) - ;; It was in the backlog. - (save-excursion - (set-buffer (gnus-backlog-buffer)) - (if (not (setq beg (text-property-any - (point-min) (point-max) 'gnus-backlog - ident))) - ;; It wasn't in the backlog after all. - (ignore - (setq gnus-backlog-articles (delq ident gnus-backlog-articles))) - ;; Find the end (i. e., the beginning of the next article). - (setq end - (next-single-property-change - (1+ beg) 'gnus-backlog (current-buffer) (point-max))))) - (let ((buffer-read-only nil)) - (erase-buffer) - (insert-buffer-substring gnus-backlog-buffer beg end) - t))))) +;;;###autoload +(defun gnus (&optional arg dont-connect slave) + "Read network news. +If ARG is non-nil and a positive number, Gnus will use that as the +startup level. If ARG is non-nil and not a positive number, Gnus will +prompt the user for the name of an NNTP server to use." + (interactive "P") + (gnus-1 arg dont-connect slave)) ;; Allow redefinition of Gnus functions. diff -r ad457d5f7d04 -r 0293115a14e9 lisp/gnus/lpath.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus/lpath.el Mon Aug 13 08:49:20 2007 +0200 @@ -0,0 +1,33 @@ +;; Shut up. + +(defvar byte-compile-default-warnings) + +(defun maybe-fbind (args) + (while args + (or (fboundp (car args)) + (fset (car args) 'ignore)) + (setq args (cdr args)))) + +(if (string-match "XEmacs" emacs-version) + (progn + (defvar track-mouse nil) + (maybe-fbind '(posn-point event-start x-popup-menu + error-message-string facemenu-get-face window-at + coordinates-in-window-p compute-motion + x-defined-colors easy-menu-create-keymaps)) + ;; XEmacs thinks writting compatible code is obsolete. + (require 'bytecomp) + (setq byte-compile-default-warnings + (delq 'obsolete byte-compile-default-warnings))) + (defvar browse-url-browser-function nil) + (maybe-fbind '(color-instance-rgb-components make-color-instance + color-instance-name specifier-instance device-type + device-class get-popup-menu-response event-object + x-defined-colors read-color add-submenu set-font-family + font-create-object set-font-size frame-device find-face + set-extent-property make-extent))) + +(setq load-path (cons "." load-path)) +(require 'custom) + +(provide 'lpath) diff -r ad457d5f7d04 -r 0293115a14e9 lisp/gnus/mailheader.el --- a/lisp/gnus/mailheader.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/gnus/mailheader.el Mon Aug 13 08:49:20 2007 +0200 @@ -36,7 +36,7 @@ ;; The car of each element in the message-header alist is a symbol whose ;; print name is the name of the header, in all lower-case. The cdr of an ;; element depends on the operation. After extracting headers from a -;; messge, it is a string, the value of the header. An extracted set of +;; message, it is a string, the value of the header. An extracted set of ;; headers may be parsed further, which may turn it into a list, whose car ;; is the original value and whose subsequent elements depend on the ;; header. For formatting, it is evaluated to obtain the strings to be @@ -72,7 +72,7 @@ value)) (push (if (cdr value) (cons header (mapconcat #'identity (nreverse value) " ")) - (cons header (car value))) + (cons header (car value))) message-headers))) (goto-char top) (nreverse message-headers))) @@ -108,7 +108,7 @@ "Return the value associated with header HEADER in HEADER-ALIST. If the value is a string, it is the original value of the header. If the value is a list, its first element is the original value of the header, -with any subsequent elements bing the result of parsing the value. +with any subsequent elements being the result of parsing the value. If HEADER-ALIST is nil, the dynamically bound variable `headers' is used." (cdr (assq header (or header-alist headers)))) @@ -117,10 +117,10 @@ HEADER-ALIST defaults to the dynamically bound variable `headers' if nil. See `mail-header' for the semantics of VALUE." (let* ((alist (or header-alist headers)) - (entry (assq header alist))) + (entry (assq header alist))) (if entry (setf (cdr entry) value) - (nconc alist (list (cons header value))))) + (nconc alist (list (cons header value))))) value) (defsetf mail-header (header &optional header-alist) (value) @@ -161,7 +161,7 @@ (mapcar #'car format-rules)))) (dolist (rule format-rules) (let* ((header (car rule)) - (value (mail-header header))) + (value (mail-header header))) (cond ((null header) 'ignore) ((eq header t) (dolist (defaulted headers) @@ -170,11 +170,11 @@ (value (cdr defaulted))) (if (cdr rule) (funcall (cdr rule) header value) - (funcall mail-header-format-function header value)))))) + (funcall mail-header-format-function header value)))))) (value (if (cdr rule) (funcall (cdr rule) header value) - (funcall mail-header-format-function header value)))))) + (funcall mail-header-format-function header value)))))) (insert "\n"))) (provide 'mailheader) diff -r ad457d5f7d04 -r 0293115a14e9 lisp/gnus/md5.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus/md5.el Mon Aug 13 08:49:20 2007 +0200 @@ -0,0 +1,409 @@ +;;; md5.el -- MD5 Message Digest Algorithm +;;; Gareth Rees + +;; LCD Archive Entry: +;; md5|Gareth Rees|gdr11@cl.cam.ac.uk| +;; MD5 cryptographic message digest algorithm| +;; 13-Nov-95|1.0|~/misc/md5.el.Z| + +;;; Details: ------------------------------------------------------------------ + +;; This is a direct translation into Emacs LISP of the reference C +;; implementation of the MD5 Message-Digest Algorithm written by RSA +;; Data Security, Inc. +;; +;; The algorithm takes a message (that is, a string of bytes) and +;; computes a 16-byte checksum or "digest" for the message. This digest +;; is supposed to be cryptographically strong in the sense that if you +;; are given a 16-byte digest D, then there is no easier way to +;; construct a message whose digest is D than to exhaustively search the +;; space of messages. However, the robustness of the algorithm has not +;; been proven, and a similar algorithm (MD4) was shown to be unsound, +;; so treat with caution! +;; +;; The C algorithm uses 32-bit integers; because GNU Emacs +;; implementations provide 28-bit integers (with 24-bit integers on +;; versions prior to 19.29), the code represents a 32-bit integer as the +;; cons of two 16-bit integers. The most significant word is stored in +;; the car and the least significant in the cdr. The algorithm requires +;; at least 17 bits of integer representation in order to represent the +;; carry from a 16-bit addition. + +;;; Usage: -------------------------------------------------------------------- + +;; To compute the MD5 Message Digest for a message M (represented as a +;; string or as a vector of bytes), call +;; +;; (md5-encode M) +;; +;; which returns the message digest as a vector of 16 bytes. If you +;; need to supply the message in pieces M1, M2, ... Mn, then call +;; +;; (md5-init) +;; (md5-update M1) +;; (md5-update M2) +;; ... +;; (md5-update Mn) +;; (md5-final) + +;;; Copyright and licence: ---------------------------------------------------- + +;; Copyright (C) 1995 by Gareth Rees +;; Derived from the RSA Data Security, Inc. MD5 Message-Digest Algorithm +;; +;; md5.el is free software; you can redistribute it and/or modify it +;; under the terms of the GNU General Public License as published by the +;; Free Software Foundation; either version 2, or (at your option) any +;; later version. +;; +;; md5.el 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. +;; +;; The original copyright notice is given below, as required by the +;; licence for the original code. This code is distributed under *both* +;; RSA's original licence and the GNU General Public Licence. (There +;; should be no problems, as the former is more liberal than the +;; latter). + +;;; Original copyright notice: ------------------------------------------------ + +;; Copyright (C) 1990, RSA Data Security, Inc. All rights reserved. +;; +;; License to copy and use this software is granted provided that it is +;; identified as the "RSA Data Security, Inc. MD5 Message- Digest +;; Algorithm" in all material mentioning or referencing this software or +;; this function. +;; +;; License is also granted to make and use derivative works provided +;; that such works are identified as "derived from the RSA Data +;; Security, Inc. MD5 Message-Digest Algorithm" in all material +;; mentioning or referencing the derived work. +;; +;; RSA Data Security, Inc. makes no representations concerning either +;; the merchantability of this software or the suitability of this +;; software for any particular purpose. It is provided "as is" without +;; express or implied warranty of any kind. +;; +;; These notices must be retained in any copies of any part of this +;; documentation and/or software. + +;;; Code: --------------------------------------------------------------------- + +(defvar md5-program "md5" + "*Program that reads a message on its standard input and writes an +MD5 digest on its output.") + +(defvar md5-maximum-internal-length 4096 + "*The maximum size of a piece of data that should use the MD5 routines +written in lisp. If a message exceeds this, it will be run through an +external filter for processing. Also see the `md5-program' variable. +This variable has no effect if you call the md5-init|update|final +functions - only used by the `md5' function's simpler interface.") + +(defvar md5-bits (make-vector 4 0) + "Number of bits handled, modulo 2^64. +Represented as four 16-bit numbers, least significant first.") +(defvar md5-buffer (make-vector 4 '(0 . 0)) + "Scratch buffer (four 32-bit integers).") +(defvar md5-input (make-vector 64 0) + "Input buffer (64 bytes).") + +(defun md5-unhex (x) + (if (> x ?9) + (if (>= x ?a) + (+ 10 (- x ?a)) + (+ 10 (- x ?A))) + (- x ?0))) + +(defun md5-encode (message) + "Encodes MESSAGE using the MD5 message digest algorithm. +MESSAGE must be a string or an array of bytes. +Returns a vector of 16 bytes containing the message digest." + (if (<= (length message) md5-maximum-internal-length) + (progn + (md5-init) + (md5-update message) + (md5-final)) + (save-excursion + (set-buffer (get-buffer-create " *md5-work*")) + (erase-buffer) + (insert message) + (call-process-region (point-min) (point-max) + (or shell-file-name "/bin/sh") + t (current-buffer) nil + "-c" md5-program) + ;; MD5 digest is 32 chars long + ;; mddriver adds a newline to make neaten output for tty + ;; viewing, make sure we leave it behind. + (let ((data (buffer-substring (point-min) (+ (point-min) 32))) + (vec (make-vector 16 0)) + (ctr 0)) + (while (< ctr 16) + (aset vec ctr (+ (* 16 (md5-unhex (aref data (* ctr 2)))) + (md5-unhex (aref data (1+ (* ctr 2)))))) + (setq ctr (1+ ctr))))))) + +(defsubst md5-add (x y) + "Return 32-bit sum of 32-bit integers X and Y." + (let ((m (+ (car x) (car y))) + (l (+ (cdr x) (cdr y)))) + (cons (logand 65535 (+ m (lsh l -16))) (logand l 65535)))) + +;; FF, GG, HH and II are basic MD5 functions, providing transformations +;; for rounds 1, 2, 3 and 4 respectively. Each function follows this +;; pattern of computation (where ROTATE(x,y) means rotate 32-bit value x +;; by y bits to the left): +;; +;; FF(a,b,c,d,x,s,ac) = ROTATE(a + F(b,c,d) + x + ac,s) + b +;; +;; so we use the macro `md5-make-step' to construct each one. The +;; helper functions F, G, H and I operate on 16-bit numbers; the full +;; operation splits its inputs, operates on the halves separately and +;; then puts the results together. + +(defsubst md5-F (x y z) (logior (logand x y) (logand (lognot x) z))) +(defsubst md5-G (x y z) (logior (logand x z) (logand y (lognot z)))) +(defsubst md5-H (x y z) (logxor x y z)) +(defsubst md5-I (x y z) (logxor y (logior x (logand 65535 (lognot z))))) + +(defmacro md5-make-step (name func) + (` + (defun (, name) (a b c d x s ac) + (let* + ((m1 (+ (car a) ((, func) (car b) (car c) (car d)) (car x) (car ac))) + (l1 (+ (cdr a) ((, func) (cdr b) (cdr c) (cdr d)) (cdr x) (cdr ac))) + (m2 (logand 65535 (+ m1 (lsh l1 -16)))) + (l2 (logand 65535 l1)) + (m3 (logand 65535 (if (> s 15) + (+ (lsh m2 (- s 32)) (lsh l2 (- s 16))) + (+ (lsh m2 s) (lsh l2 (- s 16)))))) + (l3 (logand 65535 (if (> s 15) + (+ (lsh l2 (- s 32)) (lsh m2 (- s 16))) + (+ (lsh l2 s) (lsh m2 (- s 16))))))) + (md5-add (cons m3 l3) b))))) + +(md5-make-step md5-FF md5-F) +(md5-make-step md5-GG md5-G) +(md5-make-step md5-HH md5-H) +(md5-make-step md5-II md5-I) + +(defun md5-init () + "Initialize the state of the message-digest routines." + (aset md5-bits 0 0) + (aset md5-bits 1 0) + (aset md5-bits 2 0) + (aset md5-bits 3 0) + (aset md5-buffer 0 '(26437 . 8961)) + (aset md5-buffer 1 '(61389 . 43913)) + (aset md5-buffer 2 '(39098 . 56574)) + (aset md5-buffer 3 '( 4146 . 21622))) + +(defun md5-update (string) + "Update the current MD5 state with STRING (an array of bytes)." + (let ((len (length string)) + (i 0) + (j 0)) + (while (< i len) + ;; Compute number of bytes modulo 64 + (setq j (% (/ (aref md5-bits 0) 8) 64)) + + ;; Store this byte (truncating to 8 bits to be sure) + (aset md5-input j (logand 255 (aref string i))) + + ;; Update number of bits by 8 (modulo 2^64) + (let ((c 8) (k 0)) + (while (and (> c 0) (< k 4)) + (let ((b (aref md5-bits k))) + (aset md5-bits k (logand 65535 (+ b c))) + (setq c (if (> b (- 65535 c)) 1 0) + k (1+ k))))) + + ;; Increment number of bytes processed + (setq i (1+ i)) + + ;; When 64 bytes accumulated, pack them into sixteen 32-bit + ;; integers in the array `in' and then tranform them. + (if (= j 63) + (let ((in (make-vector 16 (cons 0 0))) + (k 0) + (kk 0)) + (while (< k 16) + (aset in k (md5-pack md5-input kk)) + (setq k (+ k 1) kk (+ kk 4))) + (md5-transform in)))))) + +(defun md5-pack (array i) + "Pack the four bytes at ARRAY reference I to I+3 into a 32-bit integer." + (cons (+ (lsh (aref array (+ i 3)) 8) (aref array (+ i 2))) + (+ (lsh (aref array (+ i 1)) 8) (aref array (+ i 0))))) + +(defun md5-byte (array n b) + "Unpack byte B (0 to 3) from Nth member of ARRAY of 32-bit integers." + (let ((e (aref array n))) + (cond ((eq b 0) (logand 255 (cdr e))) + ((eq b 1) (lsh (cdr e) -8)) + ((eq b 2) (logand 255 (car e))) + ((eq b 3) (lsh (car e) -8))))) + +(defun md5-final () + (let ((in (make-vector 16 (cons 0 0))) + (j 0) + (digest (make-vector 16 0)) + (padding)) + + ;; Save the number of bits in the message + (aset in 14 (cons (aref md5-bits 1) (aref md5-bits 0))) + (aset in 15 (cons (aref md5-bits 3) (aref md5-bits 2))) + + ;; Compute number of bytes modulo 64 + (setq j (% (/ (aref md5-bits 0) 8) 64)) + + ;; Pad out computation to 56 bytes modulo 64 + (setq padding (make-vector (if (< j 56) (- 56 j) (- 120 j)) 0)) + (aset padding 0 128) + (md5-update padding) + + ;; Append length in bits and transform + (let ((k 0) (kk 0)) + (while (< k 14) + (aset in k (md5-pack md5-input kk)) + (setq k (+ k 1) kk (+ kk 4)))) + (md5-transform in) + + ;; Store the results in the digest + (let ((k 0) (kk 0)) + (while (< k 4) + (aset digest (+ kk 0) (md5-byte md5-buffer k 0)) + (aset digest (+ kk 1) (md5-byte md5-buffer k 1)) + (aset digest (+ kk 2) (md5-byte md5-buffer k 2)) + (aset digest (+ kk 3) (md5-byte md5-buffer k 3)) + (setq k (+ k 1) kk (+ kk 4)))) + + ;; Return digest + digest)) + +;; It says in the RSA source, "Note that if the Mysterious Constants are +;; arranged backwards in little-endian order and decrypted with the DES +;; they produce OCCULT MESSAGES!" Security through obscurity? + +(defun md5-transform (in) + "Basic MD5 step. Transform md5-buffer based on array IN." + (let ((a (aref md5-buffer 0)) + (b (aref md5-buffer 1)) + (c (aref md5-buffer 2)) + (d (aref md5-buffer 3))) + (setq + a (md5-FF a b c d (aref in 0) 7 '(55146 . 42104)) + d (md5-FF d a b c (aref in 1) 12 '(59591 . 46934)) + c (md5-FF c d a b (aref in 2) 17 '( 9248 . 28891)) + b (md5-FF b c d a (aref in 3) 22 '(49597 . 52974)) + a (md5-FF a b c d (aref in 4) 7 '(62844 . 4015)) + d (md5-FF d a b c (aref in 5) 12 '(18311 . 50730)) + c (md5-FF c d a b (aref in 6) 17 '(43056 . 17939)) + b (md5-FF b c d a (aref in 7) 22 '(64838 . 38145)) + a (md5-FF a b c d (aref in 8) 7 '(27008 . 39128)) + d (md5-FF d a b c (aref in 9) 12 '(35652 . 63407)) + c (md5-FF c d a b (aref in 10) 17 '(65535 . 23473)) + b (md5-FF b c d a (aref in 11) 22 '(35164 . 55230)) + a (md5-FF a b c d (aref in 12) 7 '(27536 . 4386)) + d (md5-FF d a b c (aref in 13) 12 '(64920 . 29075)) + c (md5-FF c d a b (aref in 14) 17 '(42617 . 17294)) + b (md5-FF b c d a (aref in 15) 22 '(18868 . 2081)) + a (md5-GG a b c d (aref in 1) 5 '(63006 . 9570)) + d (md5-GG d a b c (aref in 6) 9 '(49216 . 45888)) + c (md5-GG c d a b (aref in 11) 14 '( 9822 . 23121)) + b (md5-GG b c d a (aref in 0) 20 '(59830 . 51114)) + a (md5-GG a b c d (aref in 5) 5 '(54831 . 4189)) + d (md5-GG d a b c (aref in 10) 9 '( 580 . 5203)) + c (md5-GG c d a b (aref in 15) 14 '(55457 . 59009)) + b (md5-GG b c d a (aref in 4) 20 '(59347 . 64456)) + a (md5-GG a b c d (aref in 9) 5 '( 8673 . 52710)) + d (md5-GG d a b c (aref in 14) 9 '(49975 . 2006)) + c (md5-GG c d a b (aref in 3) 14 '(62677 . 3463)) + b (md5-GG b c d a (aref in 8) 20 '(17754 . 5357)) + a (md5-GG a b c d (aref in 13) 5 '(43491 . 59653)) + d (md5-GG d a b c (aref in 2) 9 '(64751 . 41976)) + c (md5-GG c d a b (aref in 7) 14 '(26479 . 729)) + b (md5-GG b c d a (aref in 12) 20 '(36138 . 19594)) + a (md5-HH a b c d (aref in 5) 4 '(65530 . 14658)) + d (md5-HH d a b c (aref in 8) 11 '(34673 . 63105)) + c (md5-HH c d a b (aref in 11) 16 '(28061 . 24866)) + b (md5-HH b c d a (aref in 14) 23 '(64997 . 14348)) + a (md5-HH a b c d (aref in 1) 4 '(42174 . 59972)) + d (md5-HH d a b c (aref in 4) 11 '(19422 . 53161)) + c (md5-HH c d a b (aref in 7) 16 '(63163 . 19296)) + b (md5-HH b c d a (aref in 10) 23 '(48831 . 48240)) + a (md5-HH a b c d (aref in 13) 4 '(10395 . 32454)) + d (md5-HH d a b c (aref in 0) 11 '(60065 . 10234)) + c (md5-HH c d a b (aref in 3) 16 '(54511 . 12421)) + b (md5-HH b c d a (aref in 6) 23 '( 1160 . 7429)) + a (md5-HH a b c d (aref in 9) 4 '(55764 . 53305)) + d (md5-HH d a b c (aref in 12) 11 '(59099 . 39397)) + c (md5-HH c d a b (aref in 15) 16 '( 8098 . 31992)) + b (md5-HH b c d a (aref in 2) 23 '(50348 . 22117)) + a (md5-II a b c d (aref in 0) 6 '(62505 . 8772)) + d (md5-II d a b c (aref in 7) 10 '(17194 . 65431)) + c (md5-II c d a b (aref in 14) 15 '(43924 . 9127)) + b (md5-II b c d a (aref in 5) 21 '(64659 . 41017)) + a (md5-II a b c d (aref in 12) 6 '(25947 . 22979)) + d (md5-II d a b c (aref in 3) 10 '(36620 . 52370)) + c (md5-II c d a b (aref in 10) 15 '(65519 . 62589)) + b (md5-II b c d a (aref in 1) 21 '(34180 . 24017)) + a (md5-II a b c d (aref in 8) 6 '(28584 . 32335)) + d (md5-II d a b c (aref in 15) 10 '(65068 . 59104)) + c (md5-II c d a b (aref in 6) 15 '(41729 . 17172)) + b (md5-II b c d a (aref in 13) 21 '(19976 . 4513)) + a (md5-II a b c d (aref in 4) 6 '(63315 . 32386)) + d (md5-II d a b c (aref in 11) 10 '(48442 . 62005)) + c (md5-II c d a b (aref in 2) 15 '(10967 . 53947)) + b (md5-II b c d a (aref in 9) 21 '(60294 . 54161))) + + (aset md5-buffer 0 (md5-add (aref md5-buffer 0) a)) + (aset md5-buffer 1 (md5-add (aref md5-buffer 1) b)) + (aset md5-buffer 2 (md5-add (aref md5-buffer 2) c)) + (aset md5-buffer 3 (md5-add (aref md5-buffer 3) d)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Here begins the merger with the XEmacs API and the md5.el from the URL +;;; package. Courtesy wmperry@spry.com +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun md5 (object &optional start end) + "Return the MD5 (a secure message digest algorithm) of an object. +OBJECT is either a string or a buffer. +Optional arguments START and END denote buffer positions for computing the +hash of a portion of OBJECT." + (let ((buffer nil)) + (unwind-protect + (save-excursion + (setq buffer (generate-new-buffer " *md5-work*")) + (set-buffer buffer) + (cond + ((bufferp object) + (insert-buffer-substring object start end)) + ((stringp object) + (insert (if (or start end) + (substring object start end) + object))) + (t nil)) + (prog1 + (if (<= (point-max) md5-maximum-internal-length) + (mapconcat + (function (lambda (node) (format "%02x" node))) + (md5-encode (buffer-string)) + "") + (call-process-region (point-min) (point-max) + (or shell-file-name "/bin/sh") + t buffer nil + "-c" md5-program) + ;; MD5 digest is 32 chars long + ;; mddriver adds a newline to make neaten output for tty + ;; viewing, make sure we leave it behind. + (buffer-substring (point-min) (+ (point-min) 32))) + (kill-buffer buffer))) + (and buffer (kill-buffer buffer) nil)))) + +(provide 'md5) + +;;; md5.el ends here ---------------------------------------------------------- diff -r ad457d5f7d04 -r 0293115a14e9 lisp/gnus/message.el --- a/lisp/gnus/message.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/gnus/message.el Mon Aug 13 08:49:20 2007 +0200 @@ -1,5 +1,5 @@ ;;; message.el --- composing mail and news messages -;; Copyright (C) 1996 Free Software Foundation, Inc. +;; Copyright (C) 1996,97 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; Keywords: mail, news @@ -36,38 +36,104 @@ (require 'nnheader) (require 'timezone) (require 'easymenu) +(require 'custom) (if (string-match "XEmacs\\|Lucid" emacs-version) (require 'mail-abbrevs) (require 'mailabbrev)) -(defvar message-directory "~/Mail/" - "*Directory from which all other mail file variables are derived.") - -(defvar message-max-buffers 10 - "*How many buffers to keep before starting to kill them off.") - -(defvar message-send-rename-function nil - "Function called to rename the buffer after sending it.") +(defgroup message '((user-mail-address custom-variable) + (user-full-name custom-variable)) + "Mail and news message composing." + :link '(custom-manual "(message)Top") + :group 'emacs) + +(put 'user-mail-address 'custom-type 'string) +(put 'user-full-name 'custom-type 'string) + +(defgroup message-various nil + "Various Message Variables" + :link '(custom-manual "(message)Various Message Variables") + :group 'message) + +(defgroup message-buffers nil + "Message Buffers" + :link '(custom-manual "(message)Message Buffers") + :group 'message) + +(defgroup message-sending nil + "Message Sending" + :link '(custom-manual "(message)Sending Variables") + :group 'message) + +(defgroup message-interface nil + "Message Interface" + :link '(custom-manual "(message)Interface") + :group 'message) + +(defgroup message-forwarding nil + "Message Forwarding" + :link '(custom-manual "(message)Forwarding") + :group 'message-interface) + +(defgroup message-insertion nil + "Message Insertion" + :link '(custom-manual "(message)Insertion") + :group 'message) + +(defgroup message-headers nil + "Message Headers" + :link '(custom-manual "(message)Message Headers") + :group 'message) + +(defgroup message-news nil + "Composing News Messages" + :group 'message) + +(defgroup message-mail nil + "Composing Mail Messages" + :group 'message) + +(defcustom message-directory "~/Mail/" + "*Directory from which all other mail file variables are derived." + :group 'message-various + :type 'directory) + +(defcustom message-max-buffers 10 + "*How many buffers to keep before starting to kill them off." + :group 'message-buffers + :type 'integer) + +(defcustom message-send-rename-function nil + "Function called to rename the buffer after sending it." + :group 'message-buffers + :type 'function) ;;;###autoload -(defvar message-fcc-handler-function 'rmail-output +(defcustom message-fcc-handler-function 'message-output "*A function called to save outgoing articles. This function will be called with the name of the file to store the -article in. The default function is `rmail-output' which saves in Unix -mailbox format.") +article in. The default function is `rmail-output' which saves in Unix +mailbox format." + :type '(radio (function-item rmail-output) + (function :tag "Other")) + :group 'message-sending) + +(defcustom message-courtesy-message + "The following message is a courtesy copy of an article\nthat has been posted to %s as well.\n\n" + "*This is inserted at the start of a mailed copy of a posted message. +If the string contains the format spec \"%s\", the Newsgroups +the article has been posted to will be inserted there. +If this variable is nil, no such courtesy message will be added." + :group 'message-sending + :type 'string) + +(defcustom message-ignored-bounced-headers "^\\(Received\\|Return-Path\\):" + "*Regexp that matches headers to be removed in resent bounced mail." + :group 'message-interface + :type 'regexp) ;;;###autoload -(defvar message-courtesy-message - "The following message is a courtesy copy of an article\nthat has been posted as well.\n\n" - "*This is inserted at the start of a mailed copy of a posted message. -If this variable is nil, no such courtesy message will be added.") - -;;;###autoload -(defvar message-ignored-bounced-headers "^\\(Received\\|Return-Path\\):" - "*Regexp that matches headers to be removed in resent bounced mail.") - -;;;###autoload -(defvar message-from-style 'default +(defcustom message-from-style 'default "*Specifies how \"From\" headers look. If `nil', they contain just the return address like: @@ -78,10 +144,15 @@ Elvis Parsley Otherwise, most addresses look like `angles', but they look like -`parens' if `angles' would need quoting and `parens' would not.") - -;;;###autoload -(defvar message-syntax-checks nil +`parens' if `angles' would need quoting and `parens' would not." + :type '(choice (const :tag "simple" nil) + (const parens) + (const angles) + (const default)) + :group 'message-headers) + +(defcustom message-syntax-checks nil + ;; Guess this one shouldn't be easy to customize... "Controls what syntax checks should not be performed on outgoing posts. To disable checking of long signatures, for instance, add `(signature . disabled)' to this list. @@ -90,231 +161,360 @@ Checks include subject-cmsg multiple-headers sendsys message-id from long-lines control-chars size new-text redirected-followup signature -approved sender empty empty-headers message-id from subject.") - -;;;###autoload -(defvar message-required-news-headers +approved sender empty empty-headers message-id from subject +shorten-followup-to existing-newsgroups." + :group 'message-news) + +(defcustom message-required-news-headers '(From Newsgroups Subject Date Message-ID (optional . Organization) Lines (optional . X-Newsreader)) - "*Headers to be generated or prompted for when posting an article. + "Headers to be generated or prompted for when posting an article. RFC977 and RFC1036 require From, Date, Newsgroups, Subject, Message-ID. Organization, Lines, In-Reply-To, Expires, and X-Newsreader are optional. If don't you want message to insert some -header, remove it from this list.") - -;;;###autoload -(defvar message-required-mail-headers +header, remove it from this list." + :group 'message-news + :group 'message-headers + :type '(repeat sexp)) + +(defcustom message-required-mail-headers '(From Subject Date (optional . In-Reply-To) Message-ID Lines (optional . X-Mailer)) - "*Headers to be generated or prompted for when mailing a message. + "Headers to be generated or prompted for when mailing a message. RFC822 required that From, Date, To, Subject and Message-ID be -included. Organization, Lines and X-Mailer are optional.") - -;;;###autoload -(defvar message-deletable-headers '(Message-ID Date) - "*Headers to be deleted if they already exist and were generated by message previously.") - -;;;###autoload -(defvar message-ignored-news-headers - "^NNTP-Posting-Host:\\|^Xref:\\|^Bcc:\\|^Gcc:\\|^Fcc:" - "*Regexp of headers to be removed unconditionally before posting.") +included. Organization, Lines and X-Mailer are optional." + :group 'message-mail + :group 'message-headers + :type '(repeat sexp)) + +(defcustom message-deletable-headers '(Message-ID Date Lines) + "Headers to be deleted if they already exist and were generated by message previously." + :group 'message-headers + :type 'sexp) + +(defcustom message-ignored-news-headers + "^NNTP-Posting-Host:\\|^Xref:\\|^Bcc:\\|^Gcc:\\|^Fcc:\\|^Resent-Fcc:" + "*Regexp of headers to be removed unconditionally before posting." + :group 'message-news + :group 'message-headers + :type 'regexp) + +(defcustom message-ignored-mail-headers "^Gcc:\\|^Fcc:\\|^Resent-Fcc:" + "*Regexp of headers to be removed unconditionally before mailing." + :group 'message-mail + :group 'message-headers + :type 'regexp) + +(defcustom message-ignored-supersedes-headers "^Path:\\|^Date\\|^NNTP-Posting-Host:\\|^Xref:\\|^Lines:\\|^Received:\\|^X-From-Line:\\|Return-Path:\\|^Supersedes:" + "*Header lines matching this regexp will be deleted before posting. +It's best to delete old Path and Date headers before posting to avoid +any confusion." + :group 'message-interface + :type 'regexp) ;;;###autoload -(defvar message-ignored-mail-headers "^Gcc:\\|^Fcc:" - "*Regexp of headers to be removed unconditionally before mailing.") - -;;;###autoload -(defvar message-ignored-supersedes-headers "^Path:\\|^Date\\|^NNTP-Posting-Host:\\|^Xref:\\|^Lines:\\|^Received:\\|^X-From-Line:\\|Return-Path:\\|^Supersedes:" - "*Header lines matching this regexp will be deleted before posting. -It's best to delete old Path and Date headers before posting to avoid -any confusion.") - -;;;###autoload -(defvar message-signature-separator "^-- *$" - "Regexp matching the signature separator.") - -;;;###autoload -(defvar message-interactive nil +(defcustom message-signature-separator "^-- *$" + "Regexp matching the signature separator." + :type 'regexp + :group 'message-various) + +(defcustom message-elide-elipsis "\n[...]\n\n" + "*The string which is inserted for elided text.") + +(defcustom message-interactive nil "Non-nil means when sending a message wait for and display errors. -nil means let mailer mail back a message to report errors.") - -;;;###autoload -(defvar message-generate-new-buffers t +nil means let mailer mail back a message to report errors." + :group 'message-sending + :group 'message-mail + :type 'boolean) + +(defcustom message-generate-new-buffers t "*Non-nil means that a new message buffer will be created whenever `mail-setup' is called. 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.") - -;;;###autoload -(defvar message-kill-buffer-on-exit nil - "*Non-nil means that the message buffer will be killed after sending a message.") +should return the new buffer name." + :group 'message-buffers + :type '(choice (const :tag "off" nil) + (const :tag "on" t) + (function fun))) + +(defcustom message-kill-buffer-on-exit nil + "*Non-nil means that the message buffer will be killed after sending a message." + :group 'message-buffers + :type 'boolean) (defvar gnus-local-organization) -(defvar message-user-organization +(defcustom message-user-organization (or (and (boundp 'gnus-local-organization) gnus-local-organization) (getenv "ORGANIZATION") t) "*String to be used as an Organization header. -If t, use `message-user-organization-file'.") +If t, use `message-user-organization-file'." + :group 'message-headers + :type '(choice string + (const :tag "consult file" t))) ;;;###autoload -(defvar message-user-organization-file "/usr/lib/news/organization" - "*Local news organization file.") - -(defvar message-autosave-directory "~/" +(defcustom message-user-organization-file "/usr/lib/news/organization" + "*Local news organization file." + :type 'file + :group 'message-headers) + +(defcustom message-autosave-directory "~/" ; (concat (file-name-as-directory message-directory) "drafts/") "*Directory where message autosaves buffers. -If nil, message won't autosave.") - -(defvar message-forward-start-separator +If nil, message won't autosave." + :group 'message-buffers + :type 'directory) + +(defcustom message-forward-start-separator "------- Start of forwarded message -------\n" - "*Delimiter inserted before forwarded messages.") - -(defvar message-forward-end-separator + "*Delimiter inserted before forwarded messages." + :group 'message-forwarding + :type 'string) + +(defcustom message-forward-end-separator "------- End of forwarded message -------\n" - "*Delimiter inserted after forwarded messages.") - -;;;###autoload -(defvar message-signature-before-forwarded-message t - "*If non-nil, put the signature before any included forwarded message.") - -;;;###autoload -(defvar message-included-forward-headers + "*Delimiter inserted after forwarded messages." + :group 'message-forwarding + :type 'string) + +(defcustom message-signature-before-forwarded-message t + "*If non-nil, put the signature before any included forwarded message." + :group 'message-forwarding + :type 'boolean) + +(defcustom message-included-forward-headers "^From:\\|^Newsgroups:\\|^Subject:\\|^Date:\\|^Followup-To:\\|^Reply-To:\\|^Organization:\\|^Summary:\\|^Keywords:\\|^To:\\|^Cc:\\|^Posted-To:\\|^Mail-Copies-To:\\|^Apparently-To:\\|^Gnus-Warning:\\|^Resent-\\|^Message-ID:\\|^References:" - "*Regexp matching headers to be included in forwarded messages.") - -;;;###autoload -(defvar message-ignored-resent-headers "^Return-receipt" - "*All headers that match this regexp will be deleted when resending a message.") - -;;;###autoload -(defvar message-ignored-cited-headers "." - "Delete these headers from the messages you yank.") + "*Regexp matching headers to be included in forwarded messages." + :group 'message-forwarding + :type 'regexp) + +(defcustom message-ignored-resent-headers "^Return-receipt" + "*All headers that match this regexp will be deleted when resending a message." + :group 'message-interface + :type 'regexp) + +(defcustom message-ignored-cited-headers "." + "*Delete these headers from the messages you yank." + :group 'message-insertion + :type 'regexp) + +(defcustom message-cancel-message "I am canceling my own article." + "Message to be inserted in the cancel message." + :group 'message-interface + :type 'string) ;; Useful to set in site-init.el ;;;###autoload -(defvar message-send-mail-function 'message-send-mail-with-sendmail +(defcustom message-send-mail-function 'message-send-mail-with-sendmail "Function to call to send the current buffer as mail. The headers should be delimited by a line whose contents match the variable `mail-header-separator'. -Legal values include `message-send-mail-with-mh' and -`message-send-mail-with-sendmail', which is the default.") - -;;;###autoload -(defvar message-send-news-function 'message-send-news +Legal values include `message-send-mail-with-sendmail' (the default), +`message-send-mail-with-mh' and `message-send-mail-with-qmail'." + :type '(radio (function-item message-send-mail-with-sendmail) + (function-item message-send-mail-with-mh) + (function-item message-send-mail-with-qmail) + (function :tag "Other")) + :group 'message-sending + :group 'message-mail) + +(defcustom message-send-news-function 'message-send-news "Function to call to send the current buffer as news. The headers should be delimited by a line whose contents match the -variable `mail-header-separator'.") - -;;;###autoload -(defvar message-reply-to-function nil +variable `mail-header-separator'." + :group 'message-sending + :group 'message-news + :type 'function) + +(defcustom message-reply-to-function nil + "Function that should return a list of headers. +This function should pick out addresses from the To, Cc, and From headers +and respond with new To and Cc headers." + :group 'message-interface + :type 'function) + +(defcustom message-wide-reply-to-function nil + "Function that should return a list of headers. +This function should pick out addresses from the To, Cc, and From headers +and respond with new To and Cc headers." + :group 'message-interface + :type 'function) + +(defcustom message-followup-to-function nil "Function that should return a list of headers. This function should pick out addresses from the To, Cc, and From headers -and respond with new To and Cc headers.") - -;;;###autoload -(defvar message-wide-reply-to-function nil - "Function that should return a list of headers. -This function should pick out addresses from the To, Cc, and From headers -and respond with new To and Cc headers.") - -;;;###autoload -(defvar message-followup-to-function nil - "Function that should return a list of headers. -This function should pick out addresses from the To, Cc, and From headers -and respond with new To and Cc headers.") - -;;;###autoload -(defvar message-use-followup-to 'ask +and respond with new To and Cc headers." + :group 'message-interface + :type 'function) + +(defcustom message-use-followup-to 'ask "*Specifies what to do with Followup-To header. -If nil, ignore the header. If it is t, use its value, but query before -using the \"poster\" value. If it is the symbol `ask', query the user -whether to ignore the \"poster\" value. If it is the symbol `use', -always use the value.") +If nil, always ignore the header. If it is t, use its value, but +query before using the \"poster\" value. If it is the symbol `ask', +always query the user whether to use the value. If it is the symbol +`use', always use the value." + :group 'message-interface + :type '(choice (const :tag "ignore" nil) + (const use) + (const ask))) + +;; stuff relating to broken sendmail in MMDF +(defcustom message-sendmail-f-is-evil nil + "*Non-nil means that \"-f username\" should not be added to the sendmail +command line, because it is even more evil than leaving it out." + :group 'message-sending + :type 'boolean) + +;; qmail-related stuff +(defcustom message-qmail-inject-program "/var/qmail/bin/qmail-inject" + "Location of the qmail-inject program." + :group 'message-sending + :type 'file) + +(defcustom message-qmail-inject-args nil + "Arguments passed to qmail-inject programs. +This should be a list of strings, one string for each argument. + +For e.g., if you wish to set the envelope sender address so that bounces +go to the right place or to deal with listserv's usage of that address, you +might set this variable to '(\"-f\" \"you@some.where\")." + :group 'message-sending + :type '(repeat string)) (defvar gnus-post-method) (defvar gnus-select-method) -;;;###autoload -(defvar message-post-method +(defcustom message-post-method (cond ((and (boundp 'gnus-post-method) gnus-post-method) gnus-post-method) ((boundp 'gnus-select-method) gnus-select-method) (t '(nnspool ""))) - "Method used to post news.") - -;;;###autoload -(defvar message-generate-headers-first nil - "*If non-nil, generate all possible headers before composing.") - -(defvar message-setup-hook nil + "Method used to post news." + :group 'message-news + :group 'mesage-sending + ;; This should be the `gnus-select-method' widget, but that might + ;; create a dependence to `gnus.el'. + :type 'sexp) + +(defcustom message-generate-headers-first nil + "*If non-nil, generate all possible headers before composing." + :group 'message-headers + :type 'boolean) + +(defcustom message-setup-hook nil "Normal hook, run each time a new outgoing message is initialized. -The function `message-setup' runs this hook.") - -(defvar message-signature-setup-hook nil +The function `message-setup' runs this hook." + :group 'message-various + :type 'hook) + +(defcustom message-signature-setup-hook nil "Normal hook, run each time a new outgoing message is initialized. It is run after the headers have been inserted and before -the signature is inserted.") - -(defvar message-mode-hook nil - "Hook run in message mode buffers.") - -(defvar message-header-hook nil - "Hook run in a message mode buffer narrowed to the headers.") - -(defvar message-header-setup-hook nil - "Hook called narrowed to the headers when setting up a message buffer.") +the signature is inserted." + :group 'message-various + :type 'hook) + +(defcustom message-mode-hook nil + "Hook run in message mode buffers." + :group 'message-various + :type 'hook) + +(defcustom message-header-hook nil + "Hook run in a message mode buffer narrowed to the headers." + :group 'message-various + :type 'hook) + +(defcustom message-header-setup-hook nil + "Hook called narrowed to the headers when setting up a message +buffer." + :group 'message-various + :type 'hook) + +;;;###autoload +(defcustom message-citation-line-function 'message-insert-citation-line + "*Function called to insert the \"Whomever writes:\" line." + :type 'function + :group 'message-insertion) ;;;###autoload -(defvar message-citation-line-function 'message-insert-citation-line - "*Function called to insert the \"Whomever writes:\" line.") +(defcustom message-yank-prefix "> " + "*Prefix inserted on the lines of yanked messages. +nil means use indentation." + :type 'string + :group 'message-insertion) + +(defcustom message-indentation-spaces 3 + "*Number of spaces to insert at the beginning of each cited line. +Used by `message-yank-original' via `message-yank-cite'." + :group 'message-insertion + :type 'integer) ;;;###autoload -(defvar message-yank-prefix "> " - "*Prefix inserted on the lines of yanked messages. -nil means use indentation.") - -(defvar message-indentation-spaces 3 - "*Number of spaces to insert at the beginning of each cited line. -Used by `message-yank-original' via `message-yank-cite'.") +(defcustom message-cite-function + (if (and (boundp 'mail-citation-hook) + mail-citation-hook) + mail-citation-hook + 'message-cite-original) + "*Function for citing an original message." + :type '(radio (function-item message-cite-original) + (function-item sc-cite-original) + (function :tag "Other")) + :group 'message-insertion) ;;;###autoload -(defvar message-cite-function 'message-cite-original - "*Function for citing an original message.") - -;;;###autoload -(defvar message-indent-citation-function 'message-indent-citation +(defcustom message-indent-citation-function 'message-indent-citation "*Function for modifying a citation just inserted in the mail buffer. This can also be a list of functions. Each function can find the citation between (point) and (mark t). And each function should leave -point and mark around the citation text as modified.") +point and mark around the citation text as modified." + :type 'function + :group 'message-insertion) (defvar message-abbrevs-loaded nil) ;;;###autoload -(defvar message-signature t +(defcustom message-signature t "*String to be inserted at the end of the message buffer. If t, the `message-signature-file' file will be inserted instead. If a function, the result from the function will be used instead. -If a form, the result from the form will be used instead.") +If a form, the result from the form will be used instead." + :type 'sexp + :group 'message-insertion) ;;;###autoload -(defvar message-signature-file "~/.signature" - "*File containing the text inserted at end of message. buffer.") - -(defvar message-distribution-function nil - "*Function called to return a Distribution header.") - -(defvar message-expires 14 - "*Number of days before your article expires.") - -(defvar message-user-path nil +(defcustom message-signature-file "~/.signature" + "*File containing the text inserted at end of message buffer." + :type 'file + :group 'message-insertion) + +(defcustom message-distribution-function nil + "*Function called to return a Distribution header." + :group 'message-news + :group 'message-headers + :type 'function) + +(defcustom message-expires 14 + "Number of days before your article expires." + :group 'message-news + :group 'message-headers + :link '(custom-manual "(message)News Headers") + :type 'integer) + +(defcustom message-user-path nil "If nil, use the NNTP server name in the Path header. -If stringp, use this; if non-nil, use no host name (user name only).") +If stringp, use this; if non-nil, use no host name (user name only)." + :group 'message-news + :group 'message-headers + :link '(custom-manual "(message)News Headers") + :type '(choice (const :tag "nntp" nil) + (string :tag "name") + (sexp :tag "none" :format "%t" t))) (defvar message-reply-buffer nil) (defvar message-reply-headers nil) @@ -331,23 +531,29 @@ (defvar message-postpone-actions nil "A list of actions to be performed after postponing a message.") -;;;###autoload -(defvar message-default-headers nil +(defcustom message-default-headers "" "*A string containing header lines to be inserted in outgoing messages. It is inserted before you edit the message, so you can edit or delete -these lines.") - -;;;###autoload -(defvar message-default-mail-headers nil - "*A string of header lines to be inserted in outgoing mails.") - -;;;###autoload -(defvar message-default-news-headers nil - "*A string of header lines to be inserted in outgoing news articles.") +these lines." + :group 'message-headers + :type 'string) + +(defcustom message-default-mail-headers "" + "*A string of header lines to be inserted in outgoing mails." + :group 'message-headers + :group 'message-mail + :type 'string) + +(defcustom message-default-news-headers "" + "*A string of header lines to be inserted in outgoing news +articles." + :group 'message-headers + :group 'message-news + :type 'string) ;; Note: could use /usr/ucb/mail instead of sendmail; ;; options -t, and -v if not interactive. -(defvar message-mailer-swallows-blank-line +(defcustom message-mailer-swallows-blank-line (if (and (string-match "sparc-sun-sunos\\(\\'\\|[^5]\\)" system-configuration) (file-readable-p "/etc/sendmail.cf") @@ -361,14 +567,27 @@ (re-search-forward "^OR\\>" nil t))) (kill-buffer buffer)))) ;; According to RFC822, "The field-name must be composed of printable - ;; ASCII characters (i.e. characters that have decimal values between - ;; 33 and 126, except colon)", i.e. any chars except ctl chars, + ;; ASCII characters (i. e., characters that have decimal values between + ;; 33 and 126, except colon)", i. e., any chars except ctl chars, ;; space, or colon. '(looking-at "[ \t]\\|[][!\"#$%&'()*+,-./0-9;<=>?@A-Z\\\\^_`a-z{|}~]+:")) "Set this non-nil if the system's mailer runs the header and body together. \(This problem exists on Sunos 4 when sendmail is run in remote mode.) The value should be an expression to test whether the problem will -actually occur.") +actually occur." + :group 'message-sending + :type 'sexp) + +(ignore-errors + (define-mail-user-agent 'message-user-agent + 'message-mail 'message-send-and-exit + 'message-kill-buffer 'message-send-hook)) + +(defvar message-delete-mh-headers t + "If non-nil, delete the deletable headers before feeding to mh.") + +;;; Internal variables. +;;; Well, not really internal. (defvar message-mode-syntax-table (let ((table (copy-syntax-table text-mode-syntax-table))) @@ -392,7 +611,7 @@ "\\([" cite-prefix "]+[" cite-suffix "]*\\)?" "[>|}].*") 'font-lock-reference-face) - '("^\\(X-[A-Za-z0-9-]+\\|In-reply-to\\):.*" + '("^\\(X-[A-Za-z0-9-]+\\|In-Reply-To\\):.*" . font-lock-string-face))) "Additional expressions to highlight in Message mode.") @@ -405,15 +624,36 @@ "Alist of mail and news faces for facemenu. The cdr of ech entry is a function for applying the face to a region.") -(defvar message-send-hook nil - "Hook run before sending messages.") - -(defvar message-sent-hook nil - "Hook run after sending messages.") +(defcustom message-send-hook nil + "Hook run before sending messages." + :group 'message-various + :options '(ispell-message) + :type 'hook) + +(defcustom message-send-mail-hook nil + "Hook run before sending mail messages." + :group 'message-various + :type 'hook) + +(defcustom message-send-news-hook nil + "Hook run before sending news messages." + :group 'message-various + :type 'hook) + +(defcustom message-sent-hook nil + "Hook run after sending messages." + :group 'message-various + :type 'hook) ;;; Internal variables. (defvar message-buffer-list nil) +(defvar message-this-is-news nil) +(defvar message-this-is-mail nil) + +;; Byte-compiler warning +(defvar gnus-active-hashtb) +(defvar gnus-read-active-file) ;;; Regexp matching the delimiter of messages in UNIX mail format ;;; (UNIX From lines), minus the initial ^. @@ -478,14 +718,16 @@ (Lines) (Expires) (Message-ID) - (References . message-fill-header) + (References) (X-Mailer) (X-Newsreader)) "Alist used for formatting headers.") (eval-and-compile (autoload 'message-setup-toolbar "messagexmas") - (autoload 'mh-send-letter "mh-comp")) + (autoload 'mh-send-letter "mh-comp") + (autoload 'gnus-output-to-mail "gnus-util") + (autoload 'gnus-output-to-rmail "gnus-util")) @@ -509,6 +751,10 @@ (point) (goto-char p)))) +(defmacro message-y-or-n-p (question show &rest text) + "Ask QUESTION, displaying the rest of the arguments in a temp. buffer if SHOW" + `(message-talkative-question 'y-or-n-p ,question ,show ,@text)) + ;; Delete the current line (and the next N lines.); (defmacro message-delete-line (&optional n) `(delete-region (progn (beginning-of-line) (point)) @@ -517,31 +763,40 @@ (defun message-tokenize-header (header &optional separator) "Split HEADER into a list of header elements. \",\" is used as the separator." - (let ((regexp (format "[%s]+" (or separator ","))) - (beg 1) - (first t) - quoted elems) - (save-excursion - (message-set-work-buffer) - (insert header) - (goto-char (point-min)) - (while (not (eobp)) - (if first - (setq first nil) - (forward-char 1)) - (cond ((and (> (point) beg) - (or (eobp) - (and (looking-at regexp) - (not quoted)))) - (push (buffer-substring beg (point)) elems) - (setq beg (match-end 0))) - ((= (following-char) ?\") - (setq quoted (not quoted))))) - (nreverse elems)))) + (if (not header) + nil + (let ((regexp (format "[%s]+" (or separator ","))) + (beg 1) + (first t) + quoted elems paren) + (save-excursion + (message-set-work-buffer) + (insert header) + (goto-char (point-min)) + (while (not (eobp)) + (if first + (setq first nil) + (forward-char 1)) + (cond ((and (> (point) beg) + (or (eobp) + (and (looking-at regexp) + (not quoted) + (not paren)))) + (push (buffer-substring beg (point)) elems) + (setq beg (match-end 0))) + ((= (following-char) ?\") + (setq quoted (not quoted))) + ((and (= (following-char) ?\() + (not quoted)) + (setq paren t)) + ((and (= (following-char) ?\)) + (not quoted)) + (setq paren nil)))) + (nreverse elems))))) (defun message-fetch-field (header) "The same as `mail-fetch-field', only remove all newlines." - (let ((value (mail-fetch-field header))) + (let ((value (mail-fetch-field header nil t))) (when value (nnheader-replace-chars-in-string value ?\n ? )))) @@ -630,19 +885,21 @@ (defun message-news-p () "Say whether the current buffer contains a news message." - (save-excursion - (save-restriction - (message-narrow-to-headers) - (message-fetch-field "newsgroups")))) + (or message-this-is-news + (save-excursion + (save-restriction + (message-narrow-to-headers) + (message-fetch-field "newsgroups"))))) (defun message-mail-p () "Say whether the current buffer contains a mail message." - (save-excursion - (save-restriction - (message-narrow-to-headers) - (or (message-fetch-field "to") - (message-fetch-field "cc") - (message-fetch-field "bcc"))))) + (or message-this-is-mail + (save-excursion + (save-restriction + (message-narrow-to-headers) + (or (message-fetch-field "to") + (message-fetch-field "cc") + (message-fetch-field "bcc")))))) (defun message-next-header () "Go to the beginning of the next header." @@ -663,7 +920,7 @@ (forward-char -1))) (lambda () (or (get-text-property (point) 'message-rank) - 0)))) + 10000)))) (defun message-sort-headers () "Sort the headers of the current message according to `message-header-format-alist'." @@ -729,37 +986,43 @@ (define-key message-mode-map "\C-c\C-k" 'message-kill-buffer) (define-key message-mode-map "\C-c\C-d" 'message-dont-send) + (define-key message-mode-map "\C-c\C-e" 'message-elide-region) + (define-key message-mode-map "\t" 'message-tab)) -(easy-menu-define message-mode-menu message-mode-map - "Message Menu." - '("Message" - "Go to Field:" - "----" - ["To" message-goto-to t] - ["Subject" message-goto-subject t] - ["Cc" message-goto-cc t] - ["Reply-to" message-goto-reply-to t] - ["Summary" message-goto-summary t] - ["Keywords" message-goto-keywords t] - ["Newsgroups" message-goto-newsgroups t] - ["Followup-To" message-goto-followup-to t] - ["Distribution" message-goto-distribution t] - ["Body" message-goto-body t] - ["Signature" message-goto-signature t] - "----" - "Miscellaneous Commands:" - "----" - ["Sort Headers" message-sort-headers t] - ["Yank Original" message-yank-original t] - ["Fill Yanked Message" message-fill-yanked-message t] - ["Insert Signature" message-insert-signature t] - ["Caesar (rot13) Message" message-caesar-buffer-body t] - ["Rename buffer" message-rename-buffer t] - ["Spellcheck" ispell-message t] - "----" - ["Send Message" message-send-and-exit t] - ["Abort Message" message-dont-send t])) +(easy-menu-define + message-mode-menu message-mode-map "Message Menu." + '("Message" + ["Sort Headers" message-sort-headers t] + ["Yank Original" message-yank-original t] + ["Fill Yanked Message" message-fill-yanked-message t] + ["Insert Signature" message-insert-signature t] + ["Caesar (rot13) Message" message-caesar-buffer-body t] + ["Caesar (rot13) Region" message-caesar-region (mark t)] + ["Elide Region" message-elide-region (mark t)] + ["Rename buffer" message-rename-buffer t] + ["Spellcheck" ispell-message t] + "----" + ["Send Message" message-send-and-exit t] + ["Abort Message" message-dont-send t])) + +(easy-menu-define + message-mode-field-menu message-mode-map "" + '("Field" + ["Fetch To" message-insert-to t] + ["Fetch Newsgroups" message-insert-newsgroups t] + "----" + ["To" message-goto-to t] + ["Subject" message-goto-subject t] + ["Cc" message-goto-cc t] + ["Reply-To" message-goto-reply-to t] + ["Summary" message-goto-summary t] + ["Keywords" message-goto-keywords t] + ["Newsgroups" message-goto-newsgroups t] + ["Followup-To" message-goto-followup-to t] + ["Distribution" message-goto-distribution t] + ["Body" message-goto-body t] + ["Signature" message-goto-signature t])) (defvar facemenu-add-face-function) (defvar facemenu-remove-face-function) @@ -772,10 +1035,10 @@ C-c C-f move to a header field (and create it if there isn't): C-c C-f C-t move to To C-c C-f C-s move to Subject C-c C-f C-c move to Cc C-c C-f C-b move to Bcc - C-c C-f C-f move to Fcc C-c C-f C-r move to Reply-To + C-c C-f C-w move to Fcc C-c C-f C-r move to Reply-To C-c C-f C-u move to Summary C-c C-f C-n move to Newsgroups C-c C-f C-k move to Keywords C-c C-f C-d move to Distribution - C-c C-f C-o move to Followup-To + C-c C-f C-f move to Followup-To C-c C-t message-insert-to (add a To header to a news followup) C-c C-n message-insert-newsgroups (add a Newsgroup header to a news reply) C-c C-b message-goto-body (move to beginning of message text). @@ -783,7 +1046,8 @@ C-c C-w message-insert-signature (insert `message-signature-file' file). C-c C-y message-yank-original (insert current message, if any). C-c C-q message-fill-yanked-message (fill what was yanked). -C-c C-r message-ceasar-buffer-body (rot13 the message body)." +C-c C-e message-elide-region (elide the text between point and mark). +C-c C-r message-caesar-buffer-body (rot13 the message body)." (interactive) (kill-all-local-variables) (make-local-variable 'message-reply-buffer) @@ -914,14 +1178,19 @@ "Move point to the beginning of the message signature." (interactive) (goto-char (point-min)) - (or (re-search-forward message-signature-separator nil t) - (goto-char (point-max)))) + (if (re-search-forward message-signature-separator nil t) + (forward-line 1) + (goto-char (point-max)))) (defun message-insert-to () "Insert a To header that points to the author of the article being replied to." (interactive) + (let ((co (message-fetch-field "courtesy-copies-to"))) + (when (and co + (equal (downcase co) "never")) + (error "The user has requested not to have copies sent via mail"))) (when (and (message-position-on-field "To") (mail-fetch-field "to") (not (string-match "\\` *\\'" (mail-fetch-field "to")))) @@ -946,20 +1215,21 @@ "Insert a signature. See documentation for the `message-signature' variable." (interactive (list 0)) (let* ((signature - (cond ((and (null message-signature) - (eq force 0)) - (save-excursion - (goto-char (point-max)) - (not (re-search-backward - message-signature-separator nil t)))) - ((and (null message-signature) - force) - t) - ((message-functionp message-signature) - (funcall message-signature)) - ((listp message-signature) - (eval message-signature)) - (t message-signature))) + (cond + ((and (null message-signature) + (eq force 0)) + (save-excursion + (goto-char (point-max)) + (not (re-search-backward + message-signature-separator nil t)))) + ((and (null message-signature) + force) + t) + ((message-functionp message-signature) + (funcall message-signature)) + ((listp message-signature) + (eval message-signature)) + (t message-signature))) (signature (cond ((stringp signature) signature) @@ -968,8 +1238,8 @@ (file-exists-p message-signature-file)) signature)))) (when signature + (goto-char (point-max)) ;; Insert the signature. - (goto-char (point-max)) (unless (bolp) (insert "\n")) (insert "\n-- \n") @@ -979,6 +1249,15 @@ (goto-char (point-max)) (or (bolp) (insert "\n"))))) +(defun message-elide-region (b e) + "Elide the text between point and mark. An ellipsis (from +message-elide-elipsis) will be inserted where the text was killed." + (interactive "r") + (kill-region b e) + (unless (bolp) + (insert "\n")) + (insert message-elide-elipsis)) + (defvar message-caesar-translation-table nil) (defun message-caesar-region (b e &optional n) @@ -1032,6 +1311,18 @@ (narrow-to-region (point) (point-max))) (message-caesar-region (point-min) (point-max) rotnum)))) +(defun message-pipe-buffer-body (program) + "Pipe the message body in the current buffer through PROGRAM." + (save-excursion + (save-restriction + (when (message-goto-body) + (narrow-to-region (point) (point-max))) + (let ((body (buffer-substring (point-min) (point-max)))) + (unless (equal 0 (call-process-region + (point-min) (point-max) program t t)) + (insert body) + (gnus-message 1 "%s failed." program)))))) + (defun message-rename-buffer (&optional enter-string) "Rename the *message* buffer to \"*message* RECIPIENT\". If the function is run with a prefix, it will ask for a new buffer @@ -1042,8 +1333,10 @@ (goto-char (point-min)) (narrow-to-region (point) (search-forward mail-header-separator nil 'end)) - (let* ((mail-to (if (message-news-p) (message-fetch-field "Newsgroups") - (message-fetch-field "To"))) + (let* ((mail-to (or + (if (message-news-p) (message-fetch-field "Newsgroups") + (message-fetch-field "To")) + "")) (mail-trimmed-to (if (string-match "," mail-to) (concat (substring mail-to 0 (match-beginning 0)) ", ...") @@ -1051,12 +1344,10 @@ (name-default (concat "*message* " mail-trimmed-to)) (name (if enter-string (read-string "New buffer name: " name-default) - name-default))) - (rename-buffer name t) - (setq buffer-auto-save-file-name - (format "%s%s" - (file-name-as-directory message-autosave-directory) - (file-name-nondirectory buffer-auto-save-file-name))))))) + name-default)) + (default-directory + (file-name-as-directory message-autosave-directory))) + (rename-buffer name t))))) (defun message-fill-yanked-message (&optional justifyp) "Fill the paragraphs of a message yanked into this one. @@ -1084,7 +1375,20 @@ (if (search-forward "\n\n" nil t) (1- (point)) (point))) - (message-remove-header message-ignored-cited-headers t))) + (message-remove-header message-ignored-cited-headers t) + (goto-char (point-max)))) + ;; Delete blank lines at the start of the buffer. + (while (and (point-min) + (eolp) + (not (eobp))) + (message-delete-line)) + ;; Delete blank lines at the end of the buffer. + (goto-char (point-max)) + (unless (eolp) + (insert "\n")) + (while (and (zerop (forward-line -1)) + (looking-at "$")) + (message-delete-line)) ;; Do the indentation. (if (null message-yank-prefix) (indent-rigidly start (mark t) message-indentation-spaces) @@ -1092,8 +1396,8 @@ (goto-char start) (while (< (point) (mark t)) (insert message-yank-prefix) - (forward-line 1))) - (goto-char start)))) + (forward-line 1)))) + (goto-char start))) (defun message-yank-original (&optional arg) "Insert the message being replied to, if any. @@ -1118,7 +1422,8 @@ (unless modified (setq message-checksum (cons (message-checksum) (buffer-size))))))) -(defun message-cite-original () +(defun message-cite-original () + "Cite function in the standard Message manner." (let ((start (point)) (functions (when message-indent-citation-function @@ -1172,21 +1477,21 @@ (save-excursion (let ((start (point)) mark) - (if (not (re-search-forward message-signature-separator (mark t) t)) - ;; No signature here, so we just indent the cited text. + (if (not (re-search-forward message-signature-separator (mark t) t)) + ;; No signature here, so we just indent the cited text. + (message-indent-citation) + ;; Find the last non-empty line. + (forward-line -1) + (while (looking-at "[ \t]*$") + (forward-line -1)) + (forward-line 1) + (setq mark (set-marker (make-marker) (point))) + (goto-char start) (message-indent-citation) - ;; Find the last non-empty line. - (forward-line -1) - (while (looking-at "[ \t]*$") - (forward-line -1)) - (forward-line 1) - (setq mark (set-marker (make-marker) (point))) - (goto-char start) - (message-indent-citation) - ;; Enable undoing the deletion. - (undo-boundary) - (delete-region mark (mark t)) - (set-marker mark nil))))) + ;; Enable undoing the deletion. + (undo-boundary) + (delete-region mark (mark t)) + (set-marker mark nil))))) @@ -1211,8 +1516,9 @@ (defun message-dont-send () "Don't send the message you have been editing." (interactive) - (message-bury (current-buffer)) - (message-do-actions message-postpone-actions)) + (let ((actions message-postpone-actions)) + (message-bury (current-buffer)) + (message-do-actions actions))) (defun message-kill-buffer () "Kill the current buffer." @@ -1295,20 +1601,19 @@ "Perform all actions in ACTIONS." ;; Now perform actions on successful sending. (while actions - (condition-case nil - (cond - ;; A simple function. - ((message-functionp (car actions)) - (funcall (car actions))) - ;; Something to be evaled. - (t - (eval (car actions)))) - (error)) + (ignore-errors + (cond + ;; A simple function. + ((message-functionp (car actions)) + (funcall (car actions))) + ;; Something to be evaled. + (t + (eval (car actions))))) (pop actions))) (defun message-send-mail (&optional arg) (require 'mail-utils) - (let ((tembuf (generate-new-buffer " message temp")) + (let ((tembuf (message-generate-new-buffer-clone-locals " message temp")) (case-fold-search nil) (news (message-news-p)) (mailbuf (current-buffer))) @@ -1364,6 +1669,7 @@ (replace-match "\n") (backward-char 1) (setq delimline (point-marker)) + (run-hooks 'message-send-mail-hook) ;; Insert an extra newline if we need it to work around ;; Sun's bug that swallows newlines. (goto-char (1+ delimline)) @@ -1382,7 +1688,10 @@ nil errbuf nil "-oi") ;; Always specify who from, ;; since some systems have broken sendmails. - (list "-f" (user-login-name)) + ;; But some systems are more broken with -f, so + ;; we'll let users override this. + (if (null message-sendmail-f-is-evil) + (list "-f" (user-login-name))) ;; These mean "report errors by mail" ;; and "deliver in background". (if (null message-interactive) '("-oem" "-odb")) @@ -1406,20 +1715,70 @@ (when (bufferp errbuf) (kill-buffer errbuf))))) +(defun message-send-mail-with-qmail () + "Pass the prepared message buffer to qmail-inject. +Refer to the documentation for the variable `message-send-mail-function' +to find out how to use this." + ;; replace the header delimiter with a blank line + (goto-char (point-min)) + (re-search-forward + (concat "^" (regexp-quote mail-header-separator) "\n")) + (replace-match "\n") + (run-hooks 'message-send-mail-hook) + ;; send the message + (case + (apply + 'call-process-region 1 (point-max) message-qmail-inject-program + nil nil nil + ;; qmail-inject's default behaviour is to look for addresses on the + ;; command line; if there're none, it scans the headers. + ;; yes, it does The Right Thing w.r.t. Resent-To and it's kin. + ;; + ;; in general, ALL of qmail-inject's defaults are perfect for simply + ;; reading a formatted (i. e., at least a To: or Resent-To header) + ;; message from stdin. + ;; + ;; qmail also has the advantage of not having been raped by + ;; various vendors, so we don't have to allow for that, either -- + ;; compare this with message-send-mail-with-sendmail and weep + ;; for sendmail's lost innocence. + ;; + ;; all this is way cool coz it lets us keep the arguments entirely + ;; free for -inject-arguments -- a big win for the user and for us + ;; since we don't have to play that double-guessing game and the user + ;; gets full control (no gestapo'ish -f's, for instance). --sj + message-qmail-inject-args) + ;; qmail-inject doesn't say anything on it's stdout/stderr, + ;; we have to look at the retval instead + (0 nil) + (1 (error "qmail-inject reported permanent failure.")) + (111 (error "qmail-inject reported transient failure.")) + ;; should never happen + (t (error "qmail-inject reported unknown failure.")))) + (defun message-send-mail-with-mh () "Send the prepared message buffer with mh." (let ((mh-previous-window-config nil) (name (make-temp-name - (concat (file-name-as-directory message-autosave-directory) + (concat (file-name-as-directory + (expand-file-name message-autosave-directory)) "msg.")))) (setq buffer-file-name name) - (mh-send-letter) - (condition-case () - (delete-file name) - (error nil)))) + ;; MH wants to generate these headers itself. + (when message-delete-mh-headers + (let ((headers message-deletable-headers)) + (while headers + (goto-char (point-min)) + (and (re-search-forward + (concat "^" (symbol-name (car headers)) ": *") nil t) + (message-delete-line)) + (pop headers)))) + (run-hooks 'message-send-mail-hook) + ;; Pass it on to mh. + (mh-send-letter))) (defun message-send-news (&optional arg) - (let ((tembuf (generate-new-buffer " *message temp*")) + (let ((tembuf (message-generate-new-buffer-clone-locals " *message temp*")) (case-fold-search nil) (method (if (message-functionp message-post-method) (funcall message-post-method arg) @@ -1438,17 +1797,20 @@ ;; Let the user do all of the above. (run-hooks 'message-header-hook)) (message-cleanup-headers) - (when (message-check-news-syntax) + (if (not (message-check-news-syntax)) + (progn + ;;(message "Posting not performed") + nil) (unwind-protect (save-excursion (set-buffer tembuf) (buffer-disable-undo (current-buffer)) (erase-buffer) ;; Avoid copying text props. - (insert (format - "%s" (save-excursion - (set-buffer messbuf) - (buffer-string)))) + (insert (format + "%s" (save-excursion + (set-buffer messbuf) + (buffer-string)))) ;; Remove some headers. (save-restriction (message-narrow-to-headers) @@ -1459,12 +1821,13 @@ (or (= (preceding-char) ?\n) (insert ?\n)) (let ((case-fold-search t)) - ;; Remove the delimeter. + ;; Remove the delimiter. (goto-char (point-min)) (re-search-forward (concat "^" (regexp-quote mail-header-separator) "\n")) (replace-match "\n") (backward-char 1)) + (run-hooks 'message-send-news-hook) (require (car method)) (funcall (intern (format "%s-open-server" (car method))) (cadr method) (cddr method)) @@ -1482,249 +1845,14 @@ ;;; Header generation & syntax checking. ;;; -(defun message-check-news-syntax () - "Check the syntax of the message." - (and - ;; We narrow to the headers and check them first. - (save-excursion - (save-restriction - (message-narrow-to-headers) - (and - ;; Check for commands in Subject. - (or - (message-check-element 'subject-cmsg) - (save-excursion - (if (string-match "^cmsg " (message-fetch-field "subject")) - (y-or-n-p - "The control code \"cmsg \" is in the subject. Really post? ") - t))) - ;; Check for multiple identical headers. - (or (message-check-element 'multiple-headers) - (save-excursion - (let (found) - (while (and (not found) - (re-search-forward "^[^ \t:]+: " nil t)) - (save-excursion - (or (re-search-forward - (concat "^" (setq found - (buffer-substring - (match-beginning 0) - (- (match-end 0) 2)))) - nil t) - (setq found nil)))) - (if found - (y-or-n-p - (format "Multiple %s headers. Really post? " found)) - t)))) - ;; Check for Version and Sendsys. - (or (message-check-element 'sendsys) - (save-excursion - (if (re-search-forward "^Sendsys:\\|^Version:" nil t) - (y-or-n-p - (format "The article contains a %s command. Really post? " - (buffer-substring (match-beginning 0) - (1- (match-end 0))))) - t))) - ;; See whether we can shorten Followup-To. - (or (message-check-element 'shorten-followup-to) - (let ((newsgroups (message-fetch-field "newsgroups")) - (followup-to (message-fetch-field "followup-to")) - to) - (when (and newsgroups (string-match "," newsgroups) - (not followup-to) - (not - (zerop - (length - (setq to (completing-read - "Followups to: (default all groups) " - (mapcar (lambda (g) (list g)) - (cons "poster" - (message-tokenize-header - newsgroups))))))))) - (goto-char (point-min)) - (insert "Followup-To: " to "\n")) - t)) - ;; Check "Shoot me". - (or (message-check-element 'shoot) - (save-excursion - (if (re-search-forward - "Message-ID.*.i-have-a-misconfigured-system-so-shoot-me" - nil t) - (y-or-n-p - "You appear to have a misconfigured system. Really post? ") - t))) - ;; Check for Approved. - (or (message-check-element 'approved) - (save-excursion - (if (re-search-forward "^Approved:" nil t) - (y-or-n-p - "The article contains an Approved header. Really post? ") - t))) - ;; Check the Message-Id header. - (or (message-check-element 'message-id) - (save-excursion - (let* ((case-fold-search t) - (message-id (message-fetch-field "message-id"))) - (or (not message-id) - (and (string-match "@" message-id) - (string-match "@[^\\.]*\\." message-id)) - (y-or-n-p - (format - "The Message-ID looks strange: \"%s\". Really post? " - message-id)))))) - ;; Check the Subject header. - (or - (message-check-element 'subject) - (save-excursion - (let* ((case-fold-search t) - (subject (message-fetch-field "subject"))) - (or - (and subject - (not (string-match "\\`[ \t]*\\'" subject))) - (progn - (message - "The subject field is empty or missing. Posting is denied.") - nil))))) - ;; Check the Newsgroups & Followup-To headers. - (or - (message-check-element 'existing-newsgroups) - (let* ((case-fold-search t) - (newsgroups (message-fetch-field "newsgroups")) - (followup-to (message-fetch-field "followup-to")) - (groups (message-tokenize-header - (if followup-to - (concat newsgroups "," followup-to) - newsgroups))) - (hashtb (and (boundp 'gnus-active-hashtb) - gnus-active-hashtb)) - errors) - (if (not hashtb) - t - (while groups - (when (and (not (boundp (intern (car groups) hashtb))) - (not (equal (car groups) "poster"))) - (push (car groups) errors)) - (pop groups)) - (if (not errors) - t - (y-or-n-p - (format - "Really post to %s unknown group%s: %s " - (if (= (length errors) 1) "this" "these") - (if (= (length errors) 1) "" "s") - (mapconcat 'identity errors ", "))))))) - ;; Check the Newsgroups & Followup-To headers for syntax errors. - (or - (message-check-element 'valid-newsgroups) - (let ((case-fold-search t) - (headers '("Newsgroups" "Followup-To")) - header error) - (while (and headers (not error)) - (when (setq header (mail-fetch-field (car headers))) - (if (or - (not - (string-match - "\\`\\([-+_&.a-zA-Z0-9]+\\)?\\(,[-.a-zA-Z0-9]+\\)*\\'" - header)) - (memq - nil (mapcar - (lambda (g) - (not (string-match "\\.\\'\\|\\.\\." g))) - (message-tokenize-header header ",")))) - (setq error t))) - (unless error - (pop headers))) - (if (not error) - t - (y-or-n-p - (format "The %s header looks odd: \"%s\". Really post? " - (car headers) header))))) - ;; Check the From header. - (or - (save-excursion - (let* ((case-fold-search t) - (from (message-fetch-field "from"))) - (cond - ((not from) - (message "There is no From line. Posting is denied.") - nil) - ((not (string-match "@[^\\.]*\\." from)) - (message - "Denied posting -- the From looks strange: \"%s\"." from) - nil) - ((string-match "@[^@]*@" from) - (message - "Denied posting -- two \"@\"'s in the From header: %s." from) - nil) - ((string-match "(.*).*(.*)" from) - (message - "Denied posting -- the From header looks strange: \"%s\"." - from) - nil) - (t t)))))))) - ;; Check for long lines. - (or (message-check-element 'long-lines) +(defmacro message-check (type &rest forms) + "Eval FORMS if TYPE is to be checked." + `(or (message-check-element ,type) (save-excursion - (goto-char (point-min)) - (re-search-forward - (concat "^" (regexp-quote mail-header-separator) "$")) - (while (and - (progn - (end-of-line) - (< (current-column) 80)) - (zerop (forward-line 1)))) - (or (bolp) - (eobp) - (y-or-n-p - "You have lines longer than 79 characters. Really post? ")))) - ;; Check whether the article is empty. - (or (message-check-element 'empty) - (save-excursion - (goto-char (point-min)) - (re-search-forward - (concat "^" (regexp-quote mail-header-separator) "$")) - (forward-line 1) - (let ((b (point))) - (goto-char (point-max)) - (re-search-backward message-signature-separator nil t) - (beginning-of-line) - (or (re-search-backward "[^ \n\t]" b t) - (y-or-n-p "Empty article. Really post? "))))) - ;; Check for control characters. - (or (message-check-element 'control-chars) - (save-excursion - (if (re-search-forward "[\000-\007\013\015-\037\200-\237]" nil t) - (y-or-n-p - "The article contains control characters. Really post? ") - t))) - ;; Check excessive size. - (or (message-check-element 'size) - (if (> (buffer-size) 60000) - (y-or-n-p - (format "The article is %d octets long. Really post? " - (buffer-size))) - t)) - ;; Check whether any new text has been added. - (or (message-check-element 'new-text) - (not message-checksum) - (not (and (eq (message-checksum) (car message-checksum)) - (eq (buffer-size) (cdr message-checksum)))) - (y-or-n-p - "It looks like no new text has been added. Really post? ")) - ;; Check the length of the signature. - (or - (message-check-element 'signature) - (progn - (goto-char (point-max)) - (if (or (not (re-search-backward message-signature-separator nil t)) - (search-forward message-forward-end-separator nil t)) - t - (if (> (count-lines (point) (point-max)) 5) - (y-or-n-p - (format - "Your .sig is %d lines; it should be max 4. Really post? " - (count-lines (point) (point-max)))) - t)))))) + ,@forms))) + +(put 'message-check 'lisp-indent-function 1) +(put 'message-check 'edebug-form-spec '(form body)) (defun message-check-element (type) "Returns non-nil if this type is not to be checked." @@ -1734,6 +1862,242 @@ (and (consp able) (eq (cdr able) 'disabled))))) +(defun message-check-news-syntax () + "Check the syntax of the message." + (save-excursion + (save-restriction + (widen) + (and + ;; We narrow to the headers and check them first. + (save-excursion + (save-restriction + (message-narrow-to-headers) + (message-check-news-header-syntax))) + ;; Check the body. + (message-check-news-body-syntax))))) + +(defun message-check-news-header-syntax () + (and + ;; Check for commands in Subject. + (message-check 'subject-cmsg + (if (string-match "^cmsg " (message-fetch-field "subject")) + (y-or-n-p + "The control code \"cmsg\" is in the subject. Really post? ") + t)) + ;; Check for multiple identical headers. + (message-check 'multiple-headers + (let (found) + (while (and (not found) + (re-search-forward "^[^ \t:]+: " nil t)) + (save-excursion + (or (re-search-forward + (concat "^" + (regexp-quote + (setq found + (buffer-substring + (match-beginning 0) (- (match-end 0) 2)))) + ":") + nil t) + (setq found nil)))) + (if found + (y-or-n-p (format "Multiple %s headers. Really post? " found)) + t))) + ;; Check for Version and Sendsys. + (message-check 'sendsys + (if (re-search-forward "^Sendsys:\\|^Version:" nil t) + (y-or-n-p + (format "The article contains a %s command. Really post? " + (buffer-substring (match-beginning 0) + (1- (match-end 0))))) + t)) + ;; See whether we can shorten Followup-To. + (message-check 'shorten-followup-to + (let ((newsgroups (message-fetch-field "newsgroups")) + (followup-to (message-fetch-field "followup-to")) + to) + (when (and newsgroups + (string-match "," newsgroups) + (not followup-to) + (not + (zerop + (length + (setq to (completing-read + "Followups to: (default all groups) " + (mapcar (lambda (g) (list g)) + (cons "poster" + (message-tokenize-header + newsgroups))))))))) + (goto-char (point-min)) + (insert "Followup-To: " to "\n")) + t)) + ;; Check "Shoot me". + (message-check 'shoot + (if (re-search-forward + "Message-ID.*.i-did-not-set--mail-host-address--so-shoot-me" nil t) + (y-or-n-p "You appear to have a misconfigured system. Really post? ") + t)) + ;; Check for Approved. + (message-check 'approved + (if (re-search-forward "^Approved:" nil t) + (y-or-n-p "The article contains an Approved header. Really post? ") + t)) + ;; Check the Message-ID header. + (message-check 'message-id + (let* ((case-fold-search t) + (message-id (message-fetch-field "message-id"))) + (or (not message-id) + (and (string-match "@" message-id) + (string-match "@[^\\.]*\\." message-id)) + (y-or-n-p + (format "The Message-ID looks strange: \"%s\". Really post? " + message-id))))) + ;; Check the Subject header. + (message-check 'subject + (let* ((case-fold-search t) + (subject (message-fetch-field "subject"))) + (or + (and subject + (not (string-match "\\`[ \t]*\\'" subject))) + (ignore + (message + "The subject field is empty or missing. Posting is denied."))))) + ;; Check the Newsgroups & Followup-To headers. + (message-check 'existing-newsgroups + (let* ((case-fold-search t) + (newsgroups (message-fetch-field "newsgroups")) + (followup-to (message-fetch-field "followup-to")) + (groups (message-tokenize-header + (if followup-to + (concat newsgroups "," followup-to) + newsgroups))) + (hashtb (and (boundp 'gnus-active-hashtb) + gnus-active-hashtb)) + errors) + (if (or (not hashtb) + (not (boundp 'gnus-read-active-file)) + (not gnus-read-active-file) + (eq gnus-read-active-file 'some)) + t + (while groups + (when (and (not (boundp (intern (car groups) hashtb))) + (not (equal (car groups) "poster"))) + (push (car groups) errors)) + (pop groups)) + (if (not errors) + t + (y-or-n-p + (format + "Really post to %s unknown group%s: %s " + (if (= (length errors) 1) "this" "these") + (if (= (length errors) 1) "" "s") + (mapconcat 'identity errors ", "))))))) + ;; Check the Newsgroups & Followup-To headers for syntax errors. + (message-check 'valid-newsgroups + (let ((case-fold-search t) + (headers '("Newsgroups" "Followup-To")) + header error) + (while (and headers (not error)) + (when (setq header (mail-fetch-field (car headers))) + (if (or + (not + (string-match + "\\`\\([-+_&.a-zA-Z0-9]+\\)?\\(,[-+_&.a-zA-Z0-9]+\\)*\\'" + header)) + (memq + nil (mapcar + (lambda (g) + (not (string-match "\\.\\'\\|\\.\\." g))) + (message-tokenize-header header ",")))) + (setq error t))) + (unless error + (pop headers))) + (if (not error) + t + (y-or-n-p + (format "The %s header looks odd: \"%s\". Really post? " + (car headers) header))))) + ;; Check the From header. + (message-check 'from + (let* ((case-fold-search t) + (from (message-fetch-field "from")) + (ad (nth 1 (mail-extract-address-components from)))) + (cond + ((not from) + (message "There is no From line. Posting is denied.") + nil) + ((or (not (string-match "@[^\\.]*\\." ad)) ;larsi@ifi + (string-match "\\.\\." ad) ;larsi@ifi..uio + (string-match "@\\." ad) ;larsi@.ifi.uio + (string-match "\\.$" ad) ;larsi@ifi.uio. + (not (string-match "^[^@]+@[^@]+$" ad)) ;larsi.ifi.uio + (string-match "(.*).*(.*)" from)) ;(lars) (lars) + (message + "Denied posting -- the From looks strange: \"%s\"." from) + nil) + (t t)))))) + +(defun message-check-news-body-syntax () + (and + ;; Check for long lines. + (message-check 'long-lines + (goto-char (point-min)) + (re-search-forward + (concat "^" (regexp-quote mail-header-separator) "$")) + (while (and + (progn + (end-of-line) + (< (current-column) 80)) + (zerop (forward-line 1)))) + (or (bolp) + (eobp) + (y-or-n-p + "You have lines longer than 79 characters. Really post? "))) + ;; Check whether the article is empty. + (message-check 'empty + (goto-char (point-min)) + (re-search-forward + (concat "^" (regexp-quote mail-header-separator) "$")) + (forward-line 1) + (let ((b (point))) + (goto-char (point-max)) + (re-search-backward message-signature-separator nil t) + (beginning-of-line) + (or (re-search-backward "[^ \n\t]" b t) + (y-or-n-p "Empty article. Really post? ")))) + ;; Check for control characters. + (message-check 'control-chars + (if (re-search-forward "[\000-\007\013\015-\037\200-\237]" nil t) + (y-or-n-p + "The article contains control characters. Really post? ") + t)) + ;; Check excessive size. + (message-check 'size + (if (> (buffer-size) 60000) + (y-or-n-p + (format "The article is %d octets long. Really post? " + (buffer-size))) + t)) + ;; Check whether any new text has been added. + (message-check 'new-text + (or + (not message-checksum) + (not (and (eq (message-checksum) (car message-checksum)) + (eq (buffer-size) (cdr message-checksum)))) + (y-or-n-p + "It looks like no new text has been added. Really post? "))) + ;; Check the length of the signature. + (message-check 'signature + (goto-char (point-max)) + (if (or (not (re-search-backward message-signature-separator nil t)) + (search-forward message-forward-end-separator nil t)) + t + (if (> (count-lines (point) (point-max)) 5) + (y-or-n-p + (format + "Your .sig is %d lines; it should be max 4. Really post? " + (1- (count-lines (point) (point-max))))) + t))))) + (defun message-checksum () "Return a \"checksum\" for the current buffer." (let ((sum 0)) @@ -1777,15 +2141,17 @@ (setq file (expand-file-name file)) (unless (file-exists-p (file-name-directory file)) (make-directory (file-name-directory file) t)) - (if (and message-fcc-handler-function - (not (eq message-fcc-handler-function 'rmail-output))) - (funcall message-fcc-handler-function file) - (if (and (file-readable-p file) (mail-file-babyl-p file)) - (rmail-output file 1 nil t) - (let ((mail-use-rfc822 t)) - (rmail-output file 1 t t)))))) + (funcall message-fcc-handler-function file))) + (kill-buffer (current-buffer))))) +(defun message-output (filename) + "Append this article to Unix/babyl mail file.." + (if (and (file-readable-p filename) + (mail-file-babyl-p filename)) + (gnus-output-to-rmail filename t) + (gnus-output-to-mail filename t))) + (defun message-cleanup-headers () "Do various automatic cleanups of the headers." ;; Remove empty lines in the header. @@ -2003,7 +2369,7 @@ (goto-char fullname-start) (while (re-search-forward "\\(\\=\\|[^\\]\\(\\\\\\\\\\)*\\)\\\\(\\(\\([^\\]\\|\\\\\\\\\\)*\\)\\\\)" - nil 1) + nil 1) (replace-match "\\1(\\3)" t) (goto-char fullname-start))) (insert ")"))) @@ -2023,7 +2389,9 @@ (defun message-user-mail-address () "Return the pertinent part of `user-mail-address'." (when user-mail-address - (nth 1 (mail-extract-address-components user-mail-address)))) + (if (string-match " " user-mail-address) + (nth 1 (mail-extract-address-components user-mail-address)) + user-mail-address))) (defun message-make-fqdn () "Return user's fully qualified domain name." @@ -2044,7 +2412,7 @@ (match-string 1 user-mail)) ;; Default to this bogus thing. (t - (concat system-name ".i-have-a-misconfigured-system-so-shoot-me"))))) + (concat system-name ".i-did-not-set--mail-host-address--so-shoot-me"))))) (defun message-make-host-name () "Return the name of the host." @@ -2089,7 +2457,7 @@ (message-delete-line)) (pop headers))) ;; Go through all the required headers and see if they are in the - ;; articles already. If they are not, or are empty, they are + ;; articles already. If they are not, or are empty, they are ;; inserted automatically - except for Subject, Newsgroups and ;; Distribution. (while headers @@ -2104,7 +2472,7 @@ (concat "^" (downcase (symbol-name header)) ":") nil t)) (progn - ;; The header was found. We insert a space after the + ;; The header was found. We insert a space after the ;; colon, if there is none. (if (/= (following-char) ? ) (insert " ") (forward-char 1)) ;; Find out whether the header is empty... @@ -2173,7 +2541,7 @@ (downcase secure-sender))))) (goto-char (point-min)) ;; Rename any old Sender headers to Original-Sender. - (when (re-search-forward "^Sender:" nil t) + (when (re-search-forward "^\\(Original-\\)*Sender:" nil t) (beginning-of-line) (insert "Original-") (beginning-of-line)) @@ -2181,15 +2549,20 @@ (defun message-insert-courtesy-copy () "Insert a courtesy message in mail copies of combined messages." - (save-excursion - (save-restriction - (message-narrow-to-headers) - (let ((newsgroups (message-fetch-field "newsgroups"))) - (when newsgroups + (let (newsgroups) + (save-excursion + (save-restriction + (message-narrow-to-headers) + (when (setq newsgroups (message-fetch-field "newsgroups")) (goto-char (point-max)) - (insert "Posted-To: " newsgroups "\n")))) - (forward-line 1) - (insert message-courtesy-message))) + (insert "Posted-To: " newsgroups "\n"))) + (forward-line 1) + (when message-courtesy-message + (cond + ((string-match "%s" message-courtesy-message) + (insert (format message-courtesy-message newsgroups))) + (t + (insert message-courtesy-message))))))) ;;; ;;; Setting up a message buffer @@ -2308,6 +2681,7 @@ ;; list of buffers. (setq message-buffer-list (delq (current-buffer) message-buffer-list)) (while (and message-max-buffers + message-buffer-list (>= (length message-buffer-list) message-max-buffers)) ;; Kill the oldest buffer -- unless it has been changed. (let ((buffer (pop message-buffer-list))) @@ -2408,19 +2782,26 @@ ;;; ;;;###autoload -(defun message-mail (&optional to subject) +(defun message-mail (&optional to subject + other-headers continue switch-function + yank-action send-actions) "Start editing a mail message to be sent." (interactive) - (message-pop-to-buffer (message-buffer-name "mail" to)) - (message-setup `((To . ,(or to "")) (Subject . ,(or subject ""))))) + (let ((message-this-is-mail t)) + (message-pop-to-buffer (message-buffer-name "mail" to)) + (message-setup + (nconc + `((To . ,(or to "")) (Subject . ,(or subject ""))) + (when other-headers (list other-headers)))))) ;;;###autoload (defun message-news (&optional newsgroups subject) "Start editing a news article to be sent." (interactive) - (message-pop-to-buffer (message-buffer-name "news" nil newsgroups)) - (message-setup `((Newsgroups . ,(or newsgroups "")) - (Subject . ,(or subject ""))))) + (let ((message-this-is-news t)) + (message-pop-to-buffer (message-buffer-name "news" nil newsgroups)) + (message-setup `((Newsgroups . ,(or newsgroups "")) + (Subject . ,(or subject "")))))) ;;;###autoload (defun message-reply (&optional to-address wide ignore-reply-to) @@ -2432,11 +2813,7 @@ (inhibit-point-motion-hooks t) mct never-mct gnus-warning) (save-restriction - (narrow-to-region - (goto-char (point-min)) - (if (search-forward "\n\n" nil t) - (1- (point)) - (point-max))) + (message-narrow-to-head) ;; Allow customizations to have their say. (if (not wide) ;; This is a regular reply. @@ -2501,9 +2878,11 @@ (setq ccalist (delq (assoc (car (pop s)) s) ccalist))))) (setq follow-to (list (cons 'To (cdr (pop ccalist))))) (when ccalist - (push (cons 'Cc - (mapconcat (lambda (addr) (cdr addr)) ccalist ", ")) - follow-to))))) + (let ((ccs (cons 'Cc (mapconcat + (lambda (addr) (cdr addr)) ccalist ", ")))) + (when (string-match "^ +" (cdr ccs)) + (setcdr ccs (substring (cdr ccs) (match-end 0)))) + (push ccs follow-to)))))) (widen)) (message-pop-to-buffer (message-buffer-name @@ -2524,16 +2903,20 @@ ;;;###autoload (defun message-wide-reply (&optional to-address) + "Make a \"wide\" reply to the message in the current buffer." (interactive) (message-reply to-address t)) ;;;###autoload -(defun message-followup () +(defun message-followup (&optional to-newsgroups) + "Follow up to the message in the current buffer. +If TO-NEWSGROUPS, use that as the new Newsgroups line." (interactive) (let ((cur (current-buffer)) from subject date reply-to mct references message-id follow-to (inhibit-point-motion-hooks t) + (message-this-is-news t) followup-to distribution newsgroups gnus-warning) (save-restriction (narrow-to-region @@ -2558,9 +2941,10 @@ (string-match "<[^>]+>" gnus-warning)) (setq message-id (match-string 0 gnus-warning))) ;; Remove bogus distribution. - (and (stringp distribution) - (string-match "world" distribution) - (setq distribution nil)) + (when (and (stringp distribution) + (let ((case-fold-search t)) + (string-match "world" distribution))) + (setq distribution nil)) ;; Remove any (buggy) Re:'s that are present and make a ;; proper one. (when (string-match "^[ \t]*[Rr][Ee]:[ \t]*" subject) @@ -2573,6 +2957,8 @@ (message-setup `((Subject . ,subject) ,@(cond + (to-newsgroups + (list (cons 'Newsgroups to-newsgroups))) (follow-to follow-to) ((and followup-to message-use-followup-to) (list @@ -2605,15 +2991,16 @@ because discussions that are spread over several newsgroup tend to be fragmented and very difficult to follow. -Also, some source/announcment newsgroups are not indented for discussion; +Also, some source/announcement newsgroups are not indented for discussion; responses here are directed to other newsgroups.")) (cons 'Newsgroups followup-to) (cons 'Newsgroups newsgroups)))))) (t `((Newsgroups . ,newsgroups)))) ,@(and distribution (list (cons 'Distribution distribution))) - (References . ,(concat (or references "") (and references " ") - (or message-id ""))) + ,@(if (or references message-id) + `((References . ,(concat (or references "") (and references " ") + (or message-id ""))))) ,@(when (and mct (not (equal (downcase mct) "never"))) (list (cons 'Cc (if (equal (downcase mct) "always") @@ -2659,7 +3046,7 @@ (concat "Distribution: " distribution "\n") "") mail-header-separator "\n" - "This is a cancel message from " from ".\n") + message-cancel-message) (message "Canceling your article...") (let ((message-syntax-checks 'dont-check-for-anything-just-trust-me)) (funcall message-send-news-function)) @@ -2717,9 +3104,14 @@ (defun message-make-forward-subject () "Return a Subject header suitable for the message in the current buffer." - (concat "[" (or (message-fetch-field (if (message-news-p) "newsgroups" "from")) - "(nowhere)") - "] " (or (message-fetch-field "Subject") ""))) + (save-excursion + (save-restriction + (current-buffer) + (message-narrow-to-head) + (concat "[" (or (message-fetch-field + (if (message-news-p) "newsgroups" "from")) + "(nowhere)") + "] " (or (message-fetch-field "Subject") ""))))) ;;;###autoload (defun message-forward (&optional news) @@ -2727,7 +3119,8 @@ Optional NEWS will use news to forward instead of mail." (interactive "P") (let ((cur (current-buffer)) - (subject (message-make-forward-subject))) + (subject (message-make-forward-subject)) + art-beg) (if news (message-news nil subject) (message-mail nil subject)) ;; Put point where we want it before inserting the forwarded ;; message. @@ -2741,13 +3134,13 @@ (narrow-to-region (point) (point)) ;; Insert the separators and the forwarded buffer. (insert message-forward-start-separator) + (setq art-beg (point)) (insert-buffer-substring cur) (goto-char (point-max)) (insert message-forward-end-separator) (set-text-properties (point-min) (point-max) nil) ;; Remove all unwanted headers. - (goto-char (point-min)) - (forward-line 1) + (goto-char art-beg) (narrow-to-region (point) (if (search-forward "\n\n" nil t) (1- (point)) (point))) @@ -2760,6 +3153,7 @@ (defun message-resend (address) "Resend the current article to ADDRESS." (interactive "sResend message to: ") + (message "Resending message to %s..." address) (save-excursion (let ((cur (current-buffer)) beg) @@ -2793,9 +3187,14 @@ (while (re-search-backward "^\\(Also-\\)?Resent-" beg t) (beginning-of-line) (insert "Also-")) + ;; Quote any "From " lines at the beginning. + (goto-char beg) + (when (looking-at "From ") + (replace-match "X-From-Line: ")) ;; Send it. (message-send-mail) - (kill-buffer (current-buffer))))) + (kill-buffer (current-buffer))) + (message "Resending message to %s...done" address))) ;;;###autoload (defun message-bounce () @@ -2905,13 +3304,13 @@ which specify the range to operate on." (interactive "r") (save-excursion - (let ((end1 (make-marker))) - (move-marker end1 (max start end)) - (goto-char (min start end)) - (while (< (point) end1) - (or (looking-at "[_\^@- ]") - (insert (following-char) "\b")) - (forward-char 1))))) + (let ((end1 (make-marker))) + (move-marker end1 (max start end)) + (goto-char (min start end)) + (while (< (point) end1) + (or (looking-at "[_\^@- ]") + (insert (following-char) "\b")) + (forward-char 1))))) ;;;###autoload (defun unbold-region (start end) @@ -2920,12 +3319,12 @@ which specify the range to operate on." (interactive "r") (save-excursion - (let ((end1 (make-marker))) - (move-marker end1 (max start end)) - (goto-char (min start end)) - (while (re-search-forward "\b" end1 t) - (if (eq (following-char) (char-after (- (point) 2))) - (delete-char -2)))))) + (let ((end1 (make-marker))) + (move-marker end1 (max start end)) + (goto-char (min start end)) + (while (re-search-forward "\b" end1 t) + (if (eq (following-char) (char-after (- (point) 2))) + (delete-char -2)))))) (defalias 'message-exchange-point-and-mark 'exchange-point-and-mark) @@ -2950,7 +3349,15 @@ (defvar gnus-active-hashtb) (defun message-expand-group () - (let* ((b (save-excursion (skip-chars-backward "^, :\t\n") (point))) + (let* ((b (save-excursion + (save-restriction + (narrow-to-region + (save-excursion + (beginning-of-line) + (skip-chars-forward "^:") + (1+ (point))) + (point)) + (skip-chars-backward "^, \t\n") (point)))) (completion-ignore-case t) (string (buffer-substring b (point))) (hashtb (and (boundp 'gnus-active-hashtb) gnus-active-hashtb)) @@ -2983,10 +3390,6 @@ ;;; Help stuff. -(defmacro message-y-or-n-p (question show &rest text) - "Ask QUESTION, displaying the rest of the arguments in a temp. buffer if SHOW" - `(message-talkative-question 'y-or-n-p ,question ,show ,@text)) - (defun message-talkative-question (ask question show &rest text) "Call FUNCTION with argument QUESTION, displaying the rest of the arguments in a temporary buffer if SHOW. The following arguments may contain lists of values." @@ -3001,15 +3404,34 @@ (funcall ask question)) (funcall ask question))) -(defun message-flatten-list (&rest list) - (message-flatten-list-1 list)) - -(defun message-flatten-list-1 (list) +(defun message-flatten-list (list) + "Return a new, flat list that contains all elements of LIST. + +\(message-flatten-list '(1 (2 3 (4 5 (6))) 7)) +=> (1 2 3 4 5 6 7)" (cond ((consp list) - (apply 'append (mapcar 'message-flatten-list-1 list))) + (apply 'append (mapcar 'message-flatten-list list))) (list (list list)))) +(defun message-generate-new-buffer-clone-locals (name &optional varstr) + "Create and return a buffer with a name based on NAME using generate-new-buffer. +Then clone the local variables and values from the old buffer to the +new one, cloning only the locals having a substring matching the +regexp varstr." + (let ((oldlocals (buffer-local-variables))) + (save-excursion + (set-buffer (generate-new-buffer name)) + (mapcar (lambda (dude) + (when (and (car dude) + (or (not varstr) + (string-match varstr (symbol-name (car dude))))) + (ignore-errors + (set (make-local-variable (car dude)) + (cdr dude))))) + oldlocals) + (current-buffer)))) + (run-hooks 'message-load-hook) (provide 'message) diff -r ad457d5f7d04 -r 0293115a14e9 lisp/gnus/messagexmas.el --- a/lisp/gnus/messagexmas.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/gnus/messagexmas.el Mon Aug 13 08:49:20 2007 +0200 @@ -1,5 +1,5 @@ ;;; messagexmas.el --- XEmacs extensions to message -;; Copyright (C) 1996 Free Software Foundation, Inc. +;; Copyright (C) 1996,97 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; Keywords: mail, news @@ -27,7 +27,7 @@ (require 'nnheader) -(defvar message-xmas-dont-activate-region nil +(defvar message-xmas-dont-activate-region t "If t, don't activate region after yanking.") (defvar message-xmas-glyph-directory nil diff -r ad457d5f7d04 -r 0293115a14e9 lisp/gnus/messcompat.el --- a/lisp/gnus/messcompat.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/gnus/messcompat.el Mon Aug 13 08:49:20 2007 +0200 @@ -1,5 +1,5 @@ ;;; messcompat.el --- making message mode compatible with mail mode -;; Copyright (C) 1996 Free Software Foundation, Inc. +;; Copyright (C) 1996,97 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; Keywords: mail, news @@ -63,15 +63,13 @@ "*Number of spaces to insert at the beginning of each cited line. Used by `message-yank-original' via `message-yank-cite'.") -(defvar message-cite-function (car mail-citation-hook) - "*Function for citing an original message.") - (defvar message-signature mail-signature "*String to be inserted at the end of the message buffer. If t, the `message-signature-file' file will be inserted instead. If a function, the result from the function will be used instead. If a form, the result from the form will be used instead.") +;;;###autoload (defvar message-signature-file mail-signature-file "*File containing the text inserted at end of message. buffer.") diff -r ad457d5f7d04 -r 0293115a14e9 lisp/gnus/nnbabyl.el --- a/lisp/gnus/nnbabyl.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/gnus/nnbabyl.el Mon Aug 13 08:49:20 2007 +0200 @@ -1,5 +1,5 @@ ;;; nnbabyl.el --- rmail mbox access for Gnus -;; Copyright (C) 1995,96 Free Software Foundation, Inc. +;; Copyright (C) 1995,96,97 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; Masanobu UMEDA @@ -85,10 +85,11 @@ (while (setq article (pop articles)) (setq art-string (nnbabyl-article-string article)) (set-buffer nnbabyl-mbox-buffer) - (beginning-of-line) + (end-of-line) (when (or (search-forward art-string nil t) (search-backward art-string nil t)) - (re-search-backward delim nil t) + (unless (re-search-backward delim nil t) + (goto-char (point-min))) (while (and (not (looking-at ".+:")) (zerop (forward-line 1)))) (setq start (point)) @@ -117,6 +118,7 @@ (deffoo nnbabyl-open-server (server &optional defs) (nnoo-change-server 'nnbabyl server defs) + (nnbabyl-create-mbox) (cond ((not (file-exists-p nnbabyl-mbox-file)) (nnbabyl-close-server) @@ -157,13 +159,16 @@ (goto-char (point-min)) (when (search-forward (nnbabyl-article-string article) nil t) (let (start stop summary-line) - (re-search-backward (concat "^" nnbabyl-mail-delimiter) nil t) + (unless (re-search-backward (concat "^" nnbabyl-mail-delimiter) nil t) + (goto-char (point-min)) + (end-of-line)) (while (and (not (looking-at ".+:")) (zerop (forward-line 1)))) (setq start (point)) - (or (and (re-search-forward - (concat "^" nnbabyl-mail-delimiter) nil t) - (forward-line -1)) + (or (when (re-search-forward + (concat "^" nnbabyl-mail-delimiter) nil t) + (beginning-of-line) + t) (goto-char (point-max))) (setq stop (point)) (let ((nntp-server-buffer (or buffer nntp-server-buffer))) @@ -184,7 +189,7 @@ (delete-region (progn (beginning-of-line) (point)) (or (search-forward "\n\n" nil t) (point))))) - (if (numberp article) + (if (numberp article) (cons nnbabyl-current-group article) (nnbabyl-article-group-number))))))) @@ -205,6 +210,7 @@ (car active) (cdr active) group)))))) (deffoo nnbabyl-request-scan (&optional group server) + (nnbabyl-possibly-change-newsgroup group server) (nnbabyl-read-mbox) (nnmail-get-new-mail 'nnbabyl @@ -229,18 +235,19 @@ (deffoo nnbabyl-close-group (group &optional server) t) -(deffoo nnbabyl-request-create-group (group &optional server) +(deffoo nnbabyl-request-create-group (group &optional server args) (nnmail-activate 'nnbabyl) (unless (assoc group nnbabyl-group-alist) - (setq nnbabyl-group-alist (cons (list group (cons 1 0)) - nnbabyl-group-alist)) + (push (list group (cons 1 0)) + nnbabyl-group-alist) (nnmail-save-active nnbabyl-group-alist nnbabyl-active-file)) t) (deffoo nnbabyl-request-list (&optional server) (save-excursion (nnmail-find-file nnbabyl-active-file) - (setq nnbabyl-group-alist (nnmail-get-active)))) + (setq nnbabyl-group-alist (nnmail-get-active)) + t)) (deffoo nnbabyl-request-newgroups (date &optional server) (nnbabyl-request-list server)) @@ -260,17 +267,17 @@ (gnus-set-text-properties (point-min) (point-max) nil) (while (and articles is-old) (goto-char (point-min)) - (if (search-forward (nnbabyl-article-string (car articles)) nil t) - (if (setq is-old - (nnmail-expired-article-p - newsgroup - (buffer-substring - (point) (progn (end-of-line) (point))) force)) - (progn - (nnheader-message 5 "Deleting article %d in %s..." - (car articles) newsgroup) - (nnbabyl-delete-mail)) - (setq rest (cons (car articles) rest)))) + (when (search-forward (nnbabyl-article-string (car articles)) nil t) + (if (setq is-old + (nnmail-expired-article-p + newsgroup + (buffer-substring + (point) (progn (end-of-line) (point))) force)) + (progn + (nnheader-message 5 "Deleting article %d in %s..." + (car articles) newsgroup) + (nnbabyl-delete-mail)) + (push (car articles) rest))) (setq articles (cdr articles))) (save-buffer) ;; Find the lowest active article in this group. @@ -286,7 +293,6 @@ (deffoo nnbabyl-request-move-article (article group server accept-form &optional last) - (nnbabyl-possibly-change-newsgroup group server) (let ((buf (get-buffer-create " *nnbabyl move*")) result) (and @@ -295,15 +301,16 @@ (set-buffer buf) (insert-buffer-substring nntp-server-buffer) (goto-char (point-min)) - (if (re-search-forward - "^X-Gnus-Newsgroup:" - (save-excursion (search-forward "\n\n" nil t) (point)) t) - (delete-region (progn (beginning-of-line) (point)) - (progn (forward-line 1) (point)))) + (while (re-search-forward + "^X-Gnus-Newsgroup:" + (save-excursion (search-forward "\n\n" nil t) (point)) t) + (delete-region (progn (beginning-of-line) (point)) + (progn (forward-line 1) (point)))) (setq result (eval accept-form)) (kill-buffer (current-buffer)) result) (save-excursion + (nnbabyl-possibly-change-newsgroup group server) (set-buffer nnbabyl-mbox-buffer) (goto-char (point-min)) (if (search-forward (nnbabyl-article-string article) nil t) @@ -325,10 +332,10 @@ (save-excursion (while (re-search-backward "^X-Gnus-Newsgroup: " beg t) (delete-region (point) (progn (forward-line 1) (point))))) - (let ((nnmail-split-methods - (if (stringp group) (list (list group "")) - nnmail-split-methods))) - (setq result (car (nnbabyl-save-mail)))) + (setq result (car (nnbabyl-save-mail + (if (stringp group) + (list (cons group (nnbabyl-active-number group))) + (nnmail-article-group 'nnbabyl-active-number))))) (set-buffer nnbabyl-mbox-buffer) (goto-char (point-max)) (search-backward "\n\^_") @@ -365,7 +372,8 @@ (while (search-forward ident nil t) (setq found t) (nnbabyl-delete-mail)) - (and found (save-buffer))))) + (when found + (save-buffer))))) ;; Remove the group from all structures. (setq nnbabyl-group-alist (delq (assoc group nnbabyl-group-alist) nnbabyl-group-alist) @@ -385,7 +393,8 @@ (while (search-forward ident nil t) (replace-match new-ident t t) (setq found t)) - (and found (save-buffer)))) + (when found + (save-buffer)))) (let ((entry (assoc group nnbabyl-group-alist))) (and entry (setcar entry new-name)) (setq nnbabyl-current-group nil) @@ -397,45 +406,45 @@ ;;; Internal functions. ;; If FORCE, delete article no matter how many X-Gnus-Newsgroup -;; headers there are. If LEAVE-DELIM, don't delete the Unix mbox +;; headers there are. If LEAVE-DELIM, don't delete the Unix mbox ;; delimiter line. (defun nnbabyl-delete-mail (&optional force leave-delim) ;; Delete the current X-Gnus-Newsgroup line. - (or force - (delete-region - (progn (beginning-of-line) (point)) - (progn (forward-line 1) (point)))) + (unless force + (delete-region + (progn (beginning-of-line) (point)) + (progn (forward-line 1) (point)))) ;; Beginning of the article. (save-excursion (save-restriction (widen) (narrow-to-region (save-excursion - (re-search-backward (concat "^" nnbabyl-mail-delimiter) nil t) + (unless (re-search-backward (concat "^" nnbabyl-mail-delimiter) nil t) + (goto-char (point-min)) + (end-of-line)) (if leave-delim (progn (forward-line 1) (point)) (match-beginning 0))) (progn (forward-line 1) - (or (and (re-search-forward (concat "^" nnbabyl-mail-delimiter) + (or (and (re-search-forward (concat "^" nnbabyl-mail-delimiter) nil t) - (if (and (not (bobp)) leave-delim) - (progn (forward-line -2) (point)) - (match-beginning 0))) + (match-beginning 0)) (point-max)))) (goto-char (point-min)) ;; Only delete the article if no other groups owns it as well. - (if (or force (not (re-search-forward "^X-Gnus-Newsgroup: " nil t))) - (delete-region (point-min) (point-max)))))) + (when (or force (not (re-search-forward "^X-Gnus-Newsgroup: " nil t))) + (delete-region (point-min) (point-max)))))) (defun nnbabyl-possibly-change-newsgroup (newsgroup &optional server) (when (and server (not (nnbabyl-server-opened server))) (nnbabyl-open-server server)) - (if (or (not nnbabyl-mbox-buffer) - (not (buffer-name nnbabyl-mbox-buffer))) - (save-excursion (nnbabyl-read-mbox))) - (or nnbabyl-group-alist - (nnmail-activate 'nnbabyl)) + (when (or (not nnbabyl-mbox-buffer) + (not (buffer-name nnbabyl-mbox-buffer))) + (save-excursion (nnbabyl-read-mbox))) + (unless nnbabyl-group-alist + (nnmail-activate 'nnbabyl)) (if newsgroup (if (assoc newsgroup nnbabyl-group-alist) (setq nnbabyl-current-group newsgroup) @@ -451,18 +460,18 @@ (defun nnbabyl-article-group-number () (save-excursion (goto-char (point-min)) - (and (re-search-forward "^X-Gnus-Newsgroup: +\\([^:]+\\):\\([0-9]+\\) " - nil t) - (cons (buffer-substring (match-beginning 1) (match-end 1)) - (string-to-int - (buffer-substring (match-beginning 2) (match-end 2))))))) + (when (re-search-forward "^X-Gnus-Newsgroup: +\\([^:]+\\):\\([0-9]+\\) " + nil t) + (cons (buffer-substring (match-beginning 1) (match-end 1)) + (string-to-int + (buffer-substring (match-beginning 2) (match-end 2))))))) (defun nnbabyl-insert-lines () "Insert how many lines and chars there are in the body of the mail." (let (lines chars) (save-excursion (goto-char (point-min)) - (when (search-forward "\n\n" nil t) + (when (search-forward "\n\n" nil t) ;; There may be an EOOH line here... (when (looking-at "\\*\\*\\* EOOH \\*\\*\\*") (search-forward "\n\n" nil t)) @@ -478,14 +487,13 @@ (insert (format "Lines: %d\n" lines)) chars)))) -(defun nnbabyl-save-mail () +(defun nnbabyl-save-mail (group-art) ;; Called narrowed to an article. - (let ((group-art (nreverse (nnmail-article-group 'nnbabyl-active-number)))) - (nnbabyl-insert-lines) - (nnmail-insert-xref group-art) - (nnbabyl-insert-newsgroup-line group-art) - (run-hooks 'nnbabyl-prepare-save-mail-hook) - group-art)) + (nnbabyl-insert-lines) + (nnmail-insert-xref group-art) + (nnbabyl-insert-newsgroup-line group-art) + (run-hooks 'nnbabyl-prepare-save-mail-hook) + group-art) (defun nnbabyl-insert-newsgroup-line (group-art) (save-excursion @@ -496,19 +504,18 @@ ;; If there is a C-l at the beginning of the narrowed region, this ;; isn't really a "save", but rather a "scan". (goto-char (point-min)) - (or (looking-at "\^L") - (save-excursion - (insert "\^L\n0, unseen,,\n*** EOOH ***\n") - (goto-char (point-max)) - (insert "\^_\n"))) - (if (search-forward "\n\n" nil t) - (progn - (forward-char -1) - (while group-art - (insert (format "X-Gnus-Newsgroup: %s:%d %s\n" - (caar group-art) (cdar group-art) - (current-time-string))) - (setq group-art (cdr group-art))))) + (unless (looking-at "\^L") + (save-excursion + (insert "\^L\n0, unseen,,\n*** EOOH ***\n") + (goto-char (point-max)) + (insert "\^_\n"))) + (when (search-forward "\n\n" nil t) + (forward-char -1) + (while group-art + (insert (format "X-Gnus-Newsgroup: %s:%d %s\n" + (caar group-art) (cdar group-art) + (current-time-string))) + (setq group-art (cdr group-art)))) t)) (defun nnbabyl-active-number (group) @@ -519,12 +526,11 @@ ;; This group is new, so we create a new entry for it. ;; This might be a bit naughty... creating groups on the drop of ;; a hat, but I don't know... - (setq nnbabyl-group-alist (cons (list group (setq active (cons 1 1))) - nnbabyl-group-alist))) + (push (list group (setq active (cons 1 1))) + nnbabyl-group-alist)) (cdr active))) -(defun nnbabyl-read-mbox () - (nnmail-activate 'nnbabyl) +(defun nnbabyl-create-mbox () (unless (file-exists-p nnbabyl-mbox-file) ;; Create a new, empty RMAIL mbox file. (save-excursion @@ -532,14 +538,19 @@ (create-file-buffer nnbabyl-mbox-file))) (setq buffer-file-name nnbabyl-mbox-file) (insert "BABYL OPTIONS:\n\n\^_") - (write-region (point-min) (point-max) nnbabyl-mbox-file t 'nomesg))) + (nnmail-write-region + (point-min) (point-max) nnbabyl-mbox-file t 'nomesg)))) - (if (and nnbabyl-mbox-buffer +(defun nnbabyl-read-mbox () + (nnmail-activate 'nnbabyl) + (nnbabyl-create-mbox) + + (unless (and nnbabyl-mbox-buffer (buffer-name nnbabyl-mbox-buffer) (save-excursion (set-buffer nnbabyl-mbox-buffer) (= (buffer-size) (nnheader-file-size nnbabyl-mbox-file)))) - () ; This buffer hasn't changed since we read it last. Possibly. + ;; This buffer has changed since we read it last. Possibly. (save-excursion (let ((delim (concat "^" nnbabyl-mail-delimiter)) (alist nnbabyl-group-alist) @@ -563,20 +574,23 @@ (goto-char (point-max)) (when (and (re-search-backward (format "^X-Gnus-Newsgroup: %s:\\([0-9]+\\) " - (caar alist)) nil t) + (caar alist)) + nil t) (> (setq number (string-to-number (buffer-substring (match-beginning 1) (match-end 1)))) (cdadar alist))) - (setcdr (cadar alist) (1+ number))) + (setcdr (cadar alist) number)) (setq alist (cdr alist))) ;; We go through the mbox and make sure that each and ;; every mail belongs to some group or other. (goto-char (point-min)) - (re-search-forward delim nil t) - (setq start (match-end 0)) + (if (looking-at "\^L") + (setq start (point)) + (re-search-forward delim nil t) + (setq start (match-end 0))) (while (re-search-forward delim nil t) (setq end (match-end 0)) (unless (search-backward "\nX-Gnus-Newsgroup: " start t) @@ -584,7 +598,8 @@ (save-excursion (save-restriction (narrow-to-region (goto-char start) end) - (nnbabyl-save-mail) + (nnbabyl-save-mail + (nnmail-article-group 'nnbabyl-active-number)) (setq end (point-max))))) (goto-char (setq start end))) (when (buffer-modified-p (current-buffer)) @@ -613,7 +628,8 @@ (delete-region (progn (beginning-of-line) (point)) (progn (forward-line 1) (point))) (nnheader-message 7 "Moving %s..." id) - (nnbabyl-save-mail)) + (nnbabyl-save-mail + (nnmail-article-group 'nnbabyl-active-number))) (intern id idents))) (when (buffer-modified-p (current-buffer)) (save-buffer)) diff -r ad457d5f7d04 -r 0293115a14e9 lisp/gnus/nndb.el --- a/lisp/gnus/nndb.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/gnus/nndb.el Mon Aug 13 08:49:20 2007 +0200 @@ -1,5 +1,5 @@ ;;; nndb.el --- nndb access for Gnus -;; Copyright (C) 1996 Free Software Foundation, Inc. +;; Copyright (C) 1996,97 Free Software Foundation, Inc. ;; Author: Kai Grossjohann ;; Keywords: news @@ -30,6 +30,9 @@ ;;- ;; Register nndb with known select methods. +(require 'gnus) +(require 'nnmail) + (setq gnus-valid-select-methods (cons '("nndb" mail address respool prompt-address) gnus-valid-select-methods)) @@ -123,7 +126,7 @@ ; get new mail from somewhere -- maybe this is not needed? ; --> todo -(deffoo nndb-request-create-group (group &optional server) +(deffoo nndb-request-create-group (group &optional server args) "Creates a group if it doesn't exist yet." (nntp-send-command "^[23].*\n" "MKGROUP" group)) @@ -132,10 +135,10 @@ (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 +If FORCE, delete regardless of expiration date, otherwise use normal expiry mechanism." (let (msg art) - (nntp-possibly-change-server group server) ;;- + (nntp-possibly-change-group group server) ;;- (while articles (setq art (pop articles)) (nntp-send-command "^\\([23]\\|^423\\).*\n" "DATE" art) @@ -143,9 +146,9 @@ ;; CCC we shouldn't be using the variable nndb-status-string? (if (string-match "^423" (nnheader-get-report 'nndb)) () - (or (string-match "\\([0-9]+\\) \\([0-9]+\\)$" msg) - (error "Not a valid response for DATE command: %s" - msg)) + (unless (string-match "\\([0-9]+\\) \\([0-9]+\\)$" msg) + (error "Not a valid response for DATE command: %s" + msg)) (if (nnmail-expired-article-p group (list (string-to-int @@ -179,18 +182,15 @@ (deffoo nndb-request-accept-article (group server &optional last) "The article in the current buffer is put into GROUP." - (nntp-possibly-change-server group server) ;;- + (nntp-possibly-change-group group server) ;;- (let (art statmsg) (when (nntp-send-command "^[23].*\r?\n" "ACCEPT" group) (nnheader-insert "") (nntp-encode-text) - (nntp-send-region-to-server (point-min) (point-max)) - ;; 1.2a NNTP's post command is buggy. "^M" (\r) is not - ;; appended to end of the status message. - (nntp-wait-for-response "^[23].*\n") + (nntp-send-buffer "^[23].*\n") (setq statmsg (nntp-status-message)) - (or (string-match "^\\([0-9]+\\)" statmsg) - (error "nndb: %s" statmsg)) + (unless (string-match "^\\([0-9]+\\)" statmsg) + (error "nndb: %s" statmsg)) (setq art (substring statmsg (match-beginning 1) (match-end 1))) @@ -205,10 +205,7 @@ (when (nntp-send-command "^[23].*\r?\n" "REPLACE" (int-to-string article)) (nnheader-insert "") (nntp-encode-text) - (nntp-send-region-to-server (point-min) (point-max)) - ;; 1.2a NNTP's post command is buggy. "^M" (\r) is not - ;; appended to end of the status message. - (nntp-wait-for-response "^[23].*\n") + (nntp-send-buffer "^[23].*\n") ; (setq statmsg (nntp-status-message)) ; (or (string-match "^\\([0-9]+\\)" statmsg) ; (error "nndb: %s" statmsg)) diff -r ad457d5f7d04 -r 0293115a14e9 lisp/gnus/nndir.el --- a/lisp/gnus/nndir.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/gnus/nndir.el Mon Aug 13 08:49:20 2007 +0200 @@ -1,5 +1,5 @@ ;;; nndir.el --- single directory newsgroup access for Gnus -;; Copyright (C) 1995,96 Free Software Foundation, Inc. +;; Copyright (C) 1995,96,97 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; Keywords: news diff -r ad457d5f7d04 -r 0293115a14e9 lisp/gnus/nndoc.el --- a/lisp/gnus/nndoc.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/gnus/nndoc.el Mon Aug 13 08:49:20 2007 +0200 @@ -1,5 +1,5 @@ ;;; nndoc.el --- single file access for Gnus -;; Copyright (C) 1995,96 Free Software Foundation, Inc. +;; Copyright (C) 1995,96,97 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; Masanobu UMEDA @@ -53,7 +53,6 @@ (article-begin . "^#! *rnews +\\([0-9]+\\) *\n") (body-end-function . nndoc-rnews-body-end)) (mbox - (article-begin . "^From \\([^ \n]*\\(\\|\".*\"[^ \n]*\\)\\) ?\\([^ \n]*\\) *\\([^ ]*\\) *\\([0-9]*\\) *\\([0-9:]*\\) *\\([A-Z]?[A-Z]?[A-Z][A-Z]\\( DST\\)?\\|[-+]?[0-9][0-9][0-9][0-9]\\|\\) * [0-9][0-9]\\([0-9]*\\) *\\([A-Z]?[A-Z]?[A-Z][A-Z]\\( DST\\)?\\|[-+]?[0-9][0-9][0-9][0-9]\\|\\) *\\(remote from .*\\)?\n") (article-begin-function . nndoc-mbox-article-begin) (body-end-function . nndoc-mbox-body-end)) (babyl @@ -64,38 +63,56 @@ (forward (article-begin . "^-+ Start of forwarded message -+\n+") (body-end . "^-+ End of forwarded message -+$") - (prepare-body . nndoc-unquote-dashes)) + (prepare-body-function . nndoc-unquote-dashes)) (clari-briefs (article-begin . "^ \\*") (body-end . "^\t------*[ \t]^*\n^ \\*") (body-begin . "^\t") (head-end . "^\t") - (generate-head . nndoc-generate-clari-briefs-head) - (article-transform . nndoc-transform-clari-briefs)) + (generate-head-function . nndoc-generate-clari-briefs-head) + (article-transform-function . nndoc-transform-clari-briefs)) + (mime-digest + (article-begin . "") + (head-end . "^ ?$") + (body-end . "") + (file-end . "") + (subtype digest guess)) + (standard-digest + (first-article . ,(concat "^" (make-string 70 ?-) "\n\n+")) + (article-begin . ,(concat "^\n" (make-string 30 ?-) "\n\n+")) + (prepare-body-function . nndoc-unquote-dashes) + (body-end-function . nndoc-digest-body-end) + (head-end . "^ ?$") + (body-begin . "^ ?\n") + (file-end . "^End of .*digest.*[0-9].*\n\\*\\*\\|^End of.*Digest *$") + (subtype digest guess)) (slack-digest (article-begin . "^------------------------------*[\n \t]+") (head-end . "^ ?$") (body-end-function . nndoc-digest-body-end) (body-begin . "^ ?$") (file-end . "^End of") - (prepare-body . nndoc-unquote-dashes)) - (mime-digest - (article-begin . "") - (head-end . "^ ?$") - (body-end . "") - (file-end . "")) - (standard-digest - (first-article . ,(concat "^" (make-string 70 ?-) "\n\n+")) - (article-begin . ,(concat "\n\n" (make-string 30 ?-) "\n\n+")) - (prepare-body . nndoc-unquote-dashes) - (body-end-function . nndoc-digest-body-end) - (head-end . "^ ?$") - (body-begin . "^ ?\n") - (file-end . "^End of .*digest.*[0-9].*\n\\*\\*\\|^End of.*Digest *$")) + (prepare-body-function . nndoc-unquote-dashes) + (subtype digest guess)) + (lanl-gov-announce + (article-begin . "^\\\\\\\\\n") + (head-begin . "^Paper.*:") + (head-end . "\\(^\\\\\\\\.*\n\\|-----------------\\)") + (body-begin . "") + (body-end . "-------------------------------------------------") + (file-end . "^Title: Recent Seminal") + (generate-head-function . nndoc-generate-lanl-gov-head) + (article-transform-function . nndoc-transform-lanl-gov-announce) + (subtype preprints guess)) (guess - (guess . nndoc-guess-type)) + (guess . t) + (subtype nil)) (digest - (guess . nndoc-guess-digest-type)) + (guess . t) + (subtype nil)) + (preprints + (guess . t) + (subtype nil)) )) @@ -104,7 +121,6 @@ (defvoo nndoc-first-article nil) (defvoo nndoc-article-end nil) (defvoo nndoc-article-begin nil) -(defvoo nndoc-article-begin-function nil) (defvoo nndoc-head-begin nil) (defvoo nndoc-head-end nil) (defvoo nndoc-file-end nil) @@ -114,9 +130,10 @@ (defvoo nndoc-head-begin-function nil) (defvoo nndoc-body-end nil) (defvoo nndoc-dissection-alist nil) -(defvoo nndoc-prepare-body nil) -(defvoo nndoc-generate-head nil) -(defvoo nndoc-article-transform nil) +(defvoo nndoc-prepare-body-function nil) +(defvoo nndoc-generate-head-function nil) +(defvoo nndoc-article-transform-function nil) +(defvoo nndoc-article-begin-function nil) (defvoo nndoc-status-string "") (defvoo nndoc-group-alist nil) @@ -145,12 +162,13 @@ (when (setq entry (cdr (assq (setq article (pop articles)) nndoc-dissection-alist))) (insert (format "221 %d Article retrieved.\n" article)) - (if nndoc-generate-head - (funcall nndoc-generate-head article) + (if nndoc-generate-head-function + (funcall nndoc-generate-head-function article) (insert-buffer-substring nndoc-current-buffer (car entry) (nth 1 entry))) (goto-char (point-max)) - (or (= (char-after (1- (point))) ?\n) (insert "\n")) + (unless (= (char-after (1- (point))) ?\n) + (insert "\n")) (insert (format "Lines: %d\n" (nth 4 entry))) (insert ".\n"))) @@ -165,20 +183,21 @@ beg) (set-buffer buffer) (erase-buffer) - (if (stringp article) - nil - (insert-buffer-substring - nndoc-current-buffer (car entry) (nth 1 entry)) - (insert "\n") - (setq beg (point)) - (insert-buffer-substring - nndoc-current-buffer (nth 2 entry) (nth 3 entry)) - (goto-char beg) - (when nndoc-prepare-body - (funcall nndoc-prepare-body)) - (when nndoc-article-transform - (funcall nndoc-article-transform article)) - t)))) + (when entry + (if (stringp article) + nil + (insert-buffer-substring + nndoc-current-buffer (car entry) (nth 1 entry)) + (insert "\n") + (setq beg (point)) + (insert-buffer-substring + nndoc-current-buffer (nth 2 entry) (nth 3 entry)) + (goto-char beg) + (when nndoc-prepare-body-function + (funcall nndoc-prepare-body-function)) + (when nndoc-article-transform-function + (funcall nndoc-article-transform-function article)) + t))))) (deffoo nndoc-request-group (group &optional server dont-check) "Select news GROUP." @@ -253,7 +272,7 @@ (buffer-disable-undo (current-buffer)) (erase-buffer) (if (stringp nndoc-address) - (insert-file-contents nndoc-address) + (nnheader-insert-file-contents nndoc-address) (insert-buffer-substring nndoc-address))))) ;; Initialize the nndoc structures according to this new document. (when (and nndoc-current-buffer @@ -267,65 +286,9 @@ ;; Return whether we managed to select a file. nndoc-current-buffer)) -;; MIME (RFC 1341) digest hack by Ulrik Dickow . -(defun nndoc-guess-digest-type () - "Guess what digest type the current document is." - (let ((case-fold-search t) ; We match a bit too much, keep it simple. - boundary-id b-delimiter entry) - (goto-char (point-min)) - (cond - ;; MIME digest. - ((and - (re-search-forward - (concat "^Content-Type: *multipart/digest;[ \t\n]*[ \t]" - "boundary=\"\\([^\"\n]*[^\" \t\n]\\)\"") - nil t) - (match-beginning 1)) - (setq boundary-id (match-string 1) - b-delimiter (concat "\n--" boundary-id "[\n \t]+")) - (setq entry (assq 'mime-digest nndoc-type-alist)) - (setcdr entry - (list - (cons 'head-end "^ ?$") - (cons 'body-begin "^ ?\n") - (cons 'article-begin b-delimiter) - (cons 'body-end-function 'nndoc-digest-body-end) -; (cons 'body-end -; (concat "\n--" boundary-id "\\(--\\)?[\n \t]+")) - (cons 'file-end (concat "\n--" boundary-id "--[ \t]*$")))) - 'mime-digest) - ;; Standard digest. - ((and (re-search-forward (concat "^" (make-string 70 ?-) "\n\n") nil t) - (re-search-forward - (concat "\n\n" (make-string 30 ?-) "\n\n") nil t)) - 'standard-digest) - ;; Stupid digest. - (t - 'slack-digest)))) - -(defun nndoc-guess-type () - "Guess what document type is in the current buffer." - (goto-char (point-min)) - (cond - ((looking-at message-unix-mail-delimiter) - 'mbox) - ((looking-at "\^A\^A\^A\^A$") - 'mmdf) - ((looking-at "^Path:.*\n") - 'news) - ((looking-at "#! *rnews") - 'rnews) - ((re-search-forward "\^_\^L *\n" nil t) - 'babyl) - ((save-excursion - (and (re-search-forward "^-+ Start of forwarded message -+\n+" nil t) - (not (re-search-forward "^Subject:.*digest" nil t)))) - 'forward) - ((let ((case-fold-search nil)) - (re-search-forward "^\t[^a-z]+ ([^a-z]+) --" nil t)) - 'clari-briefs) - (t - 'digest))) +;;; +;;; Deciding what document type we have +;;; (defun nndoc-set-delims () "Set the nndoc delimiter variables according to the type of the document." @@ -334,87 +297,49 @@ nndoc-article-end nndoc-head-begin nndoc-head-end nndoc-file-end nndoc-article-begin nndoc-body-begin nndoc-body-end-function nndoc-body-end - nndoc-prepare-body nndoc-article-transform - nndoc-generate-head nndoc-body-begin-function - nndoc-head-begin-function nndoc-article-begin-function))) + nndoc-prepare-body-function nndoc-article-transform-function + nndoc-generate-head-function nndoc-body-begin-function + nndoc-head-begin-function))) (while vars (set (pop vars) nil))) - (let* (defs guess) + (let (defs) ;; Guess away until we find the real file type. - (while (setq defs (cdr (assq nndoc-article-type nndoc-type-alist)) - guess (assq 'guess defs)) - (setq nndoc-article-type (funcall (cdr guess)))) + (while (assq 'guess (setq defs (cdr (assq nndoc-article-type + nndoc-type-alist)))) + (setq nndoc-article-type (nndoc-guess-type nndoc-article-type))) ;; Set the nndoc variables. (while defs (set (intern (format "nndoc-%s" (caar defs))) (cdr (pop defs)))))) -(defun nndoc-search (regexp) - (prog1 - (re-search-forward regexp nil t) - (beginning-of-line))) +(defun nndoc-guess-type (subtype) + (let ((alist nndoc-type-alist) + results result entry) + (while (and (not result) + (setq entry (pop alist))) + (when (memq subtype (or (cdr (assq 'subtype entry)) '(guess))) + (goto-char (point-min)) + (when (numberp (setq result (funcall (intern + (format "nndoc-%s-type-p" + (car entry)))))) + (push (cons result entry) results) + (setq result nil)))) + (unless (or result results) + (error "Document is not of any recognized type")) + (if result + (car entry) + (cadar (sort results (lambda (r1 r2) (< (car r1) (car r2)))))))) -(defun nndoc-dissect-buffer () - "Go through the document and partition it into heads/bodies/articles." - (let ((i 0) - (first t) - head-begin head-end body-begin body-end) - (setq nndoc-dissection-alist nil) - (save-excursion - (set-buffer nndoc-current-buffer) - (goto-char (point-min)) - ;; Find the beginning of the file. - (when nndoc-file-begin - (nndoc-search nndoc-file-begin)) - ;; Go through the file. - (while (if (and first nndoc-first-article) - (nndoc-search nndoc-first-article) - (if nndoc-article-begin-function - (funcall nndoc-article-begin-function) - (nndoc-search nndoc-article-begin))) - (setq first nil) - (cond (nndoc-head-begin-function - (funcall nndoc-head-begin-function)) - (nndoc-head-begin - (nndoc-search nndoc-head-begin))) - (if (and nndoc-file-end - (looking-at nndoc-file-end)) - (goto-char (point-max)) - (setq head-begin (point)) - (nndoc-search (or nndoc-head-end "^$")) - (setq head-end (point)) - (if nndoc-body-begin-function - (funcall nndoc-body-begin-function) - (nndoc-search (or nndoc-body-begin "^\n"))) - (setq body-begin (point)) - (or (and nndoc-body-end-function - (funcall nndoc-body-end-function)) - (and nndoc-body-end - (nndoc-search nndoc-body-end)) - (if nndoc-article-begin-function - (funcall nndoc-article-begin-function) - (nndoc-search nndoc-article-begin)) - (progn - (goto-char (point-max)) - (when nndoc-file-end - (and (re-search-backward nndoc-file-end nil t) - (beginning-of-line))))) - (setq body-end (point)) - (push (list (incf i) head-begin head-end body-begin body-end - (count-lines body-begin body-end)) - nndoc-dissection-alist)))))) +;;; +;;; Built-in type predicates and functions +;;; -(defun nndoc-unquote-dashes () - "Unquote quoted non-separators in digests." - (while (re-search-forward "^- -"nil t) - (replace-match "-" t t))) - -(defun nndoc-digest-body-end () - (and (re-search-forward nndoc-article-begin nil t) - (goto-char (match-beginning 0)))) +(defun nndoc-mbox-type-p () + (when (looking-at message-unix-mail-delimiter) + t)) (defun nndoc-mbox-article-begin () - (when (re-search-forward nndoc-article-begin nil t) + (when (re-search-forward (concat "^" message-unix-mail-delimiter) nil t) (goto-char (match-beginning 0)))) (defun nndoc-mbox-body-end () @@ -422,24 +347,71 @@ len end) (when (save-excursion - (and (re-search-backward nndoc-article-begin nil t) + (and (re-search-backward + (concat "^" message-unix-mail-delimiter) nil t) (setq end (point)) (search-forward "\n\n" beg t) (re-search-backward "^Content-Length:[ \t]*\\([0-9]+\\) *$" end t) (setq len (string-to-int (match-string 1))) (search-forward "\n\n" beg t) - (or (= (setq len (+ (point) len)) (point-max)) - (and (< len (point-max)) - (goto-char len) - (looking-at nndoc-article-begin))))) + (unless (= (setq len (+ (point) len)) (point-max)) + (and (< len (point-max)) + (goto-char len) + (looking-at message-unix-mail-delimiter))))) (goto-char len)))) +(defun nndoc-mmdf-type-p () + (when (looking-at "\^A\^A\^A\^A$") + t)) + +(defun nndoc-news-type-p () + (when (looking-at "^Path:.*\n") + t)) + +(defun nndoc-rnews-type-p () + (when (looking-at "#! *rnews") + t)) + (defun nndoc-rnews-body-end () (and (re-search-backward nndoc-article-begin nil t) (forward-line 1) (goto-char (+ (point) (string-to-int (match-string 1)))))) +(defun nndoc-babyl-type-p () + (when (re-search-forward "\^_\^L *\n" nil t) + t)) + +(defun nndoc-babyl-body-begin () + (re-search-forward "^\n" nil t) + (when (looking-at "\*\*\* EOOH \*\*\*") + (let ((next (or (save-excursion + (re-search-forward nndoc-article-begin nil t)) + (point-max)))) + (unless (re-search-forward "^\n" next t) + (goto-char next) + (forward-line -1) + (insert "\n") + (forward-line -1))))) + +(defun nndoc-babyl-head-begin () + (when (re-search-forward "^[0-9].*\n" nil t) + (when (looking-at "\*\*\* EOOH \*\*\*") + (forward-line 1)) + t)) + +(defun nndoc-forward-type-p () + (when (and (re-search-forward "^-+ Start of forwarded message -+\n+" nil t) + (not (re-search-forward "^Subject:.*digest" nil t)) + (not (re-search-backward "^From:" nil t 2)) + (not (re-search-forward "^From:" nil t 2))) + t)) + +(defun nndoc-clari-briefs-type-p () + (when (let ((case-fold-search nil)) + (re-search-forward "^\t[^a-z]+ ([^a-z]+) --" nil t)) + t)) + (defun nndoc-transform-clari-briefs (article) (goto-char (point-min)) (when (looking-at " *\\*\\(.*\\)\n") @@ -466,16 +438,168 @@ (insert "From: " "clari@clari.net (" (or from "unknown") ")" "\nSubject: " (or subject "(no subject)") "\n"))) -(defun nndoc-babyl-body-begin () - (re-search-forward "^\n" nil t) - (when (looking-at "\*\*\* EOOH \*\*\*") - (re-search-forward "^\n" nil t))) +(defun nndoc-mime-digest-type-p () + (let ((case-fold-search t) + boundary-id b-delimiter entry) + (when (and + (re-search-forward + (concat "^Content-Type: *multipart/digest;[ \t\n]*[ \t]" + "boundary=\"\\([^\"\n]*[^\" \t\n]\\)\"") + nil t) + (match-beginning 1)) + (setq boundary-id (match-string 1) + b-delimiter (concat "\n--" boundary-id "[\n \t]+")) + (setq entry (assq 'mime-digest nndoc-type-alist)) + (setcdr entry + (list + (cons 'head-end "^ ?$") + (cons 'body-begin "^ ?\n") + (cons 'article-begin b-delimiter) + (cons 'body-end-function 'nndoc-digest-body-end) + (cons 'file-end (concat "\n--" boundary-id "--[ \t]*$")))) + t))) + +(defun nndoc-standard-digest-type-p () + (when (and (re-search-forward (concat "^" (make-string 70 ?-) "\n\n") nil t) + (re-search-forward + (concat "\n\n" (make-string 30 ?-) "\n\n") nil t)) + t)) + +(defun nndoc-digest-body-end () + (and (re-search-forward nndoc-article-begin nil t) + (goto-char (match-beginning 0)))) + +(defun nndoc-slack-digest-type-p () + 0) + +(defun nndoc-lanl-gov-announce-type-p () + (when (let ((case-fold-search nil)) + (re-search-forward "^\\\\\\\\\nPaper: [a-z-]+/[0-9]+" nil t)) + t)) + +(defun nndoc-transform-lanl-gov-announce (article) + (goto-char (point-max)) + (when (re-search-backward "^\\\\\\\\ +(\\([^ ]*\\) , *\\([^ ]*\\))" nil t) + (replace-match "\n\nGet it at \\1 (\\2)" t nil)) + ;; (when (re-search-backward "^\\\\\\\\$" nil t) + ;; (replace-match "" t t)) + ) + +(defun nndoc-generate-lanl-gov-head (article) + (let ((entry (cdr (assq article nndoc-dissection-alist))) + (e-mail "no address given") + subject from) + (save-excursion + (set-buffer nndoc-current-buffer) + (save-restriction + (narrow-to-region (car entry) (nth 1 entry)) + (goto-char (point-min)) + (when (looking-at "^Paper.*: \\([a-z-]+/[0-9]+\\)") + (setq subject (concat " (" (match-string 1) ")")) + (when (re-search-forward "^From: \\([^ ]+\\)" nil t) + (setq e-mail (match-string 1))) + (when (re-search-forward "^Title: \\([^\f]*\\)\nAuthors?: \\(.*\\)" + nil t) + (setq subject (concat (match-string 1) subject)) + (setq from (concat (match-string 2) " <" e-mail ">")))) + )) + (while (and from (string-match "(\[^)\]*)" from)) + (setq from (replace-match "" t t from))) + (insert "From: " (or from "unknown") + "\nSubject: " (or subject "(no subject)") "\n"))) + + + +;;; +;;; Functions for dissecting the documents +;;; + +(defun nndoc-search (regexp) + (prog1 + (re-search-forward regexp nil t) + (beginning-of-line))) -(defun nndoc-babyl-head-begin () - (when (re-search-forward "^[0-9].*\n" nil t) - (when (looking-at "\*\*\* EOOH \*\*\*") - (forward-line 1)) - t)) +(defun nndoc-dissect-buffer () + "Go through the document and partition it into heads/bodies/articles." + (let ((i 0) + (first t) + head-begin head-end body-begin body-end) + (setq nndoc-dissection-alist nil) + (save-excursion + (set-buffer nndoc-current-buffer) + (goto-char (point-min)) + ;; Find the beginning of the file. + (when nndoc-file-begin + (nndoc-search nndoc-file-begin)) + ;; Go through the file. + (while (if (and first nndoc-first-article) + (nndoc-search nndoc-first-article) + (nndoc-article-begin)) + (setq first nil) + (cond (nndoc-head-begin-function + (funcall nndoc-head-begin-function)) + (nndoc-head-begin + (nndoc-search nndoc-head-begin))) + (if (or (>= (point) (point-max)) + (and nndoc-file-end + (looking-at nndoc-file-end))) + (goto-char (point-max)) + (setq head-begin (point)) + (nndoc-search (or nndoc-head-end "^$")) + (setq head-end (point)) + (if nndoc-body-begin-function + (funcall nndoc-body-begin-function) + (nndoc-search (or nndoc-body-begin "^\n"))) + (setq body-begin (point)) + (or (and nndoc-body-end-function + (funcall nndoc-body-end-function)) + (and nndoc-body-end + (nndoc-search nndoc-body-end)) + (nndoc-article-begin) + (progn + (goto-char (point-max)) + (when nndoc-file-end + (and (re-search-backward nndoc-file-end nil t) + (beginning-of-line))))) + (setq body-end (point)) + (push (list (incf i) head-begin head-end body-begin body-end + (count-lines body-begin body-end)) + nndoc-dissection-alist)))))) + +(defun nndoc-article-begin () + (if nndoc-article-begin-function + (funcall nndoc-article-begin-function) + (ignore-errors + (nndoc-search nndoc-article-begin)))) + +(defun nndoc-unquote-dashes () + "Unquote quoted non-separators in digests." + (while (re-search-forward "^- -"nil t) + (replace-match "-" t t))) + +;;;###autoload +(defun nndoc-add-type (definition &optional position) + "Add document DEFINITION to the list of nndoc document definitions. +If POSITION is nil or `last', the definition will be added +as the last checked definition, if t or `first', add as the +first definition, and if any other symbol, add after that +symbol in the alist." + ;; First remove any old instances. + (setq nndoc-type-alist + (delq (assq (car definition) nndoc-type-alist) + nndoc-type-alist)) + ;; Then enter the new definition in the proper place. + (cond + ((or (null position) (eq position 'last)) + (setq nndoc-type-alist (nconc nndoc-type-alist (list definition)))) + ((or (eq position t) (eq position 'first)) + (push definition nndoc-type-alist)) + (t + (let ((list (memq (assq position nndoc-type-alist) + nndoc-type-alist))) + (unless list + (error "No such position: %s" position)) + (setcdr list (cons definition (cdr list))))))) (provide 'nndoc) diff -r ad457d5f7d04 -r 0293115a14e9 lisp/gnus/nndraft.el --- a/lisp/gnus/nndraft.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/gnus/nndraft.el Mon Aug 13 08:49:20 2007 +0200 @@ -1,5 +1,5 @@ ;;; nndraft.el --- draft article access for Gnus -;; Copyright (C) 1995,96 Free Software Foundation, Inc. +;; Copyright (C) 1995,96,97 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; Keywords: news @@ -203,14 +203,14 @@ (deffoo nndraft-close-group (group &optional server) t) -(deffoo nndraft-request-create-group (group &optional server) +(deffoo nndraft-request-create-group (group &optional server args) (if (file-exists-p nndraft-directory) (if (file-directory-p nndraft-directory) t nil) (condition-case () (progn - (make-directory nndraft-directory t) + (gnus-make-directory nndraft-directory) t) (file-error nil)))) @@ -219,8 +219,8 @@ (defun nndraft-execute-nnmh-command (command) (let ((dir (expand-file-name nndraft-directory))) - (and (string-match "/$" dir) - (setq dir (substring dir 0 (match-beginning 0)))) + (when (string-match "/$" dir) + (setq dir (substring dir 0 (match-beginning 0)))) (string-match "/[^/]+$" dir) (let ((group (substring dir (1+ (match-beginning 0)))) (nnmh-directory (substring dir 0 (1+ (match-beginning 0)))) diff -r ad457d5f7d04 -r 0293115a14e9 lisp/gnus/nneething.el --- a/lisp/gnus/nneething.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/gnus/nneething.el Mon Aug 13 08:49:20 2007 +0200 @@ -1,5 +1,5 @@ ;;; nneething.el --- random file access for Gnus -;; Copyright (C) 1995,96 Free Software Foundation, Inc. +;; Copyright (C) 1995,96,97 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; Masanobu UMEDA @@ -33,7 +33,8 @@ (require 'nnheader) (require 'nnmail) (require 'nnoo) -(eval-when-compile (require 'cl)) +(require 'gnus-util) +(require 'cl) (nnoo-declare nneething) @@ -115,18 +116,18 @@ (deffoo nneething-request-article (id &optional group server buffer) (nneething-possibly-change-directory group) - (let ((file (unless (stringp id) (nneething-file-name id))) + (let ((file (unless (stringp id) + (nneething-file-name id))) (nntp-server-buffer (or buffer nntp-server-buffer))) (and (stringp file) ; We did not request by Message-ID. (file-exists-p file) ; The file exists. (not (file-directory-p file)) ; It's not a dir. (save-excursion (nnmail-find-file file) ; Insert the file in the nntp buf. - (or (nnheader-article-p) ; Either it's a real article... - (progn - (goto-char (point-min)) - (nneething-make-head file (current-buffer)) ; ... or we fake some headers. - (insert "\n"))) + (unless (nnheader-article-p) ; Either it's a real article... + (goto-char (point-min)) + (nneething-make-head file (current-buffer)) ; ... or we fake some headers. + (insert "\n")) t)))) (deffoo nneething-request-group (group &optional dir dont-check) @@ -180,8 +181,7 @@ (defun nneething-map-file () ;; We make sure that the .nneething directory exists. - (unless (file-exists-p nneething-map-file-directory) - (make-directory nneething-map-file-directory 'parents)) + (gnus-make-directory nneething-map-file-directory) ;; We store it in a special directory under the user's home dir. (concat (file-name-as-directory nneething-map-file-directory) nneething-group nneething-map-file)) @@ -191,17 +191,17 @@ (let ((map-file (nneething-map-file)) (files (directory-files nneething-directory)) touched map-files) - (if (file-exists-p map-file) - (condition-case nil - (load map-file nil t t) - (error nil))) - (or nneething-active (setq nneething-active (cons 1 0))) + (when (file-exists-p map-file) + (ignore-errors + (load map-file nil t t))) + (unless nneething-active + (setq nneething-active (cons 1 0))) ;; Old nneething had a different map format. (when (and (cdar nneething-map) (atom (cdar nneething-map))) (setq nneething-map (mapcar (lambda (n) - (list (cdr n) (car n) + (list (cdr n) (car n) (nth 5 (file-attributes (nneething-file-name (car n)))))) nneething-map))) @@ -234,24 +234,23 @@ (setq map (cdr map)))) ;; Find all new files and enter them into the map. (while files - (unless (member (car files) map-files) + (unless (member (car files) map-files) ;; This file is not in the map, so we enter it. (setq touched t) (setcdr nneething-active (1+ (cdr nneething-active))) - (push (list (cdr nneething-active) (car files) + (push (list (cdr nneething-active) (car files) (nth 5 (file-attributes (nneething-file-name (car files))))) nneething-map)) (setq files (cdr files))) (when (and touched (not nneething-read-only)) - (save-excursion - (nnheader-set-temp-buffer " *nneething map*") - (insert "(setq nneething-map '" (prin1-to-string nneething-map) ")\n" - "(setq nneething-active '" (prin1-to-string nneething-active) - ")\n") - (write-region (point-min) (point-max) map-file nil 'nomesg) - (kill-buffer (current-buffer)))))) + (nnheader-temp-write map-file + (insert "(setq nneething-map '") + (gnus-prin1 nneething-map) + (insert ")\n(setq nneething-active '") + (gnus-prin1 nneething-active) + (insert ")\n"))))) (defun nneething-insert-head (file) "Insert the head of FILE." @@ -269,11 +268,11 @@ "@" (system-name) ">\n" (if (equal '(0 0) (nth 5 atts)) "" (concat "Date: " (current-time-string (nth 5 atts)) "\n")) - (or (if buffer - (save-excursion - (set-buffer buffer) - (if (re-search-forward "<[a-zA-Z0-9_]@[-a-zA-Z0-9_]>" 1000 t) - (concat "From: " (match-string 0) "\n")))) + (or (when buffer + (save-excursion + (set-buffer buffer) + (when (re-search-forward "<[a-zA-Z0-9_]@[-a-zA-Z0-9_]>" 1000 t) + (concat "From: " (match-string 0) "\n")))) (nneething-from-line (nth 2 atts) file)) (if (> (string-to-int (int-to-string (nth 7 atts))) 0) (concat "Chars: " (int-to-string (nth 7 atts)) "\n") @@ -282,7 +281,8 @@ (save-excursion (set-buffer buffer) (concat "Lines: " (int-to-string - (count-lines (point-min) (point-max))) "\n")) + (count-lines (point-min) (point-max))) + "\n")) "") ))) @@ -302,13 +302,13 @@ (host (if (string-match "\\`/[^/@]*@\\([^:/]+\\):" file) (prog1 (substring file - (match-beginning 1) + (match-beginning 1) (match-end 1)) - (if (string-match "/\\(users\\|home\\)/\\([^/]+\\)/" file) - (setq login (substring file - (match-beginning 2) - (match-end 2)) - name nil))) + (when (string-match "/\\(users\\|home\\)/\\([^/]+\\)/" file) + (setq login (substring file + (match-beginning 2) + (match-end 2)) + name nil))) (system-name)))) (concat "From: " login "@" host (if name (concat " (" name ")") "") "\n"))) diff -r ad457d5f7d04 -r 0293115a14e9 lisp/gnus/nnfolder.el --- a/lisp/gnus/nnfolder.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/gnus/nnfolder.el Mon Aug 13 08:49:20 2007 +0200 @@ -1,5 +1,5 @@ ;;; nnfolder.el --- mail folder access for Gnus -;; Copyright (C) 1995,96 Free Software Foundation, Inc. +;; Copyright (C) 1995,96,97 Free Software Foundation, Inc. ;; Author: Scott Byer ;; Lars Magne Ingebrigtsen @@ -25,18 +25,14 @@ ;;; Commentary: -;; For an overview of what the interface functions do, please see the -;; Gnus sources. - -;; Various enhancements by byer@mv.us.adobe.com (Scott Byer). - ;;; Code: (require 'nnheader) (require 'message) (require 'nnmail) (require 'nnoo) -(eval-when-compile (require 'cl)) +(require 'cl) +(require 'gnus-util) (nnoo-declare nnfolder) @@ -104,8 +100,7 @@ (save-excursion (set-buffer nntp-server-buffer) (erase-buffer) - (let ((delim-string (concat "^" message-unix-mail-delimiter)) - article art-string start stop) + (let (article art-string start stop) (nnfolder-possibly-change-group group server) (when nnfolder-current-buffer (set-buffer nnfolder-current-buffer) @@ -116,22 +111,21 @@ (setq article (car articles)) (setq art-string (nnfolder-article-string article)) (set-buffer nnfolder-current-buffer) - (if (or (search-forward art-string nil t) - ;; Don't search the whole file twice! Also, articles - ;; probably have some locality by number, so searching - ;; backwards will be faster. Especially if we're at the - ;; beginning of the buffer :-). -SLB - (search-backward art-string nil t)) - (progn - (setq start (or (re-search-backward delim-string nil t) - (point))) - (search-forward "\n\n" nil t) - (setq stop (1- (point))) - (set-buffer nntp-server-buffer) - (insert (format "221 %d Article retrieved.\n" article)) - (insert-buffer-substring nnfolder-current-buffer start stop) - (goto-char (point-max)) - (insert ".\n"))) + (when (or (search-forward art-string nil t) + ;; Don't search the whole file twice! Also, articles + ;; probably have some locality by number, so searching + ;; backwards will be faster. Especially if we're at the + ;; beginning of the buffer :-). -SLB + (search-backward art-string nil t)) + (nnmail-search-unix-mail-delim-backward) + (setq start (point)) + (search-forward "\n\n" nil t) + (setq stop (1- (point))) + (set-buffer nntp-server-buffer) + (insert (format "221 %d Article retrieved.\n" article)) + (insert-buffer-substring nnfolder-current-buffer start stop) + (goto-char (point-max)) + (insert ".\n")) (setq articles (cdr articles))) (set-buffer nntp-server-buffer) @@ -141,9 +135,7 @@ (deffoo nnfolder-open-server (server &optional defs) (nnoo-change-server 'nnfolder server defs) (when (not (file-exists-p nnfolder-directory)) - (condition-case () - (make-directory nnfolder-directory t) - (error t))) + (gnus-make-directory nnfolder-directory)) (cond ((not (file-exists-p nnfolder-directory)) (nnfolder-close-server) @@ -171,33 +163,32 @@ (save-excursion (set-buffer nnfolder-current-buffer) (goto-char (point-min)) - (if (search-forward (nnfolder-article-string article) nil t) - (let (start stop) - (re-search-backward (concat "^" message-unix-mail-delimiter) nil t) - (setq start (point)) - (forward-line 1) - (or (and (re-search-forward - (concat "^" message-unix-mail-delimiter) nil t) - (forward-line -1)) - (goto-char (point-max))) - (setq stop (point)) - (let ((nntp-server-buffer (or buffer nntp-server-buffer))) - (set-buffer nntp-server-buffer) - (erase-buffer) - (insert-buffer-substring nnfolder-current-buffer start stop) + (when (search-forward (nnfolder-article-string article) nil t) + (let (start stop) + (nnmail-search-unix-mail-delim-backward) + (setq start (point)) + (forward-line 1) + (unless (and (nnmail-search-unix-mail-delim) + (forward-line -1)) + (goto-char (point-max))) + (setq stop (point)) + (let ((nntp-server-buffer (or buffer nntp-server-buffer))) + (set-buffer nntp-server-buffer) + (erase-buffer) + (insert-buffer-substring nnfolder-current-buffer start stop) + (goto-char (point-min)) + (while (looking-at "From ") + (delete-char 5) + (insert "X-From-Line: ") + (forward-line 1)) + (if (numberp article) + (cons nnfolder-current-group article) (goto-char (point-min)) - (while (looking-at "From ") - (delete-char 5) - (insert "X-From-Line: ") - (forward-line 1)) - (if (numberp article) - (cons nnfolder-current-group article) - (goto-char (point-min)) - (search-forward (concat "\n" nnfolder-article-marker)) - (cons nnfolder-current-group - (string-to-int - (buffer-substring - (point) (progn (end-of-line) (point))))))))))) + (search-forward (concat "\n" nnfolder-article-marker)) + (cons nnfolder-current-group + (string-to-int + (buffer-substring + (point) (progn (end-of-line) (point))))))))))) (deffoo nnfolder-request-group (group &optional server dont-check) (save-excursion @@ -275,7 +266,7 @@ nnfolder-current-buffer nil) t) -(deffoo nnfolder-request-create-group (group &optional server) +(deffoo nnfolder-request-create-group (group &optional server args) (nnfolder-possibly-change-group nil server) (nnmail-activate 'nnfolder) (when group @@ -288,7 +279,8 @@ (nnfolder-possibly-change-group nil server) (save-excursion (nnmail-find-file nnfolder-active-file) - (setq nnfolder-group-alist (nnmail-get-active)))) + (setq nnfolder-group-alist (nnmail-get-active)) + t)) (deffoo nnfolder-request-newgroups (date &optional server) (nnfolder-possibly-change-group nil server) @@ -310,19 +302,21 @@ (set-buffer nnfolder-current-buffer) (while (and articles is-old) (goto-char (point-min)) - (if (search-forward (nnfolder-article-string (car articles)) nil t) - (if (setq is-old - (nnmail-expired-article-p - newsgroup - (buffer-substring - (point) (progn (end-of-line) (point))) - force nnfolder-inhibit-expiry)) - (progn - (nnheader-message 5 "Deleting article %d..." - (car articles) newsgroup) - (nnfolder-delete-mail)) - (setq rest (cons (car articles) rest)))) + (when (search-forward (nnfolder-article-string (car articles)) nil t) + (if (setq is-old + (nnmail-expired-article-p + newsgroup + (buffer-substring + (point) (progn (end-of-line) (point))) + force nnfolder-inhibit-expiry)) + (progn + (nnheader-message 5 "Deleting article %d..." + (car articles) newsgroup) + (nnfolder-delete-mail)) + (push (car articles) rest))) (setq articles (cdr articles))) + (unless nnfolder-inhibit-expiry + (nnheader-message 5 "Deleting articles...done")) (nnfolder-save-buffer) ;; Find the lowest active article in this group. (let* ((active (cadr (assoc newsgroup nnfolder-group-alist))) @@ -342,7 +336,6 @@ (deffoo nnfolder-request-move-article (article group server accept-form &optional last) - (nnfolder-possibly-change-group group server) (let ((buf (get-buffer-create " *nnfolder move*")) result) (and @@ -365,15 +358,14 @@ (nnfolder-possibly-change-group group server) (set-buffer nnfolder-current-buffer) (goto-char (point-min)) - (if (search-forward (nnfolder-article-string article) nil t) - (nnfolder-delete-mail)) + (when (search-forward (nnfolder-article-string article) nil t) + (nnfolder-delete-mail)) (and last (nnfolder-save-buffer)))) result)) (deffoo nnfolder-request-accept-article (group &optional server last) (nnfolder-possibly-change-group group server) (nnmail-check-syntax) - (and (stringp group) (nnfolder-possibly-change-group group)) (let ((buf (current-buffer)) result) (goto-char (point-min)) @@ -388,7 +380,11 @@ (forward-line -1) (while (re-search-backward (concat "^" nnfolder-article-marker) nil t) (delete-region (point) (progn (forward-line 1) (point)))) - (setq result (car (nnfolder-save-mail (and (stringp group) group))))) + (setq result + (car (nnfolder-save-mail + (if (stringp group) + (list (cons group (nnfolder-active-number group))) + (nnmail-article-group 'nnfolder-active-number)))))) (save-excursion (set-buffer nnfolder-current-buffer) (and last (nnfolder-save-buffer)))) @@ -415,9 +411,8 @@ (if (not force) () ; Don't delete the articles. ;; Delete the file that holds the group. - (condition-case nil - (delete-file (nnfolder-group-pathname group)) - (error nil))) + (ignore-errors + (delete-file (nnfolder-group-pathname group)))) ;; Remove the group from all structures. (setq nnfolder-group-alist (delq (assoc group nnfolder-group-alist) nnfolder-group-alist) @@ -432,13 +427,11 @@ (save-excursion (set-buffer nnfolder-current-buffer) (and (file-writable-p buffer-file-name) - (condition-case () - (progn - (rename-file - buffer-file-name - (nnfolder-group-pathname new-name)) - t) - (error nil)) + (ignore-errors + (rename-file + buffer-file-name + (nnfolder-group-pathname new-name)) + t) ;; That went ok, so we change the internal structures. (let ((entry (assoc group nnfolder-group-alist))) (and entry (setcar entry new-name)) @@ -463,15 +456,15 @@ (save-excursion (delete-region (save-excursion - (re-search-backward (concat "^" message-unix-mail-delimiter) nil t) + (nnmail-search-unix-mail-delim-backward) (if leave-delim (progn (forward-line 1) (point)) - (match-beginning 0))) + (point))) (progn (forward-line 1) - (if (re-search-forward (concat "^" message-unix-mail-delimiter) nil t) + (if (nnmail-search-unix-mail-delim) (if (and (not (bobp)) leave-delim) (progn (forward-line -2) (point)) - (match-beginning 0)) + (point)) (point-max)))))) ;; When scanning, we're not looking t immediately switch into the group - if @@ -482,15 +475,13 @@ (nnfolder-open-server server)) (when (and group (or nnfolder-current-buffer (not (equal group nnfolder-current-group)))) - (unless (file-exists-p nnfolder-directory) - (make-directory (directory-file-name nnfolder-directory) t)) + (gnus-make-directory (directory-file-name nnfolder-directory)) (nnfolder-possibly-activate-groups nil) (or (assoc group nnfolder-group-alist) (not (file-exists-p (nnfolder-group-pathname group))) (progn - (setq nnfolder-group-alist - (cons (list group (cons 1 0)) nnfolder-group-alist)) + (push (list group (cons 1 0)) nnfolder-group-alist) (nnmail-save-active nnfolder-group-alist nnfolder-active-file))) (let (inf file) (if (and (equal group nnfolder-current-group) @@ -502,64 +493,54 @@ ;; If we have to change groups, see if we don't already have the mbox ;; in memory. If we do, verify the modtime and destroy the mbox if ;; needed so we can rescan it. - (if (setq inf (assoc group nnfolder-buffer-alist)) - (setq nnfolder-current-buffer (nth 1 inf))) + (when (setq inf (assoc group nnfolder-buffer-alist)) + (setq nnfolder-current-buffer (nth 1 inf))) ;; If the buffer is not live, make sure it isn't in the alist. If it ;; is live, verify that nobody else has touched the file since last ;; time. - (if (or (not (and nnfolder-current-buffer - (buffer-name nnfolder-current-buffer))) - (not (and (bufferp nnfolder-current-buffer) - (verify-visited-file-modtime - nnfolder-current-buffer)))) - (progn - (if (and nnfolder-current-buffer - (buffer-name nnfolder-current-buffer) - (bufferp nnfolder-current-buffer)) - (kill-buffer nnfolder-current-buffer)) - (setq nnfolder-buffer-alist (delq inf nnfolder-buffer-alist)) - (setq inf nil))) + (when (or (not (and nnfolder-current-buffer + (buffer-name nnfolder-current-buffer))) + (not (and (bufferp nnfolder-current-buffer) + (verify-visited-file-modtime + nnfolder-current-buffer)))) + (when (and nnfolder-current-buffer + (buffer-name nnfolder-current-buffer) + (bufferp nnfolder-current-buffer)) + (kill-buffer nnfolder-current-buffer)) + (setq nnfolder-buffer-alist (delq inf nnfolder-buffer-alist)) + (setq inf nil)) - (if inf - () + (unless inf (save-excursion (setq file (nnfolder-group-pathname group)) - (if (file-directory-p (file-truename file)) - () + (unless (file-directory-p (file-truename file)) (unless (file-exists-p file) - (unless (file-exists-p (file-name-directory file)) - (make-directory (file-name-directory file) t)) - (write-region 1 1 file t 'nomesg)) + (gnus-make-directory (file-name-directory file)) + (nnmail-write-region 1 1 file t 'nomesg)) + (setq nnfolder-current-group group) (setq nnfolder-current-buffer (nnfolder-read-folder file scanning)) - (if nnfolder-current-buffer - (progn - (set-buffer nnfolder-current-buffer) - (setq nnfolder-buffer-alist - (cons (list group nnfolder-current-buffer) - nnfolder-buffer-alist))))))))) + (when nnfolder-current-buffer + (set-buffer nnfolder-current-buffer) + (push (list group nnfolder-current-buffer) + nnfolder-buffer-alist))))))) (setq nnfolder-current-group group))) -(defun nnfolder-save-mail (&optional group) +(defun nnfolder-save-mail (group-art-list) "Called narrowed to an article." - (let* ((nnmail-split-methods - (if group (list (list group "")) nnmail-split-methods)) - (group-art-list - (nreverse (nnmail-article-group 'nnfolder-active-number))) - (delim (concat "^" message-unix-mail-delimiter)) - save-list group-art) + (let* (save-list group-art) (goto-char (point-min)) ;; The From line may have been quoted by movemail. (when (looking-at (concat ">" message-unix-mail-delimiter)) (delete-char 1)) ;; This might come from somewhere else. - (unless (looking-at delim) + (unless (looking-at message-unix-mail-delimiter) (insert "From nobody " (current-time-string) "\n") (goto-char (point-min))) ;; Quote all "From " lines in the article. (forward-line 1) - (while (re-search-forward delim nil t) + (while (re-search-forward "^From " nil t) (beginning-of-line) (insert "> ")) (setq save-list group-art-list) @@ -594,7 +575,8 @@ (goto-char (point-max)) (unless (eolp) (insert "\n")) - (insert "\n") + (unless (bobp) + (insert "\n")) (insert-buffer-substring obuf beg end) (set-buffer obuf))) @@ -604,17 +586,17 @@ (defun nnfolder-insert-newsgroup-line (group-art) (save-excursion (goto-char (point-min)) - (if (search-forward "\n\n" nil t) - (progn - (forward-char -1) - (insert (format (concat nnfolder-article-marker "%d %s\n") - (cdr group-art) (current-time-string))))))) + (when (search-forward "\n\n" nil t) + (forward-char -1) + (insert (format (concat nnfolder-article-marker "%d %s\n") + (cdr group-art) (current-time-string)))))) (defun nnfolder-possibly-activate-groups (&optional group) (save-excursion ;; If we're looking for the activation of a specific group, find out ;; its real name and switch to it. - (if group (nnfolder-possibly-change-group group)) + (when group + (nnfolder-possibly-change-group group)) ;; If the group alist isn't active, activate it now. (nnmail-activate 'nnfolder))) @@ -629,9 +611,8 @@ ;; This group is new, so we create a new entry for it. ;; This might be a bit naughty... creating groups on the drop of ;; a hat, but I don't know... - (setq nnfolder-group-alist - (cons (list group (setq active (cons 1 1))) - nnfolder-group-alist))) + (push (list group (setq active (cons 1 1))) + nnfolder-group-alist)) (cdr active)) (nnmail-save-active nnfolder-group-alist nnfolder-active-file) (nnfolder-possibly-activate-groups group))))) @@ -657,7 +638,7 @@ ;; if we know we've seen it since the last time it was touched. (let ((scantime (cadr (assoc nnfolder-current-group nnfolder-scantime-alist))) - (modtime (nth 5 (or (file-attributes file) '(nil nil nil nil nil))))) + (modtime (nth 5 (file-attributes file)))) (if (and scanning scantime (eq (car scantime) (car modtime)) (eq (cdr scantime) (cadr modtime))) @@ -666,8 +647,9 @@ (nnfolder-possibly-activate-groups nil) ;; Read in the file. (set-buffer (setq nnfolder-current-buffer - (nnheader-find-file-noselect file nil 'raw))) + (nnheader-find-file-noselect file))) (buffer-disable-undo (current-buffer)) + (setq buffer-read-only nil) ;; If the file hasn't been touched since the last time we scanned it, ;; don't bother doing anything with it. (let ((delim (concat "^" message-unix-mail-delimiter)) @@ -691,53 +673,51 @@ ;; file entirely for mboxes.) (when (or nnfolder-ignore-active-file (< maxid 2)) - (while (and (search-forward marker nil t) - (re-search-forward number nil t)) - (let ((newnum (string-to-number (match-string 0)))) - (setq maxid (max maxid newnum)) - (setq minid (min minid newnum)))) - (setcar active (max 1 (min minid maxid))) - (setcdr active (max maxid (cdr active))) - (goto-char (point-min))) + (while (and (search-forward marker nil t) + (re-search-forward number nil t)) + (let ((newnum (string-to-number (match-string 0)))) + (setq maxid (max maxid newnum)) + (setq minid (min minid newnum)))) + (setcar active (max 1 (min minid maxid))) + (setcdr active (max maxid (cdr active))) + (goto-char (point-min))) ;; As long as we trust that the user will only insert unmarked mail ;; at the end, go to the end and search backwards for the last ;; marker. Find the start of that message, and begin to search for ;; unmarked messages from there. - (if (not (or nnfolder-distrust-mbox - (< maxid 2))) - (progn - (goto-char (point-max)) - (if (not (re-search-backward marker nil t)) - (goto-char (point-min)) - (if (not (re-search-backward delim nil t)) - (goto-char (point-min)))))) + (when (not (or nnfolder-distrust-mbox + (< maxid 2))) + (goto-char (point-max)) + (if (not (re-search-backward marker nil t)) + (goto-char (point-min)) + (when (not (nnmail-search-unix-mail-delim)) + (goto-char (point-min))))) ;; Keep track of the active number on our own, and insert it back - ;; into the active list when we're done. Also, prime the pump to + ;; into the active list when we're done. Also, prime the pump to ;; cut down on the number of searches we do. (setq end (point-marker)) - (set-marker end (or (and (re-search-forward delim nil t) - (match-beginning 0)) + (set-marker end (or (and (nnmail-search-unix-mail-delim) + (point)) (point-max))) (while (not (= end (point-max))) (setq start (marker-position end)) (goto-char end) ;; There may be more than one "From " line, so we skip past ;; them. - (while (looking-at delim) + (while (looking-at delim) (forward-line 1)) - (set-marker end (or (and (re-search-forward delim nil t) - (match-beginning 0)) + (set-marker end (or (and (nnmail-search-unix-mail-delim) + (point)) (point-max))) (goto-char start) - (if (not (search-forward marker end t)) - (progn - (narrow-to-region start end) - (nnmail-insert-lines) - (nnfolder-insert-newsgroup-line - (cons nil (nnfolder-active-number nnfolder-current-group))) - (widen)))) + (when (not (search-forward marker end t)) + (narrow-to-region start end) + (nnmail-insert-lines) + (nnfolder-insert-newsgroup-line + (cons nil (nnfolder-active-number nnfolder-current-group))) + (widen))) ;; Make absolutely sure that the active list reflects reality! (nnmail-save-active nnfolder-group-alist nnfolder-active-file) @@ -745,7 +725,7 @@ (setq newscantime (visited-file-modtime)) (if scantime (setcdr scantime (list newscantime)) - (push (list nnfolder-current-group newscantime) + (push (list nnfolder-current-group newscantime) nnfolder-scantime-alist)) (current-buffer)))))) @@ -755,15 +735,15 @@ (interactive) (nnmail-activate 'nnfolder) (let ((files (directory-files nnfolder-directory)) - file) + file) (while (setq file (pop files)) (when (and (not (backup-file-name-p file)) - (nnheader-mail-file-mbox-p file)) - (nnheader-message 5 "Adding group %s..." file) - (push (list file (cons 1 0)) nnfolder-group-alist) - (nnfolder-possibly-change-group file) -;; (nnfolder-read-folder file) - (nnfolder-close-group file)) + (nnheader-mail-file-mbox-p + (concat nnfolder-directory file))) + (nnheader-message 5 "Adding group %s..." file) + (push (list file (cons 1 0)) nnfolder-group-alist) + (nnfolder-possibly-change-group file) + (nnfolder-close-group file)) (message "")))) (defun nnfolder-group-pathname (group) diff -r ad457d5f7d04 -r 0293115a14e9 lisp/gnus/nngateway.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus/nngateway.el Mon Aug 13 08:49:20 2007 +0200 @@ -0,0 +1,80 @@ +;;; nngateway.el --- posting news via mail gateways +;; Copyright (C) 1996,97 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen +;; Keywords: news, mail + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;;; Code: + +(require 'nnoo) +(require 'message) + +(nnoo-declare nngateway) + +(defvoo nngateway-address nil + "Address of the mail-to-news gateway.") + +(defvoo nngateway-header-transformation 'nngateway-simple-header-transformation + "Function to be called to rewrite the news headers into mail headers. +It is called narrowed to the headers to be transformed with one +parameter -- the gateway address.") + +;;; Interface functions + +(nnoo-define-basics nngateway) + +(deffoo nngateway-open-server (server &optional defs) + (if (nngateway-server-opened server) + t + (unless (assq 'nngateway-address defs) + (setq defs (append defs (list (list 'nngateway-address server))))) + (nnoo-change-server 'nngateway server defs))) + +(deffoo nngateway-request-post (&optional server) + (when (or (nngateway-server-opened server) + (nngateway-open-server server)) + ;; Rewrite the header. + (let ((buf (current-buffer))) + (nnheader-temp-write nil + (insert-buffer-substring buf) + (message-narrow-to-head) + (funcall nngateway-header-transformation nngateway-address) + (widen) + (let (message-required-mail-headers) + (message-send-mail)))))) + +;;; Internal functions + +(defun nngateway-simple-header-transformation (gateway) + "Transform the headers to use GATEWAY." + (let ((newsgroups (mail-fetch-field "newsgroups"))) + (message-remove-header "to") + (message-remove-header "cc") + (goto-char (point-min)) + (insert "To: " (nnheader-replace-chars-in-string newsgroups ?. ?-) + "@" gateway "\n"))) + +(nnoo-define-skeleton nngateway) + +(provide 'nngateway) + +;;; nngateway.el ends here diff -r ad457d5f7d04 -r 0293115a14e9 lisp/gnus/nnheader.el --- a/lisp/gnus/nnheader.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/gnus/nnheader.el Mon Aug 13 08:49:20 2007 +0200 @@ -1,5 +1,5 @@ ;;; nnheader.el --- header access macros for Gnus and its backends -;; Copyright (C) 1987,88,89,90,93,94,95,96 Free Software Foundation, Inc. +;; Copyright (C) 1987,88,89,90,93,94,95,96,97 Free Software Foundation, Inc. ;; Author: Masanobu UMEDA ;; Lars Magne Ingebrigtsen @@ -38,11 +38,13 @@ ;;; Code: (require 'mail-utils) -(eval-when-compile (require 'cl)) (defvar nnheader-max-head-length 4096 "*Max length of the head of articles.") +(defvar nnheader-head-chop-length 2048 + "*Length of each read operation when trying to fetch HEAD headers.") + (defvar nnheader-file-name-translation-alist nil "*Alist that says how to translate characters in file names. For instance, if \":\" is illegal as a file character in file names @@ -50,6 +52,12 @@ \(setq nnheader-file-name-translation-alist '((?: . ?_)))") +(eval-and-compile + (autoload 'nnmail-message-id "nnmail") + (autoload 'mail-position-on-field "sendmail") + (autoload 'message-remove-header "message") + (autoload 'cancel-function-timers "timers")) + ;;; Header access macros. (defmacro mail-header-number (header) @@ -130,22 +138,36 @@ "Create a new mail header structure initialized with INIT." (make-vector 9 init)) +(defun make-full-mail-header (&optional number subject from date id + references chars lines xref) + "Create a new mail header structure initialized with the parameters given." + (vector number subject from date id references chars lines xref)) + +;; fake message-ids: generation and detection + +(defvar nnheader-fake-message-id 1) + +(defsubst nnheader-generate-fake-message-id () + (concat "fake+none+" (int-to-string (incf nnheader-fake-message-id)))) + +(defsubst nnheader-fake-message-id-p (id) + (save-match-data ; regular message-id's are <.*> + (string-match "\\`fake\\+none\\+[0-9]+\\'" id))) + ;; Parsing headers and NOV lines. (defsubst nnheader-header-value () - (buffer-substring (match-end 0) (gnus-point-at-eol))) - -(defvar nnheader-newsgroup-none-id 1) + (buffer-substring (match-end 0) (point-at-eol))) (defun nnheader-parse-head (&optional naked) (let ((case-fold-search t) (cur (current-buffer)) (buffer-read-only nil) - end ref in-reply-to lines p) + in-reply-to lines p) (goto-char (point-min)) (when naked (insert "\n")) - ;; Search to the beginning of the next header. Error messages + ;; Search to the beginning of the next header. Error messages ;; do not begin with 2 or 3. (prog1 (when (or naked (re-search-forward "^[23][0-9]+ " nil t)) @@ -191,9 +213,7 @@ (nnheader-header-value) ;; If there was no message-id, we just fake one to make ;; subsequent routines simpler. - (concat "none+" - (int-to-string - (incf nnheader-newsgroup-none-id))))) + (nnheader-generate-fake-message-id))) ;; References. (progn (goto-char p) @@ -226,6 +246,39 @@ (goto-char (point-min)) (delete-char 1))))) +(defmacro nnheader-nov-skip-field () + '(search-forward "\t" eol 'move)) + +(defmacro nnheader-nov-field () + '(buffer-substring (point) (if (nnheader-nov-skip-field) (1- (point)) eol))) + +(defmacro nnheader-nov-read-integer () + '(prog1 + (if (= (following-char) ?\t) + 0 + (let ((num (ignore-errors (read (current-buffer))))) + (if (numberp num) num 0))) + (or (eobp) (forward-char 1)))) + +;; (defvar nnheader-none-counter 0) + +(defun nnheader-parse-nov () + (let ((eol (point-at-eol))) + (vector + (nnheader-nov-read-integer) ; number + (nnheader-nov-field) ; subject + (nnheader-nov-field) ; from + (nnheader-nov-field) ; date + (or (nnheader-nov-field) + (nnheader-generate-fake-message-id)) ; id + (nnheader-nov-field) ; refs + (nnheader-nov-read-integer) ; chars + (nnheader-nov-read-integer) ; lines + (if (= (following-char) ?\n) + nil + (nnheader-nov-field)) ; misc + ))) + (defun nnheader-insert-nov (header) (princ (mail-header-number header) (current-buffer)) (insert @@ -233,14 +286,15 @@ (or (mail-header-subject header) "(none)") "\t" (or (mail-header-from header) "(nobody)") "\t" (or (mail-header-date header) "") "\t" - (or (mail-header-id header) - (nnmail-message-id)) "\t" + (or (mail-header-id header) + (nnmail-message-id)) + "\t" (or (mail-header-references header) "") "\t") (princ (or (mail-header-chars header) 0) (current-buffer)) (insert "\t") (princ (or (mail-header-lines header) 0) (current-buffer)) (insert "\t") - (when (mail-header-xref header) + (when (mail-header-xref header) (insert "Xref: " (mail-header-xref header) "\t")) (insert "\n")) @@ -254,6 +308,61 @@ (forward-char -1) (insert ".")) +(defun nnheader-nov-delete-outside-range (beg end) + "Delete all NOV lines that lie outside the BEG to END range." + ;; First we find the first wanted line. + (nnheader-find-nov-line beg) + (delete-region (point-min) (point)) + ;; Then we find the last wanted line. + (when (nnheader-find-nov-line end) + (forward-line 1)) + (delete-region (point) (point-max))) + +(defun nnheader-find-nov-line (article) + "Put point at the NOV line that start with ARTICLE. +If ARTICLE doesn't exist, put point where that line +would have been. The function will return non-nil if +the line could be found." + ;; This function basically does a binary search. + (let ((max (point-max)) + (min (goto-char (point-min))) + (cur (current-buffer)) + (prev (point-min)) + num found) + (while (not found) + (goto-char (/ (+ max min) 2)) + (beginning-of-line) + (if (or (= (point) prev) + (eobp)) + (setq found t) + (setq prev (point)) + (cond ((> (setq num (read cur)) article) + (setq max (point))) + ((< num article) + (setq min (point))) + (t + (setq found 'yes))))) + ;; We may be at the first line. + (when (and (not num) + (not (eobp))) + (setq num (read cur))) + ;; Now we may have found the article we're looking for, or we + ;; may be somewhere near it. + (when (and (not (eq found 'yes)) + (not (eq num article))) + (setq found (point)) + (while (and (< (point) max) + (or (not (numberp num)) + (< num article))) + (forward-line 1) + (setq found (point)) + (or (eobp) + (= (setq num (read cur)) article))) + (unless (eq num article) + (goto-char found))) + (beginning-of-line) + (eq num article))) + ;; Various cruft the backends and Gnus need to communicate. (defvar nntp-server-buffer nil) @@ -269,7 +378,8 @@ (defun nnheader-init-server-buffer () "Initialize the Gnus-backend communication buffer." (save-excursion - (setq nntp-server-buffer (get-buffer-create " *nntpd*")) + (unless (gnus-buffer-live-p nntp-server-buffer) + (setq nntp-server-buffer (get-buffer-create " *nntpd*"))) (set-buffer nntp-server-buffer) (buffer-disable-undo (current-buffer)) (erase-buffer) @@ -277,7 +387,6 @@ (setq case-fold-search t) ;Should ignore case. t)) - ;;; Various functions the backends use. (defun nnheader-file-error (file) @@ -297,14 +406,15 @@ (when (file-exists-p file) (if (eq nnheader-max-head-length t) ;; Just read the entire file. - (nnheader-insert-file-contents-literally file) + (nnheader-insert-file-contents file) ;; Read 1K blocks until we find a separator. (let ((beg 0) - format-alist - (chop 1024)) - (while (and (eq chop (nth 1 (insert-file-contents - file nil beg (incf beg chop)))) - (prog1 (not (search-forward "\n\n" nil t)) + format-alist) + (while (and (eq nnheader-head-chop-length + (nth 1 (nnheader-insert-file-contents + file nil beg + (incf beg nnheader-head-chop-length)))) + (prog1 (not (search-forward "\n\n" nil t)) (goto-char (point-max))) (or (null nnheader-max-head-length) (< beg nnheader-max-head-length)))))) @@ -321,19 +431,22 @@ (goto-char (match-end 0))) (prog1 (eobp) - (widen)))) + (widen)))) (defun nnheader-insert-references (references message-id) "Insert a References header based on REFERENCES and MESSAGE-ID." - (if (and (not references) (not message-id)) - () ; This is illegal, but not all articles have Message-IDs. + (if (and (not references) (not message-id)) + () ; This is illegal, but not all articles have Message-IDs. (mail-position-on-field "References") (let ((begin (save-excursion (beginning-of-line) (point))) (fill-column 78) (fill-prefix "\t")) - (if references (insert references)) - (if (and references message-id) (insert " ")) - (if message-id (insert message-id)) + (when references + (insert references)) + (when (and references message-id) + (insert " ")) + (when message-id + (insert message-id)) ;; Fold long References lines to conform to RFC1036 (sort of). ;; The region must end with a newline to fill the region ;; without inserting extra newline. @@ -359,37 +472,58 @@ (point-max))) (goto-char (point-min))) -(defun nnheader-set-temp-buffer (name) +(defun nnheader-set-temp-buffer (name &optional noerase) "Set-buffer to an empty (possibly new) buffer called NAME with undo disabled." (set-buffer (get-buffer-create name)) (buffer-disable-undo (current-buffer)) - (erase-buffer) + (unless noerase + (erase-buffer)) (current-buffer)) (defmacro nnheader-temp-write (file &rest forms) - "Create a new buffer, evaluate FORM there, and write the buffer to FILE." - `(save-excursion - (let ((nnheader-temp-file ,file) - (nnheader-temp-cur-buffer - (nnheader-set-temp-buffer - (generate-new-buffer-name " *nnheader temp*")))) - (when (and nnheader-temp-file - (not (file-directory-p (file-name-directory - nnheader-temp-file)))) - (make-directory (file-name-directory nnheader-temp-file) t)) - (unwind-protect - (prog1 - (progn - ,@forms) - (when nnheader-temp-file - (set-buffer nnheader-temp-cur-buffer) - (write-region (point-min) (point-max) - nnheader-temp-file nil 'nomesg))) - (when (buffer-name nnheader-temp-cur-buffer) - (kill-buffer nnheader-temp-cur-buffer)))))) + "Create a new buffer, evaluate FORMS there, and write the buffer to FILE. +Return the value of FORMS. +If FILE is nil, just evaluate FORMS and don't save anything. +If FILE is t, return the buffer contents as a string." + (let ((temp-file (make-symbol "temp-file")) + (temp-buffer (make-symbol "temp-buffer")) + (temp-results (make-symbol "temp-results"))) + `(save-excursion + (let* ((,temp-file ,file) + (default-major-mode 'fundamental-mode) + (,temp-buffer + (set-buffer + (get-buffer-create + (generate-new-buffer-name " *nnheader temp*")))) + ,temp-results) + (unwind-protect + (progn + (setq ,temp-results (progn ,@forms)) + (cond + ;; Don't save anything. + ((null ,temp-file) + ,temp-results) + ;; Return the buffer contents. + ((eq ,temp-file t) + (set-buffer ,temp-buffer) + (buffer-string)) + ;; Save a file. + (t + (set-buffer ,temp-buffer) + ;; Make sure the directory where this file is + ;; to be saved exists. + (when (not (file-directory-p + (file-name-directory ,temp-file))) + (make-directory (file-name-directory ,temp-file) t)) + ;; Save the file. + (write-region (point-min) (point-max) + ,temp-file nil 'nomesg) + ,temp-results))) + ;; Kill the buffer. + (when (buffer-name ,temp-buffer) + (kill-buffer ,temp-buffer))))))) (put 'nnheader-temp-write 'lisp-indent-function 1) -(put 'nnheader-temp-write 'lisp-indent-hook 1) (put 'nnheader-temp-write 'edebug-form-spec '(form body)) (defvar jka-compr-compression-info-list) @@ -440,9 +574,7 @@ (defun nnheader-fold-continuation-lines () "Fold continuation lines in the current buffer." - (goto-char (point-min)) - (while (re-search-forward "\\(\r?\n[ \t]+\\)+" nil t) - (replace-match " " t t))) + (nnheader-replace-regexp "\\(\r?\n[ \t]+\\)+" " ")) (defun nnheader-translate-file-chars (file) (if (null nnheader-file-name-translation-alist) @@ -477,10 +609,14 @@ nil) (defun nnheader-get-report (backend) - (message "%s" (symbol-value (intern (format "%s-status-string" backend))))) + "Get the most recent report from BACKEND." + (condition-case () + (message "%s" (symbol-value (intern (format "%s-status-string" + backend)))) + (error (message "")))) (defun nnheader-insert (format &rest args) - "Clear the communicaton buffer and insert FORMAT and ARGS into the buffer. + "Clear the communication buffer and insert FORMAT and ARGS into the buffer. If FORMAT isn't a format string, it and all ARGS will be inserted without formatting." (save-excursion @@ -498,7 +634,7 @@ (file-regular-p file)) (save-excursion (nnheader-set-temp-buffer " *mail-file-mbox-p*") - (nnheader-insert-file-contents-literally file) + (nnheader-insert-file-contents file) (goto-char (point-min)) (prog1 (looking-at message-unix-mail-delimiter) @@ -511,8 +647,8 @@ (idx 0)) ;; Replace all occurrences of FROM with TO. (while (< idx len) - (if (= (aref string idx) from) - (aset string idx to)) + (when (= (aref string idx) from) + (aset string idx to)) (setq idx (1+ idx))) string)) @@ -559,9 +695,9 @@ (or (and (symbolp form) (fboundp form)) (and (listp form) (eq (car form) 'lambda)))) -(defun nnheader-concat (dir file) +(defun nnheader-concat (dir &rest files) "Concat DIR as directory to FILE." - (concat (file-name-as-directory dir) file)) + (apply 'concat (file-name-as-directory dir) files)) (defun nnheader-ms-strip-cr () "Strip ^M from the end of all lines." @@ -574,8 +710,9 @@ "Return the file size of FILE or 0." (or (nth 7 (file-attributes file)) 0)) -(defun nnheader-find-etc-directory (package) - "Go through the path and find the \".../etc/PACKAGE\" directory." +(defun nnheader-find-etc-directory (package &optional file) + "Go through the path and find the \".../etc/PACKAGE\" directory. +If FILE, find the \".../etc/PACKAGE\" file instead." (let ((path load-path) dir result) ;; We try to find the dir by looking at the load path, @@ -586,8 +723,9 @@ (setq dir (concat (file-name-directory (directory-file-name (car path))) - "etc/" package "/"))) - (file-directory-p dir)) + "etc/" package + (if file "" "/")))) + (or file (file-directory-p dir))) (setq result dir path nil) (setq path (cdr path)))) @@ -597,18 +735,90 @@ (defvar efs-path-regexp) (defun nnheader-re-read-dir (path) "Re-read directory PATH if PATH is on a remote system." - (if (and (fboundp 'efs-re-read-dir) (boundp 'efs-path-regexp)) - (when (string-match efs-path-regexp path) - (efs-re-read-dir path)) - (if (and (fboundp 'ange-ftp-re-read-dir) (boundp 'ange-ftp-path-format)) + (if (and (fboundp 'efs-re-read-dir) (boundp 'efs-path-regexp)) + (when (string-match efs-path-regexp path) + (efs-re-read-dir path)) + (when (and (fboundp 'ange-ftp-re-read-dir) (boundp 'ange-ftp-path-format)) (when (string-match (car ange-ftp-path-format) path) (ange-ftp-re-read-dir path))))) +(defun nnheader-insert-file-contents (filename &optional visit beg end replace) + "Like `insert-file-contents', q.v., but only reads in the file. +A buffer may be modified in several ways after reading into the buffer due +to advanced Emacs features, such as file-name-handlers, format decoding, +find-file-hooks, etc. + This function ensures that none of these modifications will take place." + (let ((format-alist nil) + (auto-mode-alist (nnheader-auto-mode-alist)) + (default-major-mode 'fundamental-mode) + (after-insert-file-functions nil)) + (insert-file-contents filename visit beg end replace))) + +(defun nnheader-find-file-noselect (&rest args) + (let ((format-alist nil) + (auto-mode-alist (nnheader-auto-mode-alist)) + (default-major-mode 'fundamental-mode) + (enable-local-variables nil) + (after-insert-file-functions nil)) + (apply 'find-file-noselect args))) + +(defun nnheader-auto-mode-alist () + "Return an `auto-mode-alist' with only the .gz (etc) thingies." + (let ((alist auto-mode-alist) + out) + (while alist + (when (listp (cdar alist)) + (push (car alist) out)) + (pop alist)) + (nreverse out))) + +(defun nnheader-directory-regular-files (dir) + "Return a list of all regular files in DIR." + (let ((files (directory-files dir t)) + out) + (while files + (when (file-regular-p (car files)) + (push (car files) out)) + (pop files)) + (nreverse out))) + +(defmacro nnheader-skeleton-replace (from &optional to regexp) + `(let ((new (generate-new-buffer " *nnheader replace*")) + (cur (current-buffer)) + (start (point-min))) + (set-buffer new) + (buffer-disable-undo (current-buffer)) + (set-buffer cur) + (goto-char (point-min)) + (while (,(if regexp 're-search-forward 'search-forward) + ,from nil t) + (insert-buffer-substring + cur start (prog1 (match-beginning 0) (set-buffer new))) + (goto-char (point-max)) + ,(when to `(insert ,to)) + (set-buffer cur) + (setq start (point))) + (insert-buffer-substring + cur start (prog1 (point-max) (set-buffer new))) + (copy-to-buffer cur (point-min) (point-max)) + (kill-buffer (current-buffer)) + (set-buffer cur))) + +(defun nnheader-replace-string (from to) + "Do a fast replacement of FROM to TO from point to point-max." + (nnheader-skeleton-replace from to)) + +(defun nnheader-replace-regexp (from to) + "Do a fast regexp replacement of FROM to TO from point to point-max." + (nnheader-skeleton-replace from to t)) + +(defun nnheader-strip-cr () + "Strip all \r's from the current buffer." + (nnheader-skeleton-replace "\r")) + (fset 'nnheader-run-at-time 'run-at-time) (fset 'nnheader-cancel-timer 'cancel-timer) -(fset 'nnheader-find-file-noselect 'find-file-noselect) -(fset 'nnheader-insert-file-contents-literally - 'insert-file-contents-literally) +(fset 'nnheader-cancel-function-timers 'cancel-function-timers) (when (string-match "XEmacs\\|Lucid" emacs-version) (require 'nnheaderxm)) diff -r ad457d5f7d04 -r 0293115a14e9 lisp/gnus/nnheaderxm.el --- a/lisp/gnus/nnheaderxm.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/gnus/nnheaderxm.el Mon Aug 13 08:49:20 2007 +0200 @@ -1,5 +1,5 @@ ;;; nnheaderxm.el --- making Gnus backends work under XEmacs -;; Copyright (C) 1996 Free Software Foundation, Inc. +;; Copyright (C) 1996,97 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; Keywords: news @@ -35,28 +35,8 @@ (defun nnheader-xmas-cancel-timer (timer) (delete-itimer timer)) -;; Written by Erik Naggum . -;; Saved by Steve Baur . -(defun nnheader-xmas-insert-file-contents-literally (filename &optional visit beg end replace) - "Like `insert-file-contents', q.v., but only reads in the file. -A buffer may be modified in several ways after reading into the buffer due -to advanced Emacs features, such as file-name-handlers, format decoding, -find-file-hooks, etc. - This function ensures that none of these modifications will take place." - (let ( ; (file-name-handler-alist nil) - (format-alist nil) - (after-insert-file-functions nil) - (find-buffer-file-type-function - (if (fboundp 'find-buffer-file-type) - (symbol-function 'find-buffer-file-type) - nil))) - (unwind-protect - (progn - (fset 'find-buffer-file-type (lambda (filename) t)) - (insert-file-contents filename visit beg end replace)) - (if find-buffer-file-type-function - (fset 'find-buffer-file-type find-buffer-file-type-function) - (fmakunbound 'find-buffer-file-type))))) +(defun nnheader-xmas-cancel-function-timers (function) + ) (defun nnheader-xmas-find-file-noselect (filename &optional nowarn rawfile) "Read file FILENAME into a buffer and return the buffer. @@ -74,21 +54,20 @@ (truename (abbreviate-file-name (file-truename filename))) (number (nthcdr 10 (file-attributes truename))) ;; Find any buffer for a file which has same truename. - (other (and (not buf) + (other (and (not buf) (get-file-buffer filename))) error) ;; Let user know if there is a buffer with the same truename. - (if other - (progn - (or nowarn - (string-equal filename (buffer-file-name other)) - (message "%s and %s are the same file" - filename (buffer-file-name other))) - ;; Optionally also find that buffer. - (if (or (and (boundp 'find-file-existing-other-name) - find-file-existing-other-name) - find-file-visit-truename) - (setq buf other)))) + (when other + (or nowarn + (string-equal filename (buffer-file-name other)) + (message "%s and %s are the same file" + filename (buffer-file-name other))) + ;; Optionally also find that buffer. + (when (or (and (boundp 'find-file-existing-other-name) + find-file-existing-other-name) + find-file-visit-truename) + (setq buf other))) (if buf (or nowarn (verify-visited-file-modtime buf) @@ -125,7 +104,7 @@ (erase-buffer) (if rawfile (condition-case () - (nnheader-insert-file-contents-literally filename t) + (nnheader-insert-file-contents filename t) (file-error ;; Unconditionally set error (setq error t))) @@ -143,23 +122,22 @@ ;; the file was found in. (and (eq system-type 'vax-vms) (let (logical) - (if (string-match ":" (file-name-directory filename)) - (setq logical (substring (file-name-directory filename) - 0 (match-beginning 0)))) + (when (string-match ":" (file-name-directory filename)) + (setq logical (substring (file-name-directory filename) + 0 (match-beginning 0)))) (not (member logical find-file-not-true-dirname-list))) (setq buffer-file-name buffer-file-truename)) - (if find-file-visit-truename - (setq buffer-file-name - (setq filename - (expand-file-name buffer-file-truename)))) + (when find-file-visit-truename + (setq buffer-file-name + (setq filename + (expand-file-name buffer-file-truename)))) ;; Set buffer's default directory to that of the file. (setq default-directory (file-name-directory filename)) ;; Turn off backup files for certain file names. Since ;; this is a permanent local, the major mode won't eliminate it. - (and (not (funcall backup-enable-predicate buffer-file-name)) - (progn - (make-local-variable 'backup-inhibited) - (setq backup-inhibited t))) + (when (not (funcall backup-enable-predicate buffer-file-name)) + (make-local-variable 'backup-inhibited) + (setq backup-inhibited t)) (if rawfile nil (after-find-file error (not nowarn))))) @@ -167,11 +145,8 @@ (fset 'nnheader-run-at-time 'nnheader-xmas-run-at-time) (fset 'nnheader-cancel-timer 'nnheader-xmas-cancel-timer) +(fset 'nnheader-cancel-function-timers 'nnheader-xmas-cancel-function-timers) (fset 'nnheader-find-file-noselect 'nnheader-xmas-find-file-noselect) -(fset 'nnheader-insert-file-contents-literally - (if (fboundp 'insert-file-contents-literally) - 'insert-file-contents-literally - 'nnheader-xmas-insert-file-contents-literally)) (provide 'nnheaderxm) diff -r ad457d5f7d04 -r 0293115a14e9 lisp/gnus/nnkiboze.el --- a/lisp/gnus/nnkiboze.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/gnus/nnkiboze.el Mon Aug 13 08:49:20 2007 +0200 @@ -1,5 +1,5 @@ ;;; nnkiboze.el --- select virtual news access for Gnus -;; Copyright (C) 1995,96 Free Software Foundation, Inc. +;; Copyright (C) 1995,96,97 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; Keywords: news @@ -24,7 +24,7 @@ ;;; Commentary: ;; The other access methods (nntp, nnspool, etc) are general news -;; access methods. This module relies on Gnus and can not be used +;; access methods. This module relies on Gnus and can't be used ;; separately. ;;; Code: @@ -37,24 +37,33 @@ (eval-when-compile (require 'cl)) (nnoo-declare nnkiboze) -(defvoo nnkiboze-directory gnus-directory +(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.") + "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.") + "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.") -(defconst nnkiboze-version "nnkiboze 1.0" - "Version numbers of this version of nnkiboze.") +(defconst nnkiboze-version "nnkiboze 1.0") (defvoo nnkiboze-current-group nil) -(defvoo nnkiboze-current-score-group "") (defvoo nnkiboze-status-string "") +(defvoo nnkiboze-headers nil) + ;;; Interface functions. @@ -62,122 +71,87 @@ (nnoo-define-basics nnkiboze) (deffoo nnkiboze-retrieve-headers (articles &optional group server fetch-old) - (nnkiboze-possibly-change-newsgroups group) - (if gnus-nov-is-evil - nil + (nnkiboze-possibly-change-group group) + (unless gnus-nov-is-evil (if (stringp (car articles)) 'headers - (let ((first (car articles)) - (last (progn (while (cdr articles) (setq articles (cdr articles))) - (car articles))) - (nov (nnkiboze-nov-file-name))) - (if (file-exists-p nov) - (save-excursion - (set-buffer nntp-server-buffer) - (erase-buffer) - (insert-file-contents nov) - (goto-char (point-min)) - (while (and (not (eobp)) (< first (read (current-buffer)))) - (forward-line 1)) - (beginning-of-line) - (if (not (eobp)) (delete-region 1 (point))) - (while (and (not (eobp)) (>= last (read (current-buffer)))) - (forward-line 1)) - (beginning-of-line) - (if (not (eobp)) (delete-region (point) (point-max))) - 'nov)))))) - -(deffoo nnkiboze-open-server (newsgroups &optional something) - (gnus-make-directory nnkiboze-directory) - (nnheader-init-server-buffer)) - -(deffoo nnkiboze-server-opened (&optional server) - (and nntp-server-buffer - (get-buffer nntp-server-buffer))) + (let ((nov (nnkiboze-nov-file-name))) + (when (file-exists-p nov) + (save-excursion + (set-buffer nntp-server-buffer) + (erase-buffer) + (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-newsgroups newsgroup) + (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 + ;; 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)) - igroup iarticle) - (or xref (error "nnkiboze: No xref")) - (or (string-match " \\([^ ]+\\):\\([0-9]+\\)" xref) - (error "nnkiboze: Malformed xref")) - (setq igroup (substring xref (match-beginning 1) (match-end 1))) - (setq iarticle (string-to-int - (substring xref (match-beginning 2) (match-end 2)))) - (and (gnus-request-group igroup t) - (gnus-request-article iarticle igroup buffer))))) + (xref (mail-header-xref header))) + (unless xref + (error "nnkiboze: No xref")) + (unless (string-match " \\([^ ]+\\):\\([0-9]+\\)" xref) + (error "nnkiboze: Malformed xref")) + (gnus-request-article (string-to-int (match-string 2 xref)) + (match-string 1 xref) + buffer)))) + +(deffoo nnkiboze-request-scan (&optional group server) + (nnkiboze-generate-group (concat "nnkiboze:" group))) (deffoo nnkiboze-request-group (group &optional server dont-check) "Make GROUP the current newsgroup." - (nnkiboze-possibly-change-newsgroups group) + (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) (if (not (file-exists-p nov-file)) - (insert (format "211 0 0 0 %s\n" group)) - (insert-file-contents nov-file) + (nnheader-report 'nnkiboze "Can't select group %s" group) + (nnheader-insert-file-contents nov-file) (if (zerop (buffer-size)) - (insert (format "211 0 0 0 %s\n" group)) + (nnheader-insert "211 0 0 0 %s\n" group) (goto-char (point-min)) - (and (looking-at "[0-9]+") (setq beg (read (current-buffer)))) + (when (looking-at "[0-9]+") + (setq beg (read (current-buffer)))) (goto-char (point-max)) - (and (re-search-backward "^[0-9]" nil t) - (setq end (read (current-buffer)))) + (when (re-search-backward "^[0-9]" nil t) + (setq end (read (current-buffer)))) (setq total (count-lines (point-min) (point-max))) - (erase-buffer) - (insert (format "211 %d %d %d %s\n" total beg end group))))))) - t) + (nnheader-insert "211 %d %d %d %s\n" total beg end group))))))) (deffoo nnkiboze-close-group (group &optional server) - (nnkiboze-possibly-change-newsgroups group) + (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 - (eq major-mode 'gnus-summary-mode)) - (save-excursion - (let ((unreads gnus-newsgroup-unreads) - (unselected gnus-newsgroup-unselected) - (version-control 'never)) - (set-buffer (get-buffer-create "*nnkiboze work*")) - (buffer-disable-undo (current-buffer)) - (erase-buffer) - (let ((cur (current-buffer)) - article) - (insert-file-contents (nnkiboze-nov-file-name)) - (goto-char (point-min)) - (while (looking-at "[0-9]+") - (if (or (memq (setq article (read cur)) unreads) - (memq article unselected)) - (forward-line 1) - (delete-region (progn (beginning-of-line) (point)) - (progn (forward-line 1) (point))))) - (write-file (nnkiboze-nov-file-name)) - (kill-buffer (current-buffer))))) - (setq nnkiboze-current-group nil))) + nnkiboze-remove-read-articles) + (nnheader-temp-write (nnkiboze-nov-file-name) + (let ((cur (current-buffer))) + (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-request-list (&optional server) - (nnheader-report 'nnkiboze "LIST is not implemented.")) - -(deffoo nnkiboze-request-newgroups (date &optional server) - "List new groups." - (nnheader-report 'nnkiboze "NEWGROUPS is not supported.")) - -(deffoo nnkiboze-request-list-newsgroups (&optional server) - (nnheader-report 'nnkiboze "LIST NEWSGROUPS is not implemented.")) +(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-newsgroups group) + (nnkiboze-possibly-change-group group) (when force (let ((files (list (nnkiboze-nov-file-name) (concat nnkiboze-directory group ".newsrc") @@ -189,10 +163,12 @@ (setq files (cdr files))))) (setq nnkiboze-current-group nil)) +(nnoo-define-skeleton nnkiboze) + ;;; Internal functions. -(defun nnkiboze-possibly-change-newsgroups (group) +(defun nnkiboze-possibly-change-group (group) (setq nnkiboze-current-group group)) (defun nnkiboze-prefixed-name (group) @@ -209,137 +185,138 @@ (gnus-expert-user t)) (gnus)) (let* ((gnus-newsrc-alist (gnus-copy-sequence gnus-newsrc-alist)) - (newsrc gnus-newsrc-alist) - gnus-newsrc-hashtb) + (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 newsrc - (if (string-match "nnkiboze" (caar newsrc)) - ;; For each kiboze group, we call this function to generate - ;; it. - (nnkiboze-generate-group (caar newsrc))) - (setq newsrc (cdr newsrc))))) + (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)))))) (defun nnkiboze-score-file (group) (list (expand-file-name (concat (file-name-as-directory gnus-kill-files-directory) (nnheader-translate-file-chars - (concat nnkiboze-current-score-group + (concat (nnkiboze-prefixed-name nnkiboze-current-group) "." gnus-score-file-suffix)))))) -(defun nnkiboze-generate-group (group) +(defun nnkiboze-generate-group (group) (let* ((info (nth 2 (gnus-gethash group gnus-newsrc-hashtb))) (newsrc-file (concat nnkiboze-directory group ".newsrc")) (nov-file (concat nnkiboze-directory group ".nov")) - (regexp (nth 1 (nth 4 info))) + 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) - (version-control 'never) (gnus-score-find-score-files-function 'nnkiboze-score-file) + (gnus-verbose (min gnus-verbose 3)) gnus-select-group-hook gnus-summary-prepare-hook gnus-thread-sort-functions gnus-show-threads - gnus-visual - method nnkiboze-newsrc nov-buffer gname newsrc active - ginfo lowest glevel) - (setq nnkiboze-current-score-group group) - (or info (error "No such group: %s" group)) + gnus-visual gnus-suppress-duplicates) + (unless info + (error "No such group: %s" group)) ;; Load the kiboze newsrc file for this group. - (and (file-exists-p newsrc-file) (load newsrc-file)) - ;; We also load the nov file for this group. - (save-excursion - (set-buffer (setq nov-buffer (find-file-noselect nov-file))) - (buffer-disable-undo (current-buffer))) - ;; Go through the active hashtb and add new all groups that match the - ;; kiboze regexp. - (mapatoms - (lambda (group) - (and (string-match 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 (nth 1 (nth 2 (gnus-gethash - gname gnus-newsrc-hashtb)))) - (>= nnkiboze-level glevel))) - (not (string-match "^nnkiboze:" gname)) ; Exclude kibozes - (setq nnkiboze-newsrc - (cons (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-gethash - (caar newsrc) gnus-active-hashtb))) - ;; 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)) - ;; 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. - (and (setq ginfo (nth 2 (gnus-gethash (gnus-group-group-name) - gnus-newsrc-hashtb))) - (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)'. - (and ginfo (setcar (nthcdr 2 ginfo) - (and (not (= lowest 1)) (cons 1 lowest)))) - (if (not (and (or (not ginfo) - (> (length (gnus-list-of-unread-articles - (car ginfo))) 0)) - (progn - (gnus-group-select-group nil) - (eq major-mode 'gnus-summary-mode)))) - () ; No unread articles, or we couldn't enter this group. - ;; We are now in the group where we want to be. - (setq method (gnus-find-method-for-group gnus-newsgroup-name)) - (and (eq method gnus-select-method) (setq method nil)) - ;; We go through the list of scored articles. - (while gnus-newsgroup-scored - (if (> (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)) - (if method - (gnus-group-prefixed-name gnus-newsgroup-name method) - gnus-newsgroup-name))) - (setq gnus-newsgroup-scored (cdr gnus-newsgroup-scored))) - ;; That's it. We exit this group. - (gnus-summary-exit-no-update))) - (setcdr (car newsrc) (car active)) - (setq newsrc (cdr newsrc))) - ;; We save the nov file. - (set-buffer nov-buffer) - (save-buffer) - (kill-buffer (current-buffer)) + (when (file-exists-p newsrc-file) + (load newsrc-file)) + (nnheader-temp-write 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 (nth 1 (nth 2 (gnus-gethash + gname gnus-newsrc-hashtb)))) + (>= 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-gethash + (caar newsrc) gnus-active-hashtb))) + ;; 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)) + (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 + (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. + (gnus-summary-exit-no-update))) + ;; Restore the proper info. + (when ginfo + (setcdr ginfo (cdr orig-info))))) + (setcdr (car newsrc) (car active)) + (gnus-message 3 "nnkiboze: Checking %s...done" (caar newsrc)) + (setq newsrc (cdr newsrc)))) ;; We save the kiboze newsrc for this group. - (set-buffer (get-buffer-create "*nnkiboze work*")) - (buffer-disable-undo (current-buffer)) - (erase-buffer) - (insert "(setq nnkiboze-newsrc '" (prin1-to-string nnkiboze-newsrc) - ")\n") - (write-file newsrc-file) - (kill-buffer (current-buffer)) - (switch-to-buffer gnus-group-buffer) - (gnus-group-list-groups 5 nil))) + (nnheader-temp-write newsrc-file + (insert "(setq nnkiboze-newsrc '") + (gnus-prin1 nnkiboze-newsrc) + (insert ")\n")) + t)) (defun nnkiboze-enter-nov (buffer header group) (save-excursion (set-buffer buffer) (goto-char (point-max)) + (debug) (let ((xref (mail-header-xref header)) (prefix (gnus-group-real-prefix group)) + (oheader (copy-sequence header)) (first t) article) (if (zerop (forward-line -1)) @@ -347,36 +324,20 @@ (setq article (1+ (read (current-buffer)))) (forward-line 1)) (setq article 1)) - (insert (int-to-string article) "\t" - (or (mail-header-subject header) "") "\t" - (or (mail-header-from header) "") "\t" - (or (mail-header-date header) "") "\t" - (or (mail-header-id header) "") "\t" - (or (mail-header-references header) "") "\t" - (int-to-string (or (mail-header-chars header) 0)) "\t" - (int-to-string (or (mail-header-lines header) 0)) "\t") - (if (or (not xref) (equal "" xref)) - (insert "Xref: " (system-name) " " group ":" - (int-to-string (mail-header-number header)) - "\t\n") - (insert (mail-header-xref header) "\t\n") - (search-backward "\t" nil t) - (search-backward "\t" nil t) - (while (re-search-forward - "[^ ]+:[0-9]+" - (save-excursion (end-of-line) (point)) t) - (if first - ;; 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. - (save-excursion - (goto-char (match-beginning 0)) - (insert prefix group ":" - (int-to-string (mail-header-number header)) " ") - (setq first nil))) - (save-excursion - (goto-char (match-beginning 0)) - (insert prefix))))))) + (mail-header-set-number oheader article) + (nnheader-insert-nov oheader) + (search-backward "\t" nil t 2) + (if (re-search-forward " [^ ]+:[0-9]+" nil t) + (goto-char (match-beginning 0)) + (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))))) (defun nnkiboze-nov-file-name () (concat (file-name-as-directory nnkiboze-directory) diff -r ad457d5f7d04 -r 0293115a14e9 lisp/gnus/nnmail.el --- a/lisp/gnus/nnmail.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/gnus/nnmail.el Mon Aug 13 08:49:20 2007 +0200 @@ -1,5 +1,5 @@ ;;; nnmail.el --- mail support functions for the Gnus mail backends -;; Copyright (C) 1995,96 Free Software Foundation, Inc. +;; Copyright (C) 1995,96,97 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; Keywords: news, mail @@ -29,10 +29,15 @@ (require 'timezone) (require 'message) (eval-when-compile (require 'cl)) +(require 'custom) -(defvar nnmail-split-methods +(defgroup gnus-mail nil + "Mailreading.." + :group 'gnus) + +(defcustom nnmail-split-methods '(("mail.misc" "")) - "*Incoming mail will be split according to this variable. + "Incoming mail will be split according to this variable. If you'd like, for instance, one mail group for mail from the \"4ad-l\" mailing list, one group for junk mail and one for everything @@ -56,32 +61,51 @@ The last element should always have \"\" as the regexp. -This variable can also have a function as its value.") +This variable can also have a function as its value." + :group 'gnus-mail + :type '(choice (repeat :tag "Alist" (group (string :tag "Name") regexp)) + (function-item nnmail-split-fancy) + (function :tag "Other"))) ;; Suggested by Erik Selberg . -(defvar nnmail-crosspost t - "*If non-nil, do crossposting if several split methods match the mail. -If nil, the first match found will be used.") +(defcustom nnmail-crosspost t + "If non-nil, do crossposting if several split methods match the mail. +If nil, the first match found will be used." + :group 'gnus-mail + :type 'boolean) ;; Added by gord@enci.ucalgary.ca (Gordon Matzigkeit). -(defvar nnmail-keep-last-article nil - "*If non-nil, nnmail will never delete the last expired article in a directory. +(defcustom nnmail-keep-last-article nil + "If non-nil, nnmail will never delete the last expired article in a directory. You may need to set this variable if other programs are putting -new mail into folder numbers that Gnus has marked as expired.") +new mail into folder numbers that Gnus has marked as expired." + :group 'gnus-mail + :type 'boolean) -(defvar nnmail-use-long-file-names nil - "*If non-nil the mail backends will use long file and directory names. +(defcustom nnmail-use-long-file-names nil + "If non-nil the mail backends will use long file and directory names. If nil, groups like \"mail.misc\" will end up in directories like -\"mail/misc/\".") +\"mail/misc/\"." + :group 'gnus-mail + :type 'boolean) -(defvar nnmail-expiry-wait 7 +(defcustom nnmail-default-file-modes 384 + "Set the mode bits of all new mail files to this integer." + :group 'gnus-mail + :type 'integer) + +(defcustom nnmail-expiry-wait 7 "*Expirable articles that are older than this will be expired. This variable can either be a number (which will be interpreted as a number of days) -- this doesn't have to be an integer. This variable -can also be `immediate' and `never'.") +can also be `immediate' and `never'." + :group 'gnus-mail + :type '(choice (const immediate) + (integer :tag "days") + (const never))) -(defvar nnmail-expiry-wait-function nil - "*Variable that holds function to specify how old articles should be before they are expired. +(defcustom nnmail-expiry-wait-function nil + "Variable that holds function to specify how old articles should be before they are expired. The function will be called with the name of the group that the expiry is to be performed in, and it should return an integer that says how many days an article can be stored before it is considered @@ -89,69 +113,103 @@ Eg.: -(setq nnmail-expiry-wait-function +\(setq nnmail-expiry-wait-function (lambda (newsgroup) (cond ((string-match \"private\" newsgroup) 31) ((string-match \"junk\" newsgroup) 1) ((string-match \"important\" newsgroup) 'never) - (t 7))))") + (t 7))))" + :group 'gnus-mail + :type '(choice (const :tag "nnmail-expiry-wait" nil) + (function :format "%v" nnmail-))) -(defvar nnmail-spool-file +(defcustom nnmail-spool-file (or (getenv "MAIL") (concat "/usr/spool/mail/" (user-login-name))) "Where the mail backends will look for incoming mail. This variable is \"/usr/spool/mail/$user\" by default. If this variable is nil, no mail backends will read incoming mail. If this variable is a list, all files mentioned in this list will be -used as incoming mailboxes.") +used as incoming mailboxes. +If this variable is a directory (i. e., it's name ends with a \"/\"), +treat all files in that directory as incoming spool files." + :group 'gnus-mail + :type 'file) -(defvar nnmail-crash-box "~/.gnus-crash-box" - "*File where Gnus will store mail while processing it.") +(defcustom nnmail-crash-box "~/.gnus-crash-box" + "File where Gnus will store mail while processing it." + :group 'gnus-mail + :type 'file) -(defvar nnmail-use-procmail nil +(defcustom nnmail-use-procmail nil "*If non-nil, the mail backends will look in `nnmail-procmail-directory' for spool files. -The file(s) in `nnmail-spool-file' will also be read.") +The file(s) in `nnmail-spool-file' will also be read." + :group 'gnus-mail + :type 'boolean) -(defvar nnmail-procmail-directory "~/incoming/" +(defcustom nnmail-procmail-directory "~/incoming/" "*When using procmail (and the like), incoming mail is put in this directory. -The Gnus mail backends will read the mail from this directory.") +The Gnus mail backends will read the mail from this directory." + :group 'gnus-mail + :type 'directory) -(defvar nnmail-procmail-suffix "\\.spool" +(defcustom nnmail-procmail-suffix "\\.spool" "*Suffix of files created by procmail (and the like). This variable might be a suffix-regexp to match the suffixes of -several files - eg. \".spool[0-9]*\".") - -(defvar nnmail-resplit-incoming nil - "*If non-nil, re-split incoming procmail sorted mail.") +several files - eg. \".spool[0-9]*\"." + :group 'gnus-mail + :type 'regexp) -(defvar nnmail-delete-file-function 'delete-file - "Function called to delete files in some mail backends.") +(defcustom nnmail-resplit-incoming nil + "*If non-nil, re-split incoming procmail sorted mail." + :group 'gnus-mail + :type 'boolean) -(defvar nnmail-crosspost-link-function 'add-name-to-file +(defcustom nnmail-delete-file-function 'delete-file + "Function called to delete files in some mail backends." + :group 'gnus-mail + :type 'function) + +(defcustom nnmail-crosspost-link-function 'add-name-to-file "Function called to create a copy of a file. This is `add-name-to-file' by default, which means that crossposts will use hard links. If your file system doesn't allow hard -links, you could set this variable to `copy-file' instead.") +links, you could set this variable to `copy-file' instead." + :group 'gnus-mail + :type '(radio (function-item add-name-to-file) + (function-item copy-file) + (function :tag "Other"))) -(defvar nnmail-movemail-program "movemail" +(defcustom nnmail-movemail-program "movemail" "*A command to be executed to move mail from the inbox. -The default is \"movemail\".") +The default is \"movemail\". -(defvar nnmail-pop-password-required nil - "*Non-nil if a password is required when reading mail using POP.") +This can also be a function. In that case, the function will be +called with two parameters -- the name of the INBOX file, and the file +to be moved to." + :group 'gnus-mail + :type 'string) -(defvar nnmail-read-incoming-hook nil - "*Hook that will be run after the incoming mail has been transferred. +(defcustom nnmail-pop-password-required nil + "*Non-nil if a password is required when reading mail using POP." + :group 'gnus-mail + :type 'boolean) + +(defcustom nnmail-read-incoming-hook + (if (eq system-type 'windows-nt) + '(nnheader-ms-strip-cr) + nil) + "Hook that will be run after the incoming mail has been transferred. The incoming mail is moved from `nnmail-spool-file' (which normally is something like \"/usr/spool/mail/$user\") to the user's home -directory. This hook is called after the incoming mail box has been +directory. This hook is called after the incoming mail box has been emptied, and can be used to call any mail box programs you have running (\"xwatch\", etc.) Eg. \(add-hook 'nnmail-read-incoming-hook - (lambda () + (lambda () (start-process \"mailsend\" nil \"/local/bin/mailsend\" \"read\" \"mbox\"))) @@ -164,40 +222,77 @@ (lambda () ;; Update the displayed time, since that will clear out ;; the flag that says you have mail. - (if (eq (process-status \"display-time\") 'run) - (display-time-filter display-time-process \"\"))))") - -(when (eq system-type 'windows-nt) - (add-hook 'nnmail-prepare-incoming-hook 'nnheader-ms-strip-cr)) + (when (eq (process-status \"display-time\") 'run) + (display-time-filter display-time-process \"\"))))" + :group 'gnus-mail + :type 'hook) ;; Suggested by Erik Selberg . -(defvar nnmail-prepare-incoming-hook nil - "*Hook called before treating incoming mail. -The hook is run in a buffer with all the new, incoming mail.") +(defcustom nnmail-prepare-incoming-hook nil + "Hook called before treating incoming mail. +The hook is run in a buffer with all the new, incoming mail." + :group 'gnus-mail + :type 'hook) + +(defcustom nnmail-prepare-incoming-header-hook nil + "Hook called narrowed to the headers of each message. +This can be used to remove excessive spaces (and stuff like +that) from the headers before splitting and saving the messages." + :group 'gnus-mail + :type 'hook) + +(defcustom nnmail-prepare-incoming-message-hook nil + "Hook called narrowed to each message." + :group 'gnus-mail + :type 'hook) -(defvar nnmail-pre-get-new-mail-hook nil - "Hook called just before starting to handle new incoming mail.") +(defcustom nnmail-list-identifiers nil + "Regexp that matches list identifiers to be removed. +This can also be a list of regexps." + :group 'gnus-mail + :type '(choice regexp + (repeat regexp))) + +(defcustom nnmail-pre-get-new-mail-hook nil + "Hook called just before starting to handle new incoming mail." + :group 'gnus-mail + :type 'hook) -(defvar nnmail-post-get-new-mail-hook nil - "Hook called just after finishing handling new incoming mail.") +(defcustom nnmail-post-get-new-mail-hook nil + "Hook called just after finishing handling new incoming mail." + :group 'gnus-mail + :type 'hook) + +(defcustom nnmail-split-hook nil + "Hook called before deciding where to split an article. +The functions in this hook are free to modify the buffer +contents in any way they choose -- the buffer contents are +discarded after running the split process." + :group 'gnus-mail + :type 'hook) ;; Suggested by Mejia Pablo J . -(defvar nnmail-tmp-directory nil - "*If non-nil, use this directory for temporary storage when reading incoming mail.") +(defcustom nnmail-tmp-directory nil + "*If non-nil, use this directory for temporary storage when reading incoming mail." + :group 'gnus-mail + :type '(choice (const :tag "default" nil) + (directory :format "%v"))) -(defvar nnmail-large-newsgroup 50 +(defcustom nnmail-large-newsgroup 50 "*The number of the articles which indicates a large newsgroup. If the number of the articles is greater than the value, verbose -messages will be shown to indicate the current status.") +messages will be shown to indicate the current status." + :group 'gnus-mail + :type 'integer) -(defvar nnmail-split-fancy "mail.misc" - "*Incoming mail can be split according to this fancy variable. +(defcustom nnmail-split-fancy "mail.misc" + "Incoming mail can be split according to this fancy variable. To enable this, set `nnmail-split-methods' to `nnmail-split-fancy'. The format is this variable is SPLIT, where SPLIT can be one of the following: -GROUP: Mail will be stored in GROUP (a string). +GROUP: Mail will be stored in GROUP (a string). \(FIELD VALUE SPLIT): If the message field FIELD (a regexp) contains VALUE (a regexp), store the messages as specified by SPLIT. @@ -208,6 +303,10 @@ \(& SPLIT...): Process each SPLIT expression. +\(: FUNCTION optional args): Call FUNCTION with the optional args, in + the buffer containing the message headers. The return value FUNCTION + should be a split, which is then recursively processed. + FIELD must match a complete field name. VALUE must match a complete word according to the `nnmail-split-fancy-syntax-table' syntax table. You can use .* in the regexps to match partial field names or words. @@ -215,11 +314,14 @@ FIELD and VALUE can also be lisp symbols, in that case they are expanded as specified in `nnmail-split-abbrev-alist'. +GROUP can contain \\& and \\N which will substitute from matching +\\(\\) patterns in the previous VALUE. + Example: \(setq nnmail-split-methods 'nnmail-split-fancy nnmail-split-fancy - ;; Messages from the mailer deamon are not crossposted to any of + ;; Messages from the mailer daemon are not crossposted to any of ;; the ordinary groups. Warnings are put in a separate group ;; from real errors. '(| (\"from\" mail (| (\"subject\" \"warn.*\" \"mail.warning\") @@ -235,25 +337,38 @@ ;; People... (any \"larsi@ifi\\\\.uio\\\\.no\" \"people.Lars Magne Ingebrigtsen\")) ;; Unmatched mail goes to the catch all group. - \"misc.misc\"))") + \"misc.misc\"))" + :group 'gnus-mail + ;; Sigh! + :type 'sexp) -(defvar nnmail-split-abbrev-alist +(defcustom nnmail-split-abbrev-alist '((any . "from\\|to\\|cc\\|sender\\|apparently-to\\|resent-from\\|resent-to\\|resent-cc") - (mail . "mailer-daemon\\|postmaster")) - "*Alist of abbreviations allowed in `nnmail-split-fancy'.") + (mail . "mailer-daemon\\|postmaster\\|uucp")) + "Alist of abbreviations allowed in `nnmail-split-fancy'." + :group 'gnus-mail + :type '(repeat (cons :format "%v" symbol regexp))) -(defvar nnmail-delete-incoming t - "*If non-nil, the mail backends will delete incoming files after splitting.") +(defcustom nnmail-delete-incoming t + "*If non-nil, the mail backends will delete incoming files after +splitting." + :group 'gnus-mail + :type 'boolean) -(defvar nnmail-message-id-cache-length 1000 +(defcustom nnmail-message-id-cache-length 1000 "*The approximate number of Message-IDs nnmail will keep in its cache. If this variable is nil, no checking on duplicate messages will be -performed.") +performed." + :group 'gnus-mail + :type '(choice (const :tag "disable" nil) + (integer :format "%v"))) -(defvar nnmail-message-id-cache-file "~/.nnmail-cache" - "*The file name of the nnmail Message-ID cache.") +(defcustom nnmail-message-id-cache-file "~/.nnmail-cache" + "*The file name of the nnmail Message-ID cache." + :group 'gnus-mail + :type 'file) -(defvar nnmail-treat-duplicates 'warn +(defcustom nnmail-treat-duplicates 'warn "*If non-nil, nnmail keep a cache of Message-IDs to discover mail duplicates. Three values are legal: nil, which means that nnmail is not to keep a Message-ID cache; `warn', which means that nnmail should insert extra @@ -262,10 +377,17 @@ This variable can also be a function. It will be called from a buffer narrowed to the article in question with the Message-ID as a -parameter. It should return nil, `warn' or `delete'.") +parameter. It should return nil, `warn' or `delete'." + :group 'gnus-mail + :type '(choice (const :tag "off" nil) + (const warn) + (const delete))) ;;; Internal variables. +(defvar nnmail-split-history nil + "List of group/article elements that say where the previous split put messages.") + (defvar nnmail-pop-password nil "*Password to use when reading mail from a POP server, if required.") @@ -277,7 +399,6 @@ ;; support the %-hack (modify-syntax-entry ?\% "." nnmail-split-fancy-syntax-table)) - (defvar nnmail-prepare-save-mail-hook nil "Hook called before saving mail.") @@ -317,18 +438,22 @@ ;; If not, we translate dots into slashes. (concat dir (nnheader-replace-chars-in-string group ?. ?/) "/"))) (or file ""))) - + (defun nnmail-date-to-time (date) "Convert DATE into time." - (let* ((d1 (timezone-parse-date date)) - (t1 (timezone-parse-time (aref d1 3)))) - (apply 'encode-time - (mapcar (lambda (el) - (and el (string-to-number el))) - (list - (aref t1 2) (aref t1 1) (aref t1 0) - (aref d1 2) (aref d1 1) (aref d1 0) - (aref d1 4)))))) + (condition-case () + (let* ((d1 (timezone-parse-date date)) + (t1 (timezone-parse-time (aref d1 3)))) + (apply 'encode-time + (mapcar (lambda (el) + (and el (string-to-number el))) + (list + (aref t1 2) (aref t1 1) (aref t1 0) + (aref d1 2) (aref d1 1) (aref d1 0) + (number-to-string + (* 60 (timezone-zone-to-minute (aref d1 4)))))))) + ;; If we get an error, then we just return a 0 time. + (error (list 0 0)))) (defun nnmail-time-less (t1 t2) "Say whether time T1 is less than time T2." @@ -340,7 +465,7 @@ "Convert DAYS into time." (let* ((seconds (* 1.0 days 60 60 24)) (rest (expt 2 16)) - (ms (condition-case nil (round (/ seconds rest)) + (ms (condition-case nil (round (/ seconds rest)) (range-error (expt 2 16))))) (list ms (condition-case nil (round (- seconds (* ms rest))) (range-error (expt 2 16)))))) @@ -351,101 +476,115 @@ ;; Convert date strings to internal time. (setq time (nnmail-date-to-time time))) (let* ((current (current-time)) - (rest (if (< (nth 1 current) (nth 1 time)) (expt 2 16)))) + (rest (when (< (nth 1 current) (nth 1 time)) + (expt 2 16)))) (list (- (+ (car current) (if rest -1 0)) (car time)) (- (+ (or rest 0) (nth 1 current)) (nth 1 time))))) ;; Function rewritten from rmail.el. (defun nnmail-move-inbox (inbox) "Move INBOX to `nnmail-crash-box'." - (let ((inbox (file-truename (expand-file-name inbox))) - (tofile (file-truename (expand-file-name nnmail-crash-box))) - movemail popmail errors password) - ;; If getting from mail spool directory, - ;; use movemail to move rather than just renaming, - ;; so as to interlock with the mailer. - (unless (setq popmail (string-match "^po:" (file-name-nondirectory inbox))) - (setq movemail t)) - (when popmail - (setq inbox (file-name-nondirectory inbox))) - (when (and movemail - ;; On some systems, /usr/spool/mail/foo is a directory - ;; and the actual inbox is /usr/spool/mail/foo/foo. - (file-directory-p inbox)) - (setq inbox (expand-file-name (user-login-name) inbox))) - (if (member inbox nnmail-moved-inboxes) - nil - (if popmail - (progn - (setq nnmail-internal-password nnmail-pop-password) - (when (and nnmail-pop-password-required (not nnmail-pop-password)) - (setq nnmail-internal-password - (nnmail-read-passwd - (format "Password for %s: " - (substring inbox (+ popmail 3)))))) - (message "Getting mail from post office ...")) - (when (or (and (file-exists-p tofile) - (/= 0 (nnheader-file-size tofile))) - (and (file-exists-p inbox) - (/= 0 (nnheader-file-size inbox)))) - (message "Getting mail from %s..." inbox))) - ;; Set TOFILE if have not already done so, and - ;; rename or copy the file INBOX to TOFILE if and as appropriate. - (cond - ((file-exists-p tofile) - ;; The crash box exists already. - t) - ((and (not popmail) - (not (file-exists-p inbox))) - ;; There is no inbox. - (setq tofile nil)) - ((and (not movemail) (not popmail)) - ;; Try copying. If that fails (perhaps no space), - ;; rename instead. - (condition-case nil - (copy-file inbox tofile nil) - (error - ;; Third arg is t so we can replace existing file TOFILE. - (rename-file inbox tofile t))) - (push inbox nnmail-moved-inboxes) - ;; Make the real inbox file empty. - ;; Leaving it deleted could cause lossage - ;; because mailers often won't create the file. - (condition-case () - (write-region (point) (point) inbox) - (file-error nil))) - (t - ;; Use movemail. - (unwind-protect - (save-excursion - (setq errors (generate-new-buffer " *nnmail loss*")) - (buffer-disable-undo errors) - (let ((default-directory "/")) - (apply - 'call-process - (append - (list - (expand-file-name nnmail-movemail-program exec-directory) - nil errors nil inbox tofile) - (when nnmail-internal-password - (list nnmail-internal-password))))) - (if (not (buffer-modified-p errors)) - ;; No output => movemail won - (push inbox nnmail-moved-inboxes) - (set-buffer errors) - (subst-char-in-region (point-min) (point-max) ?\n ?\ ) - (goto-char (point-max)) - (skip-chars-backward " \t") - (delete-region (point) (point-max)) - (goto-char (point-min)) - (if (looking-at "movemail: ") - (delete-region (point-min) (match-end 0))) - (error (concat "movemail: " (buffer-string))) - (setq tofile nil)))))) - (and errors - (buffer-name errors) - (kill-buffer errors)) - tofile))) + (if (not (file-writable-p nnmail-crash-box)) + (gnus-error 1 "Can't write to crash box %s. Not moving mail." + nnmail-crash-box) + ;; If the crash box exists and is empty, we delete it. + (when (and (file-exists-p nnmail-crash-box) + (zerop (nnheader-file-size (file-truename nnmail-crash-box)))) + (delete-file nnmail-crash-box)) + (let ((inbox (file-truename (expand-file-name inbox))) + (tofile (file-truename (expand-file-name nnmail-crash-box))) + movemail popmail errors) + (if (setq popmail (string-match + "^po:" (file-name-nondirectory inbox))) + (setq inbox (file-name-nondirectory inbox)) + (setq movemail t) + ;; On some systems, /usr/spool/mail/foo is a directory + ;; and the actual inbox is /usr/spool/mail/foo/foo. + (when (file-directory-p inbox) + (setq inbox (expand-file-name (user-login-name) inbox)))) + (if (member inbox nnmail-moved-inboxes) + ;; We don't try to move an already moved inbox. + nil + (if popmail + (progn + (when (and nnmail-pop-password + (not nnmail-internal-password)) + (setq nnmail-internal-password nnmail-pop-password)) + (when (and nnmail-pop-password-required + (not nnmail-internal-password)) + (setq nnmail-internal-password + (nnmail-read-passwd + (format "Password for %s: " + (substring inbox (+ popmail 3)))))) + (message "Getting mail from post office ...")) + (when (or (and (file-exists-p tofile) + (/= 0 (nnheader-file-size tofile))) + (and (file-exists-p inbox) + (/= 0 (nnheader-file-size inbox)))) + (message "Getting mail from %s..." inbox))) + ;; Set TOFILE if have not already done so, and + ;; rename or copy the file INBOX to TOFILE if and as appropriate. + (cond + ((file-exists-p tofile) + ;; The crash box exists already. + t) + ((and (not popmail) + (not (file-exists-p inbox))) + ;; There is no inbox. + (setq tofile nil)) + (t + ;; If getting from mail spool directory, use movemail to move + ;; rather than just renaming, so as to interlock with the + ;; mailer. + (unwind-protect + (save-excursion + (setq errors (generate-new-buffer " *nnmail loss*")) + (buffer-disable-undo errors) + (let ((default-directory "/")) + (if (nnheader-functionp nnmail-movemail-program) + (funcall nnmail-movemail-program inbox tofile) + (apply + 'call-process + (append + (list + (expand-file-name + nnmail-movemail-program exec-directory) + nil errors nil inbox tofile) + (when nnmail-internal-password + (list nnmail-internal-password)))))) + (if (not (buffer-modified-p errors)) + ;; No output => movemail won + (progn + (unless popmail + (set-file-modes tofile nnmail-default-file-modes)) + (push inbox nnmail-moved-inboxes)) + (set-buffer errors) + ;; There may be a warning about older revisions. We + ;; ignore those. + (goto-char (point-min)) + (if (search-forward "older revision" nil t) + (progn + (unless popmail + (set-file-modes tofile nnmail-default-file-modes)) + (push inbox nnmail-moved-inboxes)) + ;; Probably a real error. + (subst-char-in-region (point-min) (point-max) ?\n ?\ ) + (goto-char (point-max)) + (skip-chars-backward " \t") + (delete-region (point) (point-max)) + (goto-char (point-min)) + (when (looking-at "movemail: ") + (delete-region (point-min) (match-end 0))) + (unless (yes-or-no-p + (format "movemail: %s. Continue? " + (buffer-string))) + (error "%s" (buffer-string))) + (setq tofile nil))))))) + (message "Getting mail from %s...done" inbox) + (and errors + (buffer-name errors) + (kill-buffer errors)) + tofile)))) (defun nnmail-get-active () "Returns an assoc of group names and active ranges. @@ -467,49 +606,64 @@ (defun nnmail-save-active (group-assoc file-name) "Save GROUP-ASSOC in ACTIVE-FILE." (when file-name - (let (group) - (save-excursion - (set-buffer (get-buffer-create " *nnmail active*")) - (buffer-disable-undo (current-buffer)) - (erase-buffer) - (while group-assoc - (setq group (pop group-assoc)) - (insert (format "%s %d %d y\n" (car group) (cdadr group) - (caadr group)))) - (unless (file-exists-p (file-name-directory file-name)) - (make-directory (file-name-directory file-name) t)) - (write-region 1 (point-max) (expand-file-name file-name) nil 'nomesg) - (kill-buffer (current-buffer)))))) + (nnheader-temp-write file-name + (nnmail-generate-active group-assoc)))) + +(defun nnmail-generate-active (alist) + "Generate an active file from group-alist ALIST." + (erase-buffer) + (let (group) + (while (setq group (pop alist)) + (insert (format "%s %d %d y\n" (car group) (cdadr group) + (caadr group)))))) (defun nnmail-get-split-group (file group) + "Find out whether this FILE is to be split into GROUP only. +If GROUP is non-nil and we are using procmail, return the group name +only when the file is the correct procmail file. When GROUP is nil, +return nil if FILE is a spool file or the procmail group for which it +is a spool. If not using procmail, return GROUP." (if (or (eq nnmail-spool-file 'procmail) nnmail-use-procmail) - (cond (group group) - ((string-match (concat "^" (expand-file-name - (file-name-as-directory - nnmail-procmail-directory)) - "\\([^/]*\\)" nnmail-procmail-suffix "$") - (expand-file-name file)) - (substring (expand-file-name file) - (match-beginning 1) (match-end 1))) - (t - group)) + (if (string-match (concat "^" (expand-file-name + (file-name-as-directory + nnmail-procmail-directory)) + "\\([^/]*\\)" nnmail-procmail-suffix "$") + (expand-file-name file)) + (let ((procmail-group (substring (expand-file-name file) + (match-beginning 1) + (match-end 1)))) + (if group + (if (string-equal group procmail-group) + group + nil) + procmail-group)) + nil) group)) -(defun nnmail-process-babyl-mail-format (func) +(defun nnmail-process-babyl-mail-format (func artnum-func) (let ((case-fold-search t) start message-id content-length do-search end) + (goto-char (point-min)) (while (not (eobp)) - (goto-char (point-min)) (re-search-forward " \n0, *unseen,+\n\\(\\*\\*\\* EOOH \\*\\*\\*\n\\)?" nil t) (goto-char (match-end 0)) (delete-region (match-beginning 0) (match-end 0)) - (setq start (point)) - ;; Skip all the headers in case there are more "From "s... - (or (search-forward "\n\n" nil t) - (search-forward-regexp "^[^:]*\\( .*\\|\\)$" nil t) - (search-forward " ")) + (narrow-to-region + (setq start (point)) + (progn + ;; Skip all the headers in case there are more "From "s... + (or (search-forward "\n\n" nil t) + (search-forward-regexp "^[^:]*\\( .*\\|\\)$" nil t) + (search-forward " ")) + (point))) + ;; Unquote the ">From " line, if any. + (goto-char (point-min)) + (when (looking-at ">From ") + (replace-match "X-From-Line: ") ) + (run-hooks 'nnmail-prepare-incoming-header-hook) + (goto-char (point-max)) ;; Find the Message-ID header. (save-excursion (if (re-search-backward "^Message-ID:[ \t]*\\(<[^>]*>\\)" nil t) @@ -537,6 +691,7 @@ ;; a (possibly) faulty header. (progn (insert "X-") t)))) (setq do-search t) + (widen) (if (or (= (+ (point) content-length) (point-max)) (save-excursion (goto-char (+ (point) content-length)) @@ -545,42 +700,85 @@ (goto-char (+ (point) content-length)) (setq do-search nil)) (setq do-search t))) + (widen) ;; Go to the beginning of the next article - or to the end ;; of the buffer. - (if do-search - (if (re-search-forward "^" nil t) - (goto-char (match-beginning 0)) - (goto-char (1- (point-max))))) + (when do-search + (if (re-search-forward "^" nil t) + (goto-char (match-beginning 0)) + (goto-char (1- (point-max))))) (delete-char 1) ; delete ^_ (save-excursion (save-restriction (narrow-to-region start (point)) (goto-char (point-min)) - (nnmail-check-duplication message-id func) + (nnmail-check-duplication message-id func artnum-func) (setq end (point-max)))) (goto-char end)))) (defun nnmail-search-unix-mail-delim () - "Put point at the beginning of the next message." - (let ((case-fold-search t) - (delim (concat "^" message-unix-mail-delimiter)) + "Put point at the beginning of the next Unix mbox message." + ;; Algorithm used to find the the next article in the + ;; brain-dead Unix mbox format: + ;; + ;; 1) Search for "^From ". + ;; 2) If we find it, then see whether the previous + ;; line is blank and the next line looks like a header. + ;; Then it's possible that this is a mail delim, and we use it. + (let ((case-fold-search nil) found) (while (not found) - (if (re-search-forward delim nil t) - (when (or (looking-at "[^\n :]+ *:") - (looking-at delim) - (looking-at (concat ">" message-unix-mail-delimiter))) - (forward-line -1) - (setq found 'yes)) - (setq found 'no))) + (if (not (re-search-forward "^From " nil t)) + (setq found 'no) + (save-excursion + (beginning-of-line) + (when (and (or (bobp) + (save-excursion + (forward-line -1) + (= (following-char) ?\n))) + (save-excursion + (forward-line 1) + (while (looking-at ">From ") + (forward-line 1)) + (looking-at "[^ \t:]+[ \t]*:"))) + (setq found 'yes))))) + (beginning-of-line) (eq found 'yes))) -(defun nnmail-process-unix-mail-format (func) +(defun nnmail-search-unix-mail-delim-backward () + "Put point at the beginning of the current Unix mbox message." + ;; Algorithm used to find the the next article in the + ;; brain-dead Unix mbox format: + ;; + ;; 1) Search for "^From ". + ;; 2) If we find it, then see whether the previous + ;; line is blank and the next line looks like a header. + ;; Then it's possible that this is a mail delim, and we use it. + (let ((case-fold-search nil) + found) + (while (not found) + (if (not (re-search-backward "^From " nil t)) + (setq found 'no) + (save-excursion + (beginning-of-line) + (when (and (or (bobp) + (save-excursion + (forward-line -1) + (= (following-char) ?\n))) + (save-excursion + (forward-line 1) + (while (looking-at ">From ") + (forward-line 1)) + (looking-at "[^ \t:]+[ \t]*:"))) + (setq found 'yes))))) + (beginning-of-line) + (eq found 'yes))) + +(defun nnmail-process-unix-mail-format (func artnum-func) (let ((case-fold-search t) - (delim (concat "^" message-unix-mail-delimiter)) start message-id content-length end skip head-end) (goto-char (point-min)) - (if (not (and (re-search-forward delim nil t) + (if (not (and (re-search-forward "^From " nil t) (goto-char (match-beginning 0)))) ;; Possibly wrong format? (error "Error, unknown mail format! (Possibly corrupted.)") @@ -621,6 +819,7 @@ ;; having a (possibly) faulty header. (beginning-of-line) (insert "X-")) + (run-hooks 'nnmail-prepare-incoming-header-hook) ;; Find the end of this article. (goto-char (point-max)) (widen) @@ -638,10 +837,9 @@ (cond ((or (= skip (point-max)) (= (1+ skip) (point-max))) (setq end (point-max))) - ((looking-at delim) + ((looking-at "From ") (setq end skip)) - ((looking-at - (concat "[ \t]*\n\\(" delim "\\)")) + ((looking-at "[ \t]*\n\\(From \\)") (setq end (match-beginning 1))) (t (setq end nil)))) (if end @@ -656,11 +854,11 @@ (save-restriction (narrow-to-region start (point)) (goto-char (point-min)) - (nnmail-check-duplication message-id func) + (nnmail-check-duplication message-id func artnum-func) (setq end (point-max)))) (goto-char end))))) -(defun nnmail-process-mmdf-mail-format (func) +(defun nnmail-process-mmdf-mail-format (func artnum-func) (let ((delim "^\^A\^A\^A\^A$") (case-fold-search t) start message-id end) @@ -694,6 +892,7 @@ (insert "Original-"))) (forward-line 1) (insert "Message-ID: " (setq message-id (nnmail-message-id)) "\n")) + (run-hooks 'nnmail-prepare-incoming-header-hook) ;; Find the end of this article. (goto-char (point-max)) (widen) @@ -705,12 +904,13 @@ (save-restriction (narrow-to-region start (point)) (goto-char (point-min)) - (nnmail-check-duplication message-id func) + (nnmail-check-duplication message-id func artnum-func) (setq end (point-max)))) (goto-char end) (forward-line 2))))) -(defun nnmail-split-incoming (incoming func &optional exit-func group) +(defun nnmail-split-incoming (incoming func &optional exit-func + group artnum-func) "Go through the entire INCOMING file and pick out each individual mail. FUNC will be called with the buffer narrowed to each mail." (let (;; If this is a group-specific split, we bind the split @@ -726,7 +926,7 @@ (set-buffer (get-buffer-create " *nnmail incoming*")) (buffer-disable-undo (current-buffer)) (erase-buffer) - (nnheader-insert-file-contents-literally incoming) + (nnheader-insert-file-contents incoming) (unless (zerop (buffer-size)) (goto-char (point-min)) (save-excursion (run-hooks 'nnmail-prepare-incoming-hook)) @@ -735,12 +935,13 @@ ;; fetches from a file. (cond ((or (looking-at "\^L") (looking-at "BABYL OPTIONS:")) - (nnmail-process-babyl-mail-format func)) + (nnmail-process-babyl-mail-format func artnum-func)) ((looking-at "\^A\^A\^A\^A") - (nnmail-process-mmdf-mail-format func)) + (nnmail-process-mmdf-mail-format func artnum-func)) (t - (nnmail-process-unix-mail-format func)))) - (if exit-func (funcall exit-func)) + (nnmail-process-unix-mail-format func artnum-func)))) + (when exit-func + (funcall exit-func)) (kill-buffer (current-buffer))))) ;; Mail crossposts suggested by Brian Edmonds . @@ -769,13 +970,11 @@ (goto-char (point-min)) (while (re-search-forward "\\(\r?\n[ \t]+\\)+" nil t) (replace-match " " t t)) + ;; Allow washing. + (run-hooks 'nnmail-split-hook) (if (and (symbolp nnmail-split-methods) (fboundp nnmail-split-methods)) - ;; `nnmail-split-methods' is a function, so we just call - ;; this function here and use the result. - (setq group-art - (mapcar - (lambda (group) (cons group (funcall func group))) + (let ((split (condition-case nil (or (funcall nnmail-split-methods) '("bogus")) @@ -784,6 +983,13 @@ "Error in `nnmail-split-methods'; using `bogus' mail group") (sit-for 1) '("bogus"))))) + (unless (equal split '(junk)) + ;; `nnmail-split-methods' is a function, so we just call + ;; this function here and use the result. + (setq group-art + (mapcar + (lambda (group) (cons group (funcall func group))) + split)))) ;; Go through the split methods to find a match. (while (and methods (or nnmail-crosspost (not group-art))) (goto-char (point-max)) @@ -791,24 +997,26 @@ (if (or methods (not (equal "" (nth 1 method)))) (when (and - (condition-case () - (if (stringp (nth 1 method)) - (re-search-backward (cadr method) nil t) - ;; Function to say whether this is a match. - (funcall (nth 1 method) (car method))) - (error nil)) + (ignore-errors + (if (stringp (nth 1 method)) + (re-search-backward (cadr method) nil t) + ;; Function to say whether this is a match. + (funcall (nth 1 method) (car method)))) ;; Don't enter the article into the same ;; group twice. (not (assoc (car method) group-art))) - (push (cons (car method) (funcall func (car method))) + (push (cons (car method) (funcall func (car method))) group-art)) ;; This is the final group, which is used as a ;; catch-all. (unless group-art (setq group-art - (list (cons (car method) + (list (cons (car method) (funcall func (car method))))))))) - group-art)))) + ;; See whether the split methods returned `junk'. + (if (equal group-art '(junk)) + nil + (nreverse (delq 'junk group-art))))))) (defun nnmail-insert-lines () "Insert how many lines there are in the body of the mail. @@ -816,7 +1024,7 @@ (let (lines chars) (save-excursion (goto-char (point-min)) - (when (search-forward "\n\n" nil t) + (when (search-forward "\n\n" nil t) (setq chars (- (point-max) (point))) (setq lines (count-lines (point) (point-max))) (forward-char -1) @@ -831,10 +1039,10 @@ "Insert an Xref line based on the (group . article) alist." (save-excursion (goto-char (point-min)) - (when (search-forward "\n\n" nil t) + (when (search-forward "\n\n" nil t) (forward-char -1) (when (re-search-backward "^Xref: " nil t) - (delete-region (match-beginning 0) + (delete-region (match-beginning 0) (progn (forward-line 1) (point)))) (insert (format "Xref: %s" (system-name))) (while group-alist @@ -842,6 +1050,31 @@ (setq group-alist (cdr group-alist))) (insert "\n")))) +;;; Message washing functions + +(defun nnmail-remove-leading-whitespace () + "Remove excessive whitespace from all headers." + (goto-char (point-min)) + (while (re-search-forward "^\\([^ :]+: \\) +" nil t) + (replace-match "\\1" t))) + +(defun nnmail-remove-list-identifiers () + "Remove list identifiers from Subject headers." + (let ((regexp (if (stringp nnmail-list-identifiers) nnmail-list-identifiers + (mapconcat 'identity nnmail-list-identifiers "\\|")))) + (when regexp + (goto-char (point-min)) + (when (re-search-forward + (concat "^Subject: +\\(Re: +\\)?\\(" regexp "\\) *") + nil t) + (delete-region (match-beginning 2) (match-end 0)))))) + +(defun nnmail-remove-tabs () + "Translate TAB characters into SPACE characters." + (subst-char-in-region (point-min) (point-max) ?\t ? t)) + +;;; Utility functions + ;; Written by byer@mv.us.adobe.com (Scott Byer). (defun nnmail-make-complex-temp-name (prefix) (let ((newname (make-temp-name prefix)) @@ -868,42 +1101,114 @@ (defun nnmail-split-it (split) ;; Return a list of groups matching SPLIT. - (cond ((stringp split) - ;; A group. - (list split)) - ((eq (car split) '&) - (apply 'nconc (mapcar 'nnmail-split-it (cdr split)))) - ((eq (car split) '|) - (let (done) - (while (and (not done) (cdr split)) - (setq split (cdr split) - done (nnmail-split-it (car split)))) - done)) - ((assq split nnmail-split-cache) - ;; A compiled match expression. - (goto-char (point-max)) - (if (re-search-backward (cdr (assq split nnmail-split-cache)) nil t) - (nnmail-split-it (nth 2 split)))) - (t - ;; An uncompiled match. - (let* ((field (nth 0 split)) - (value (nth 1 split)) - (regexp (concat "^\\(" - (if (symbolp field) - (cdr (assq field - nnmail-split-abbrev-alist)) - field) - "\\):.*\\<\\(" - (if (symbolp value) - (cdr (assq value - nnmail-split-abbrev-alist)) - value) - "\\)\\>"))) - (setq nnmail-split-cache - (cons (cons split regexp) nnmail-split-cache)) - (goto-char (point-max)) - (if (re-search-backward regexp nil t) - (nnmail-split-it (nth 2 split))))))) + (cond + ;; nil split + ((null split) + nil) + + ;; A group name. Do the \& and \N subs into the string. + ((stringp split) + (list (nnmail-expand-newtext split))) + + ;; Junk the message. + ((eq split 'junk) + (list 'junk)) + + ;; Builtin & operation. + ((eq (car split) '&) + (apply 'nconc (mapcar 'nnmail-split-it (cdr split)))) + + ;; Builtin | operation. + ((eq (car split) '|) + (let (done) + (while (and (not done) (cdr split)) + (setq split (cdr split) + done (nnmail-split-it (car split)))) + done)) + + ;; Builtin : operation. + ((eq (car split) ':) + (nnmail-split-it (eval (cdr split)))) + + ;; Check the cache for the regexp for this split. + ;; FIX FIX FIX could avoid calling assq twice here + ((assq split nnmail-split-cache) + (goto-char (point-max)) + ;; FIX FIX FIX problem with re-search-backward is that if you have + ;; a split: (from "foo-\\(bar\\|baz\\)@gnus.org "mail.foo.\\1") + ;; and someone mails a message with 'To: foo-bar@gnus.org' and + ;; 'CC: foo-baz@gnus.org', we'll pick 'mail.foo.baz' as the group + ;; if the cc line is a later header, even though the other choice + ;; is probably better. Also, this routine won't do a crosspost + ;; when there are two different matches. + ;; I guess you could just make this more determined, and it could + ;; look for still more matches prior to this one, and recurse + ;; on each of the multiple matches hit. Of course, then you'd + ;; want to make sure that nnmail-article-group or nnmail-split-fancy + ;; removed duplicates, since there might be more of those. + ;; I guess we could also remove duplicates in the & split case, since + ;; that's the only thing that can introduce them. + (when (re-search-backward (cdr (assq split nnmail-split-cache)) nil t) + ;; Someone might want to do a \N sub on this match, so get the + ;; correct match positions. + (goto-char (match-end 0)) + (let ((value (nth 1 split))) + (re-search-backward (if (symbolp value) + (cdr (assq value nnmail-split-abbrev-alist)) + value) + (match-end 1))) + (nnmail-split-it (nth 2 split)))) + + ;; Not in cache, compute a regexp for the field/value pair. + (t + (let* ((field (nth 0 split)) + (value (nth 1 split)) + (regexp (concat "^\\(\\(" + (if (symbolp field) + (cdr (assq field nnmail-split-abbrev-alist)) + field) + "\\):.*\\)\\<\\(" + (if (symbolp value) + (cdr (assq value nnmail-split-abbrev-alist)) + value) + "\\)\\>"))) + (push (cons split regexp) nnmail-split-cache) + ;; Now that it's in the cache, just call nnmail-split-it again + ;; on the same split, which will find it immediately in the cache. + (nnmail-split-it split))))) + +(defun nnmail-expand-newtext (newtext) + (let ((len (length newtext)) + (pos 0) + c expanded beg N did-expand) + (while (< pos len) + (setq beg pos) + (while (and (< pos len) + (not (= (aref newtext pos) ?\\))) + (setq pos (1+ pos))) + (unless (= beg pos) + (push (substring newtext beg pos) expanded)) + (when (< pos len) + ;; we hit a \, expand it. + (setq did-expand t) + (setq pos (1+ pos)) + (setq c (aref newtext pos)) + (if (not (or (= c ?\&) + (and (>= c ?1) + (<= c ?9)))) + ;; \ followed by some character we don't expand + (push (char-to-string c) expanded) + ;; \& or \N + (if (= c ?\&) + (setq N 0) + (setq N (- c ?0))) + (when (match-beginning N) + (push (buffer-substring (match-beginning N) (match-end N)) + expanded)))) + (setq pos (1+ pos))) + (if did-expand + (apply 'concat (nreverse expanded)) + newtext))) ;; Get a list of spool files to read. (defun nnmail-get-spool-files (&optional group) @@ -919,13 +1224,14 @@ (directory-files nnmail-procmail-directory t (concat (if group (concat "^" group) "") - nnmail-procmail-suffix "$") t))) + nnmail-procmail-suffix "$")))) (p procmails) (crash (when (and (file-exists-p nnmail-crash-box) (> (nnheader-file-size - (file-truename nnmail-crash-box)) 0)) + (file-truename nnmail-crash-box)) + 0)) (list nnmail-crash-box)))) - ;; Remove any directories that inadvertantly match the procmail + ;; Remove any directories that inadvertently match the procmail ;; suffix, which might happen if the suffix is "". (while p (when (file-directory-p (car p)) @@ -943,9 +1249,24 @@ (eq nnmail-spool-file 'procmail)) nil) ((listp nnmail-spool-file) - (append nnmail-spool-file procmails)) - ((stringp nnmail-spool-file) + (nconc + (apply + 'nconc + (mapcar + (lambda (file) + (if (file-directory-p file) + (nnheader-directory-regular-files file) + (list file))) + nnmail-spool-file)) + procmails)) + ((and (stringp nnmail-spool-file) + (not (file-directory-p nnmail-spool-file))) (cons nnmail-spool-file procmails)) + ((and (stringp nnmail-spool-file) + (file-directory-p nnmail-spool-file)) + (nconc + (nnheader-directory-regular-files nnmail-spool-file) + procmails)) ((eq nnmail-spool-file 'pop) (cons (format "po:%s" (user-login-name)) procmails)) (t @@ -958,10 +1279,9 @@ (let (file timestamp file-time) (if (or (not (symbol-value (intern (format "%s-group-alist" backend)))) force - (and (setq file (condition-case () - (symbol-value (intern (format "%s-active-file" - backend))) - (error nil))) + (and (setq file (ignore-errors + (symbol-value (intern (format "%s-active-file" + backend))))) (setq file-time (nth 5 (file-attributes file))) (or (not (setq timestamp @@ -978,10 +1298,19 @@ (save-excursion (or (eq timestamp 'none) (set (intern (format "%s-active-timestamp" backend)) - (current-time))) +;;; dmoore@ucsd.edu 25.10.96 +;;; it's not always the case that current-time +;;; does correspond to changes in the file's time. So just compare +;;; the file's new time against its own previous time. +;;; (current-time) + file-time + )) (funcall (intern (format "%s-request-list" backend))) - (set (intern (format "%s-group-alist" backend)) - (nnmail-get-active)))) +;;; dmoore@ucsd.edu 25.10.96 +;;; BACKEND-request-list already does this itself! +;;; (set (intern (format "%s-group-alist" backend)) +;;; (nnmail-get-active)) + )) t)) (defun nnmail-message-id () @@ -1003,8 +1332,8 @@ (setq nnmail-cache-buffer (get-buffer-create " *nnmail message-id cache*"))) (buffer-disable-undo (current-buffer)) - (and (file-exists-p nnmail-message-id-cache-file) - (insert-file-contents nnmail-message-id-cache-file)) + (when (file-exists-p nnmail-message-id-cache-file) + (nnheader-insert-file-contents nnmail-message-id-cache-file)) (set-buffer-modified-p nil) (current-buffer)))) @@ -1017,16 +1346,16 @@ (set-buffer nnmail-cache-buffer) ;; Weed out the excess number of Message-IDs. (goto-char (point-max)) - (and (search-backward "\n" nil t nnmail-message-id-cache-length) - (progn - (beginning-of-line) - (delete-region (point-min) (point)))) + (when (search-backward "\n" nil t nnmail-message-id-cache-length) + (progn + (beginning-of-line) + (delete-region (point-min) (point)))) ;; Save the buffer. (or (file-exists-p (file-name-directory nnmail-message-id-cache-file)) (make-directory (file-name-directory nnmail-message-id-cache-file) t)) - (write-region (point-min) (point-max) - nnmail-message-id-cache-file nil 'silent) + (nnmail-write-region (point-min) (point-max) + nnmail-message-id-cache-file nil 'silent) (set-buffer-modified-p nil) (setq nnmail-cache-buffer nil) ;;(kill-buffer (current-buffer)) @@ -1046,9 +1375,11 @@ (goto-char (point-max)) (search-backward id nil t)))) -(defun nnmail-check-duplication (message-id func) +(defun nnmail-check-duplication (message-id func artnum-func) + (run-hooks 'nnmail-prepare-incoming-message-hook) ;; If this is a duplicate message, then we do not save it. (let* ((duplication (nnmail-cache-id-exists-p message-id)) + (case-fold-search t) (action (when duplication (cond ((memq nnmail-treat-duplicates '(warn delete)) @@ -1056,13 +1387,16 @@ ((nnheader-functionp nnmail-treat-duplicates) (funcall nnmail-treat-duplicates message-id)) (t - nnmail-treat-duplicates))))) + nnmail-treat-duplicates)))) + group-art) + ;; Let the backend save the article (or not). (cond ((not duplication) (nnmail-cache-insert message-id) - (funcall func)) + (funcall func (setq group-art + (nreverse (nnmail-article-group artnum-func))))) ((eq action 'delete) - (delete-region (point-min) (point-max))) + (setq group-art nil)) ((eq action 'warn) ;; We insert a warning. (let ((case-fold-search t) @@ -1076,9 +1410,15 @@ "Message-ID: " newid "\n" "Gnus-Warning: This is a duplicate of message " message-id "\n") (nnmail-cache-insert newid) - (funcall func))) + (funcall func (setq group-art + (nreverse (nnmail-article-group artnum-func)))))) (t - (funcall func))))) + (funcall func (setq group-art + (nreverse (nnmail-article-group artnum-func)))))) + ;; Add the group-art list to the history list. + (if group-art + (push group-art nnmail-split-history) + (delete-region (point-min) (point-max))))) ;;; Get new mail. @@ -1090,6 +1430,9 @@ (defun nnmail-get-new-mail (method exit-func temp &optional group spool-func) "Read new incoming mail." + ;; Nix out the previous split history. + (unless group + (setq nnmail-split-history nil)) (let* ((spools (nnmail-get-spool-files group)) (group-in group) incoming incomings spool) @@ -1107,9 +1450,9 @@ (setq spool (pop spools)) ;; We read each spool file if either the spool is a POP-mail ;; spool, or the file exists. We can't check for the - ;; existance of POPped mail. + ;; existence of POPped mail. (when (or (string-match "^po:" spool) - (and (file-exists-p spool) + (and (file-exists-p (file-truename spool)) (> (nnheader-file-size (file-truename spool)) 0))) (nnheader-message 3 "%s: Reading incoming mail..." method) (when (and (nnmail-move-inbox spool) @@ -1119,8 +1462,8 @@ (setq group (nnmail-get-split-group spool group-in)) ;; We split the mail (nnmail-split-incoming - nnmail-crash-box (intern (format "%s-save-mail" method)) - spool-func group) + nnmail-crash-box (intern (format "%s-save-mail" method)) + spool-func group (intern (format "%s-active-number" method))) ;; Check whether the inbox is to be moved to the special tmp dir. (setq incoming (nnmail-make-complex-temp-name @@ -1177,22 +1520,117 @@ (nnmail-time-less days (nnmail-time-since time))))))) (defvar nnmail-read-passwd nil) -(defun nnmail-read-passwd (prompt) - (unless nnmail-read-passwd - (if (load "passwd" t) - (setq nnmail-read-passwd 'read-passwd) - (autoload 'ange-ftp-read-passwd "ange-ftp") - (setq nnmail-read-passwd 'ange-ftp-read-passwd))) - (funcall nnmail-read-passwd prompt)) +(defun nnmail-read-passwd (prompt &rest args) + "Read a password using PROMPT. +If ARGS, PROMPT is used as an argument to `format'." + (let ((prompt + (if args + (apply 'format prompt args) + prompt))) + (unless nnmail-read-passwd + (if (load "passwd" t) + (setq nnmail-read-passwd 'read-passwd) + (autoload 'ange-ftp-read-passwd "ange-ftp") + (setq nnmail-read-passwd 'ange-ftp-read-passwd))) + (funcall nnmail-read-passwd prompt))) (defun nnmail-check-syntax () "Check (and modify) the syntax of the message in the current buffer." (save-restriction (message-narrow-to-head) (let ((case-fold-search t)) - (unless (re-search-forward "^Message-Id:" nil t) + (unless (re-search-forward "^Message-ID:" nil t) (insert "Message-ID: " (nnmail-message-id) "\n"))))) +(defun nnmail-write-region (start end filename &optional append visit lockname) + "Do a `write-region', and then set the file modes." + (write-region start end filename append visit lockname) + (set-file-modes filename nnmail-default-file-modes)) + +;;; +;;; Status functions +;;; + +(defun nnmail-replace-status (name value) + "Make status NAME and VALUE part of the current status line." + (save-restriction + (message-narrow-to-head) + (let ((status (nnmail-decode-status))) + (setq status (delq (member name status) status)) + (when value + (push (cons name value) status)) + (message-remove-header "status") + (goto-char (point-max)) + (insert "Status: " (nnmail-encode-status status) "\n")))) + +(defun nnmail-decode-status () + "Return a status-value alist from STATUS." + (goto-char (point-min)) + (when (re-search-forward "^Status: " nil t) + (let (name value status) + (save-restriction + ;; Narrow to the status. + (narrow-to-region + (point) + (if (re-search-forward "^[^ \t]" nil t) + (1- (point)) + (point-max))) + ;; Go through all elements and add them to the list. + (goto-char (point-min)) + (while (re-search-forward "[^ \t=]+" nil t) + (setq name (match-string 0)) + (if (not (= (following-char) ?=)) + ;; Implied "yes". + (setq value "yes") + (forward-char 1) + (if (not (= (following-char) ?\")) + (if (not (looking-at "[^ \t]")) + ;; Implied "no". + (setq value "no") + ;; Unquoted value. + (setq value (match-string 0)) + (goto-char (match-end 0))) + ;; Quoted value. + (setq value (read (current-buffer))))) + (push (cons name value) status))) + status))) + +(defun nnmail-encode-status (status) + "Return a status string from STATUS." + (mapconcat + (lambda (elem) + (concat + (car elem) "=" + (if (string-match "[ \t]" (cdr elem)) + (prin1-to-string (cdr elem)) + (cdr elem)))) + status " ")) + +(defun nnmail-split-history () + "Generate an overview of where the last mail split put articles." + (interactive) + (unless nnmail-split-history + (error "No current split history")) + (with-output-to-temp-buffer "*nnmail split history*" + (let ((history nnmail-split-history) + elem) + (while (setq elem (pop history)) + (princ (mapconcat (lambda (ga) + (concat (car ga) ":" (int-to-string (cdr ga)))) + elem + ", ")) + (princ "\n"))))) + +(defun nnmail-new-mail-p (group) + "Say whether GROUP has new mail." + (let ((his nnmail-split-history) + found) + (while his + (when (assoc group (pop his)) + (setq found t + his nil))) + found)) + (run-hooks 'nnmail-load-hook) (provide 'nnmail) diff -r ad457d5f7d04 -r 0293115a14e9 lisp/gnus/nnmbox.el --- a/lisp/gnus/nnmbox.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/gnus/nnmbox.el Mon Aug 13 08:49:20 2007 +0200 @@ -1,5 +1,5 @@ ;;; nnmbox.el --- mail mbox access for Gnus -;; Copyright (C) 1995,96 Free Software Foundation, Inc. +;; Copyright (C) 1995,96,97 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; Masanobu UMEDA @@ -82,22 +82,21 @@ (setq article (car sequence)) (setq art-string (nnmbox-article-string article)) (set-buffer nnmbox-mbox-buffer) - (if (or (search-forward art-string nil t) - (progn (goto-char (point-min)) - (search-forward art-string nil t))) - (progn - (setq start - (save-excursion - (re-search-backward - (concat "^" message-unix-mail-delimiter) nil t) - (point))) - (search-forward "\n\n" nil t) - (setq stop (1- (point))) - (set-buffer nntp-server-buffer) - (insert (format "221 %d Article retrieved.\n" article)) - (insert-buffer-substring nnmbox-mbox-buffer start stop) - (goto-char (point-max)) - (insert ".\n"))) + (when (or (search-forward art-string nil t) + (progn (goto-char (point-min)) + (search-forward art-string nil t))) + (setq start + (save-excursion + (re-search-backward + (concat "^" message-unix-mail-delimiter) nil t) + (point))) + (search-forward "\n\n" nil t) + (setq stop (1- (point))) + (set-buffer nntp-server-buffer) + (insert (format "221 %d Article retrieved.\n" article)) + (insert-buffer-substring nnmbox-mbox-buffer start stop) + (goto-char (point-max)) + (insert ".\n")) (setq sequence (cdr sequence)) (setq count (1+ count)) (and (numberp nnmail-large-newsgroup) @@ -116,6 +115,7 @@ (deffoo nnmbox-open-server (server &optional defs) (nnoo-change-server 'nnmbox server defs) + (nnmbox-create-mbox) (cond ((not (file-exists-p nnmbox-mbox-file)) (nnmbox-close-server) @@ -147,28 +147,28 @@ (save-excursion (set-buffer nnmbox-mbox-buffer) (goto-char (point-min)) - (if (search-forward (nnmbox-article-string article) nil t) - (let (start stop) - (re-search-backward (concat "^" message-unix-mail-delimiter) nil t) - (setq start (point)) - (forward-line 1) - (or (and (re-search-forward - (concat "^" message-unix-mail-delimiter) nil t) - (forward-line -1)) - (goto-char (point-max))) - (setq stop (point)) - (let ((nntp-server-buffer (or buffer nntp-server-buffer))) - (set-buffer nntp-server-buffer) - (erase-buffer) - (insert-buffer-substring nnmbox-mbox-buffer start stop) - (goto-char (point-min)) - (while (looking-at "From ") - (delete-char 5) - (insert "X-From-Line: ") - (forward-line 1)) - (if (numberp article) - (cons nnmbox-current-group article) - (nnmbox-article-group-number))))))) + (when (search-forward (nnmbox-article-string article) nil t) + (let (start stop) + (re-search-backward (concat "^" message-unix-mail-delimiter) nil t) + (setq start (point)) + (forward-line 1) + (or (and (re-search-forward + (concat "^" message-unix-mail-delimiter) nil t) + (forward-line -1)) + (goto-char (point-max))) + (setq stop (point)) + (let ((nntp-server-buffer (or buffer nntp-server-buffer))) + (set-buffer nntp-server-buffer) + (erase-buffer) + (insert-buffer-substring nnmbox-mbox-buffer start stop) + (goto-char (point-min)) + (while (looking-at "From ") + (delete-char 5) + (insert "X-From-Line: ") + (forward-line 1)) + (if (numberp article) + (cons nnmbox-current-group article) + (nnmbox-article-group-number))))))) (deffoo nnmbox-request-group (group &optional server dont-check) (let ((active (cadr (assoc group nnmbox-group-alist)))) @@ -186,6 +186,7 @@ (car active) (cdr active) group))))) (deffoo nnmbox-request-scan (&optional group server) + (nnmbox-possibly-change-newsgroup group server) (nnmbox-read-mbox) (nnmail-get-new-mail 'nnmbox @@ -208,7 +209,8 @@ (deffoo nnmbox-request-list (&optional server) (save-excursion (nnmail-find-file nnmbox-active-file) - (setq nnmbox-group-alist (nnmail-get-active)))) + (setq nnmbox-group-alist (nnmail-get-active)) + t)) (deffoo nnmbox-request-newgroups (date &optional server) (nnmbox-request-list server)) @@ -227,17 +229,17 @@ (set-buffer nnmbox-mbox-buffer) (while (and articles is-old) (goto-char (point-min)) - (if (search-forward (nnmbox-article-string (car articles)) nil t) - (if (setq is-old - (nnmail-expired-article-p - newsgroup - (buffer-substring - (point) (progn (end-of-line) (point))) force)) - (progn - (nnheader-message 5 "Deleting article %d in %s..." - (car articles) newsgroup) - (nnmbox-delete-mail)) - (setq rest (cons (car articles) rest)))) + (when (search-forward (nnmbox-article-string (car articles)) nil t) + (if (setq is-old + (nnmail-expired-article-p + newsgroup + (buffer-substring + (point) (progn (end-of-line) (point))) force)) + (progn + (nnheader-message 5 "Deleting article %d in %s..." + (car articles) newsgroup) + (nnmbox-delete-mail)) + (push (car articles) rest))) (setq articles (cdr articles))) (save-buffer) ;; Find the lowest active article in this group. @@ -253,7 +255,6 @@ (deffoo nnmbox-request-move-article (article group server accept-form &optional last) - (nnmbox-possibly-change-newsgroup group server) (let ((buf (get-buffer-create " *nnmbox move*")) result) (and @@ -273,10 +274,11 @@ (kill-buffer buf) result) (save-excursion + (nnmbox-possibly-change-newsgroup group server) (set-buffer nnmbox-mbox-buffer) (goto-char (point-min)) - (if (search-forward (nnmbox-article-string article) nil t) - (nnmbox-delete-mail)) + (when (search-forward (nnmbox-article-string article) nil t) + (nnmbox-delete-mail)) (and last (save-buffer)))) result)) @@ -301,7 +303,10 @@ (forward-line -1) (while (re-search-backward "^X-Gnus-Newsgroup: " nil t) (delete-region (point) (progn (forward-line 1) (point)))) - (setq result (nnmbox-save-mail (and (stringp group) group)))) + (setq result (nnmbox-save-mail + (if (stringp group) + (list (cons group (nnmbox-active-number group))) + (nnmail-article-group 'nnmbox-active-number))))) (save-excursion (set-buffer nnmbox-mbox-buffer) (goto-char (point-max)) @@ -337,7 +342,8 @@ (while (search-forward ident nil t) (setq found t) (nnmbox-delete-mail)) - (and found (save-buffer))))) + (when found + (save-buffer))))) ;; Remove the group from all structures. (setq nnmbox-group-alist (delq (assoc group nnmbox-group-alist) nnmbox-group-alist) @@ -357,9 +363,11 @@ (while (search-forward ident nil t) (replace-match new-ident t t) (setq found t)) - (and found (save-buffer)))) + (when found + (save-buffer)))) (let ((entry (assoc group nnmbox-group-alist))) - (and entry (setcar entry new-name)) + (when entry + (setcar entry new-name)) (setq nnmbox-current-group nil) ;; Save the new group alist. (nnmail-save-active nnmbox-group-alist nnmbox-active-file) @@ -369,7 +377,7 @@ ;;; Internal functions. ;; If FORCE, delete article no matter how many X-Gnus-Newsgroup -;; headers there are. If LEAVE-DELIM, don't delete the Unix mbox +;; headers there are. If LEAVE-DELIM, don't delete the Unix mbox ;; delimiter line. (defun nnmbox-delete-mail (&optional force leave-delim) ;; Delete the current X-Gnus-Newsgroup line. @@ -387,7 +395,7 @@ (match-beginning 0))) (progn (forward-line 1) - (or (and (re-search-forward (concat "^" message-unix-mail-delimiter) + (or (and (re-search-forward (concat "^" message-unix-mail-delimiter) nil t) (if (and (not (bobp)) leave-delim) (progn (forward-line -2) (point)) @@ -395,25 +403,25 @@ (point-max)))) (goto-char (point-min)) ;; Only delete the article if no other groups owns it as well. - (if (or force (not (re-search-forward "^X-Gnus-Newsgroup: " nil t))) - (delete-region (point-min) (point-max)))))) + (when (or force (not (re-search-forward "^X-Gnus-Newsgroup: " nil t))) + (delete-region (point-min) (point-max)))))) (defun nnmbox-possibly-change-newsgroup (newsgroup &optional server) (when (and server (not (nnmbox-server-opened server))) (nnmbox-open-server server)) - (if (or (not nnmbox-mbox-buffer) - (not (buffer-name nnmbox-mbox-buffer))) - (save-excursion - (set-buffer (setq nnmbox-mbox-buffer - (nnheader-find-file-noselect - nnmbox-mbox-file nil 'raw))) - (buffer-disable-undo (current-buffer)))) - (if (not nnmbox-group-alist) - (nnmail-activate 'nnmbox)) + (when (or (not nnmbox-mbox-buffer) + (not (buffer-name nnmbox-mbox-buffer))) + (save-excursion + (set-buffer (setq nnmbox-mbox-buffer + (nnheader-find-file-noselect + nnmbox-mbox-file nil 'raw))) + (buffer-disable-undo (current-buffer)))) + (when (not nnmbox-group-alist) + (nnmail-activate 'nnmbox)) (if newsgroup - (if (assoc newsgroup nnmbox-group-alist) - (setq nnmbox-current-group newsgroup)) + (when (assoc newsgroup nnmbox-group-alist) + (setq nnmbox-current-group newsgroup)) t)) (defun nnmbox-article-string (article) @@ -425,18 +433,15 @@ (defun nnmbox-article-group-number () (save-excursion (goto-char (point-min)) - (and (re-search-forward "^X-Gnus-Newsgroup: +\\([^:]+\\):\\([0-9]+\\) " - nil t) - (cons (buffer-substring (match-beginning 1) (match-end 1)) - (string-to-int - (buffer-substring (match-beginning 2) (match-end 2))))))) + (when (re-search-forward "^X-Gnus-Newsgroup: +\\([^:]+\\):\\([0-9]+\\) " + nil t) + (cons (buffer-substring (match-beginning 1) (match-end 1)) + (string-to-int + (buffer-substring (match-beginning 2) (match-end 2))))))) -(defun nnmbox-save-mail (&optional group) +(defun nnmbox-save-mail (group-art) "Called narrowed to an article." - (let* ((nnmail-split-methods - (if group (list (list group "")) nnmail-split-methods)) - (group-art (nreverse (nnmail-article-group 'nnmbox-active-number))) - (delim (concat "^" message-unix-mail-delimiter))) + (let ((delim (concat "^" message-unix-mail-delimiter))) (goto-char (point-min)) ;; This might come from somewhere else. (unless (looking-at delim) @@ -457,14 +462,13 @@ (defun nnmbox-insert-newsgroup-line (group-art) (save-excursion (goto-char (point-min)) - (if (search-forward "\n\n" nil t) - (progn - (forward-char -1) - (while group-art - (insert (format "X-Gnus-Newsgroup: %s:%d %s\n" - (caar group-art) (cdar group-art) - (current-time-string))) - (setq group-art (cdr group-art))))) + (when (search-forward "\n\n" nil t) + (forward-char -1) + (while group-art + (insert (format "X-Gnus-Newsgroup: %s:%d %s\n" + (caar group-art) (cdar group-art) + (current-time-string))) + (setq group-art (cdr group-art)))) t)) (defun nnmbox-active-number (group) @@ -475,14 +479,17 @@ ;; This group is new, so we create a new entry for it. ;; This might be a bit naughty... creating groups on the drop of ;; a hat, but I don't know... - (setq nnmbox-group-alist (cons (list group (setq active (cons 1 1))) - nnmbox-group-alist))) + (push (list group (setq active (cons 1 1))) + nnmbox-group-alist)) (cdr active))) +(defun nnmbox-create-mbox () + (when (not (file-exists-p nnmbox-mbox-file)) + (nnmail-write-region 1 1 nnmbox-mbox-file t 'nomesg))) + (defun nnmbox-read-mbox () (nnmail-activate 'nnmbox) - (if (not (file-exists-p nnmbox-mbox-file)) - (write-region 1 1 nnmbox-mbox-file t 'nomesg)) + (nnmbox-create-mbox) (if (and nnmbox-mbox-buffer (buffer-name nnmbox-mbox-buffer) (save-excursion @@ -516,19 +523,20 @@ (goto-char (point-min)) (while (re-search-forward delim nil t) (setq start (match-beginning 0)) - (if (not (search-forward "\nX-Gnus-Newsgroup: " - (save-excursion - (setq end - (or - (and - (re-search-forward delim nil t) - (match-beginning 0)) - (point-max)))) - t)) - (save-excursion - (save-restriction - (narrow-to-region start end) - (nnmbox-save-mail)))) + (when (not (search-forward "\nX-Gnus-Newsgroup: " + (save-excursion + (setq end + (or + (and + (re-search-forward delim nil t) + (match-beginning 0)) + (point-max)))) + t)) + (save-excursion + (save-restriction + (narrow-to-region start end) + (nnmbox-save-mail + (nnmail-article-group 'nnmbox-active-number))))) (goto-char end)))))) (provide 'nnmbox) diff -r ad457d5f7d04 -r 0293115a14e9 lisp/gnus/nnmh.el --- a/lisp/gnus/nnmh.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/gnus/nnmh.el Mon Aug 13 08:49:20 2007 +0200 @@ -1,5 +1,5 @@ ;;; nnmh.el --- mhspool access for Gnus -;; Copyright (C) 1995,96 Free Software Foundation, Inc. +;; Copyright (C) 1995,96,97 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; Masanobu UMEDA @@ -32,9 +32,9 @@ (require 'nnheader) (require 'nnmail) -(require 'gnus) +(require 'gnus-start) (require 'nnoo) -(eval-and-compile (require 'cl)) +(require 'cl) (nnoo-declare nnmh) @@ -105,7 +105,8 @@ (message "nnmh: Receiving headers... %d%%" (/ (* count 100) number)))) - (and large (message "nnmh: Receiving headers...done")) + (when large + (message "nnmh: Receiving headers...done")) (nnheader-fold-continuation-lines) 'headers)))) @@ -176,7 +177,7 @@ (nnheader-insert (format "211 0 1 0 %s\n" group)))))))))) (deffoo nnmh-request-scan (&optional group server) - (nnmail-get-new-mail 'nnmh nil nnmh-directory group)) + (nnmail-get-new-mail 'nnmh nil nnmh-directory group)) (deffoo nnmh-request-list (&optional server dir) (nnheader-insert "") @@ -216,10 +217,11 @@ (string-match (regexp-quote (file-truename (file-name-as-directory - (expand-file-name nnmh-toplev)))) dir) + (expand-file-name nnmh-toplev)))) + dir) (nnheader-replace-chars-in-string (substring dir (match-end 0)) ?/ ?.)) - (apply 'max files) + (apply 'max files) (apply 'min files))))))) t) @@ -241,20 +243,20 @@ (while (and articles is-old) (setq article (concat nnmh-current-directory (int-to-string (car articles)))) - (if (setq mod-time (nth 5 (file-attributes article))) - (if (and (nnmh-deletable-article-p newsgroup (car articles)) - (setq is-old - (nnmail-expired-article-p newsgroup mod-time force))) - (progn - (nnheader-message 5 "Deleting article %s in %s..." - article newsgroup) - (condition-case () - (funcall nnmail-delete-file-function article) - (file-error - (nnheader-message 1 "Couldn't delete article %s in %s" - article newsgroup) - (setq rest (cons (car articles) rest))))) - (setq rest (cons (car articles) rest)))) + (when (setq mod-time (nth 5 (file-attributes article))) + (if (and (nnmh-deletable-article-p newsgroup (car articles)) + (setq is-old + (nnmail-expired-article-p newsgroup mod-time force))) + (progn + (nnheader-message 5 "Deleting article %s in %s..." + article newsgroup) + (condition-case () + (funcall nnmail-delete-file-function article) + (file-error + (nnheader-message 1 "Couldn't delete article %s in %s" + article newsgroup) + (push (car articles) rest)))) + (push (car articles) rest))) (setq articles (cdr articles))) (message "") (nconc rest articles))) @@ -289,45 +291,42 @@ (if (stringp group) (and (nnmail-activate 'nnmh) - ;; We trick the choosing function into believing that only one - ;; group is available. - (let ((nnmail-split-methods (list (list group "")))) - (car (nnmh-save-mail noinsert)))) + (car (nnmh-save-mail + (list (cons group (nnmh-active-number group))) + noinsert))) (and (nnmail-activate 'nnmh) - (car (nnmh-save-mail noinsert))))) + (car (nnmh-save-mail (nnmail-article-group 'nnmh-active-number) + noinsert))))) (deffoo nnmh-request-replace-article (article group buffer) (nnmh-possibly-change-directory group) (save-excursion (set-buffer buffer) (nnmh-possibly-create-directory group) - (condition-case () - (progn - (write-region - (point-min) (point-max) - (concat nnmh-current-directory (int-to-string article)) - nil (if (nnheader-be-verbose 5) nil 'nomesg)) - t) - (error nil)))) + (ignore-errors + (nnmail-write-region + (point-min) (point-max) + (concat nnmh-current-directory (int-to-string article)) + nil (if (nnheader-be-verbose 5) nil 'nomesg)) + t))) -(deffoo nnmh-request-create-group (group &optional server) +(deffoo nnmh-request-create-group (group &optional server args) (nnmail-activate 'nnmh) - (or (assoc group nnmh-group-alist) - (let (active) - (setq nnmh-group-alist (cons (list group (setq active (cons 1 0))) - nnmh-group-alist)) - (nnmh-possibly-create-directory group) - (nnmh-possibly-change-directory group server) - (let ((articles (mapcar - (lambda (file) - (string-to-int file)) - (directory-files - nnmh-current-directory nil "^[0-9]+$")))) - (and articles - (progn - (setcar active (apply 'min articles)) - (setcdr active (apply 'max articles))))))) + (unless (assoc group nnmh-group-alist) + (let (active) + (push (list group (setq active (cons 1 0))) + nnmh-group-alist) + (nnmh-possibly-create-directory group) + (nnmh-possibly-change-directory group server) + (let ((articles (mapcar + (lambda (file) + (string-to-int file)) + (directory-files + nnmh-current-directory nil "^[0-9]+$")))) + (when articles + (setcar active (apply 'min articles)) + (setcdr active (apply 'max articles)))))) t) (deffoo nnmh-request-delete-group (group &optional force server) @@ -337,16 +336,14 @@ () ; Don't delete the articles. (let ((articles (directory-files nnmh-current-directory t "^[0-9]+$"))) (while articles - (and (file-writable-p (car articles)) - (progn - (nnheader-message 5 "Deleting article %s in %s..." - (car articles) group) - (funcall nnmail-delete-file-function (car articles)))) + (when (file-writable-p (car articles)) + (nnheader-message 5 "Deleting article %s in %s..." + (car articles) group) + (funcall nnmail-delete-file-function (car articles))) (setq articles (cdr articles)))) ;; Try to delete the directory itself. - (condition-case () - (delete-directory nnmh-current-directory) - (error nil))) + (ignore-errors + (delete-directory nnmh-current-directory))) ;; Remove the group from all structures. (setq nnmh-group-alist (delq (assoc group nnmh-group-alist) nnmh-group-alist) @@ -355,21 +352,31 @@ (deffoo nnmh-request-rename-group (group new-name &optional server) (nnmh-possibly-change-directory group server) - ;; Rename directory. - (and (file-writable-p nnmh-current-directory) - (condition-case () - (progn - (rename-file - (directory-file-name nnmh-current-directory) - (directory-file-name - (nnmail-group-pathname new-name nnmh-directory))) - t) - (error nil)) - ;; That went ok, so we change the internal structures. - (let ((entry (assoc group nnmh-group-alist))) - (and entry (setcar entry new-name)) - (setq nnmh-current-directory nil) - t))) + (let ((new-dir (nnmail-group-pathname new-name nnmh-directory)) + (old-dir (nnmail-group-pathname group nnmh-directory))) + (when (ignore-errors + (make-directory new-dir t) + t) + ;; We move the articles file by file instead of renaming + ;; the directory -- there may be subgroups in this group. + ;; One might be more clever, I guess. + (let ((files (nnheader-article-to-file-alist old-dir))) + (while files + (rename-file + (concat old-dir (cdar files)) + (concat new-dir (cdar files))) + (pop files))) + (when (<= (length (directory-files old-dir)) 2) + (ignore-errors + (delete-directory old-dir))) + ;; That went ok, so we change the internal structures. + (let ((entry (assoc group nnmh-group-alist))) + (when entry + (setcar entry new-name)) + (setq nnmh-current-directory nil) + t)))) + +(nnoo-define-skeleton nnmh) ;;; Internal functions. @@ -378,62 +385,71 @@ (when (and server (not (nnmh-server-opened server))) (nnmh-open-server server)) - (if newsgroup - (let ((pathname (nnmail-group-pathname newsgroup nnmh-directory))) - (if (file-directory-p pathname) - (setq nnmh-current-directory pathname) - (error "No such newsgroup: %s" newsgroup))))) + (when newsgroup + (let ((pathname (nnmail-group-pathname newsgroup nnmh-directory))) + (if (file-directory-p pathname) + (setq nnmh-current-directory pathname) + (error "No such newsgroup: %s" newsgroup))))) (defun nnmh-possibly-create-directory (group) (let (dir dirs) (setq dir (nnmail-group-pathname group nnmh-directory)) (while (not (file-directory-p dir)) - (setq dirs (cons dir dirs)) + (push dir dirs) (setq dir (file-name-directory (directory-file-name dir)))) (while dirs - (if (make-directory (directory-file-name (car dirs))) - (error "Could not create directory %s" (car dirs))) + (when (make-directory (directory-file-name (car dirs))) + (error "Could not create directory %s" (car dirs))) (nnheader-message 5 "Creating mail directory %s" (car dirs)) (setq dirs (cdr dirs))))) -(defun nnmh-save-mail (&optional noinsert) +(defun nnmh-save-mail (group-art &optional noinsert) "Called narrowed to an article." - (let ((group-art (nreverse (nnmail-article-group 'nnmh-active-number)))) - (unless noinsert - (nnmail-insert-lines) - (nnmail-insert-xref group-art)) - (run-hooks 'nnmail-prepare-save-mail-hook) - (run-hooks 'nnmh-prepare-save-mail-hook) - (goto-char (point-min)) - (while (looking-at "From ") - (replace-match "X-From-Line: ") - (forward-line 1)) - ;; We save the article in all the newsgroups it belongs in. - (let ((ga group-art) - first) - (while ga - (nnmh-possibly-create-directory (caar ga)) - (let ((file (concat (nnmail-group-pathname - (caar ga) nnmh-directory) - (int-to-string (cdar ga))))) - (if first - ;; It was already saved, so we just make a hard link. - (funcall nnmail-crosspost-link-function first file t) - ;; Save the article. - (write-region (point-min) (point-max) file nil nil) - (setq first file))) - (setq ga (cdr ga)))) - group-art)) + (unless noinsert + (nnmail-insert-lines) + (nnmail-insert-xref group-art)) + (run-hooks 'nnmail-prepare-save-mail-hook) + (run-hooks 'nnmh-prepare-save-mail-hook) + (goto-char (point-min)) + (while (looking-at "From ") + (replace-match "X-From-Line: ") + (forward-line 1)) + ;; We save the article in all the newsgroups it belongs in. + (let ((ga group-art) + first) + (while ga + (nnmh-possibly-create-directory (caar ga)) + (let ((file (concat (nnmail-group-pathname + (caar ga) nnmh-directory) + (int-to-string (cdar ga))))) + (if first + ;; It was already saved, so we just make a hard link. + (funcall nnmail-crosspost-link-function first file t) + ;; Save the article. + (nnmail-write-region (point-min) (point-max) file nil nil) + (setq first file))) + (setq ga (cdr ga)))) + group-art) (defun nnmh-active-number (group) "Compute the next article number in GROUP." (let ((active (cadr (assoc group nnmh-group-alist)))) - ;; The group wasn't known to nnmh, so we just create an active - ;; entry for it. - (or active - (progn - (setq active (cons 1 0)) - (setq nnmh-group-alist (cons (list group active) nnmh-group-alist)))) + (unless active + ;; The group wasn't known to nnmh, so we just create an active + ;; entry for it. + (setq active (cons 1 0)) + (push (list group active) nnmh-group-alist) + ;; Find the highest number in the group. + (let ((files (sort + (mapcar + (lambda (f) + (string-to-int f)) + (directory-files + (nnmail-group-pathname group nnmh-directory) + nil "^[0-9]+$")) + '>))) + (when files + (setcdr active (car files))))) (setcdr active (1+ (cdr active))) (while (file-exists-p (concat (nnmail-group-pathname group nnmh-directory) @@ -443,77 +459,77 @@ (defun nnmh-update-gnus-unreads (group) ;; Go through the .nnmh-articles file and compare with the actual - ;; articles in this folder. The articles that are "new" will be + ;; articles in this folder. The articles that are "new" will be ;; marked as unread by Gnus. (let* ((dir nnmh-current-directory) (files (sort (mapcar (function (lambda (name) (string-to-int name))) (directory-files nnmh-current-directory - nil "^[0-9]+$" t)) '<)) + nil "^[0-9]+$" t)) + '<)) (nnmh-file (concat dir ".nnmh-articles")) new articles) ;; Load the .nnmh-articles file. - (if (file-exists-p nnmh-file) - (setq articles - (let (nnmh-newsgroup-articles) - (condition-case nil (load nnmh-file nil t t) (error nil)) - nnmh-newsgroup-articles))) + (when (file-exists-p nnmh-file) + (setq articles + (let (nnmh-newsgroup-articles) + (ignore-errors (load nnmh-file nil t t)) + nnmh-newsgroup-articles))) ;; Add all new articles to the `new' list. (let ((art files)) (while art - (if (not (assq (car art) articles)) (setq new (cons (car art) new))) + (unless (assq (car art) articles) + (push (car art) new)) (setq art (cdr art)))) ;; Remove all deleted articles. (let ((art articles)) (while art - (if (not (memq (caar art) files)) - (setq articles (delq (car art) articles))) + (unless (memq (caar art) files) + (setq articles (delq (car art) articles))) (setq art (cdr art)))) - ;; Check whether the highest-numbered articles really are the ones - ;; that Gnus thinks they are by looking at the time-stamps. - (let ((art articles)) - (while (and art - (not (equal - (nth 5 (file-attributes - (concat dir (int-to-string (caar art))))) - (cdar art)))) - (setq articles (delq (car art) articles)) - (setq new (cons (caar art) new)) - (setq art (cdr art)))) + ;; Check whether the articles really are the ones that Gnus thinks + ;; they are by looking at the time-stamps. + (let ((arts articles) + art) + (while (setq art (pop arts)) + (when (not (equal + (nth 5 (file-attributes + (concat dir (int-to-string (car art))))) + (cdr art))) + (setq articles (delq art articles)) + (push (car art) new)))) ;; Go through all the new articles and add them, and their - ;; time-stamps to the list. - (let ((n new)) - (while n - (setq articles - (cons (cons - (car n) - (nth 5 (file-attributes - (concat dir (int-to-string (car n)))))) - articles)) - (setq n (cdr n)))) + ;; time-stamps, to the list. + (setq articles + (nconc articles + (mapcar + (lambda (art) + (cons art + (nth 5 (file-attributes + (concat dir (int-to-string art)))))) + new))) ;; Make Gnus mark all new articles as unread. - (or (zerop (length new)) - (gnus-make-articles-unread - (gnus-group-prefixed-name group (list 'nnmh "")) - (setq new (sort new '<)))) + (when new + (gnus-make-articles-unread + (gnus-group-prefixed-name group (list 'nnmh "")) + (setq new (sort new '<)))) ;; Sort the article list with highest numbers first. - (setq articles (sort articles (lambda (art1 art2) + (setq articles (sort articles (lambda (art1 art2) (> (car art1) (car art2))))) ;; Finally write this list back to the .nnmh-articles file. - (save-excursion - (set-buffer (get-buffer-create "*nnmh out*")) + (nnheader-temp-write nnmh-file (insert ";; Gnus article active file for " group "\n\n") (insert "(setq nnmh-newsgroup-articles '") - (insert (prin1-to-string articles) ")\n") - (write-region (point-min) (point-max) nnmh-file nil 'nomesg) - (kill-buffer (current-buffer))))) + (gnus-prin1 articles) + (insert ")\n")))) (defun nnmh-deletable-article-p (group article) "Say whether ARTICLE in GROUP can be deleted." (let ((path (concat nnmh-current-directory (int-to-string article)))) - (and (file-writable-p path) - (or (not nnmail-keep-last-article) - (not (eq (cdr (nth 1 (assoc group nnmh-group-alist))) - article)))))) + ;; Writable. + (and (file-writable-p path) + ;; We can never delete the last article in the group. + (not (eq (cdr (nth 1 (assoc group nnmh-group-alist))) + article))))) (provide 'nnmh) diff -r ad457d5f7d04 -r 0293115a14e9 lisp/gnus/nnml.el --- a/lisp/gnus/nnml.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/gnus/nnml.el Mon Aug 13 08:49:20 2007 +0200 @@ -1,5 +1,5 @@ ;;; nnml.el --- mail spool access for Gnus -;; Copyright (C) 1995,96 Free Software Foundation, Inc. +;; Copyright (C) 1995,96,97 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; Masanobu UMEDA @@ -54,11 +54,11 @@ (defvoo nnml-nov-is-evil nil "If non-nil, Gnus will never generate and use nov databases for mail groups. Using nov databases will speed up header fetching considerably. -This variable shouldn't be flipped much. If you have, for some reason, +This variable shouldn't be flipped much. If you have, for some reason, set this to t, and want to set it to nil again, you should always run -the `nnml-generate-nov-databases' command. The function will go +the `nnml-generate-nov-databases' command. The function will go through all nnml directories and generate nov databases for them -all. This may very well take some time.") +all. This may very well take some time.") (defvoo nnml-prepare-save-mail-hook nil "Hook run narrowed to an article before saving.") @@ -90,62 +90,61 @@ (nnoo-define-basics nnml) -(deffoo nnml-retrieve-headers (sequence &optional newsgroup server fetch-old) - (save-excursion - (set-buffer nntp-server-buffer) - (erase-buffer) - (let ((file nil) - (number (length sequence)) - (count 0) - beg article) - (if (stringp (car sequence)) - 'headers - (nnml-possibly-change-directory newsgroup server) - (unless nnml-article-file-alist - (setq nnml-article-file-alist - (nnheader-article-to-file-alist nnml-current-directory))) - (if (nnml-retrieve-headers-with-nov sequence fetch-old) - 'nov - (while sequence - (setq article (car sequence)) - (setq file - (concat nnml-current-directory - (or (cdr (assq article nnml-article-file-alist)) - ""))) - (if (and (file-exists-p file) - (not (file-directory-p file))) - (progn - (insert (format "221 %d Article retrieved.\n" article)) - (setq beg (point)) - (nnheader-insert-head file) - (goto-char beg) - (if (search-forward "\n\n" nil t) - (forward-char -1) - (goto-char (point-max)) - (insert "\n\n")) - (insert ".\n") - (delete-region (point) (point-max)))) - (setq sequence (cdr sequence)) - (setq count (1+ count)) +(deffoo nnml-retrieve-headers (sequence &optional group server fetch-old) + (when (nnml-possibly-change-directory group server) + (save-excursion + (set-buffer nntp-server-buffer) + (erase-buffer) + (let ((file nil) + (number (length sequence)) + (count 0) + beg article) + (if (stringp (car sequence)) + 'headers + (unless nnml-article-file-alist + (setq nnml-article-file-alist + (nnheader-article-to-file-alist nnml-current-directory))) + (if (nnml-retrieve-headers-with-nov sequence fetch-old) + 'nov + (while sequence + (setq article (car sequence)) + (setq file + (concat nnml-current-directory + (or (cdr (assq article nnml-article-file-alist)) + ""))) + (when (and (file-exists-p file) + (not (file-directory-p file))) + (insert (format "221 %d Article retrieved.\n" article)) + (setq beg (point)) + (nnheader-insert-head file) + (goto-char beg) + (if (search-forward "\n\n" nil t) + (forward-char -1) + (goto-char (point-max)) + (insert "\n\n")) + (insert ".\n") + (delete-region (point) (point-max))) + (setq sequence (cdr sequence)) + (setq count (1+ count)) + (and (numberp nnmail-large-newsgroup) + (> number nnmail-large-newsgroup) + (zerop (% count 20)) + (nnheader-message 6 "nnml: Receiving headers... %d%%" + (/ (* count 100) number)))) + (and (numberp nnmail-large-newsgroup) (> number nnmail-large-newsgroup) - (zerop (% count 20)) - (nnheader-message 6 "nnml: Receiving headers... %d%%" - (/ (* count 100) number)))) + (nnheader-message 6 "nnml: Receiving headers...done")) - (and (numberp nnmail-large-newsgroup) - (> number nnmail-large-newsgroup) - (nnheader-message 6 "nnml: Receiving headers...done")) - - (nnheader-fold-continuation-lines) - 'headers))))) + (nnheader-fold-continuation-lines) + 'headers)))))) (deffoo nnml-open-server (server &optional defs) (nnoo-change-server 'nnml server defs) (when (not (file-exists-p nnml-directory)) (condition-case () (make-directory nnml-directory t) - (error t))) + (error))) (cond ((not (file-exists-p nnml-directory)) (nnml-close-server) @@ -158,25 +157,25 @@ server nnml-directory) t))) -(deffoo nnml-request-article (id &optional newsgroup server buffer) - (nnml-possibly-change-directory newsgroup server) +(defun nnml-request-regenerate (server) + (nnml-possibly-change-directory nil server) + (nnml-generate-nov-databases)) + +(deffoo nnml-request-article (id &optional group server buffer) + (nnml-possibly-change-directory group server) (let* ((nntp-server-buffer (or buffer nntp-server-buffer)) - file path gpath group-num) + path gpath group-num) (if (stringp id) (when (and (setq group-num (nnml-find-group-number id)) - (setq file (cdr - (assq (cdr group-num) - (nnheader-article-to-file-alist - (setq gpath - (nnmail-group-pathname - (car group-num) - nnml-directory))))))) + (cdr + (assq (cdr group-num) + (nnheader-article-to-file-alist + (setq gpath + (nnmail-group-pathname + (car group-num) + nnml-directory)))))) (setq path (concat gpath (int-to-string (cdr group-num))))) - (unless nnml-article-file-alist - (setq nnml-article-file-alist - (nnheader-article-to-file-alist nnml-current-directory))) - (when (setq file (cdr (assq id nnml-article-file-alist))) - (setq path (concat nnml-current-directory file)))) + (setq path (nnml-article-to-file id))) (cond ((not path) (nnheader-report 'nnml "No such article: %s" id)) @@ -189,18 +188,22 @@ (t (nnheader-report 'nnml "Article %s retrieved" id) ;; We return the article number. - (cons newsgroup (string-to-int (file-name-nondirectory path))))))) + (cons group (string-to-int (file-name-nondirectory path))))))) (deffoo nnml-request-group (group &optional server dont-check) (cond ((not (nnml-possibly-change-directory group server)) (nnheader-report 'nnml "Invalid group (no such directory)")) + ((not (file-exists-p nnml-current-directory)) + (nnheader-report 'nnml "Directory %s does not exist" + nnml-current-directory)) ((not (file-directory-p nnml-current-directory)) (nnheader-report 'nnml "%s is not a directory" nnml-current-directory)) (dont-check (nnheader-report 'nnml "Group %s selected" group) t) (t + (nnheader-re-read-dir nnml-current-directory) (nnmail-activate 'nnml) (let ((active (nth 1 (assoc group nnml-group-alist)))) (if (not active) @@ -212,33 +215,33 @@ (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)) (deffoo nnml-close-group (group &optional server) (setq nnml-article-file-alist nil) t) -(deffoo nnml-request-create-group (group &optional server) +(deffoo nnml-request-create-group (group &optional server args) (nnmail-activate 'nnml) - (or (assoc group nnml-group-alist) - (let (active) - (setq nnml-group-alist (cons (list group (setq active (cons 1 0))) - nnml-group-alist)) - (nnml-possibly-create-directory group) - (nnml-possibly-change-directory group server) - (let ((articles - (nnheader-directory-articles nnml-current-directory ))) - (and articles - (progn - (setcar active (apply 'min articles)) - (setcdr active (apply 'max articles))))) - (nnmail-save-active nnml-group-alist nnml-active-file))) + (unless (assoc group nnml-group-alist) + (let (active) + (push (list group (setq active (cons 1 0))) + nnml-group-alist) + (nnml-possibly-create-directory group) + (nnml-possibly-change-directory group server) + (let ((articles (nnheader-directory-articles nnml-current-directory))) + (when articles + (setcar active (apply 'min articles)) + (setcdr active (apply 'max articles)))) + (nnmail-save-active nnml-group-alist nnml-active-file))) t) (deffoo nnml-request-list (&optional server) (save-excursion (nnmail-find-file nnml-active-file) - (setq nnml-group-alist (nnmail-get-active)))) + (setq nnml-group-alist (nnmail-get-active)) + t)) (deffoo nnml-request-newgroups (date &optional server) (nnml-request-list server)) @@ -247,8 +250,9 @@ (save-excursion (nnmail-find-file nnml-newsgroups-file))) -(deffoo nnml-request-expire-articles (articles newsgroup &optional server force) - (nnml-possibly-change-directory newsgroup server) +(deffoo nnml-request-expire-articles (articles group + &optional server force) + (nnml-possibly-change-directory group server) (let* ((active-articles (nnheader-directory-articles nnml-current-directory)) (is-old t) @@ -260,32 +264,32 @@ (nnheader-article-to-file-alist nnml-current-directory))) (while (and articles is-old) - (setq article (concat nnml-current-directory - (int-to-string - (setq number (pop articles))))) - (when (setq mod-time (nth 5 (file-attributes article))) - (if (and (nnml-deletable-article-p newsgroup number) - (setq is-old - (nnmail-expired-article-p newsgroup mod-time force - nnml-inhibit-expiry))) - (progn - (nnheader-message 5 "Deleting article %s in %s..." - article newsgroup) - (condition-case () - (funcall nnmail-delete-file-function article) - (file-error - (push number rest))) - (setq active-articles (delq number active-articles)) - (nnml-nov-delete-article newsgroup number)) - (push number rest)))) - (let ((active (nth 1 (assoc newsgroup nnml-group-alist)))) + (when (setq article + (assq (setq number (pop articles)) + nnml-article-file-alist)) + (setq article (concat nnml-current-directory (cdr article))) + (when (setq mod-time (nth 5 (file-attributes article))) + (if (and (nnml-deletable-article-p group number) + (setq is-old + (nnmail-expired-article-p group mod-time force + nnml-inhibit-expiry))) + (progn + (nnheader-message 5 "Deleting article %s in %s" + article group) + (condition-case () + (funcall nnmail-delete-file-function article) + (file-error + (push number rest))) + (setq active-articles (delq number active-articles)) + (nnml-nov-delete-article group number)) + (push number rest))))) + (let ((active (nth 1 (assoc group nnml-group-alist)))) (when active (setcar active (or (and active-articles (apply 'min active-articles)) (1+ (cdr active))))) (nnmail-save-active nnml-group-alist nnml-active-file)) (nnml-save-nov) - (message "") (nconc rest articles))) (deffoo nnml-request-move-article @@ -323,16 +327,15 @@ (if (stringp group) (and (nnmail-activate 'nnml) - ;; We trick the choosing function into believing that only one - ;; group is available. - (let ((nnmail-split-methods (list (list group "")))) - (setq result (car (nnml-save-mail)))) + (setq result (car (nnml-save-mail + (list (cons group (nnml-active-number group)))))) (progn (nnmail-save-active nnml-group-alist nnml-active-file) (and last (nnml-save-nov)))) (and (nnmail-activate 'nnml) - (setq result (car (nnml-save-mail))) + (setq result (car (nnml-save-mail + (nnmail-article-group 'nnml-active-number)))) (progn (nnmail-save-active nnml-group-alist nnml-active-file) (and last (nnml-save-nov))))) @@ -348,9 +351,10 @@ headers) (when (condition-case () (progn - (write-region + (nnmail-write-region (point-min) (point-max) - (concat nnml-current-directory (int-to-string article)) + (concat nnml-current-directory + (int-to-string article)) nil (if (nnheader-be-verbose 5) nil 'nomesg)) t) (error nil)) @@ -365,7 +369,7 @@ (delete-region (progn (beginning-of-line) (point)) (progn (forward-line 1) (point))) ;; The line isn't here, so we have to find out where - ;; we should insert it. (This situation should never + ;; we should insert it. (This situation should never ;; occur, but one likes to make sure...) (while (and (looking-at "[0-9]+\t") (< (string-to-int @@ -408,42 +412,72 @@ (deffoo nnml-request-rename-group (group new-name &optional server) (nnml-possibly-change-directory group server) - ;; Rename directory. - (and (file-writable-p nnml-current-directory) - (condition-case () - (let ((parent - (file-name-directory - (directory-file-name - (nnmail-group-pathname new-name nnml-directory))))) - (unless (file-exists-p parent) - (make-directory parent t)) - (rename-file - (directory-file-name nnml-current-directory) - (directory-file-name - (nnmail-group-pathname new-name nnml-directory))) - t) - (error nil)) - ;; That went ok, so we change the internal structures. - (let ((entry (assoc group nnml-group-alist))) - (and entry (setcar entry new-name)) - (setq nnml-current-directory nil - nnml-current-group nil) - ;; Save the new group alist. - (nnmail-save-active nnml-group-alist nnml-active-file) - t))) + (let ((new-dir (nnmail-group-pathname new-name nnml-directory)) + (old-dir (nnmail-group-pathname group nnml-directory))) + (when (condition-case () + (progn + (make-directory new-dir t) + t) + (error nil)) + ;; We move the articles file by file instead of renaming + ;; the directory -- there may be subgroups in this group. + ;; One might be more clever, I guess. + (let ((files (nnheader-article-to-file-alist old-dir))) + (while files + (rename-file + (concat old-dir (cdar files)) + (concat new-dir (cdar files))) + (pop files))) + ;; Move .overview file. + (let ((overview (concat old-dir nnml-nov-file-name))) + (when (file-exists-p overview) + (rename-file overview (concat new-dir nnml-nov-file-name)))) + (when (<= (length (directory-files old-dir)) 2) + (condition-case () + (delete-directory old-dir) + (error nil))) + ;; That went ok, so we change the internal structures. + (let ((entry (assoc group nnml-group-alist))) + (when entry + (setcar entry new-name)) + (setq nnml-current-directory nil + nnml-current-group nil) + ;; Save the new group alist. + (nnmail-save-active nnml-group-alist nnml-active-file) + t)))) + +(deffoo nnml-set-status (article name value &optional group server) + (nnml-possibly-change-directory group server) + (let ((file (nnml-article-to-file article))) + (cond + ((not (file-exists-p file)) + (nnheader-report 'nnml "File %s does not exist" file)) + (t + (nnheader-temp-write file + (nnheader-insert-file-contents file) + (nnmail-replace-status name value)) + t)))) ;;; Internal functions. +(defun nnml-article-to-file (article) + (unless nnml-article-file-alist + (setq nnml-article-file-alist + (nnheader-article-to-file-alist nnml-current-directory))) + (let (file) + (when (setq file (cdr (assq article nnml-article-file-alist))) + (concat nnml-current-directory file)))) + (defun nnml-deletable-article-p (group article) "Say whether ARTICLE in GROUP can be deleted." (let (file path) (when (setq file (cdr (assq article nnml-article-file-alist))) (setq path (concat nnml-current-directory file)) - (and (file-writable-p path) - (or (not nnmail-keep-last-article) - (not (eq (cdr (nth 1 (assoc group nnml-group-alist))) - article))))))) + (when (file-writable-p path) + (or (not nnmail-keep-last-article) + (not (eq (cdr (nth 1 (assoc group nnml-group-alist))) + article))))))) ;; Find an article number in the current group given the Message-ID. (defun nnml-find-group-number (id) @@ -473,77 +507,67 @@ nnml-nov-file-name)) number found) (when (file-exists-p nov) - (insert-file-contents nov) - (while (and (not found) + (nnheader-insert-file-contents nov) + (while (and (not found) (search-forward id nil t)) ; We find the ID. ;; And the id is in the fourth field. - (if (search-backward - "\t" (save-excursion (beginning-of-line) (point)) t 4) - (progn - (beginning-of-line) - (setq found t) - ;; We return the article number. - (setq number - (condition-case () - (read (current-buffer)) - (error nil)))))) + (if (not (and (search-backward "\t" nil t 4) + (not (search-backward"\t" (gnus-point-at-bol) t)))) + (forward-line 1) + (beginning-of-line) + (setq found t) + ;; We return the article number. + (setq number + (condition-case () + (read (current-buffer)) + (error nil))))) number))) (defun nnml-retrieve-headers-with-nov (articles &optional fetch-old) (if (or gnus-nov-is-evil nnml-nov-is-evil) nil - (let ((first (car articles)) - (last (progn (while (cdr articles) (setq articles (cdr articles))) - (car articles))) - (nov (concat nnml-current-directory nnml-nov-file-name))) + (let ((nov (concat nnml-current-directory nnml-nov-file-name))) (when (file-exists-p nov) (save-excursion (set-buffer nntp-server-buffer) (erase-buffer) - (insert-file-contents nov) + (nnheader-insert-file-contents nov) (if (and fetch-old (not (numberp fetch-old))) t ; Don't remove anything. - (if fetch-old - (setq first (max 1 (- first fetch-old)))) - (goto-char (point-min)) - (while (and (not (eobp)) (> first (read (current-buffer)))) - (forward-line 1)) - (beginning-of-line) - (if (not (eobp)) (delete-region 1 (point))) - (while (and (not (eobp)) (>= last (read (current-buffer)))) - (forward-line 1)) - (beginning-of-line) - (if (not (eobp)) (delete-region (point) (point-max))) + (nnheader-nov-delete-outside-range + (if fetch-old (max 1 (- (car articles) fetch-old)) + (car articles)) + (car (last articles))) t)))))) (defun nnml-possibly-change-directory (group &optional server) (when (and server (not (nnml-server-opened server))) (nnml-open-server server)) - (when group + (if (not group) + t (let ((pathname (nnmail-group-pathname group nnml-directory))) (when (not (equal pathname nnml-current-directory)) (setq nnml-current-directory pathname nnml-current-group group - nnml-article-file-alist nil)))) - t) + nnml-article-file-alist nil)) + (file-exists-p nnml-current-directory)))) (defun nnml-possibly-create-directory (group) (let (dir dirs) (setq dir (nnmail-group-pathname group nnml-directory)) (while (not (file-directory-p dir)) - (setq dirs (cons dir dirs)) + (push dir dirs) (setq dir (file-name-directory (directory-file-name dir)))) (while dirs (make-directory (directory-file-name (car dirs))) (nnheader-message 5 "Creating mail directory %s" (car dirs)) (setq dirs (cdr dirs))))) -(defun nnml-save-mail () +(defun nnml-save-mail (group-art) "Called narrowed to an article." - (let ((group-art (nreverse (nnmail-article-group 'nnml-active-number))) - chars headers) + (let (chars headers) (setq chars (nnmail-insert-lines)) (nnmail-insert-xref group-art) (run-hooks 'nnmail-prepare-save-mail-hook) @@ -552,7 +576,7 @@ (while (looking-at "From ") (replace-match "X-From-Line: ") (forward-line 1)) - ;; We save the article in all the newsgroups it belongs in. + ;; We save the article in all the groups it belongs in. (let ((ga group-art) first) (while ga @@ -564,11 +588,11 @@ ;; It was already saved, so we just make a hard link. (funcall nnmail-crosspost-link-function first file t) ;; Save the article. - (write-region (point-min) (point-max) file nil - (if (nnheader-be-verbose 5) nil 'nomesg)) + (nnmail-write-region (point-min) (point-max) file nil + (if (nnheader-be-verbose 5) nil 'nomesg)) (setq first file))) (setq ga (cdr ga)))) - ;; Generate a nov line for this article. We generate the nov + ;; Generate a nov line for this article. We generate the nov ;; line after saving, because nov generation destroys the ;; header. (setq headers (nnml-parse-head chars)) @@ -599,7 +623,7 @@ (cons (caar nnml-article-file-alist) (caar (last nnml-article-file-alist))) (cons 1 0))) - (setq nnml-group-alist (cons (list group active) nnml-group-alist))) + (push (list group active) nnml-group-alist)) (setcdr active (1+ (cdr active))) (while (file-exists-p (concat (nnmail-group-pathname group nnml-directory) @@ -639,14 +663,13 @@ (defun nnml-open-nov (group) (or (cdr (assoc group nnml-nov-buffer-alist)) - (let ((buffer (find-file-noselect + (let ((buffer (nnheader-find-file-noselect (concat (nnmail-group-pathname group nnml-directory) nnml-nov-file-name)))) (save-excursion (set-buffer buffer) (buffer-disable-undo (current-buffer))) - (setq nnml-nov-buffer-alist - (cons (cons group buffer) nnml-nov-buffer-alist)) + (push (cons group buffer) nnml-nov-buffer-alist) buffer))) (defun nnml-save-nov () @@ -654,9 +677,8 @@ (while nnml-nov-buffer-alist (when (buffer-name (cdar nnml-nov-buffer-alist)) (set-buffer (cdar nnml-nov-buffer-alist)) - (and (buffer-modified-p) - (write-region - 1 (point-max) (buffer-file-name) nil 'nomesg)) + (when (buffer-modified-p) + (nnmail-write-region 1 (point-max) (buffer-file-name) nil 'nomesg)) (set-buffer-modified-p nil) (kill-buffer (current-buffer))) (setq nnml-nov-buffer-alist (cdr nnml-nov-buffer-alist))))) @@ -675,26 +697,25 @@ ;; Save the active file. (nnmail-save-active nnml-group-alist nnml-active-file)) -(defun nnml-generate-nov-databases-1 (dir) +(defun nnml-generate-nov-databases-1 (dir &optional seen) (setq dir (file-name-as-directory dir)) - ;; We descend recursively - (let ((dirs (directory-files dir t nil t)) - dir) - (while dirs - (setq dir (pop dirs)) - (when (and (not (member (file-name-nondirectory dir) '("." ".."))) - (file-directory-p dir)) - (nnml-generate-nov-databases-1 dir)))) - ;; Do this directory. - (let ((files (sort - (mapcar - (lambda (name) (string-to-int name)) - (directory-files dir nil "^[0-9]+$" t)) - '<))) - (when files - (funcall nnml-generate-active-function dir) - ;; Generate the nov file. - (nnml-generate-nov-file dir files)))) + ;; Only scan this sub-tree if we haven't been here yet. + (unless (member (file-truename dir) seen) + (push (file-truename dir) seen) + ;; We descend recursively + (let ((dirs (directory-files dir t nil t)) + dir) + (while (setq dir (pop dirs)) + (when (and (not (member (file-name-nondirectory dir) '("." ".."))) + (file-directory-p dir)) + (nnml-generate-nov-databases-1 dir seen)))) + ;; Do this directory. + (let ((files (sort (nnheader-article-to-file-alist dir) + (lambda (a b) (< (car a) (car b)))))) + (when files + (funcall nnml-generate-active-function dir) + ;; Generate the nov file. + (nnml-generate-nov-file dir files))))) (defvar files) (defun nnml-generate-active-info (dir) @@ -704,17 +725,17 @@ (setq nnml-group-alist (delq (assoc group nnml-group-alist) nnml-group-alist)) (push (list group - (cons (car files) + (cons (caar files) (let ((f files)) (while (cdr f) (setq f (cdr f))) - (car f)))) + (caar f)))) nnml-group-alist))) (defun nnml-generate-nov-file (dir files) (let* ((dir (file-name-as-directory dir)) (nov (concat dir nnml-nov-file-name)) (nov-buffer (get-buffer-create " *nov*")) - nov-line chars file headers) + chars file headers) (save-excursion ;; Init the nov buffer. (set-buffer nov-buffer) @@ -725,10 +746,9 @@ (when (file-exists-p nov) (funcall nnmail-delete-file-function nov)) (while files - (unless (file-directory-p - (setq file (concat dir (int-to-string (car files))))) + (unless (file-directory-p (setq file (concat dir (cdar files)))) (erase-buffer) - (insert-file-contents file) + (nnheader-insert-file-contents file) (narrow-to-region (goto-char (point-min)) (progn @@ -738,7 +758,7 @@ (when (and (not (= 0 chars)) ; none of them empty files... (not (= (point-min) (point-max)))) (goto-char (point-min)) - (setq headers (nnml-parse-head chars (car files))) + (setq headers (nnml-parse-head chars (caar files))) (save-excursion (set-buffer nov-buffer) (goto-char (point-max)) @@ -747,16 +767,15 @@ (setq files (cdr files))) (save-excursion (set-buffer nov-buffer) - (write-region 1 (point-max) (expand-file-name nov) nil - 'nomesg) + (nnmail-write-region 1 (point-max) nov nil 'nomesg) (kill-buffer (current-buffer)))))) (defun nnml-nov-delete-article (group article) (save-excursion (set-buffer (nnml-open-nov group)) (goto-char (point-min)) - (if (re-search-forward (concat "^" (int-to-string article) "\t") nil t) - (delete-region (match-beginning 0) (progn (forward-line 1) (point)))) + (when (re-search-forward (concat "^" (int-to-string article) "\t") nil t) + (delete-region (match-beginning 0) (progn (forward-line 1) (point)))) t)) (provide 'nnml) diff -r ad457d5f7d04 -r 0293115a14e9 lisp/gnus/nnoo.el --- a/lisp/gnus/nnoo.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/gnus/nnoo.el Mon Aug 13 08:49:20 2007 +0200 @@ -1,5 +1,5 @@ ;;; nnoo.el --- OO Gnus Backends -;; Copyright (C) 1996 Free Software Foundation, Inc. +;; Copyright (C) 1996,97 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; Keywords: news @@ -25,7 +25,8 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(require 'nnheader) +(require 'cl) (defvar nnoo-definition-alist nil) (defvar nnoo-state-alist nil) @@ -38,7 +39,6 @@ `(defvar ,var ,init)) (nnoo-define ',var ',map))) (put 'defvoo 'lisp-indent-function 2) -(put 'defvoo 'lisp-indent-hook 2) (put 'defvoo 'edebug-form-spec '(var init &optional doc &rest map)) (defmacro deffoo (func args &rest forms) @@ -47,11 +47,10 @@ (defun ,func ,args ,@forms) (nnoo-register-function ',func))) (put 'deffoo 'lisp-indent-function 2) -(put 'deffoo 'lisp-indent-hook 2) (put 'deffoo 'edebug-form-spec '(&define name lambda-list def-body)) (defun nnoo-register-function (func) - (let ((funcs (nthcdr 3 (assoc (nnoo-backend func) + (let ((funcs (nthcdr 3 (assoc (nnoo-backend func) nnoo-definition-alist)))) (unless funcs (error "%s belongs to a backend that hasn't been declared" func)) @@ -62,9 +61,10 @@ (push (list ',backend (mapcar (lambda (p) (list p)) ',parents) nil nil) - nnoo-definition-alist))) + nnoo-definition-alist) + (push (list ',backend "*internal-non-initialized-backend*") + nnoo-state-alist))) (put 'nnoo-declare 'lisp-indent-function 1) -(put 'nnoo-declare 'lisp-indent-hook 1) (defun nnoo-parents (backend) (nth 1 (assoc backend nnoo-definition-alist))) @@ -78,7 +78,6 @@ (defmacro nnoo-import (backend &rest imports) `(nnoo-import-1 ',backend ',imports)) (put 'nnoo-import 'lisp-indent-function 1) -(put 'nnoo-import 'lisp-indent-hook 1) (defun nnoo-import-1 (backend imports) (let ((call-function @@ -91,7 +90,7 @@ (while functions (unless (fboundp (setq function (nnoo-symbol backend (nnoo-rest-symbol - (car functions))))) + (car functions))))) (eval `(deffoo ,function (&rest args) (,call-function ',backend ',(car functions) args)))) (pop functions))))) @@ -112,7 +111,6 @@ (defmacro nnoo-map-functions (backend &rest maps) `(nnoo-map-functions-1 ',backend ',maps)) (put 'nnoo-map-functions 'lisp-indent-function 1) -(put 'nnoo-map-functions 'lisp-indent-hook 1) (defun nnoo-map-functions-1 (backend maps) (let (m margs i) @@ -126,7 +124,7 @@ (incf i)) (eval `(deffoo ,(nnoo-symbol backend (nnoo-rest-symbol (car m))) (&rest args) - (nnoo-parent-function ',backend ',(car m) + (nnoo-parent-function ',backend ',(car m) ,(cons 'list (nreverse margs)))))))) (defun nnoo-backend (symbol) @@ -146,7 +144,7 @@ (parents (nth 1 def))) (unless def (error "%s belongs to a backend that hasn't been declared." var)) - (setcar (nthcdr 2 def) + (setcar (nthcdr 2 def) (delq (assq var (nth 2 def)) (nth 2 def))) (setcar (nthcdr 2 def) (cons (cons var (symbol-value var)) @@ -157,10 +155,10 @@ (defun nnoo-change-server (backend server defs) (let* ((bstate (cdr (assq backend nnoo-state-alist))) - (sdefs (assq backend nnoo-definition-alist)) (current (car bstate)) (parents (nnoo-parents backend)) - state) + (bvariables (nnoo-variables backend)) + state def) (unless bstate (push (setq bstate (list backend nil)) nnoo-state-alist) @@ -175,9 +173,12 @@ (pop state)) (setcar bstate server) (unless (cdr (assoc server (cddr bstate))) - (while defs - (set (caar defs) (cadar defs)) - (pop defs))) + (while (setq def (pop defs)) + (unless (assq (car def) bvariables) + (nconc bvariables + (list (cons (car def) (and (boundp (car def)) + (symbol-value (car def))))))) + (set (car def) (cadr def)))) (while parents (nnoo-change-server (caar parents) server @@ -191,6 +192,14 @@ (defs (nnoo-variables backend))) ;; Remove the old definition. (setcdr (cdr bstate) (delq (assoc current (cddr bstate)) (cddr bstate))) + ;; If this is the first time we push the server (i. e., this is + ;; the nil server), then we update the default values of + ;; all the variables to reflect the current values. + (when (equal current "*internal-non-initialized-backend*") + (let ((defaults (nnoo-variables backend)) + def) + (while (setq def (pop defaults)) + (setcdr def (symbol-value (car def)))))) (let (state) (while defs (push (cons (caar defs) (symbol-value (caar defs))) @@ -233,19 +242,38 @@ (buffer-name nntp-server-buffer))) (defmacro nnoo-define-basics (backend) + "Define `close-server', `server-opened' and `status-message'." `(eval-and-compile (nnoo-define-basics-1 ',backend))) (defun nnoo-define-basics-1 (backend) (let ((functions '(close-server server-opened status-message))) (while functions - (eval `(deffoo ,(nnoo-symbol backend (car functions)) + (eval `(deffoo ,(nnoo-symbol backend (car functions)) (&optional server) (,(nnoo-symbol 'nnoo (pop functions)) ',backend server))))) (eval `(deffoo ,(nnoo-symbol backend 'open-server) (server &optional defs) (nnoo-change-server ',backend server defs)))) +(defmacro nnoo-define-skeleton (backend) + "Define all required backend functions for BACKEND. +All functions will return nil and report an error." + `(eval-and-compile + (nnoo-define-skeleton-1 ',backend))) + +(defun nnoo-define-skeleton-1 (backend) + (let ((functions '(retrieve-headers + request-close request-article + request-group close-group + request-list request-post request-list-newsgroups)) + function fun) + (while (setq function (pop functions)) + (when (not (fboundp (setq fun (nnoo-symbol backend function)))) + (eval `(deffoo ,fun + (&rest args) + (nnheader-report ',backend ,(format "%s-%s not implemented" + backend function)))))))) (provide 'nnoo) ;;; nnoo.el ends here. diff -r ad457d5f7d04 -r 0293115a14e9 lisp/gnus/nnsoup.el --- a/lisp/gnus/nnsoup.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/gnus/nnsoup.el Mon Aug 13 08:49:20 2007 +0200 @@ -1,5 +1,5 @@ ;;; nnsoup.el --- SOUP access for Gnus -;; Copyright (C) 1995,96 Free Software Foundation, Inc. +;; Copyright (C) 1995,96,97 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; Masanobu UMEDA @@ -56,7 +56,7 @@ (defvoo nnsoup-packer "tar cf - %s | gzip > $HOME/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 +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 -" @@ -81,6 +81,7 @@ (defvoo nnsoup-buffers nil) (defvoo nnsoup-current-group nil) (defvoo nnsoup-group-alist-touched nil) +(defvoo nnsoup-article-alist nil) @@ -231,11 +232,15 @@ (nnheader-report 'nnsoup "No such group: %s" group) (nnheader-insert "211 %d %d %d %s\n" - (max (1+ (- (cdr active) (car active))) 0) + (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 articl ein the group. + (when (not article) + (setq article + (cdaar (cddr (assoc group nnsoup-group-alist))))) (if (not article) 'unknown (let ((kind (gnus-soup-encoding-kind @@ -310,20 +315,18 @@ ;; This file is old enough. (nnmail-expired-article-p group mod-time force)) ;; Ok, we delete this file. - (when (condition-case nil - (progn - (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) - (error nil)) + (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-complement articles range-list)))) (when (not mod-time) @@ -339,16 +342,17 @@ ;;; Internal functions (defun nnsoup-possibly-change-group (group &optional force) - (if group - (setq nnsoup-current-group group) - t)) + (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) - (condition-case () - (load nnsoup-active-file t t t) - (error nil)) + (ignore-errors + (load nnsoup-active-file t t t)) ;; Be backwards compatible. (when (and nnsoup-group-alist (not (atom (caadar nnsoup-group-alist)))) @@ -369,11 +373,10 @@ nnsoup-group-alist-touched)) (setq nnsoup-group-alist-touched nil) (nnheader-temp-write nnsoup-active-file - (let ((standard-output (current-buffer))) - (prin1 `(setq nnsoup-group-alist ',nnsoup-group-alist)) - (insert "\n") - (prin1 `(setq nnsoup-current-prefix ,nnsoup-current-prefix)) - (insert "\n"))))) + (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." @@ -386,43 +389,58 @@ (incf nnsoup-current-prefix) prefix)) +(defun nnsoup-file-name (dir file) + "Return the full path 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 () - (save-excursion - (set-buffer nntp-server-buffer) - (let ((areas (gnus-soup-parse-areas (concat nnsoup-tmp-directory "AREAS"))) - 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)) - (message "Incorporating file %s..." cur-prefix) - (when (file-exists-p - (setq file (concat nnsoup-tmp-directory - (gnus-soup-area-prefix area) ".IDX"))) - (rename-file file (nnsoup-file cur-prefix))) - (when (file-exists-p - (setq file (concat nnsoup-tmp-directory - (gnus-soup-area-prefix area) ".MSG"))) - (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 (concat nnsoup-tmp-directory "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)) + (message "Incorporating file %s..." cur-prefix) + (when (file-exists-p + (setq file (concat nnsoup-tmp-directory + (gnus-soup-area-prefix area) ".IDX"))) + (rename-file file (nnsoup-file cur-prefix))) + (when (file-exists-p + (setq file (concat nnsoup-tmp-directory + (gnus-soup-area-prefix area) ".MSG"))) + (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 @@ -438,24 +456,79 @@ ;; buffer. (t (set-buffer (nnsoup-message-buffer (gnus-soup-area-prefix area))) - (goto-char (point-min)) - (let ((regexp (nnsoup-header (gnus-soup-encoding-format - (gnus-soup-area-encoding area)))) - (num 0)) - (while (re-search-forward regexp nil t) - (setq num (1+ num))) - num))))) + (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 + ((= format ?n) + (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 aready loaded. + (or (get-buffer buffer-name) ; File already loaded. (when (file-exists-p (concat nnsoup-directory file)) - (save-excursion ; Load the file. + (save-excursion ; Load the file. (set-buffer (get-buffer-create buffer-name)) (buffer-disable-undo (current-buffer)) (push (cons nnsoup-current-group (current-buffer)) nnsoup-buffers) - (insert-file-contents (concat nnsoup-directory file)) + (nnheader-insert-file-contents (concat nnsoup-directory file)) (current-buffer)))))) (defun nnsoup-file (prefix &optional message) @@ -471,7 +544,7 @@ nnsoup-packet-directory t nnsoup-packet-regexp)) packet) (while (setq packet (pop packets)) - (message (format "nnsoup: unpacking %s..." packet)) + (message "nnsoup: unpacking %s..." packet) (if (not (gnus-soup-unpack-packet nnsoup-tmp-directory nnsoup-unpacker packet)) (message "Couldn't unpack %s" packet) @@ -490,8 +563,8 @@ ;; There is no MSG file. ((null msg-buf) nil) - - ;; We use the index file to find out where the article begins and ends. + ;; 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) @@ -510,24 +583,22 @@ (let ((format (gnus-soup-encoding-format (gnus-soup-area-encoding (nth 1 area))))) (goto-char end) - (if (or (= format ?n) (= format ?m)) - (setq end (progn (forward-line -1) (point)))))) + (when (or (= 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) - (goto-char (point-min)) - (let ((header (nnsoup-header - (gnus-soup-encoding-format - (gnus-soup-area-encoding (nth 1 area)))))) - (re-search-forward header nil t (- article (caar area))) - (narrow-to-region - (match-beginning 0) - (if (re-search-forward header nil t) - (match-beginning 0) - (point-max)))))) + (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) () @@ -538,27 +609,21 @@ (point-max)))) msg-buf)))) -(defun nnsoup-header (format) - (cond - ((= format ?n) - "^#! *rnews +[0-9]+ *$") - ((= format ?m) - (concat "^" message-unix-mail-delimiter)) - ((= format ?M) - "^\^A\^A\^A\^A\n") - (t - (error "Unknown format: %c" format)))) - ;;;###autoload (defun nnsoup-pack-replies () "Make an outbound package of SOUP replies." (interactive) + (unless (file-exists-p nnsoup-replies-directory) + (message "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)) @@ -597,8 +662,6 @@ (require 'mail-utils) (let ((tembuf (generate-new-buffer " message temp")) (case-fold-search nil) - (news (message-news-p)) - (resend-to-addresses (mail-fetch-field "resent-to")) delimline (mailbuf (current-buffer))) (unwind-protect @@ -620,11 +683,6 @@ ;; require one newline at the end. (or (= (preceding-char) ?\n) (insert ?\n)) - (when (and news - (equal kind "mail") - (or (mail-fetch-field "cc") - (mail-fetch-field "to"))) - (message-insert-courtesy-copy)) (let ((case-fold-search t)) ;; Change header-delimiter to be what sendmail expects. (goto-char (point-min)) @@ -665,15 +723,14 @@ (setq replies (cdr replies))) (if replies (gnus-soup-reply-prefix (car replies)) - (setq nnsoup-replies-list - (cons (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)) + (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 () @@ -691,7 +748,7 @@ (while files (message "Doing %s..." (car files)) (erase-buffer) - (insert-file-contents (car files)) + (nnheader-insert-file-contents (car files)) (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") @@ -704,7 +761,7 @@ (match-end 1)))) (if (not (setq elem (assoc group active))) (push (list group (cons 1 lines) - (list (cons 1 lines) + (list (cons 1 lines) (vector ident group "ncm" "" lines))) active) (nconc elem diff -r ad457d5f7d04 -r 0293115a14e9 lisp/gnus/nnspool.el --- a/lisp/gnus/nnspool.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/gnus/nnspool.el Mon Aug 13 08:49:20 2007 +0200 @@ -1,5 +1,5 @@ ;;; nnspool.el --- spool access for GNU Emacs -;; Copyright (C) 1988,89,90,93,94,95,96 Free Software Foundation, Inc. +;; Copyright (C) 1988,89,90,93,94,95,96,97 Free Software Foundation, Inc. ;; Author: Masanobu UMEDA ;; Lars Magne Ingebrigtsen @@ -143,8 +143,8 @@ (message "nnspool: Receiving headers... %d%%" (/ (* count 100) number)))) - (and do-message - (message "nnspool: Receiving headers...done")) + (when do-message + (message "nnspool: Receiving headers...done")) ;; Fold continuation lines. (nnheader-fold-continuation-lines) @@ -282,7 +282,7 @@ (while (and (looking-at "\\([^ ]+\\) +[0-9]+ ") (progn ;; We insert a .0 to make the list reader - ;; interpret the number as a float. It is far + ;; interpret the number as a float. It is far ;; too big to be stored in a lisp integer. (goto-char (1- (match-end 0))) (insert ".0") @@ -290,9 +290,9 @@ (goto-char (match-end 1)) (read (current-buffer))) seconds)) - (setq groups (cons (buffer-substring + (push (buffer-substring (match-beginning 1) (match-end 1)) - groups)) + groups) (zerop (forward-line -1)))) (erase-buffer) (while groups @@ -320,9 +320,8 @@ (process-send-region proc (point-min) (point-max)) ;; We slap a condition-case around this, because the process may ;; have exited already... - (condition-case nil - (process-send-eof proc) - (error nil)) + (ignore-errors + (process-send-eof proc)) t)))) @@ -358,44 +357,34 @@ (erase-buffer) (if nnspool-sift-nov-with-sed (nnspool-sift-nov-with-sed articles nov) - (insert-file-contents nov) + (nnheader-insert-file-contents nov) (if (and fetch-old (not (numberp fetch-old))) t ; We want all the headers. - (condition-case () - (progn - ;; First we find the first wanted line. - (nnspool-find-nov-line - (if fetch-old (max 1 (- (car articles) fetch-old)) - (car articles))) - (delete-region (point-min) (point)) - ;; Then we find the last wanted line. - (if (nnspool-find-nov-line - (progn (while (cdr articles) - (setq articles (cdr articles))) - (car articles))) - (forward-line 1)) - (delete-region (point) (point-max)) - ;; If the buffer is empty, this wasn't very successful. - (unless (zerop (buffer-size)) - ;; We check what the last article number was. - ;; The NOV file may be out of sync with the articles - ;; in the group. - (forward-line -1) - (setq last (read (current-buffer))) - (if (= last (car articles)) - ;; Yup, it's all there. - t - ;; Perhaps not. We try to find the missing articles. - (while (and arts - (<= last (car arts))) - (pop arts)) - ;; The articles in `arts' are missing from the buffer. - (while arts - (nnspool-insert-nov-head (pop arts))) - t))) - ;; The NOV file was corrupted. - (error nil))))))))) + (ignore-errors + ;; Delete unwanted NOV lines. + (nnheader-nov-delete-outside-range + (if fetch-old (max 1 (- (car articles) fetch-old)) + (car articles)) + (car (last articles))) + ;; If the buffer is empty, this wasn't very successful. + (unless (zerop (buffer-size)) + ;; We check what the last article number was. + ;; The NOV file may be out of sync with the articles + ;; in the group. + (forward-line -1) + (setq last (read (current-buffer))) + (if (= last (car articles)) + ;; Yup, it's all there. + t + ;; Perhaps not. We try to find the missing articles. + (while (and arts + (<= last (car arts))) + (pop arts)) + ;; The articles in `arts' are missing from the buffer. + (while arts + (nnspool-insert-nov-head (pop arts))) + t)))))))))) (defun nnspool-insert-nov-head (article) "Read the head of ARTICLE, convert to NOV headers, and insert." @@ -412,42 +401,6 @@ (nnheader-insert-nov headers))) (kill-buffer buf)))) -(defun nnspool-find-nov-line (article) - (let ((max (point-max)) - (min (goto-char (point-min))) - (cur (current-buffer)) - (prev (point-min)) - num found) - (while (not found) - (goto-char (/ (+ max min) 2)) - (beginning-of-line) - (if (or (= (point) prev) - (eobp)) - (setq found t) - (setq prev (point)) - (cond ((> (setq num (read cur)) article) - (setq max (point))) - ((< num article) - (setq min (point))) - (t - (setq found 'yes))))) - ;; Now we may have found the article we're looking for, or we - ;; may be somewhere near it. - (when (and (not (eq found 'yes)) - (not (eq num article))) - (setq found (point)) - (while (and (< (point) max) - (or (not (numberp num)) - (< num article))) - (forward-line 1) - (setq found (point)) - (or (eobp) - (= (setq num (read cur)) article))) - (unless (eq num article) - (goto-char found))) - (beginning-of-line) - (eq num article))) - (defun nnspool-sift-nov-with-sed (articles file) (let ((first (car articles)) (last (progn (while (cdr articles) (setq articles (cdr articles))) @@ -464,13 +417,12 @@ (set-buffer (get-buffer-create " *nnspool work*")) (buffer-disable-undo (current-buffer)) (erase-buffer) - (condition-case () - (call-process "grep" nil t nil (regexp-quote id) nnspool-history-file) - (error nil)) + (ignore-errors + (call-process "grep" nil t nil (regexp-quote id) nnspool-history-file)) (goto-char (point-min)) (prog1 - (if (looking-at "<[^>]+>[ \t]+[-0-9~]+[ \t]+\\([^ /\t\n]+\\)/\\([0-9]+\\)[ \t\n]") - (cons (match-string 1) (string-to-int (match-string 2)))) + (when (looking-at "<[^>]+>[ \t]+[-0-9~]+[ \t]+\\([^ /\t\n]+\\)/\\([0-9]+\\)[ \t\n]") + (cons (match-string 1) (string-to-int (match-string 2)))) (kill-buffer (current-buffer))))) (defun nnspool-find-file (file) @@ -478,7 +430,7 @@ (set-buffer nntp-server-buffer) (erase-buffer) (condition-case () - (progn (nnheader-insert-file-contents-literally file) t) + (progn (nnheader-insert-file-contents file) t) (file-error nil))) (defun nnspool-possibly-change-directory (group) @@ -501,7 +453,7 @@ (timezone-parse-time (aref (timezone-parse-date date) 3)))) (unix (encode-time (nth 2 ttime) (nth 1 ttime) (nth 0 ttime) - (nth 2 tdate) (nth 1 tdate) (nth 0 tdate) + (nth 2 tdate) (nth 1 tdate) (nth 0 tdate) (nth 4 tdate)))) (+ (* (car unix) 65536.0) (cadr unix)))) diff -r ad457d5f7d04 -r 0293115a14e9 lisp/gnus/nntp.el --- a/lisp/gnus/nntp.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/gnus/nntp.el Mon Aug 13 08:49:20 2007 +0200 @@ -1,8 +1,7 @@ ;;; nntp.el --- nntp access for Gnus -;; Copyright (C) 1987,88,89,90,92,93,94,95,96 Free Software Foundation, Inc. +;;; Copyright (C) 1987,88,89,90,92,93,94,95,96,97 Free Software Foundation, Inc. -;; Author: Masanobu UMEDA -;; Lars Magne Ingebrigtsen +;; Author: Lars Magne Ingebrigtsen ;; Keywords: news ;; This file is part of GNU Emacs. @@ -18,9 +17,8 @@ ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;; along with GNU Emacs; see the file COPYING. If not, write to +;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. ;;; Commentary: @@ -28,7 +26,7 @@ (require 'nnheader) (require 'nnoo) -(eval-when-compile (require 'cl)) +(require 'gnus-util) (nnoo-declare nntp) @@ -38,27 +36,11 @@ (eval-when-compile (require 'cl)) -(eval-and-compile - (autoload 'cancel-timer "timer") - (autoload 'telnet "telnet" nil t) - (autoload 'telnet-send-input "telnet" nil t) - (autoload 'timezone-parse-date "timezone")) +(defvoo nntp-address nil + "Address of the physical nntp server.") -(defvoo nntp-server-hook nil - "*Hooks for the NNTP server. -If the kanji code of the NNTP server is different from the local kanji -code, the correct kanji code of the buffer associated with the NNTP -server must be specified as follows: - -\(setq nntp-server-hook - (function - (lambda () - ;; Server's Kanji code is EUC (NEmacs hack). - (make-local-variable 'kanji-fileio-code) - (setq kanji-fileio-code 0)))) - -If you'd like to change something depending on the server in this -hook, use the variable `nntp-address'.") +(defvoo nntp-port-number "nntp" + "Port number on the physical nntp server.") (defvoo nntp-server-opened-hook '(nntp-send-mode-reader) "*Hook used for sending commands to the server at startup. @@ -66,12 +48,16 @@ server spawn an nnrpd server. Another useful function to put in this hook might be `nntp-send-authinfo', which will prompt for a password to allow posting from the server. Note that this is only necessary to -do on servers that use strict access control.") -(add-hook 'nntp-server-opened-hook 'nntp-send-mode-reader) +do on servers that use strict access control.") + +(defvoo nntp-authinfo-function 'nntp-send-authinfo + "Function used to send AUTHINFO to the server.") (defvoo nntp-server-action-alist '(("nntpd 1\\.5\\.11t" - (remove-hook 'nntp-server-opened-hook 'nntp-send-mode-reader))) + (remove-hook 'nntp-server-opened-hook 'nntp-send-mode-reader)) + ("NNRP server Netscape" + (setq nntp-server-list-active-group nil))) "Alist of regexps to match on server types and actions to be taken. For instance, if you want Gnus to beep every time you connect to innd, you could say something like: @@ -81,27 +67,28 @@ You probably don't want to do that, though.") -(defvoo nntp-open-server-function 'nntp-open-network-stream +(defvoo nntp-open-connection-function 'nntp-open-network-stream "*Function used for connecting to a remote system. -It will be called with the address of the remote system. +It will be called with the buffer to output in. Two pre-made functions are `nntp-open-network-stream', which is the default, and simply connects to some port or other on the remote -system (see nntp-port-number). The other is `nntp-open-rlogin', which +system (see nntp-port-number). The other are `nntp-open-rlogin', which does an rlogin on the remote system, and then does a telnet to the -NNTP server available there (see nntp-rlogin-parameters).") +NNTP server available there (see nntp-rlogin-parameters) and `nntp-open-telnet' which +telnets to a remote system, logs in and does the same") -(defvoo nntp-rlogin-parameters '("telnet" "${NNTPSERVER:=localhost}" "nntp") - "*Parameters to `nntp-open-rlogin'. -That function may be used as `nntp-open-server-function'. In that +(defvoo nntp-rlogin-parameters '("telnet" "-8" "${NNTPSERVER:=news}" "nntp") + "*Parameters to `nntp-open-login'. +That function may be used as `nntp-open-connection-function'. In that case, this list will be used as the parameter list given to rsh.") (defvoo nntp-rlogin-user-name nil "*User name on remote system when using the rlogin connect method.") -(defvoo nntp-telnet-parameters '("exec" "telnet" "-8" "${NNTPSERVER:=localhost}" "nntp") +(defvoo nntp-telnet-parameters '("exec" "telnet" "-8" "${NNTPSERVER:=news}" "nntp") "*Parameters to `nntp-open-telnet'. -That function may be used as `nntp-open-server-function'. In that +That function may be used as `nntp-open-connection-function'. In that case, this list will be executed as a command after logging in via telnet.") @@ -111,12 +98,6 @@ (defvoo nntp-telnet-passwd nil "Password to use to log in via telnet with.") -(defvoo nntp-address nil - "*The name of the NNTP server.") - -(defvoo nntp-port-number "nntp" - "*Port number to connect to.") - (defvoo nntp-end-of-line "\r\n" "String to use on the end of lines when talking to the NNTP server. This is \"\\r\\n\" by default, but should be \"\\n\" when @@ -127,28 +108,17 @@ If the number of the articles is greater than the value, verbose messages will be shown to indicate the current status.") -(defvoo nntp-buggy-select (memq system-type '(fujitsu-uts)) - "*t if your select routine is buggy. -If the select routine signals error or fall into infinite loop while -waiting for the server response, the variable must be set to t. In -case of Fujitsu UTS, it is set to T since `accept-process-output' -doesn't work properly.") - (defvoo nntp-maximum-request 400 "*The maximum number of the requests sent to the NNTP server at one time. If Emacs hangs up while retrieving headers, set the variable to a lower value.") -(defvoo nntp-debug-read 10000 - "*Display '...' every 10Kbytes of a message being received if it is non-nil. -If it is a number, dots are displayed per the number.") - (defvoo nntp-nov-is-evil nil "*If non-nil, nntp will never attempt to use XOVER when talking to the server.") (defvoo nntp-xover-commands '("XOVER" "XOVERVIEW") "*List of strings that are used as commands to fetch NOV lines from a server. -The strings are tried in turn until a positive response is gotten. If +The strings are tried in turn until a positive response is gotten. If none of the commands are successful, nntp will just grab headers one by one.") @@ -161,72 +131,58 @@ "*Number of seconds to wait before an nntp connection times out. If this variable is nil, which is the default, no timers are set.") -(defvoo nntp-command-timeout nil - "*Number of seconds to wait for a response when sending a command. -If this variable is nil, which is the default, no timers are set.") - -(defvoo nntp-retry-on-break nil - "*If non-nil, re-send the command when the user types `C-g'.") - -(defvoo nntp-news-default-headers nil - "*If non-nil, override `mail-default-headers' when posting news.") - (defvoo nntp-prepare-server-hook nil "*Hook run before a server is opened. If can be used to set up a server remotely, for instance. Say you have an account at the machine \"other.machine\". This machine has access to an NNTP server that you can't access locally. You could then use this hook to rsh to the remote machine and start a proxy NNTP -server there that you can connect to.") - -(defvoo nntp-async-number 5 - "*How many articles should be prefetched when in asynchronous mode.") +server there that you can connect to. See also `nntp-open-connection-function'") (defvoo nntp-warn-about-losing-connection t "*If non-nil, beep when a server closes connection.") -(defconst nntp-version "nntp 4.0" - "Version numbers of this version of NNTP.") +;;; Internal variables. -(defvar nntp-server-buffer nil - "Buffer associated with the NNTP server process.") +(defvar nntp-have-messaged nil) -(defvoo nntp-server-process nil - "The NNTP server process. -You'd better not use this variable in NNTP front-end program, but -instead use `nntp-server-buffer'.") +(defvar nntp-process-wait-for nil) +(defvar nntp-process-to-buffer nil) +(defvar nntp-process-callback nil) +(defvar nntp-process-decode nil) +(defvar nntp-process-start-point nil) +(defvar nntp-inside-change-function nil) -(defvoo nntp-status-string nil - "Save the server response message.") +(defvar nntp-connection-list nil) -(defvar nntp-opened-connections nil - "All (possibly) opened connections.") +(defvoo nntp-server-type nil) +(defvoo nntp-connection-alist nil) +(defvoo nntp-status-string "") +(defconst nntp-version "nntp 5.0") +(defvoo nntp-inhibit-erase nil) +(defvoo nntp-inhibit-output nil) (defvoo nntp-server-xover 'try) (defvoo nntp-server-list-active-group 'try) -(defvoo nntp-current-group "") -(defvoo nntp-server-type nil) -(defvoo nntp-async-process nil) -(defvoo nntp-async-buffer nil) -(defvoo nntp-async-articles nil) -(defvoo nntp-async-fetched nil) -(defvoo nntp-async-group-alist nil) +(eval-and-compile + (autoload 'nnmail-read-passwd "nnmail")) + ;;; Interface functions. (nnoo-define-basics nntp) (deffoo nntp-retrieve-headers (articles &optional group server fetch-old) "Retrieve the headers of ARTICLES." - (nntp-possibly-change-server group server) + (nntp-possibly-change-group group server) (save-excursion - (set-buffer nntp-server-buffer) + (set-buffer (nntp-find-connection-buffer nntp-server-buffer)) (erase-buffer) - (if (and (not gnus-nov-is-evil) + (if (and (not gnus-nov-is-evil) (not nntp-nov-is-evil) (nntp-retrieve-headers-with-xover articles fetch-old)) ;; We successfully retrieved the headers via XOVER. @@ -236,12 +192,14 @@ (let ((number (length articles)) (count 0) (received 0) - (message-log-max nil) - (last-point (point-min))) + (last-point (point-min)) + (buf (nntp-find-connection-buffer nntp-server-buffer)) + (nntp-inhibit-erase t)) ;; Send HEAD command. (while articles - (nntp-send-strings-to-server - "HEAD" (if (numberp (car articles)) + (nntp-send-command + nil + "HEAD" (if (numberp (car articles)) (int-to-string (car articles)) ;; `articles' is either a list of article numbers ;; or a list of article IDs. @@ -254,10 +212,12 @@ (zerop (% count nntp-maximum-request))) (nntp-accept-response) (while (progn - (goto-char last-point) + (progn + (set-buffer buf) + (goto-char last-point)) ;; Count replies. (while (re-search-forward "^[0-9]" nil t) - (setq received (1+ received))) + (incf received)) (setq last-point (point)) (< received count)) ;; If number of headers is greater than 100, give @@ -265,7 +225,7 @@ (and (numberp nntp-large-newsgroup) (> number nntp-large-newsgroup) (zerop (% received 20)) - (nnheader-message 7 "NNTP: Receiving headers... %d%%" + (nnheader-message 6 "NNTP: Receiving headers... %d%%" (/ (* received 100) number))) (nntp-accept-response)))) ;; Wait for text of last command. @@ -278,22 +238,20 @@ (nntp-accept-response))) (and (numberp nntp-large-newsgroup) (> number nntp-large-newsgroup) - (nnheader-message 7 "NNTP: Receiving headers...done")) + (nnheader-message 6 "NNTP: Receiving headers...done")) ;; Now all of replies are received. Fold continuation lines. (nnheader-fold-continuation-lines) ;; Remove all "\r"'s. - (goto-char (point-min)) - (while (search-forward "\r" nil t) - (replace-match "" t t)) + (nnheader-strip-cr) + (copy-to-buffer nntp-server-buffer (point-min) (point-max)) 'headers)))) - (deffoo nntp-retrieve-groups (groups &optional server) "Retrieve group info on GROUPS." - (nntp-possibly-change-server nil server) + (nntp-possibly-change-group nil server) (save-excursion - (set-buffer nntp-server-buffer) + (set-buffer (nntp-find-connection-buffer nntp-server-buffer)) ;; The first time this is run, this variable is `try'. So we ;; try. (when (eq nntp-server-list-active-group 'try) @@ -302,12 +260,12 @@ (let ((count 0) (received 0) (last-point (point-min)) + (nntp-inhibit-erase t) (command (if nntp-server-list-active-group "LIST ACTIVE" "GROUP"))) (while groups ;; Send the command to the server. - (nntp-send-strings-to-server command (car groups)) - (setq groups (cdr groups)) - (setq count (1+ count)) + (nntp-send-command nil command (pop groups)) + (incf count) ;; Every 400 requests we have to read the stream in ;; order to avoid deadlocks. (when (or (null groups) ;All requests have been sent. @@ -317,312 +275,249 @@ (goto-char last-point) ;; Count replies. (while (re-search-forward "^[0-9]" nil t) - (setq received (1+ received))) + (incf received)) (setq last-point (point)) (< received count)) (nntp-accept-response)))) ;; Wait for the reply from the final command. - (when nntp-server-list-active-group - (goto-char (point-max)) - (re-search-backward "^[0-9]" nil t) - (when (looking-at "^[23]") - (while (progn - (goto-char (- (point-max) 3)) - (not (looking-at "^\\.\r?\n"))) - (nntp-accept-response)))) + (goto-char (point-max)) + (re-search-backward "^[0-9]" nil t) + (when (looking-at "^[23]") + (while (progn + (goto-char (point-max)) + (if (not nntp-server-list-active-group) + (not (re-search-backward "\r?\n" (- (point) 3) t)) + (not (re-search-backward "^\\.\r?\n" (- (point) 4) t)))) + (nntp-accept-response))) - ;; Now all replies are received. We remove CRs. + ;; Now all replies are received. We remove CRs. (goto-char (point-min)) (while (search-forward "\r" nil t) (replace-match "" t t)) (if (not nntp-server-list-active-group) - 'group + (progn + (copy-to-buffer nntp-server-buffer (point-min) (point-max)) + 'group) ;; We have read active entries, so we just delete the - ;; superfluos gunk. + ;; superfluous gunk. (goto-char (point-min)) (while (re-search-forward "^[.2-5]" nil t) - (delete-region (match-beginning 0) + (delete-region (match-beginning 0) (progn (forward-line 1) (point)))) + (copy-to-buffer nntp-server-buffer (point-min) (point-max)) 'active)))) -(deffoo nntp-open-server (server &optional defs connectionless) - "Open the virtual server SERVER. -If CONNECTIONLESS is non-nil, don't attempt to connect to any physical -servers." - (nnheader-init-server-buffer) - ;; Called with just a port number as the defs. - (when (or (stringp (car defs)) - (numberp (car defs))) - (setq defs `((nntp-port-number ,(car defs))))) - (unless (assq 'nntp-address defs) - (setq defs (append defs `((nntp-address ,server))))) - (nnoo-change-server 'nntp server defs) - (if (nntp-server-opened server) - t - (or (nntp-server-opened server) - connectionless - (prog2 - (run-hooks 'nntp-prepare-server-hook) - (nntp-open-server-semi-internal nntp-address nntp-port-number) - (nnheader-insert ""))))) +(deffoo nntp-retrieve-articles (articles &optional group server) + (nntp-possibly-change-group group server) + (save-excursion + (let ((number (length articles)) + (count 0) + (received 0) + (last-point (point-min)) + (buf (nntp-find-connection-buffer nntp-server-buffer)) + (nntp-inhibit-erase t) + (map (apply 'vector articles)) + (point 1) + article alist) + (set-buffer buf) + (erase-buffer) + ;; Send HEAD command. + (while (setq article (pop articles)) + (nntp-send-command + nil + "ARTICLE" (if (numberp article) + (int-to-string article) + ;; `articles' is either a list of article numbers + ;; or a list of article IDs. + article)) + (incf count) + ;; Every 400 requests we have to read the stream in + ;; order to avoid deadlocks. + (when (or (null articles) ;All requests have been sent. + (zerop (% count nntp-maximum-request))) + (nntp-accept-response) + (while (progn + (progn + (set-buffer buf) + (goto-char last-point)) + ;; Count replies. + (while (nntp-next-result-arrived-p) + (aset map received (cons (aref map received) (point))) + (incf received)) + (setq last-point (point)) + (< received count)) + ;; If number of headers is greater than 100, give + ;; informative messages. + (and (numberp nntp-large-newsgroup) + (> number nntp-large-newsgroup) + (zerop (% received 20)) + (nnheader-message 6 "NNTP: Receiving articles... %d%%" + (/ (* received 100) number))) + (nntp-accept-response)))) + (and (numberp nntp-large-newsgroup) + (> number nntp-large-newsgroup) + (nnheader-message 6 "NNTP: Receiving headers...done")) -(deffoo nntp-close-server (&optional server) - "Close connection to SERVER." - (nntp-possibly-change-server nil server t) - (unwind-protect - (progn - ;; Un-set default sentinel function before closing connection. - (and nntp-server-process - (eq 'nntp-default-sentinel - (process-sentinel nntp-server-process)) - (set-process-sentinel nntp-server-process nil)) - ;; We cannot send QUIT command unless the process is running. - (when (nntp-server-opened server) - (nntp-send-command nil "QUIT") - ;; Give the QUIT time to arrive. - (sleep-for 1))) - (nntp-close-server-internal server))) + ;; Now we have all the responses. We go through the results, + ;; washes it and copies it over to the server buffer. + (set-buffer nntp-server-buffer) + (erase-buffer) + (mapcar + (lambda (entry) + (narrow-to-region + (setq point (goto-char (point-max))) + (progn + (insert-buffer-substring buf last-point (cdr entry)) + (point-max))) + (nntp-decode-text) + (widen) + (cons (car entry) point)) + map)))) + +(defun nntp-next-result-arrived-p () + (let ((point (point))) + (cond + ((looking-at "2") + (if (re-search-forward "\n.\r?\n" nil t) + t + (goto-char point) + nil)) + ((looking-at "[34]") + (forward-line 1) + t) + (t + nil)))) -(deffoo nntp-request-close () - "Close all server connections." - (let (proc) - (while nntp-opened-connections - (when (setq proc (pop nntp-opened-connections)) - ;; Un-set default sentinel function before closing connection. - (when (eq 'nntp-default-sentinel (process-sentinel proc)) - (set-process-sentinel proc nil)) - (condition-case () - (process-send-string proc (concat "QUIT" nntp-end-of-line)) - (error nil)) - ;; Give the QUIT time to reach the server before we close - ;; down the process. - (sleep-for 1) - (delete-process proc))) - (and nntp-async-buffer - (buffer-name nntp-async-buffer) - (kill-buffer nntp-async-buffer)) - (let ((alist (cddr (assq 'nntp nnoo-state-alist))) - entry) - (while (setq entry (pop alist)) - (and (setq proc (cdr (assq 'nntp-async-buffer entry))) - (buffer-name proc) - (kill-buffer proc)))) - (nnoo-close-server 'nntp) - (setq nntp-async-group-alist nil - nntp-async-articles nil))) +(defun nntp-try-list-active (group) + (nntp-list-active-group group) + (save-excursion + (set-buffer nntp-server-buffer) + (goto-char (point-min)) + (cond ((or (eobp) + (looking-at "5[0-9]+")) + (setq nntp-server-list-active-group nil)) + (t + (setq nntp-server-list-active-group t))))) + +(deffoo nntp-list-active-group (group &optional server) + "Return the active info on GROUP (which can be a regexp." + (nntp-possibly-change-group nil server) + (nntp-send-command "^.*\r?\n" "LIST ACTIVE" group)) + +(deffoo nntp-request-article (article &optional group server buffer command) + (nntp-possibly-change-group group server) + (when (nntp-send-command-and-decode + "\r?\n\\.\r?\n" "ARTICLE" + (if (numberp article) (int-to-string article) article)) + (when (and buffer + (not (equal buffer nntp-server-buffer))) + (save-excursion + (set-buffer nntp-server-buffer) + (copy-to-buffer buffer (point-min) (point-max)) + (nntp-find-group-and-number))) + (nntp-find-group-and-number))) + +(deffoo nntp-request-head (article &optional group server) + (nntp-possibly-change-group group server) + (when (nntp-send-command-and-decode + "\r?\n\\.\r?\n" "HEAD" + (if (numberp article) (int-to-string article) article)) + (nntp-find-group-and-number))) + +(deffoo nntp-request-body (article &optional group server) + (nntp-possibly-change-group group server) + (nntp-send-command-and-decode + "\r?\n\\.\r?\n" "BODY" + (if (numberp article) (int-to-string article) article))) + +(deffoo nntp-request-group (group &optional server dont-check) + (nntp-possibly-change-group nil server) + (when (nntp-send-command "^2.*\n" "GROUP" group) + (let ((entry (nntp-find-connection-entry nntp-server-buffer))) + (setcar (cddr entry) group)))) + +(deffoo nntp-close-group (group &optional server) + t) (deffoo nntp-server-opened (&optional server) "Say whether a connection to SERVER has been opened." (and (nnoo-current-server-p 'nntp server) nntp-server-buffer - (buffer-name nntp-server-buffer) - nntp-server-process - (memq (process-status nntp-server-process) '(open run)))) - -(deffoo nntp-status-message (&optional server) - "Return server status as a string." - (if (and nntp-status-string - ;; NNN MESSAGE - (string-match "[0-9][0-9][0-9][ \t]+\\([^\r]*\\).*$" - nntp-status-string)) - (substring nntp-status-string (match-beginning 1) (match-end 1)) - ;; Empty message if nothing. - (or nntp-status-string ""))) - -(deffoo nntp-request-article (id &optional group server buffer) - "Request article ID (Message-ID or number)." - (nntp-possibly-change-server group server) - - (let (found) + (gnus-buffer-live-p nntp-server-buffer) + (nntp-find-connection nntp-server-buffer))) - ;; First we see whether we can get the article from the async buffer. - (when (and (numberp id) - nntp-async-articles - (memq id nntp-async-fetched)) - (save-excursion - (set-buffer nntp-async-buffer) - (let ((opoint (point)) - (art (if (numberp id) (int-to-string id) id)) - beg end) - (when (and (or (re-search-forward (concat "^2.. +" art) nil t) - (progn - (goto-char (point-min)) - (re-search-forward (concat "^2.. +" art) opoint t))) - (progn - (beginning-of-line) - (setq beg (point) - end (re-search-forward "^\\.\r?\n" nil t)))) - (setq found t) - (save-excursion - (set-buffer (or buffer nntp-server-buffer)) - (erase-buffer) - (insert-buffer-substring nntp-async-buffer beg end) - (let ((nntp-server-buffer (current-buffer))) - (nntp-decode-text))) - (delete-region beg end) - (when nntp-async-articles - (nntp-async-fetch-articles id)))))) +(deffoo nntp-open-server (server &optional defs connectionless) + (nnheader-init-server-buffer) + (if (nntp-server-opened server) + t + (when (or (stringp (car defs)) + (numberp (car defs))) + (setq defs (cons (list 'nntp-port-number (car defs)) (cdr defs)))) + (unless (assq 'nntp-address defs) + (setq defs (append defs (list (list 'nntp-address server))))) + (nnoo-change-server 'nntp server defs) + (unless connectionless + (or (nntp-find-connection nntp-server-buffer) + (nntp-open-connection nntp-server-buffer))))) - (if found - id - ;; The article was not in the async buffer, so we fetch it now. - (unwind-protect - (progn - (if buffer (set-process-buffer nntp-server-process buffer)) - (let ((nntp-server-buffer (or buffer nntp-server-buffer)) - (art (or (and (numberp id) (int-to-string id)) id))) - (prog1 - (and (nntp-send-command - ;; A bit odd regexp to ensure working over rlogin. - "^\\.\r?\n" "ARTICLE" art) - (if (numberp id) - (cons nntp-current-group id) - ;; We find out what the article number was. - (nntp-find-group-and-number))) - (nntp-decode-text) - (and nntp-async-articles (nntp-async-fetch-articles id))))) - (when buffer - (set-process-buffer nntp-server-process nntp-server-buffer)))))) +(deffoo nntp-close-server (&optional server) + (nntp-possibly-change-group nil server t) + (let (process) + (while (setq process (car (pop nntp-connection-alist))) + (when (memq (process-status process) '(open run)) + (set-process-sentinel process nil) + (nntp-send-string process "QUIT")) + (when (buffer-name (process-buffer process)) + (kill-buffer (process-buffer process)))) + (nnoo-close-server 'nntp))) -(deffoo nntp-request-body (id &optional group server) - "Request body of article ID (Message-ID or number)." - (nntp-possibly-change-server group server) - (prog1 - ;; If NEmacs, end of message may look like: "\256\215" (".^M") - (nntp-send-command - "^\\.\r?\n" "BODY" (or (and (numberp id) (int-to-string id)) id)) - (nntp-decode-text))) +(deffoo nntp-request-close () + (let (process) + (while (setq process (pop nntp-connection-list)) + (when (memq (process-status process) '(open run)) + (set-process-sentinel process nil) + (ignore-errors + (nntp-send-string process "QUIT"))) + (when (buffer-name (process-buffer process)) + (kill-buffer (process-buffer process)))))) -(deffoo nntp-request-head (id &optional group server) - "Request head of article ID (Message-ID or number)." - (nntp-possibly-change-server group server) - (prog1 - (when (nntp-send-command - "^\\.\r?\n" "HEAD" (if (numberp id) (int-to-string id) id)) - (if (numberp id) id - ;; We find out what the article number was. - (nntp-find-group-and-number))) - (nntp-decode-text) - (save-excursion - (set-buffer nntp-server-buffer) - (nnheader-fold-continuation-lines)))) +(deffoo nntp-request-list (&optional server) + (nntp-possibly-change-group nil server) + (nntp-send-command-and-decode "\r?\n\\.\r?\n" "LIST")) -(deffoo nntp-request-stat (id &optional group server) - "Request STAT of article ID (Message-ID or number)." - (nntp-possibly-change-server group server) - (nntp-send-command - "^[23].*\r?\n" "STAT" (or (and (numberp id) (int-to-string id)) id))) - -(deffoo nntp-request-type (group &optional article) - 'news) - -(deffoo nntp-request-group (group &optional server dont-check) - "Select GROUP." - (nntp-possibly-change-server nil server) - (setq nntp-current-group - (when (nntp-send-command "^2.*\r?\n" "GROUP" group) - group))) +(deffoo nntp-request-list-newsgroups (&optional server) + (nntp-possibly-change-group nil server) + (nntp-send-command "\r?\n\\.\r?\n" "LIST NEWSGROUPS")) -(deffoo nntp-request-asynchronous (group &optional server articles) - "Enable pre-fetch in GROUP." - (when nntp-async-articles - (nntp-async-request-group group)) - (when nntp-async-number - (if (not (or (nntp-async-server-opened) - (nntp-async-open-server))) - ;; Couldn't open the second connection - (progn - (message "Can't open second connection to %s" nntp-address) - (ding) - (setq nntp-async-articles nil) - (sit-for 2)) - ;; We opened the second connection (or it was opened already). - (setq nntp-async-articles articles) - (setq nntp-async-fetched nil) - ;; Clear any old data. - (save-excursion - (set-buffer nntp-async-buffer) - (erase-buffer)) - ;; Select the correct current group on this server. - (nntp-async-send-strings "GROUP" group) - t))) +(deffoo nntp-request-newgroups (date &optional server) + (nntp-possibly-change-group nil server) + (save-excursion + (set-buffer nntp-server-buffer) + (let* ((date (timezone-parse-date date)) + (time-string + (format "%s%02d%02d %s%s%s" + (substring (aref date 0) 2) (string-to-int (aref date 1)) + (string-to-int (aref date 2)) (substring (aref date 3) 0 2) + (substring + (aref date 3) 3 5) (substring (aref date 3) 6 8)))) + (prog1 + (nntp-send-command "^\\.\r?\n" "NEWGROUPS" time-string) + (nntp-decode-text))))) -(deffoo nntp-list-active-group (group &optional server) - "Return the active info on GROUP (which can be a regexp." - (nntp-possibly-change-server group server) - (nntp-send-command "^.*\r?\n" "LIST ACTIVE" group)) +(deffoo nntp-request-post (&optional server) + (nntp-possibly-change-group nil server) + (when (nntp-send-command "^[23].*\r?\n" "POST") + (nntp-send-buffer "^[23].*\n"))) -(deffoo nntp-request-group-description (group &optional server) - "Get the description of GROUP." - (nntp-possibly-change-server nil server) - (prog1 - (nntp-send-command "^.*\r?\n" "XGTITLE" group) - (nntp-decode-text))) - -(deffoo nntp-close-group (group &optional server) - "Close GROUP." - (setq nntp-current-group nil) +(deffoo nntp-request-type (group article) + 'news) + +(deffoo nntp-asynchronous-p () t) -(deffoo nntp-request-list (&optional server) - "List all active groups." - (nntp-possibly-change-server nil server) - (prog1 - (nntp-send-command "^\\.\r?\n" "LIST") - (nntp-decode-text))) - -(deffoo nntp-request-list-newsgroups (&optional server) - "Get descriptions on all groups on SERVER." - (nntp-possibly-change-server nil server) - (prog1 - (nntp-send-command "^\\.\r?\n" "LIST NEWSGROUPS") - (nntp-decode-text))) - -(deffoo nntp-request-newgroups (date &optional server) - "List groups that have arrived since DATE." - (nntp-possibly-change-server nil server) - (let* ((date (timezone-parse-date date)) - (time-string - (format "%s%02d%02d %s%s%s" - (substring (aref date 0) 2) (string-to-int (aref date 1)) - (string-to-int (aref date 2)) (substring (aref date 3) 0 2) - (substring - (aref date 3) 3 5) (substring (aref date 3) 6 8)))) - (prog1 - (nntp-send-command "^\\.\r?\n" "NEWGROUPS" time-string) - (nntp-decode-text)))) - -(deffoo nntp-request-list-distributions (&optional server) - "List distributions." - (nntp-possibly-change-server nil server) - (prog1 - (nntp-send-command "^\\.\r?\n" "LIST DISTRIBUTIONS") - (nntp-decode-text))) - -(deffoo nntp-request-last (&optional group server) - "Decrease the current article pointer." - (nntp-possibly-change-server group server) - (nntp-send-command "^[23].*\r?\n" "LAST")) - -(deffoo nntp-request-next (&optional group server) - "Advance the current article pointer." - (nntp-possibly-change-server group server) - (nntp-send-command "^[23].*\r?\n" "NEXT")) - -(deffoo nntp-request-post (&optional server) - "Post the current buffer." - (nntp-possibly-change-server nil server) - (when (nntp-send-command "^[23].*\r?\n" "POST") - (nnheader-insert "") - (nntp-encode-text) - (nntp-send-region-to-server (point-min) (point-max)) - ;; 1.2a NNTP's post command is buggy. "^M" (\r) is not - ;; appended to end of the status message. - (nntp-wait-for-response "^[23].*\n"))) - -;;; Internal functions. +;;; Hooky functions. (defun nntp-send-mode-reader () "Send the MODE READER command to the nntp server. @@ -635,254 +530,565 @@ "Send the AUTHINFO to the nntp server. This function is supposed to be called from `nntp-server-opened-hook'. It will prompt for a password." - (nntp-send-command "^.*\r?\n" "AUTHINFO USER" - (read-string "NNTP user name: ")) - (nntp-send-command "^.*\r?\n" "AUTHINFO PASS" - (read-string "NNTP password: "))) + (nntp-send-command + "^.*\r?\n" "AUTHINFO USER" + (read-string (format "NNTP (%s) user name: " nntp-address))) + (nntp-send-command + "^.*\r?\n" "AUTHINFO PASS" + (nnmail-read-passwd "NNTP (%s) password: " nntp-address))) (defun nntp-send-authinfo () "Send the AUTHINFO to the nntp server. This function is supposed to be called from `nntp-server-opened-hook'. It will prompt for a password." (nntp-send-command "^.*\r?\n" "AUTHINFO USER" (user-login-name)) - (nntp-send-command "^.*\r?\n" "AUTHINFO PASS" - (read-string "NNTP password: "))) + (nntp-send-command + "^.*\r?\n" "AUTHINFO PASS" + (nnmail-read-passwd (format "NNTP (%s) password: " nntp-address)))) (defun nntp-send-authinfo-from-file () "Send the AUTHINFO to the nntp server. This function is supposed to be called from `nntp-server-opened-hook'. It will prompt for a password." (when (file-exists-p "~/.nntp-authinfo") - (save-excursion - (set-buffer (get-buffer-create " *authinfo*")) - (buffer-disable-undo (current-buffer)) - (erase-buffer) + (nnheader-temp-write nil (insert-file-contents "~/.nntp-authinfo") (goto-char (point-min)) (nntp-send-command "^.*\r?\n" "AUTHINFO USER" (user-login-name)) (nntp-send-command "^.*\r?\n" "AUTHINFO PASS" - (buffer-substring (point) (progn (end-of-line) (point)))) - (kill-buffer (current-buffer))))) + (buffer-substring (point) (progn (end-of-line) (point))))))) + +;;; Internal functions. + +(defun nntp-send-command (wait-for &rest strings) + "Send STRINGS to server and wait until WAIT-FOR returns." + (when (and (not nnheader-callback-function) + (not nntp-inhibit-output)) + (save-excursion + (set-buffer nntp-server-buffer) + (erase-buffer))) + (nntp-retrieve-data + (mapconcat 'identity strings " ") + nntp-address nntp-port-number nntp-server-buffer + wait-for nnheader-callback-function)) + +(defun nntp-send-command-nodelete (wait-for &rest strings) + "Send STRINGS to server and wait until WAIT-FOR returns." + (nntp-retrieve-data + (mapconcat 'identity strings " ") + nntp-address nntp-port-number nntp-server-buffer + wait-for nnheader-callback-function)) + +(defun nntp-send-command-and-decode (wait-for &rest strings) + "Send STRINGS to server and wait until WAIT-FOR returns." + (when (and (not nnheader-callback-function) + (not nntp-inhibit-output)) + (save-excursion + (set-buffer nntp-server-buffer) + (erase-buffer))) + (nntp-retrieve-data + (mapconcat 'identity strings " ") + nntp-address nntp-port-number nntp-server-buffer + wait-for nnheader-callback-function t)) + +(defun nntp-send-buffer (wait-for) + "Send the current buffer to server and wait until WAIT-FOR returns." + (when (and (not nnheader-callback-function) + (not nntp-inhibit-output)) + (save-excursion + (set-buffer (nntp-find-connection-buffer nntp-server-buffer)) + (erase-buffer))) + (nntp-encode-text) + (process-send-region (nntp-find-connection nntp-server-buffer) + (point-min) (point-max)) + (nntp-retrieve-data + nil nntp-address nntp-port-number nntp-server-buffer + wait-for nnheader-callback-function)) + +(defun nntp-find-connection (buffer) + "Find the connection delivering to BUFFER." + (let ((alist nntp-connection-alist) + (buffer (if (stringp buffer) (get-buffer buffer) buffer)) + process entry) + (while (setq entry (pop alist)) + (when (eq buffer (cadr entry)) + (setq process (car entry) + alist nil))) + (when process + (if (memq (process-status process) '(open run)) + process + (when (buffer-name (process-buffer process)) + (kill-buffer (process-buffer process))) + (setq nntp-connection-alist (delq entry nntp-connection-alist)) + nil)))) -(defun nntp-default-sentinel (proc status) - "Default sentinel function for NNTP server process." - (let ((servers (cddr (assq 'nntp nnoo-state-alist))) - server) - ;; Go through the alist of server names and find the name of the - ;; server that the process that sent the signal is connected to. - ;; If you get my drift. - (if (equal proc nntp-server-process) - (setq server nntp-address) - (while (and servers - (not (equal proc (cdr (assq 'nntp-server-process - (car servers)))))) - (setq servers (cdr servers))) - (setq server (caar servers))) - (when (and server - nntp-warn-about-losing-connection) - (nnheader-message 3 "nntp: Connection closed to server %s" server) - (setq nntp-current-group "") - (ding)))) +(defun nntp-find-connection-entry (buffer) + "Return the entry for the connection to BUFFER." + (assq (nntp-find-connection buffer) nntp-connection-alist)) + +(defun nntp-find-connection-buffer (buffer) + "Return the process connection buffer tied to BUFFER." + (let ((process (nntp-find-connection buffer))) + (when process + (process-buffer process)))) + +(defun nntp-make-process-buffer (buffer) + "Create a new, fresh buffer usable for nntp process connections." + (save-excursion + (set-buffer + (generate-new-buffer + (format " *server %s %s %s*" + nntp-address nntp-port-number + (buffer-name (get-buffer buffer))))) + (buffer-disable-undo (current-buffer)) + (set (make-local-variable 'after-change-functions) nil) + (set (make-local-variable 'nntp-process-wait-for) nil) + (set (make-local-variable 'nntp-process-callback) nil) + (set (make-local-variable 'nntp-process-to-buffer) nil) + (set (make-local-variable 'nntp-process-start-point) nil) + (set (make-local-variable 'nntp-process-decode) nil) + (current-buffer))) + +(defun nntp-open-connection (buffer) + "Open a connection to PORT on ADDRESS delivering output to BUFFER." + (run-hooks 'nntp-prepare-server-hook) + (let* ((pbuffer (nntp-make-process-buffer buffer)) + (process + (condition-case () + (funcall nntp-open-connection-function pbuffer) + (error nil) + (quit nil)))) + (when process + (process-kill-without-query process) + (nntp-wait-for process "^.*\n" buffer nil t) + (if (memq (process-status process) '(open run)) + (prog1 + (caar (push (list process buffer nil) nntp-connection-alist)) + (push process nntp-connection-list) + (save-excursion + (set-buffer pbuffer) + (nntp-read-server-type) + (erase-buffer) + (set-buffer nntp-server-buffer) + (let ((nnheader-callback-function nil)) + (run-hooks 'nntp-server-opened-hook)))) + (when (buffer-name (process-buffer process)) + (kill-buffer (process-buffer process))) + nil)))) + +(defun nntp-open-network-stream (buffer) + (open-network-stream "nntpd" buffer nntp-address nntp-port-number)) + +(defun nntp-read-server-type () + "Find out what the name of the server we have connected to is." + ;; Wait for the status string to arrive. + (setq nntp-server-type (buffer-string)) + (let ((alist nntp-server-action-alist) + (case-fold-search t) + entry) + ;; Run server-specific commands. + (while alist + (setq entry (pop alist)) + (when (string-match (car entry) nntp-server-type) + (if (and (listp (cadr entry)) + (not (eq 'lambda (caadr entry)))) + (eval (cadr entry)) + (funcall (cadr entry))))))) -(defun nntp-kill-connection (server) - "Choke the connection to SERVER." - (let ((proc (cdr (assq 'nntp-server-process - (assoc server (cddr - (assq 'nntp nnoo-state-alist))))))) - (when proc - (delete-process (process-name proc))) - (nntp-close-server server) - (nnheader-report - 'nntp (message "Connection timed out to server %s" server)) - (ding) - (sit-for 1))) +(defun nntp-after-change-function-callback (beg end len) + (when nntp-process-callback + (save-match-data + (if (and (= beg (point-min)) + (memq (char-after beg) '(?4 ?5))) + ;; Report back error messages. + (save-excursion + (goto-char beg) + (if (looking-at "480") + (funcall nntp-authinfo-function) + (nntp-snarf-error-message) + (funcall nntp-process-callback nil))) + (goto-char end) + (when (and (> (point) nntp-process-start-point) + (re-search-backward nntp-process-wait-for + nntp-process-start-point t)) + (when (buffer-name (get-buffer nntp-process-to-buffer)) + (let ((cur (current-buffer)) + (start nntp-process-start-point)) + (save-excursion + (set-buffer (get-buffer nntp-process-to-buffer)) + (goto-char (point-max)) + (let ((b (point))) + (insert-buffer-substring cur start) + (narrow-to-region b (point-max)) + (nntp-decode-text) + (widen))))) + (goto-char end) + (let ((callback nntp-process-callback) + (nntp-inside-change-function t)) + (setq nntp-process-callback nil) + (save-excursion + (funcall callback (buffer-name + (get-buffer nntp-process-to-buffer)))))))))) -;; Encoding and decoding of NNTP text. +(defun nntp-retrieve-data (command address port buffer + &optional wait-for callback decode) + "Use COMMAND to retrieve data into BUFFER from PORT on ADDRESS." + (let ((process (or (nntp-find-connection buffer) + (nntp-open-connection buffer)))) + (if (not process) + (nnheader-report 'nntp "Couldn't open connection to %s" address) + (unless (or nntp-inhibit-erase nnheader-callback-function) + (save-excursion + (set-buffer (process-buffer process)) + (erase-buffer))) + (when command + (nntp-send-string process command)) + (cond + ((eq callback 'ignore) + t) + ((and callback wait-for) + (save-excursion + (set-buffer (process-buffer process)) + (unless nntp-inside-change-function + (erase-buffer)) + (setq nntp-process-decode decode + nntp-process-to-buffer buffer + nntp-process-wait-for wait-for + nntp-process-callback callback + nntp-process-start-point (point-max) + after-change-functions + (list 'nntp-after-change-function-callback))) + t) + (wait-for + (nntp-wait-for process wait-for buffer decode)) + (t t))))) + +(defun nntp-send-string (process string) + "Send STRING to PROCESS." + (process-send-string process (concat string nntp-end-of-line))) -(defun nntp-decode-text () - "Decode text transmitted by NNTP. -0. Delete status line. -1. Delete `^M' at end of line. -2. Delete `.' at end of buffer (end of text mark). -3. Delete `.' at beginning of line." +(defun nntp-wait-for (process wait-for buffer &optional decode discard) + "Wait for WAIT-FOR to arrive from PROCESS." (save-excursion - (set-buffer nntp-server-buffer) - ;; Insert newline at end of buffer. - (goto-char (point-max)) - (or (bolp) (insert "\n")) - ;; Delete status line. - (delete-region (goto-char (point-min)) (progn (forward-line 1) (point))) - ;; Delete `^M's. - (while (search-forward "\r" nil t) - (replace-match "" t t)) - ;; Delete `.' at end of the buffer (end of text mark). + (set-buffer (process-buffer process)) + (goto-char (point-min)) + (while (or (not (memq (following-char) '(?2 ?3 ?4 ?5))) + (looking-at "480")) + (when (looking-at "480") + (erase-buffer) + (funcall nntp-authinfo-function)) + (nntp-accept-process-output process) + (goto-char (point-min))) + (prog1 + (if (looking-at "[45]") + (progn + (nntp-snarf-error-message) + nil) + (goto-char (point-max)) + (let ((limit (point-min))) + (while (not (re-search-backward wait-for limit t)) + ;; We assume that whatever we wait for is less than 1000 + ;; characters long. + (setq limit (max (- (point-max) 1000) (point-min))) + (nntp-accept-process-output process) + (goto-char (point-max)))) + (nntp-decode-text (not decode)) + (unless discard + (save-excursion + (set-buffer buffer) + (goto-char (point-max)) + (insert-buffer-substring (process-buffer process)) + ;; Nix out "nntp reading...." message. + (when nntp-have-messaged + (setq nntp-have-messaged nil) + (message "")) + t))) + (unless discard + (erase-buffer))))) + +(defun nntp-snarf-error-message () + "Save the error message in the current buffer." + (let ((message (buffer-string))) + (while (string-match "[\r\n]+" message) + (setq message (replace-match " " t t message))) + (nnheader-report 'nntp message) + message)) + +(defun nntp-accept-process-output (process) + "Wait for output from PROCESS and message some dots." + (save-excursion + (set-buffer (or (nntp-find-connection-buffer nntp-server-buffer) + nntp-server-buffer)) + (let ((len (/ (point-max) 1024))) + (unless (< len 10) + (setq nntp-have-messaged t) + (nnheader-message 7 "nntp read: %dk" len))) + (accept-process-output process 1))) + +(defun nntp-accept-response () + "Wait for output from the process that outputs to BUFFER." + (nntp-accept-process-output (nntp-find-connection nntp-server-buffer))) + +(defun nntp-possibly-change-group (group server &optional connectionless) + (let ((nnheader-callback-function nil)) + (when server + (or (nntp-server-opened server) + (nntp-open-server server nil connectionless))) + + (unless connectionless + (or (nntp-find-connection nntp-server-buffer) + (nntp-open-connection nntp-server-buffer)))) + + (when group + (let ((entry (nntp-find-connection-entry nntp-server-buffer))) + (when (not (equal group (caddr entry))) + (save-excursion + (set-buffer (process-buffer (car entry))) + (erase-buffer) + (nntp-send-string (car entry) (concat "GROUP " group)) + (nntp-wait-for-string "^2.*\n") + (setcar (cddr entry) group) + (erase-buffer)))))) + +(defun nntp-decode-text (&optional cr-only) + "Decode the text in the current buffer." + (goto-char (point-min)) + (while (search-forward "\r" nil t) + (delete-char -1)) + (unless cr-only + ;; Remove trailing ".\n" end-of-transfer marker. (goto-char (point-max)) (forward-line -1) - (when (looking-at "^\\.\n") - (delete-region (point) (progn (forward-line 1) (point)))) - ;; Replace `..' at beginning of line with `.'. + (when (looking-at ".\n") + (delete-char 2)) + ;; Delete status line. (goto-char (point-min)) - ;; (replace-regexp "^\\.\\." ".") + (delete-region (point) (progn (forward-line 1) (point))) + ;; Remove "." -> ".." encoding. (while (search-forward "\n.." nil t) (delete-char -1)))) (defun nntp-encode-text () - "Encode text in current buffer for NNTP transmission. -1. Insert `.' at beginning of line. -2. Insert `.' at end of buffer (end of text mark)." + "Encode the text in the current buffer." (save-excursion - ;; Replace `.' at beginning of line with `..'. + ;; Replace "." at beginning of line with "..". (goto-char (point-min)) (while (re-search-forward "^\\." nil t) (insert ".")) (goto-char (point-max)) - ;; Insert newline at end of buffer. - (or (bolp) (insert "\n")) - ;(goto-char (point-min)) - ;(while (not (eobp)) - ; (end-of-line) - ; (insert "\r") - ; (forward-line 1)) + ;; Insert newline at the end of the buffer. + (unless (bolp) + (insert "\n")) ;; Insert `.' at end of buffer (end of text mark). (goto-char (point-max)) (insert "." nntp-end-of-line))) +(defun nntp-retrieve-headers-with-xover (articles &optional fetch-old) + (set-buffer nntp-server-buffer) + (erase-buffer) + (cond - -;;; -;;; Synchronous Communication with NNTP servers. -;;; - -(defvar nntp-retry-command) + ;; This server does not talk NOV. + ((not nntp-server-xover) + nil) -(defun nntp-send-command (response cmd &rest args) - "Wait for server RESPONSE after sending CMD and optional ARGS to server." - (let ((timer - (and nntp-command-timeout - (nnheader-run-at-time - nntp-command-timeout nil 'nntp-kill-command - (nnoo-current-server 'nntp)))) - (nntp-retry-command t) - result) - (unwind-protect - (save-excursion - (while nntp-retry-command - (setq nntp-retry-command nil) - ;; Clear communication buffer. - (set-buffer nntp-server-buffer) - (widen) - (erase-buffer) - (if nntp-retry-on-break - (condition-case () - (progn - (apply 'nntp-send-strings-to-server cmd args) - (setq result - (if response - (nntp-wait-for-response response) - t))) - (quit (setq nntp-retry-command t))) - (apply 'nntp-send-strings-to-server cmd args) - (setq result - (if response - (nntp-wait-for-response response) - t)))) - result) - (when timer - (nnheader-cancel-timer timer))))) + ;; We don't care about gaps. + ((or (not nntp-nov-gap) + fetch-old) + (nntp-send-xover-command + (if fetch-old + (if (numberp fetch-old) + (max 1 (- (car articles) fetch-old)) + 1) + (car articles)) + (car (last articles)) 'wait) -(defun nntp-kill-command (server) - "Kill and restart the connection to SERVER." - (let ((proc (cdr (assq - 'nntp-server-process - (assoc server (cddr (assq 'nntp nnoo-state-alist))))))) - (when proc - (delete-process (process-name proc))) - (nntp-close-server server) - (nntp-open-server server) - (when nntp-current-group - (nntp-request-group nntp-current-group)) - (setq nntp-retry-command t))) + (goto-char (point-min)) + (when (looking-at "[1-5][0-9][0-9] ") + (delete-region (point) (progn (forward-line 1) (point)))) + (while (search-forward "\r" nil t) + (replace-match "" t t)) + (goto-char (point-max)) + (forward-line -1) + (when (looking-at "\\.") + (delete-region (point) (progn (forward-line 1) (point))))) -(defun nntp-send-command-old (response cmd &rest args) - "Wait for server RESPONSE after sending CMD and optional ARGS to server." - (save-excursion - ;; Clear communication buffer. - (set-buffer nntp-server-buffer) - (erase-buffer) - (apply 'nntp-send-strings-to-server cmd args) - (if response - (nntp-wait-for-response response) - t))) + ;; We do it the hard way. For each gap, an XOVER command is sent + ;; to the server. We do not wait for a reply from the server, we + ;; just send them off as fast as we can. That means that we have + ;; to count the number of responses we get back to find out when we + ;; have gotten all we asked for. + ((numberp nntp-nov-gap) + (let ((count 0) + (received 0) + (last-point (point-min)) + (buf nntp-server-buffer) + ;;(process-buffer (nntp-find-connection (current-buffer)))) + first) + ;; We have to check `nntp-server-xover'. If it gets set to nil, + ;; that means that the server does not understand XOVER, but we + ;; won't know that until we try. + (while (and nntp-server-xover articles) + (setq first (car articles)) + ;; Search forward until we find a gap, or until we run out of + ;; articles. + (while (and (cdr articles) + (< (- (nth 1 articles) (car articles)) nntp-nov-gap)) + (setq articles (cdr articles))) + + (when (nntp-send-xover-command first (car articles)) + (setq articles (cdr articles) + count (1+ count)) -(defun nntp-wait-for-response (regexp &optional slow) - "Wait for server response which matches REGEXP." - (save-excursion - (let ((status t) - (wait t) - (dotnum 0) ;Number of "." being displayed. - (dotsize ;How often "." displayed. - (if (numberp nntp-debug-read) nntp-debug-read 10000))) - (set-buffer nntp-server-buffer) - ;; Wait for status response (RFC977). - ;; 1xx - Informative message. - ;; 2xx - Command ok. - ;; 3xx - Command ok so far, send the rest of it. - ;; 4xx - Command was correct, but couldn't be performed for some - ;; reason. - ;; 5xx - Command unimplemented, or incorrect, or a serious - ;; program error occurred. - (nntp-accept-response) - (while wait + ;; Every 400 requests we have to read the stream in + ;; order to avoid deadlocks. + (when (or (null articles) ;All requests have been sent. + (zerop (% count nntp-maximum-request))) + (accept-process-output) + ;; On some Emacs versions the preceding function has + ;; a tendency to change the buffer. Perhaps. It's + ;; quite difficult to reproduce, because it only + ;; seems to happen once in a blue moon. + (set-buffer buf) + (while (progn + (goto-char last-point) + ;; Count replies. + (while (re-search-forward "^[0-9][0-9][0-9] " nil t) + (setq received (1+ received))) + (setq last-point (point)) + (< received count)) + (accept-process-output) + (set-buffer buf))))) + + (when nntp-server-xover + ;; Wait for the reply from the final command. + (goto-char (point-max)) + (re-search-backward "^[0-9][0-9][0-9] " nil t) + (when (looking-at "^[23]") + (while (progn + (goto-char (point-max)) + (forward-line -1) + (not (looking-at "^\\.\r?\n"))) + (nntp-accept-response))) + + ;; We remove any "." lines and status lines. (goto-char (point-min)) - (if slow - (progn - (cond ((re-search-forward "^[23][0-9][0-9]" nil t) - (setq wait nil)) - ((re-search-forward "^[45][0-9][0-9]" nil t) - (setq status nil) - (setq wait nil)) - (t (nntp-accept-response))) - (if (not wait) (delete-region (point-min) - (progn (beginning-of-line) - (point))))) - (cond ((looking-at "[23]") - (setq wait nil)) - ((looking-at "[45]") - (setq status nil) - (setq wait nil)) - (t (nntp-accept-response))))) - ;; Save status message. - (end-of-line) - (setq nntp-status-string - (nnheader-replace-chars-in-string - (buffer-substring (point-min) (point)) ?\r ? )) - (when status - (setq wait t) - (while wait - (goto-char (point-max)) - (if (bolp) (forward-line -1) (beginning-of-line)) - (if (looking-at regexp) - (setq wait nil) - (when nntp-debug-read - (let ((newnum (/ (buffer-size) dotsize)) - (message-log-max nil)) - (unless (= dotnum newnum) - (setq dotnum newnum) - (nnheader-message 7 "NNTP: Reading %s" - (make-string dotnum ?.))))) - (nntp-accept-response))) - ;; Remove "...". - (when (and nntp-debug-read (> dotnum 0)) - (message "")) - ;; Successfully received server response. + (while (search-forward "\r" nil t) + (delete-char -1)) + (goto-char (point-min)) + (delete-matching-lines "^\\.$\\|^[1-5][0-9][0-9] ") + ;;(copy-to-buffer nntp-server-buffer (point-min) (point-max)) t)))) - + nntp-server-xover) + +(defun nntp-send-xover-command (beg end &optional wait-for-reply) + "Send the XOVER command to the server." + (let ((range (format "%d-%d" beg end)) + (nntp-inhibit-erase t)) + (if (stringp nntp-server-xover) + ;; If `nntp-server-xover' is a string, then we just send this + ;; command. + (if wait-for-reply + (nntp-send-command-nodelete + "\r?\n\\.\r?\n" nntp-server-xover range) + ;; We do not wait for the reply. + (nntp-send-command-nodelete "\r?\n\\.\r?\n" nntp-server-xover range)) + (let ((commands nntp-xover-commands)) + ;; `nntp-xover-commands' is a list of possible XOVER commands. + ;; We try them all until we get at positive response. + (while (and commands (eq nntp-server-xover 'try)) + (nntp-send-command-nodelete "\r?\n\\.\r?\n" (car commands) range) + (save-excursion + (set-buffer nntp-server-buffer) + (goto-char (point-min)) + (and (looking-at "[23]") ; No error message. + ;; We also have to look at the lines. Some buggy + ;; servers give back simple lines with just the + ;; article number. How... helpful. + (progn + (forward-line 1) + (looking-at "[0-9]+\t...")) ; More text after number. + (setq nntp-server-xover (car commands)))) + (setq commands (cdr commands))) + ;; If none of the commands worked, we disable XOVER. + (when (eq nntp-server-xover 'try) + (save-excursion + (set-buffer nntp-server-buffer) + (erase-buffer) + (setq nntp-server-xover nil))) + nntp-server-xover)))) + +;;; Alternative connection methods. + +(defun nntp-wait-for-string (regexp) + "Wait until string arrives in the buffer." + (let ((buf (current-buffer))) + (goto-char (point-min)) + (while (not (re-search-forward regexp nil t)) + (accept-process-output (nntp-find-connection nntp-server-buffer)) + (set-buffer buf) + (goto-char (point-min))))) -;;; -;;; Low-Level Interface to NNTP Server. -;;; +(defun nntp-open-telnet (buffer) + (save-excursion + (set-buffer buffer) + (erase-buffer) + (let ((proc (start-process + "nntpd" buffer "telnet" "-8")) + (case-fold-search t)) + (when (memq (process-status proc) '(open run)) + (process-send-string proc "set escape \^X\n") + (process-send-string proc (concat "open " nntp-address "\n")) + (nntp-wait-for-string "^\r*.?login:") + (process-send-string + proc (concat + (or nntp-telnet-user-name + (setq nntp-telnet-user-name (read-string "login: "))) + "\n")) + (nntp-wait-for-string "^\r*.?password:") + (process-send-string + proc (concat + (or nntp-telnet-passwd + (setq nntp-telnet-passwd + (nnmail-read-passwd "Password: "))) + "\n")) + (erase-buffer) + (nntp-wait-for-string "bash\\|\$ *\r?$\\|> *\r?") + (process-send-string + proc (concat (mapconcat 'identity nntp-telnet-parameters " ") "\n")) + (nntp-wait-for-string "^\r*200") + (beginning-of-line) + (delete-region (point-min) (point)) + (process-send-string proc "\^]") + (nntp-wait-for-string "^telnet") + (process-send-string proc "mode character\n") + (accept-process-output proc 1) + (sit-for 1) + (goto-char (point-min)) + (forward-line 1) + (delete-region (point) (point-max))) + proc))) + +(defun nntp-open-rlogin (buffer) + "Open a connection to SERVER using rsh." + (let ((proc (if nntp-rlogin-user-name + (start-process + "nntpd" buffer "rsh" + nntp-address "-l" nntp-rlogin-user-name + (mapconcat 'identity + nntp-rlogin-parameters " ")) + (start-process + "nntpd" buffer "rsh" nntp-address + (mapconcat 'identity + nntp-rlogin-parameters " "))))) + (set-buffer buffer) + (nntp-wait-for-string "^\r*200") + (beginning-of-line) + (delete-region (point-min) (point)) + proc) + ) (defun nntp-find-group-and-number () (save-excursion @@ -919,471 +1125,10 @@ (string-match (format "\\([^ :]+\\):%d" number) xref)) (substring xref (match-beginning 1) (match-end 1))) (t ""))) - (when (string-match "\r" group) + (when (string-match "\r" group) (setq group (substring group 0 (match-beginning 0)))) (cons group number))))) -(defun nntp-retrieve-headers-with-xover (articles &optional fetch-old) - (erase-buffer) - (cond - - ;; This server does not talk NOV. - ((not nntp-server-xover) - nil) - - ;; We don't care about gaps. - ((or (not nntp-nov-gap) - fetch-old) - (nntp-send-xover-command - (if fetch-old - (if (numberp fetch-old) - (max 1 (- (car articles) fetch-old)) - 1) - (car articles)) - (nntp-last-element articles) 'wait) - - (goto-char (point-min)) - (when (looking-at "[1-5][0-9][0-9] ") - (delete-region (point) (progn (forward-line 1) (point)))) - (while (search-forward "\r" nil t) - (replace-match "" t t)) - (goto-char (point-max)) - (forward-line -1) - (when (looking-at "\\.") - (delete-region (point) (progn (forward-line 1) (point))))) - - ;; We do it the hard way. For each gap, an XOVER command is sent - ;; to the server. We do not wait for a reply from the server, we - ;; just send them off as fast as we can. That means that we have - ;; to count the number of responses we get back to find out when we - ;; have gotten all we asked for. - ((numberp nntp-nov-gap) - (let ((count 0) - (received 0) - (last-point (point-min)) - (buf (current-buffer)) - first) - ;; We have to check `nntp-server-xover'. If it gets set to nil, - ;; that means that the server does not understand XOVER, but we - ;; won't know that until we try. - (while (and nntp-server-xover articles) - (setq first (car articles)) - ;; Search forward until we find a gap, or until we run out of - ;; articles. - (while (and (cdr articles) - (< (- (nth 1 articles) (car articles)) nntp-nov-gap)) - (setq articles (cdr articles))) - - (when (nntp-send-xover-command first (car articles)) - (setq articles (cdr articles) - count (1+ count)) - - ;; Every 400 requests we have to read the stream in - ;; order to avoid deadlocks. - (when (or (null articles) ;All requests have been sent. - (zerop (% count nntp-maximum-request))) - (accept-process-output nntp-server-process 1) - ;; On some Emacs versions the preceding function has - ;; a tendency to change the buffer. Perhaps. It's - ;; quite difficult to reproduce, because it only - ;; seems to happen once in a blue moon. - (set-buffer buf) - (while (progn - (goto-char last-point) - ;; Count replies. - (while (re-search-forward "^[0-9][0-9][0-9] " nil t) - (setq received (1+ received))) - (setq last-point (point)) - (< received count)) - (accept-process-output nntp-server-process) - (set-buffer buf))))) - - (when nntp-server-xover - ;; Wait for the reply from the final command. - (goto-char (point-max)) - (re-search-backward "^[0-9][0-9][0-9] " nil t) - (when (looking-at "^[23]") - (while (progn - (goto-char (point-max)) - (forward-line -1) - (not (looking-at "^\\.\r?\n"))) - (nntp-accept-response))) - - ;; We remove any "." lines and status lines. - (goto-char (point-min)) - (while (search-forward "\r" nil t) - (delete-char -1)) - (goto-char (point-min)) - (delete-matching-lines "^\\.$\\|^[1-5][0-9][0-9] "))))) - - nntp-server-xover) - -(defun nntp-send-xover-command (beg end &optional wait-for-reply) - "Send the XOVER command to the server." - (let ((range (format "%d-%d" (or beg 1) (or end beg 1)))) - (if (stringp nntp-server-xover) - ;; If `nntp-server-xover' is a string, then we just send this - ;; command. - (if wait-for-reply - (nntp-send-command "^\\.\r?\n" nntp-server-xover range) - ;; We do not wait for the reply. - (nntp-send-strings-to-server nntp-server-xover range)) - (let ((commands nntp-xover-commands)) - ;; `nntp-xover-commands' is a list of possible XOVER commands. - ;; We try them all until we get at positive response. - (while (and commands (eq nntp-server-xover 'try)) - (nntp-send-command "^\\.\r?\n" (car commands) range) - (save-excursion - (set-buffer nntp-server-buffer) - (goto-char (point-min)) - (and (looking-at "[23]") ; No error message. - ;; We also have to look at the lines. Some buggy - ;; servers give back simple lines with just the - ;; article number. How... helpful. - (progn - (forward-line 1) - (looking-at "[0-9]+\t...")) ; More text after number. - (setq nntp-server-xover (car commands)))) - (setq commands (cdr commands))) - ;; If none of the commands worked, we disable XOVER. - (when (eq nntp-server-xover 'try) - (save-excursion - (set-buffer nntp-server-buffer) - (erase-buffer) - (setq nntp-server-xover nil))) - nntp-server-xover)))) - -(defun nntp-send-strings-to-server (&rest strings) - "Send STRINGS to the server." - (let ((cmd (concat (mapconcat 'identity strings " ") nntp-end-of-line))) - ;; We open the nntp server if it is down. - (or (nntp-server-opened (nnoo-current-server 'nntp)) - (nntp-open-server (nnoo-current-server 'nntp)) - (error "Couldn't open server: " (nntp-status-message))) - ;; Send the strings. - (process-send-string nntp-server-process cmd) - t)) - -(defun nntp-send-region-to-server (begin end) - "Send the current buffer region (from BEGIN to END) to the server." - (save-excursion - (let ((cur (current-buffer))) - ;; Copy the buffer over to the send buffer. - (nnheader-set-temp-buffer " *nntp send*") - (insert-buffer-substring cur begin end) - (save-excursion - (set-buffer cur) - (erase-buffer)) - ;; `process-send-region' does not work if the text to be sent is very - ;; large, so we send it piecemeal. - (let ((last (point-min)) - (size 100)) ;Size of text sent at once. - (while (and (/= last (point-max)) - (memq (process-status nntp-server-process) '(open run))) - (process-send-region - nntp-server-process - last (setq last (min (+ last size) (point-max)))) - ;; Read any output from the server. May be unnecessary. - (accept-process-output))) - (kill-buffer (current-buffer))))) - -(defun nntp-open-server-semi-internal (server &optional service) - "Open SERVER. -If SERVER is nil, use value of environment variable `NNTPSERVER'. -If SERVICE, use this as the port number." - (nnheader-insert "") - (let ((server (or server (getenv "NNTPSERVER"))) - (status nil) - (timer - (and nntp-connection-timeout - (nnheader-run-at-time nntp-connection-timeout - nil 'nntp-kill-connection server)))) - (save-excursion - (set-buffer nntp-server-buffer) - (setq nntp-status-string "") - (nnheader-message 5 "nntp: Connecting to server on %s..." nntp-address) - (cond ((and server (nntp-open-server-internal server service)) - (setq nntp-address server) - (setq status - (condition-case nil - (nntp-wait-for-response "^[23].*\r?\n" 'slow) - (error nil) - ;(quit nil) - )) - (unless status - (nntp-close-server-internal server) - (nnheader-report - 'nntp "Couldn't open connection to %s" - (if (and nntp-address - (not (equal nntp-address ""))) - nntp-address server))) - (when nntp-server-process - (set-process-sentinel - nntp-server-process 'nntp-default-sentinel) - ;; You can send commands at startup like AUTHINFO here. - ;; Added by Hallvard B Furuseth - (run-hooks 'nntp-server-opened-hook))) - ((null server) - (nnheader-report 'nntp "NNTP server is not specified.")) - (t ; We couldn't open the server. - (nnheader-report 'nntp (buffer-string)))) - (when timer - (nnheader-cancel-timer timer)) - (message "") - (unless status - (nnoo-close-server 'nntp server) - (setq nntp-async-number nil)) - status))) - -(defvar nntp-default-directories '("~" "/tmp" "/") - "Directories to as current directory in the nntp server buffer.") - -(defun nntp-open-server-internal (server &optional service) - "Open connection to news server on SERVER by SERVICE (default is nntp)." - (let (proc) - (save-excursion - (set-buffer nntp-server-buffer) - ;; Make sure we have a valid current directory for the - ;; nntp server buffer. - (unless (file-exists-p default-directory) - (let ((dirs nntp-default-directories)) - (while dirs - (when (file-exists-p (car dirs)) - (setq default-directory (car dirs) - dirs nil)) - (setq dirs (cdr dirs))))) - (cond - ((and (setq proc - (condition-case nil - (funcall nntp-open-server-function server) - (error nil))) - (memq (process-status proc) '(open run))) - (setq nntp-server-process proc) - (setq nntp-address server) - ;; Suggested by Hallvard B Furuseth . - (process-kill-without-query proc) - (run-hooks 'nntp-server-hook) - (push proc nntp-opened-connections) - (condition-case () - (nntp-read-server-type) - (error - (nnheader-report 'nntp "Couldn't open server %s" server) - (nntp-close-server))) - nntp-server-process) - (t - (nnheader-report 'nntp "Couldn't open server %s" server)))))) - -(defun nntp-read-server-type () - "Find out what the name of the server we have connected to is." - ;; Wait for the status string to arrive. - (nntp-wait-for-response "^.*\n" t) - (setq nntp-server-type (buffer-string)) - (let ((alist nntp-server-action-alist) - entry) - ;; Run server-specific commmands. - (while alist - (setq entry (pop alist)) - (when (string-match (car entry) nntp-server-type) - (if (and (listp (cadr entry)) - (not (eq 'lambda (caadr entry)))) - (eval (cadr entry)) - (funcall (cadr entry))))))) - -(defun nntp-open-network-stream (server) - (open-network-stream - "nntpd" nntp-server-buffer server nntp-port-number)) - -(defun nntp-open-rlogin (server) - "Open a connection to SERVER using rsh." - (let ((proc (if nntp-rlogin-user-name - (start-process - "nntpd" nntp-server-buffer "rsh" - server "-l" nntp-rlogin-user-name - (mapconcat 'identity - nntp-rlogin-parameters " ")) - (start-process - "nntpd" nntp-server-buffer "rsh" server - (mapconcat 'identity - nntp-rlogin-parameters " "))))) - proc)) - -(defun nntp-wait-for-string (regexp) - "Wait until string arrives in the buffer." - (let ((buf (current-buffer))) - (goto-char (point-min)) - (while (not (re-search-forward regexp nil t)) - (accept-process-output nntp-server-process) - (set-buffer buf) - (goto-char (point-min))))) - -(defun nntp-open-telnet (server) - (save-excursion - (set-buffer nntp-server-buffer) - (erase-buffer) - (let ((proc (start-process - "nntpd" nntp-server-buffer "telnet" "-8")) - (case-fold-search t)) - (when (memq (process-status proc) '(open run)) - (process-send-string proc "set escape \^X\n") - (process-send-string proc (concat "open " server "\n")) - (nntp-wait-for-string "^\r*.?login:") - (process-send-string - proc (concat - (or nntp-telnet-user-name - (setq nntp-telnet-user-name (read-string "login: "))) - "\n")) - (nntp-wait-for-string "^\r*.?password:") - (process-send-string - proc (concat - (or nntp-telnet-passwd - (setq nntp-telnet-passwd - (nnmail-read-passwd "Password: "))) - "\n")) - (erase-buffer) - (nntp-wait-for-string "bash\\|\$ *\r?$\\|> *\r?") - (process-send-string - proc (concat (mapconcat 'identity nntp-telnet-parameters " ") "\n")) - (nntp-wait-for-string "^\r*200") - (beginning-of-line) - (delete-region (point-min) (point)) - (process-send-string proc "\^]") - (nntp-wait-for-string "^telnet") - (process-send-string proc "mode character\n") - (accept-process-output proc 1) - (sit-for 1) - (goto-char (point-min)) - (forward-line 1) - (delete-region (point) (point-max))) - proc))) - -(defun nntp-close-server-internal (&optional server) - "Close connection to news server." - (nntp-possibly-change-server nil server) - (if nntp-server-process - (delete-process nntp-server-process)) - (setq nntp-server-process nil) - ;(setq nntp-address "") - ) - -(defun nntp-accept-response () - "Read response of server. -It is well-known that the communication speed will be much improved by -defining this function as macro." - ;; To deal with server process exiting before - ;; accept-process-output is called. - ;; Suggested by Jason Venner . - ;; This is a copy of `nntp-default-sentinel'. - (let ((buf (current-buffer))) - (prog1 - (if (or (not nntp-server-process) - (not (memq (process-status nntp-server-process) '(open run)))) - (error "nntp: Process connection closed; %s" (nntp-status-message)) - (if nntp-buggy-select - (progn - ;; We cannot use `accept-process-output'. - ;; Fujitsu UTS requires messages during sleep-for. - ;; I don't know why. - (nnheader-message 5 "NNTP: Reading...") - (sleep-for 1) - (nnheader-message 5 "")) - (condition-case errorcode - (accept-process-output nntp-server-process 1) - (error - (cond ((string-equal "select error: Invalid argument" - (nth 1 errorcode)) - ;; Ignore select error. - nil) - (t - (signal (car errorcode) (cdr errorcode)))))))) - (set-buffer buf)))) - -(defun nntp-last-element (list) - "Return last element of LIST." - (while (cdr list) - (setq list (cdr list))) - (car list)) - -(defun nntp-possibly-change-server (newsgroup server &optional connectionless) - "Check whether the virtual server needs changing." - (when (and server - (not (nntp-server-opened server))) - ;; This virtual server isn't open, so we (re)open it here. - (nntp-open-server server nil t)) - (when (and newsgroup - (not (equal newsgroup nntp-current-group))) - ;; Set the proper current group. - (nntp-request-group newsgroup server))) - -(defun nntp-try-list-active (group) - (nntp-list-active-group group) - (save-excursion - (set-buffer nntp-server-buffer) - (goto-char (point-min)) - (cond ((looking-at "5[0-9]+") - (setq nntp-server-list-active-group nil)) - (t - (setq nntp-server-list-active-group t))))) - -(defun nntp-async-server-opened () - (and nntp-async-process - (memq (process-status nntp-async-process) '(open run)))) - -(defun nntp-async-open-server () - (save-excursion - (set-buffer (generate-new-buffer " *async-nntp*")) - (setq nntp-async-buffer (current-buffer)) - (buffer-disable-undo (current-buffer))) - (let ((nntp-server-process nil) - (nntp-server-buffer nntp-async-buffer)) - (nntp-open-server-semi-internal nntp-address nntp-port-number) - (if (not (setq nntp-async-process nntp-server-process)) - (progn - (setq nntp-async-number nil)) - (set-process-buffer nntp-async-process nntp-async-buffer)))) - -(defun nntp-async-fetch-articles (article) - (if (stringp article) - () - (let ((articles (cdr (memq (assq article nntp-async-articles) - nntp-async-articles))) - (max (cond ((numberp nntp-async-number) - nntp-async-number) - ((eq nntp-async-number t) - (length nntp-async-articles)) - (t 0))) - nart) - (while (and (>= (setq max (1- max)) 0) - articles) - (or (memq (setq nart (caar articles)) nntp-async-fetched) - (progn - (nntp-async-send-strings "ARTICLE " (int-to-string nart)) - (setq nntp-async-fetched (cons nart nntp-async-fetched)))) - (setq articles (cdr articles)))))) - -(defun nntp-async-send-strings (&rest strings) - (let ((cmd (concat (mapconcat 'identity strings " ") nntp-end-of-line))) - (or (nntp-async-server-opened) - (nntp-async-open-server) - (error (nntp-status-message))) - (process-send-string nntp-async-process cmd))) - -(defun nntp-async-request-group (group) - (if (equal group nntp-current-group) - () - (let ((asyncs (assoc group nntp-async-group-alist))) - ;; A new group has been selected, so we push the current state - ;; of async articles on an alist, and pull the old state off. - (setq nntp-async-group-alist - (cons (list nntp-current-group - nntp-async-articles nntp-async-fetched - nntp-async-process) - (delq asyncs nntp-async-group-alist))) - (and asyncs - (progn - (setq nntp-async-articles (nth 1 asyncs)) - (setq nntp-async-fetched (nth 2 asyncs)) - (setq nntp-async-process (nth 3 asyncs))))))) - (provide 'nntp) ;;; nntp.el ends here diff -r ad457d5f7d04 -r 0293115a14e9 lisp/gnus/nnvirtual.el --- a/lisp/gnus/nnvirtual.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/gnus/nnvirtual.el Mon Aug 13 08:49:20 2007 +0200 @@ -1,7 +1,8 @@ ;;; nnvirtual.el --- virtual newsgroups access for Gnus -;; Copyright (C) 1994,95,96 Free Software Foundation, Inc. +;; Copyright (C) 1994,95,96,97 Free Software Foundation, Inc. -;; Author: Lars Magne Ingebrigtsen +;; Author: David Moore +;; Lars Magne Ingebrigtsen ;; Masanobu UMEDA ;; Keywords: news @@ -25,7 +26,7 @@ ;;; Commentary: ;; The other access methods (nntp, nnspool, etc) are general news -;; access methods. This module relies on Gnus and can not be used +;; access methods. This module relies on Gnus and can not be used ;; separately. ;;; Code: @@ -34,6 +35,9 @@ (require 'nnheader) (require 'gnus) (require 'nnoo) +(require 'gnus-util) +(require 'gnus-start) +(require 'gnus-sum) (eval-when-compile (require 'cl)) (nnoo-declare nnvirtual) @@ -48,13 +52,33 @@ (defvoo nnvirtual-component-regexp nil "*Regexp to match component groups.") +(defvoo nnvirtual-component-groups nil + "Component group in this nnvirtual group.") + -(defconst nnvirtual-version "nnvirtual 1.0") +(defconst nnvirtual-version "nnvirtual 1.1") (defvoo nnvirtual-current-group nil) -(defvoo nnvirtual-component-groups nil) -(defvoo nnvirtual-mapping nil) + +(defvoo nnvirtual-mapping-table nil + "Table of rules on how to map between component group and article number +to virtual article number.") + +(defvoo nnvirtual-mapping-offsets nil + "Table indexed by component group to an offset to be applied to article numbers in that group.") + +(defvoo nnvirtual-mapping-len 0 + "Number of articles in this virtual group.") + +(defvoo nnvirtual-mapping-reads nil + "Compressed sequence of read articles on the virtual group as computed from the unread status of individual component groups.") + +(defvoo nnvirtual-mapping-marks nil + "Compressed marks alist for the virtual group as computed from the marks of individual component groups.") + +(defvoo nnvirtual-info-installed nil + "T if we have already installed the group info for this group, and shouldn't blast over it again.") (defvoo nnvirtual-status-string "") @@ -67,6 +91,7 @@ (nnoo-define-basics nnvirtual) + (deffoo nnvirtual-retrieve-headers (articles &optional newsgroup server fetch-old) (when (nnvirtual-possibly-change-server server) @@ -77,78 +102,71 @@ 'headers (let ((vbuf (nnheader-set-temp-buffer (get-buffer-create " *virtual headers*"))) - (unfetched (mapcar (lambda (g) (list g)) - nnvirtual-component-groups)) + (carticles (nnvirtual-partition-sequence articles)) (system-name (system-name)) - cgroup article result prefix) - (while articles - (setq article (assq (pop articles) nnvirtual-mapping)) - (when (and (setq cgroup (cadr article)) + cgroup carticle article result prefix) + (while carticles + (setq cgroup (caar carticles)) + (setq articles (cdar carticles)) + (pop carticles) + (when (and articles (gnus-check-server (gnus-find-method-for-group cgroup) t) - (gnus-request-group cgroup t)) - (setq prefix (gnus-group-real-prefix cgroup)) - (when (setq result (gnus-retrieve-headers - (list (caddr article)) cgroup nil)) - (set-buffer nntp-server-buffer) - (if (zerop (buffer-size)) - (nconc (assq cgroup unfetched) (list (caddr article))) - ;; If we got HEAD headers, we convert them into NOV - ;; headers. This is slow, inefficient and, come to think - ;; of it, downright evil. So sue me. I couldn't be - ;; bothered to write a header parse routine that could - ;; parse a mixed HEAD/NOV buffer. - (when (eq result 'headers) - (nnvirtual-convert-headers)) - (goto-char (point-min)) - (while (not (eobp)) - (delete-region - (point) (progn (read nntp-server-buffer) (point))) - (princ (car article) (current-buffer)) + (gnus-request-group cgroup t) + (setq prefix (gnus-group-real-prefix cgroup)) + ;; FIX FIX FIX we want to check the cache! + ;; This is probably evil if people have set + ;; gnus-use-cache to nil themselves, but I + ;; have no way of finding the true value of it. + (let ((gnus-use-cache t)) + (setq result (gnus-retrieve-headers + articles cgroup nil)))) + (set-buffer nntp-server-buffer) + ;; If we got HEAD headers, we convert them into NOV + ;; headers. This is slow, inefficient and, come to think + ;; of it, downright evil. So sue me. I couldn't be + ;; bothered to write a header parse routine that could + ;; parse a mixed HEAD/NOV buffer. + (when (eq result 'headers) + (nnvirtual-convert-headers)) + (goto-char (point-min)) + (while (not (eobp)) + (delete-region (point) + (progn + (setq carticle (read nntp-server-buffer)) + (point))) + + ;; We remove this article from the articles list, if + ;; anything is left in the articles list after going through + ;; the entire buffer, then those articles have been + ;; expired or canceled, so we appropriately update the + ;; component group below. They should be coming up + ;; generally in order, so this shouldn't be slow. + (setq articles (delq carticle articles)) + + (setq article (nnvirtual-reverse-map-article cgroup carticle)) + (if (null article) + ;; This line has no reverse mapping, that means it + ;; was an extra article reference returned by nntp. + (progn (beginning-of-line) - (looking-at - "[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t") - (goto-char (match-end 0)) - (or (search-forward - "\t" (save-excursion (end-of-line) (point)) t) - (end-of-line)) - (while (= (char-after (1- (point))) ? ) - (forward-char -1) - (delete-char 1)) - (if (eolp) - (progn - (end-of-line) - (or (= (char-after (1- (point))) ?\t) - (insert ?\t)) - (insert "Xref: " system-name " " cgroup ":") - (princ (caddr article) (current-buffer)) - (insert "\t")) - (insert "Xref: " system-name " " cgroup ":") - (princ (caddr article) (current-buffer)) - (insert " ") - (if (not (string= "" prefix)) - (while (re-search-forward - "[^ ]+:[0-9]+" - (save-excursion (end-of-line) (point)) t) - (save-excursion - (goto-char (match-beginning 0)) - (insert prefix)))) - (end-of-line) - (or (= (char-after (1- (point))) ?\t) - (insert ?\t))) - (forward-line 1)) - (set-buffer vbuf) - (goto-char (point-max)) - (insert-buffer-substring nntp-server-buffer))))) - - ;; In case some of the articles have expired or been - ;; cancelled, we have to mark them as read in the - ;; component group. - (while unfetched - (when (cdar unfetched) - (gnus-group-make-articles-read - (caar unfetched) (sort (cdar unfetched) '<))) - (setq unfetched (cdr unfetched))) + (delete-region (point) (progn (forward-line 1) (point)))) + ;; Otherwise insert the virtual article number, + ;; and clean up the xrefs. + (princ article nntp-server-buffer) + (nnvirtual-update-xref-header cgroup carticle + prefix system-name) + (forward-line 1)) + ) + + (set-buffer vbuf) + (goto-char (point-max)) + (insert-buffer-substring nntp-server-buffer)) + ;; Anything left in articles is expired or canceled. + ;; Could be smart and not tell it about articles already known? + (when articles + (gnus-group-make-articles-read cgroup articles)) + ) ;; The headers are ready for reading, so they are inserted into ;; the nntp-server-buffer, which is where Gnus expects to find @@ -158,14 +176,20 @@ (set-buffer nntp-server-buffer) (erase-buffer) (insert-buffer-substring vbuf) + ;; FIX FIX FIX, we should be able to sort faster than + ;; this if needed, since each cgroup is sorted, we just + ;; need to merge + (sort-numeric-fields 1 (point-min) (point-max)) 'nov) (kill-buffer vbuf))))))) + + (deffoo nnvirtual-request-article (article &optional group server buffer) (when (and (nnvirtual-possibly-change-server server) (numberp article)) - (let* ((amap (assq article nnvirtual-mapping)) - (cgroup (cadr amap))) + (let* ((amap (nnvirtual-map-article article)) + (cgroup (car amap))) (cond ((not amap) (nnheader-report 'nnvirtual "No such article: %s" article)) @@ -178,8 +202,9 @@ (if buffer (save-excursion (set-buffer buffer) - (gnus-request-article-this-buffer (caddr amap) cgroup)) - (gnus-request-article (caddr amap) cgroup))))))) + (gnus-request-article-this-buffer (cdr amap) cgroup)) + (gnus-request-article (cdr amap) cgroup))))))) + (deffoo nnvirtual-open-server (server &optional defs) (unless (assq 'nnvirtual-component-regexp defs) @@ -188,19 +213,26 @@ (nnoo-change-server 'nnvirtual server defs) (if nnvirtual-component-groups t - (setq nnvirtual-mapping nil) - ;; Go through the newsrc alist and find all component groups. - (let ((newsrc (cdr gnus-newsrc-alist)) - group) - (while (setq group (car (pop newsrc))) - (when (string-match nnvirtual-component-regexp group) ; Match - ;; Add this group to the list of component groups. - (setq nnvirtual-component-groups - (cons group (delete group nnvirtual-component-groups)))))) + (setq nnvirtual-mapping-table nil + nnvirtual-mapping-offsets nil + nnvirtual-mapping-len 0 + nnvirtual-mapping-reads nil + nnvirtual-mapping-marks nil + nnvirtual-info-installed nil) + (when nnvirtual-component-regexp + ;; Go through the newsrc alist and find all component groups. + (let ((newsrc (cdr gnus-newsrc-alist)) + group) + (while (setq group (car (pop newsrc))) + (when (string-match nnvirtual-component-regexp group) ; Match + ;; Add this group to the list of component groups. + (setq nnvirtual-component-groups + (cons group (delete group nnvirtual-component-groups))))))) (if (not nnvirtual-component-groups) (nnheader-report 'nnvirtual "No component groups: %s" server) t))) + (deffoo nnvirtual-request-group (group &optional server dont-check) (nnvirtual-possibly-change-server server) (setq nnvirtual-component-groups @@ -210,103 +242,89 @@ (setq nnvirtual-current-group nil) (nnheader-report 'nnvirtual "No component groups in %s" group)) (t - (unless dont-check + (when (or (not dont-check) + nnvirtual-always-rescan) (nnvirtual-create-mapping)) (setq nnvirtual-current-group group) - (let ((len (length nnvirtual-mapping))) - (nnheader-insert "211 %d 1 %d %s\n" len len group))))) + (nnheader-insert "211 %d 1 %d %s\n" + nnvirtual-mapping-len nnvirtual-mapping-len group)))) + (deffoo nnvirtual-request-type (group &optional article) (if (not article) 'unknown - (let ((mart (assq article nnvirtual-mapping))) + (let ((mart (nnvirtual-map-article article))) (when mart - (gnus-request-type (cadr mart) (car mart)))))) + (gnus-request-type (car mart) (cdr mart)))))) (deffoo nnvirtual-request-update-mark (group article mark) - (let* ((nart (assq article nnvirtual-mapping)) - (cgroup (cadr nart)) + (let* ((nart (nnvirtual-map-article article)) + (cgroup (car nart)) ;; The component group might be a virtual group. - (nmark (gnus-request-update-mark cgroup (caddr nart) mark))) + (nmark (gnus-request-update-mark cgroup (cdr nart) mark))) (when (and nart (= mark nmark) (gnus-group-auto-expirable-p cgroup)) (setq mark gnus-expirable-mark))) mark) + (deffoo nnvirtual-close-group (group &optional server) - (when (nnvirtual-possibly-change-server server) - ;; Copy (un)read articles. - (nnvirtual-update-reads) - ;; We copy the marks from this group to the component - ;; groups here. - (nnvirtual-update-marked)) + (when (and (nnvirtual-possibly-change-server server) + (not (gnus-ephemeral-group-p (nnvirtual-current-group)))) + (nnvirtual-update-read-and-marked t t)) t) -(deffoo nnvirtual-request-list (&optional server) + +(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.")) + (deffoo nnvirtual-request-list-newsgroups (&optional server) (nnheader-report 'nnvirtual "LIST NEWSGROUPS is not implemented.")) + (deffoo nnvirtual-request-update-info (group info &optional server) - (when (nnvirtual-possibly-change-server server) - (let ((map nnvirtual-mapping) - (marks (mapcar (lambda (m) (list (cdr m))) gnus-article-mark-lists)) - reads mr m op) - ;; Go through the mapping. - (while map - (unless (nth 3 (setq m (pop map))) - ;; Read article. - (push (car m) reads)) - ;; Copy marks. - (when (setq mr (nth 4 m)) - (while mr - (setcdr (setq op (assq (pop mr) marks)) (cons (car m) (cdr op)))))) - ;; Compress the marks and the reads. - (setq mr marks) - (while mr - (setcdr (car mr) (gnus-compress-sequence (sort (cdr (pop mr)) '<)))) - (setcar (cddr info) (gnus-compress-sequence (nreverse reads))) - ;; Remove empty marks lists. - (while (and marks (not (cdar marks))) - (setq marks (cdr marks))) - (setq mr marks) - (while (cdr mr) - (if (cdadr mr) - (setq mr (cdr mr)) - (setcdr mr (cddr mr)))) - - ;; Enter these new marks into the info of the group. + (when (and (nnvirtual-possibly-change-server server) + (not nnvirtual-info-installed)) + ;; Install the precomputed lists atomically, so the virtual group + ;; is not left in a half-way state in case of C-g. + (gnus-atomic-progn + (setcar (cddr info) nnvirtual-mapping-reads) (if (nthcdr 3 info) - (setcar (nthcdr 3 info) marks) - ;; Add the marks lists to the end of the info. - (when marks - (setcdr (nthcdr 2 info) (list marks)))) - t))) + (setcar (nthcdr 3 info) nnvirtual-mapping-marks) + (when nnvirtual-mapping-marks + (setcdr (nthcdr 2 info) (list nnvirtual-mapping-marks)))) + (setq nnvirtual-info-installed t)) + t)) + (deffoo nnvirtual-catchup-group (group &optional server all) - (nnvirtual-possibly-change-server server) - (let ((gnus-group-marked (copy-sequence nnvirtual-component-groups)) - (gnus-expert-user t)) - ;; Make sure all groups are activated. - (mapcar - (lambda (g) - (when (not (numberp (car (gnus-gethash g gnus-newsrc-hashtb)))) - (gnus-activate-group g))) - nnvirtual-component-groups) - (save-excursion - (set-buffer gnus-group-buffer) - (gnus-group-catchup-current nil all)))) + (when (and (nnvirtual-possibly-change-server server) + (not (gnus-ephemeral-group-p (nnvirtual-current-group)))) + ;; copy over existing marks first, in case they set anything + (nnvirtual-update-read-and-marked nil nil) + ;; do a catchup on all component groups + (let ((gnus-group-marked (copy-sequence nnvirtual-component-groups)) + (gnus-expert-user t)) + ;; Make sure all groups are activated. + (mapcar + (lambda (g) + (when (not (numberp (car (gnus-gethash g gnus-newsrc-hashtb)))) + (gnus-activate-group g))) + nnvirtual-component-groups) + (save-excursion + (set-buffer gnus-group-buffer) + (gnus-group-catchup-current nil all))))) + (deffoo nnvirtual-find-group-art (group article) "Return the real group and article for virtual GROUP and ARTICLE." - (let ((mart (assq article nnvirtual-mapping))) - (when mart - (cons (cadr mart) (caddr mart))))) + (nnvirtual-map-article article)) ;;; Internal functions. @@ -322,87 +340,410 @@ (while (setq header (pop headers)) (nnheader-insert-nov header))))) + +(defun nnvirtual-update-xref-header (group article prefix system-name) + "Edit current NOV header in current buffer to have an xref to the component group, and also server prefix any existing xref lines." + ;; Move to beginning of Xref field, creating a slot if needed. + (beginning-of-line) + (looking-at + "[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t") + (goto-char (match-end 0)) + (unless (search-forward "\t" (point-at-eol) 'move) + (insert "\t")) + + ;; Remove any spaces at the beginning of the Xref field. + (while (= (char-after (1- (point))) ? ) + (forward-char -1) + (delete-char 1)) + + (insert "Xref: " system-name " " group ":") + (princ article (current-buffer)) + + ;; If there were existing xref lines, clean them up to have the correct + ;; component server prefix. + (let ((xref-end (save-excursion + (search-forward "\t" (point-at-eol) 'move) + (point))) + (len (length prefix))) + (unless (= (point) xref-end) + (insert " ") + (when (not (string= "" prefix)) + (while (re-search-forward "[^ ]+:[0-9]+" xref-end t) + (save-excursion + (goto-char (match-beginning 0)) + (insert prefix)) + (setq xref-end (+ xref-end len))) + ))) + + ;; Ensure a trailing \t. + (end-of-line) + (or (= (char-after (1- (point))) ?\t) + (insert ?\t))) + + (defun nnvirtual-possibly-change-server (server) (or (not server) (nnoo-current-server-p 'nnvirtual server) (nnvirtual-open-server server))) -(defun nnvirtual-update-marked () - "Copy marks from the virtual group to the component groups." - (let ((mark-lists gnus-article-mark-lists) - (marks (gnus-info-marks (gnus-get-info (nnvirtual-current-group)))) - type list mart cgroups) - (while (setq type (cdr (pop mark-lists))) - (setq list (gnus-uncompress-range (cdr (assq type marks)))) - (setq cgroups - (mapcar (lambda (g) (list g)) nnvirtual-component-groups)) - (while list - (nconc (assoc (cadr (setq mart (assq (pop list) nnvirtual-mapping))) - cgroups) - (list (caddr mart)))) - (while cgroups - (gnus-add-marked-articles - (caar cgroups) type (cdar cgroups) nil t) - (gnus-group-update-group (car (pop cgroups)) t))))) + +(defun nnvirtual-update-read-and-marked (read-p update-p) + "Copy marks from the virtual group to the component groups. +If READ-P is not nil, update the (un)read status of the components. +If UPDATE-P is not nil, call gnus-group-update-group on the components." + (let ((unreads (and read-p + (nnvirtual-partition-sequence + (gnus-list-of-unread-articles + (nnvirtual-current-group))))) + (type-marks (mapcar (lambda (ml) + (cons (car ml) + (nnvirtual-partition-sequence (cdr ml)))) + (gnus-info-marks (gnus-get-info + (nnvirtual-current-group))))) + mark type groups carticles info entry) + + ;; Ok, atomically move all of the (un)read info, clear any old + ;; marks, and move all of the current marks. This way if someone + ;; hits C-g, you won't leave the component groups in a half-way state. + (gnus-atomic-progn + ;; move (un)read + (let ((gnus-newsgroup-active nil)) ;workaround guns-update-read-articles + (while (setq entry (pop unreads)) + (gnus-update-read-articles (car entry) (cdr entry)))) -(defun nnvirtual-update-reads () - "Copy (un)reads from the current group to the component groups." - (let ((groups (mapcar (lambda (g) (list g)) nnvirtual-component-groups)) - (articles (gnus-list-of-unread-articles - (nnvirtual-current-group))) - m) - (while articles - (setq m (assq (pop articles) nnvirtual-mapping)) - (nconc (assoc (nth 1 m) groups) (list (nth 2 m)))) - (while groups - (gnus-update-read-articles (caar groups) (cdr (pop groups)))))) + ;; clear all existing marks on the component groups + (setq groups nnvirtual-component-groups) + (while groups + (when (and (setq info (gnus-get-info (pop groups))) + (gnus-info-marks info)) + (gnus-info-set-marks info nil))) + + ;; Ok, currently type-marks is an assq list with keys of a mark type, + ;; with data of an assq list with keys of component group names + ;; and the articles which correspond to that key/group pair. + (while (setq mark (pop type-marks)) + (setq type (car mark)) + (setq groups (cdr mark)) + (while (setq carticles (pop groups)) + (gnus-add-marked-articles (car carticles) type (cdr carticles) + nil t)))) + + ;; possibly update the display, it is really slow + (when update-p + (setq groups nnvirtual-component-groups) + (while groups + (gnus-group-update-group (pop groups) t))) + )) + (defun nnvirtual-current-group () "Return the prefixed name of the current nnvirtual group." (concat "nnvirtual:" nnvirtual-current-group)) -(defsubst nnvirtual-marks (article marks) - "Return a list of mark types for ARTICLE." - (let (out) - (while marks - (when (memq article (cdar marks)) - (push (caar marks) out)) - (setq marks (cdr marks))) - out)) + + +;;; This is currently O(kn^2) to merge n lists of length k. +;;; You could do it in O(knlogn), but we have a small n, and the +;;; overhead of the other approach is probably greater. +(defun nnvirtual-merge-sorted-lists (&rest lists) + "Merge many sorted lists of numbers." + (if (null (cdr lists)) + (car lists) + (apply 'nnvirtual-merge-sorted-lists + (merge 'list (car lists) (cadr lists) '<) + (cddr lists)))) + + + +;;; We map between virtual articles and real articles in a manner +;;; which keeps the size of the virtual active list the same as +;;; the sum of the component active lists. +;;; To achieve fair mixing of the groups, the last article in +;;; each of N component groups will be in the the last N articles +;;; in the virtual group. + +;;; If you have 3 components A, B and C, with articles 1-8, 1-5, and 6-7 +;;; resprectively, then the virtual article numbers look like: +;;; +;;; 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 +;;; A1 A2 A3 A4 B1 A5 B2 A6 B3 A7 B4 C6 A8 B5 C7 + +;;; To compute these mappings we generate a couple tables and then +;;; do some fast operations on them. Tables for the example above: +;;; +;;; Offsets - [(A 0) (B -3) (C -1)] +;;; +;;; a b c d e +;;; Mapping - ([ 3 0 1 3 0 ] +;;; [ 6 3 2 9 3 ] +;;; [ 8 6 3 15 9 ]) +;;; +;;; (note column 'e' is different in real algorithm, which is slightly +;;; different than described here, but this gives you the methodology.) +;;; +;;; The basic idea is this, when going from component->virtual, apply +;;; the appropriate offset to the article number. Then search the first +;;; column of the table for a row where 'a' is less than or equal to the +;;; modified number. You can see that only group A can therefore go to +;;; the first row, groups A and B to the second, and all to the last. +;;; The third column of the table is telling us the number of groups +;;; which might be able to reach that row (it might increase by more than +;;; 1 if several groups have the same size). +;;; Then column 'b' provides an additional offset you apply when you have +;;; found the correct row. You then multiply by 'c' and add on the groups +;;; _position_ in the offset table. The basic idea here is that on +;;; any given row we are going to map back and forth using X'=X*c+Y and +;;; X=(X'/c), Y=(X' mod c). Then once you've done this transformation, +;;; you apply a final offset from column 'e' to give the virtual article. +;;; +;;; Going the other direction, you instead search on column 'd' instead +;;; of 'a', and apply everything in reverse order. + +;;; Convert component -> virtual: +;;; set num = num - Offset(group) +;;; find first row in Mapping where num <= 'a' +;;; num = (num-'b')*c + Position(group) + 'e' + +;;; Convert virtual -> component: +;;; find first row in Mapping where num <= 'd' +;;; num = num - 'e' +;;; group_pos = num mod 'c' +;;; num = (num / 'c') + 'b' + Offset(group_pos) + +;;; Easy no? :) +;;; +;;; Well actually, you need to keep column e offset smaller by the 'c' +;;; column for that line, and always add 1 more when going from +;;; component -> virtual. Otherwise you run into a problem with +;;; unique reverse mapping. + +(defun nnvirtual-map-article (article) + "Return a cons of the component group and article corresponding to the given virtual ARTICLE." + (let ((table nnvirtual-mapping-table) + entry group-pos) + (while (and table + (> article (aref (car table) 3))) + (setq table (cdr table))) + (when (and table + (> article 0)) + (setq entry (car table)) + (setq article (- article (aref entry 4) 1)) + (setq group-pos (mod article (aref entry 2))) + (cons (car (aref nnvirtual-mapping-offsets group-pos)) + (+ (/ article (aref entry 2)) + (aref entry 1) + (cdr (aref nnvirtual-mapping-offsets group-pos))) + )) + )) + + + +(defun nnvirtual-reverse-map-article (group article) + "Return the virtual article number corresponding to the given component GROUP and ARTICLE." + (let ((table nnvirtual-mapping-table) + (group-pos 0) + entry) + (while (not (string= group (car (aref nnvirtual-mapping-offsets + group-pos)))) + (setq group-pos (1+ group-pos))) + (setq article (- article (cdr (aref nnvirtual-mapping-offsets + group-pos)))) + (while (and table + (> article (aref (car table) 0))) + (setq table (cdr table))) + (setq entry (car table)) + (when (and entry + (> article 0) + (< group-pos (aref entry 2))) ; article not out of range below + (+ (aref entry 4) + group-pos + (* (- article (aref entry 1)) + (aref entry 2)) + 1)) + )) + + +(defun nnvirtual-reverse-map-sequence (group articles) + "Return list of virtual article numbers for all ARTICLES in GROUP. +The ARTICLES should be sorted, and can be a compressed sequence. +If any of the article numbers has no corresponding virtual article, +then it is left out of the result." + (when (numberp (cdr-safe articles)) + (setq articles (list articles))) + (let (result a i j new-a) + (while (setq a (pop articles)) + (if (atom a) + (setq i a + j a) + (setq i (car a) + j (cdr a))) + (while (<= i j) + ;; If this is slow, you can optimize by moving article checking + ;; into here. You don't have to recompute the group-pos, + ;; nor scan the table every time. + (when (setq new-a (nnvirtual-reverse-map-article group i)) + (push new-a result)) + (setq i (1+ i)))) + (nreverse result))) + + +(defun nnvirtual-partition-sequence (articles) + "Return an association list of component article numbers. +These are indexed by elements of nnvirtual-component-groups, based on +the sequence ARTICLES of virtual article numbers. ARTICLES should be +sorted, and can be a compressed sequence. If any of the article +numbers has no corresponding component article, then it is left out of +the result." + (when (numberp (cdr-safe articles)) + (setq articles (list articles))) + (let ((carticles (mapcar (lambda (g) (list g)) + nnvirtual-component-groups)) + a i j article entry) + (while (setq a (pop articles)) + (if (atom a) + (setq i a + j a) + (setq i (car a) + j (cdr a))) + (while (<= i j) + (when (setq article (nnvirtual-map-article i)) + (setq entry (assoc (car article) carticles)) + (setcdr entry (cons (cdr article) (cdr entry)))) + (setq i (1+ i)))) + (mapc '(lambda (x) (setcdr x (nreverse (cdr x)))) + carticles) + carticles)) + (defun nnvirtual-create-mapping () - "Create an article mapping for the current group." - (let* ((div nil) - m marks list article unreads marks active - (map (sort - (apply - 'nconc - (mapcar - (lambda (g) - (when (and (setq active (gnus-activate-group g)) - (> (cdr active) (car active))) - (setq unreads (gnus-list-of-unread-articles g) - marks (gnus-uncompress-marks - (gnus-info-marks (gnus-get-info g)))) - (when gnus-use-cache - (push (cons 'cache (gnus-cache-articles-in-group g)) - marks)) - (setq div (/ (float (car active)) - (if (zerop (cdr active)) - 1 (cdr active)))) - (mapcar (lambda (n) - (list (* div (- n (car active))) - g n (and (memq n unreads) t) - (inline (nnvirtual-marks n marks)))) - (gnus-uncompress-range active)))) - nnvirtual-component-groups)) - (lambda (m1 m2) - (< (car m1) (car m2))))) - (i 0)) - (setq nnvirtual-mapping map) - ;; Set the virtual article numbers. - (while (setq m (pop map)) - (setcar m (setq article (incf i)))))) + "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." + (let ((cnt 0) + (tot 0) + (M 0) + (i 0) + actives all-unreads all-marks + active min max size unreads marks + next-M next-tot + reads beg) + ;; Ok, we loop over all component groups and collect a lot of + ;; information: + ;; Into actives we place (g size max), where size is max-min+1. + ;; Into all-unreads we put (g unreads). + ;; 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) + min (car active) + max (cdr active)) + (when (and active (>= max min) (not (zerop max))) + ;; store active information + (push (list g (- max min -1) max) actives) + ;; collect unread/mark info for later + (setq unreads (gnus-list-of-unread-articles g)) + (setq marks (gnus-info-marks (gnus-get-info g))) + (when gnus-use-cache + (push (cons 'cache + (gnus-cache-articles-in-group g)) + marks)) + (push (cons g unreads) all-unreads) + (push (cons g marks) all-marks) + ;; count groups, total #articles, and max size + (setq size (- max min -1)) + (setq cnt (1+ cnt) + tot (+ tot size) + M (max M size)))) + nnvirtual-component-groups) + + ;; Number of articles in the virtual group. + (setq nnvirtual-mapping-len tot) + + + ;; We want the actives list sorted by size, to build the tables. + (setq actives (sort actives (lambda (g1 g2) (< (nth 1 g1) (nth 1 g2))))) + + ;; Build the offset table. Largest sized groups are at the front. + (setq nnvirtual-mapping-offsets + (vconcat + (nreverse + (mapcar (lambda (entry) + (cons (nth 0 entry) + (- (nth 2 entry) M))) + actives)))) + + ;; Build the mapping table. + (setq nnvirtual-mapping-table nil) + (setq actives (mapcar (lambda (entry) (nth 1 entry)) actives)) + (while actives + (setq size (car actives)) + (setq next-M (- M size)) + (setq next-tot (- tot (* cnt size))) + ;; make current row in table + (push (vector M next-M cnt tot (- next-tot cnt)) + nnvirtual-mapping-table) + ;; update M and tot + (setq M next-M) + (setq tot next-tot) + ;; subtract the current size from all entries. + (setq actives (mapcar (lambda (x) (- x size)) actives)) + ;; remove anything that went to 0. + (while (and actives + (= (car actives) 0)) + (pop actives) + (setq cnt (- cnt 1)))) + + + ;; Now that the mapping tables are generated, we can convert + ;; and combine the separate component unreads and marks lists + ;; into single lists of virtual article numbers. + (setq unreads (apply 'nnvirtual-merge-sorted-lists + (mapcar (lambda (x) + (nnvirtual-reverse-map-sequence + (car x) (cdr x))) + all-unreads))) + (setq marks (mapcar + (lambda (type) + (cons (cdr type) + (gnus-compress-sequence + (apply + 'nnvirtual-merge-sorted-lists + (mapcar (lambda (x) + (nnvirtual-reverse-map-sequence + (car x) + (cdr (assq (cdr type) (cdr x))))) + all-marks))))) + gnus-article-mark-lists)) + + ;; Remove any empty marks lists, and store. + (setq nnvirtual-mapping-marks (delete-if-not 'cdr marks)) + + ;; We need to convert the unreads to reads. We compress the + ;; sequence as we go, otherwise it could be huge. + (while (and (<= (incf i) nnvirtual-mapping-len) + unreads) + (if (= i (car unreads)) + (setq unreads (cdr unreads)) + ;; try to get a range. + (setq beg i) + (while (and (<= (incf i) nnvirtual-mapping-len) + (not (= i (car unreads))))) + (setq i (- i 1)) + (if (= i beg) + (push i reads) + (push (cons beg i) reads)) + )) + (when (<= i nnvirtual-mapping-len) + (if (= i nnvirtual-mapping-len) + (push i reads) + (push (cons i nnvirtual-mapping-len) reads))) + + ;; Store the reads list for later use. + (setq nnvirtual-mapping-reads (nreverse reads)) + + ;; Throw flag to show we changed the info. + (setq nnvirtual-info-installed nil) + )) (provide 'nnvirtual) diff -r ad457d5f7d04 -r 0293115a14e9 lisp/gnus/nnweb.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus/nnweb.el Mon Aug 13 08:49:20 2007 +0200 @@ -0,0 +1,689 @@ +;;; nnweb.el --- retrieving articles via web search engines +;; Copyright (C) 1996,97 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen +;; Keywords: news + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; Note: You need to have `url' and `w3' installed for this +;; backend to work. + +;;; Code: + +(require 'nnoo) +(require 'message) +(require 'gnus-util) +(require 'gnus) +(require 'w3) +(require 'url) +(ignore-errors + (require 'w3-forms)) + +(nnoo-declare nnweb) + +(defvoo nnweb-directory (nnheader-concat gnus-directory "nnweb/") + "Where nnweb will save its files.") + +(defvoo nnweb-type 'dejanews + "What search engine type is being used.") + +(defvar nnweb-type-definition + '((dejanews + (article . nnweb-dejanews-wash-article) + (map . nnweb-dejanews-create-mapping) + (search . nnweb-dejanews-search) + (address . "http://xp9.dejanews.com/dnquery.xp") + (identifier . nnweb-dejanews-identity)) + (reference + (article . nnweb-reference-wash-article) + (map . nnweb-reference-create-mapping) + (search . nnweb-reference-search) + (address . "http://www.reference.com/cgi-bin/pn/go") + (identifier . identity)) + (altavista + (article . nnweb-altavista-wash-article) + (map . nnweb-altavista-create-mapping) + (search . nnweb-altavista-search) + (address . "http://www.altavista.digital.com/cgi-bin/query") + (id . "/cgi-bin/news?id@%s") + (identifier . identity))) + "Type-definition alist.") + +(defvoo nnweb-search nil + "Search string to feed to DejaNews.") + +(defvoo nnweb-max-hits 30 + "Maximum number of hits to display.") + +(defvoo nnweb-ephemeral-p nil + "Whether this nnweb server is ephemeral.") + +;;; Internal variables + +(defvoo nnweb-articles nil) +(defvoo nnweb-buffer nil) +(defvoo nnweb-group-alist nil) +(defvoo nnweb-group nil) +(defvoo nnweb-hashtb nil) + +;;; Interface functions + +(nnoo-define-basics nnweb) + +(deffoo nnweb-retrieve-headers (articles &optional group server fetch-old) + (nnweb-possibly-change-server group server) + (save-excursion + (set-buffer nntp-server-buffer) + (erase-buffer) + (let (article header) + (while (setq article (pop articles)) + (when (setq header (cadr (assq article nnweb-articles))) + (nnheader-insert-nov header))) + 'nov))) + +(deffoo nnweb-request-scan (&optional group server) + (nnweb-possibly-change-server group server) + (funcall (nnweb-definition 'map)) + (unless nnweb-ephemeral-p + (nnweb-write-active) + (nnweb-write-overview group))) + +(deffoo nnweb-request-group (group &optional server dont-check) + (nnweb-possibly-change-server nil server) + (when (and group + (not (equal group nnweb-group)) + (not nnweb-ephemeral-p)) + (let ((info (assoc group nnweb-group-alist))) + (setq nnweb-group group) + (setq nnweb-type (nth 2 info)) + (setq nnweb-search (nth 3 info)) + (unless dont-check + (nnweb-read-overview group)))) + (cond + ((not nnweb-articles) + (nnheader-report 'nnweb "No matching articles")) + (t + (let ((active (if nnweb-ephemeral-p + (cons (caar nnweb-articles) + (caar (last nnweb-articles))) + (cadr (assoc group nnweb-group-alist))))) + (nnheader-report 'nnweb "Opened group %s" group) + (nnheader-insert + "211 %d %d %d %s\n" (length nnweb-articles) + (car active) (cdr active) group))))) + +(deffoo nnweb-close-group (group &optional server) + (nnweb-possibly-change-server group server) + (when (gnus-buffer-live-p nnweb-buffer) + (save-excursion + (set-buffer nnweb-buffer) + (set-buffer-modified-p nil) + (kill-buffer nnweb-buffer))) + t) + +(deffoo nnweb-request-article (article &optional group server buffer) + (nnweb-possibly-change-server group server) + (save-excursion + (set-buffer (or buffer nntp-server-buffer)) + (let* ((header (cadr (assq article nnweb-articles))) + (url (and header (mail-header-xref header)))) + (when (or (and url + (nnweb-fetch-url url)) + (and (stringp article) + (nnweb-definition 'id t) + (let ((fetch (nnweb-definition 'id)) + art) + (when (string-match "^<\\(.*\\)>$" article) + (setq art (match-string 1 article))) + (and fetch + art + (nnweb-fetch-url + (format fetch article)))))) + (unless nnheader-callback-function + (funcall (nnweb-definition 'article)) + (nnweb-decode-entities)) + (nnheader-report 'nnweb "Fetched article %s" article) + t)))) + +(deffoo nnweb-close-server (&optional server) + (when (and (nnweb-server-opened server) + (gnus-buffer-live-p nnweb-buffer)) + (save-excursion + (set-buffer nnweb-buffer) + (set-buffer-modified-p nil) + (kill-buffer nnweb-buffer))) + (nnoo-close-server 'nnweb server)) + +(deffoo nnweb-request-list (&optional server) + (nnweb-possibly-change-server nil server) + (save-excursion + (set-buffer nntp-server-buffer) + (nnmail-generate-active nnweb-group-alist) + t)) + +(deffoo nnweb-request-update-info (group info &optional server) + (nnweb-possibly-change-server group server) + ;;(setcar (cddr info) nil) + ) + +(deffoo nnweb-asynchronous-p () + t) + +(deffoo nnweb-request-create-group (group &optional server args) + (nnweb-possibly-change-server nil server) + (nnweb-request-delete-group group) + (push `(,group ,(cons 1 0) ,@args) nnweb-group-alist) + (nnweb-write-active) + t) + +(deffoo nnweb-request-delete-group (group &optional force server) + (nnweb-possibly-change-server group server) + (gnus-delete-assoc group nnweb-group-alist) + (gnus-delete-file (nnweb-overview-file group)) + t) + +(nnoo-define-skeleton nnweb) + +;;; Internal functions + +(defun nnweb-read-overview (group) + "Read the overview of GROUP and build the map." + (when (file-exists-p (nnweb-overview-file group)) + (nnheader-temp-write nil + (nnheader-insert-file-contents (nnweb-overview-file group)) + (goto-char (point-min)) + (setq nnweb-hashtb (gnus-make-hashtable + (count-lines (point-min) (point-max)))) + (let (header) + (while (not (eobp)) + (setq header (nnheader-parse-nov)) + (forward-line 1) + (push (list (mail-header-number header) + header (mail-header-xref header)) + nnweb-articles) + (nnweb-set-hashtb header (car nnweb-articles))))))) + +(defun nnweb-write-overview (group) + "Write the overview file for GROUP." + (nnheader-temp-write (nnweb-overview-file group) + (let ((articles nnweb-articles)) + (while articles + (nnheader-insert-nov (cadr (pop articles))))))) + +(defun nnweb-set-hashtb (header data) + (gnus-sethash (nnweb-identifier (mail-header-xref header)) + data nnweb-hashtb)) + +(defun nnweb-get-hashtb (url) + (gnus-gethash (nnweb-identifier url) nnweb-hashtb)) + +(defun nnweb-identifier (ident) + (funcall (nnweb-definition 'identifier) ident)) + +(defun nnweb-overview-file (group) + "Return the name of the overview file of GROUP." + (nnheader-concat nnweb-directory group ".overview")) + +(defun nnweb-write-active () + "Save the active file." + (nnheader-temp-write (nnheader-concat nnweb-directory "active") + (prin1 `(setq nnweb-group-alist ',nnweb-group-alist) (current-buffer)))) + +(defun nnweb-read-active () + "Read the active file." + (load (nnheader-concat nnweb-directory "active") t t t)) + +(defun nnweb-definition (type &optional noerror) + "Return the definition of TYPE." + (let ((def (cdr (assq type (assq nnweb-type nnweb-type-definition))))) + (when (and (not def) + (not noerror)) + (error "Undefined definition %s" type)) + def)) + +(defun nnweb-possibly-change-server (&optional group server) + (nnweb-init server) + (when server + (unless (nnweb-server-opened server) + (nnweb-open-server server))) + (unless nnweb-group-alist + (nnweb-read-active)) + (when group + (when (and (not nnweb-ephemeral-p) + (not (equal group nnweb-group))) + (nnweb-request-group group nil t)))) + +(defun nnweb-init (server) + "Initialize buffers and such." + (unless (gnus-buffer-live-p nnweb-buffer) + (setq nnweb-buffer + (save-excursion + (nnheader-set-temp-buffer + (format " *nnweb %s %s %s*" nnweb-type nnweb-search server)))))) + +(defun nnweb-fetch-url (url) + (save-excursion + (if (not nnheader-callback-function) + (let ((buf (current-buffer))) + (save-excursion + (set-buffer nnweb-buffer) + (erase-buffer) + (prog1 + (url-insert-file-contents url) + (copy-to-buffer buf (point-min) (point-max))))) + (nnweb-url-retrieve-asynch + url 'nnweb-callback (current-buffer) nnheader-callback-function) + t))) + +(defun nnweb-callback (buffer callback) + (when (gnus-buffer-live-p url-working-buffer) + (save-excursion + (set-buffer url-working-buffer) + (funcall (nnweb-definition 'article)) + (nnweb-decode-entities) + (set-buffer buffer) + (goto-char (point-max)) + (insert-buffer-substring url-working-buffer)) + (funcall callback t) + (gnus-kill-buffer url-working-buffer))) + +(defun nnweb-url-retrieve-asynch (url callback &rest data) + (let ((url-request-method "GET") + (old-asynch url-be-asynchronous) + (url-request-data nil) + (url-request-extra-headers nil) + (url-working-buffer (generate-new-buffer-name " *nnweb*"))) + (setq-default url-be-asynchronous t) + (save-excursion + (set-buffer (get-buffer-create url-working-buffer)) + (setq url-current-callback-data data + url-be-asynchronous t + url-current-callback-func callback) + (url-retrieve url)) + (setq-default url-be-asynchronous old-asynch))) + +(defun nnweb-encode-www-form-urlencoded (pairs) + "Return PAIRS encoded for forms." + (mapconcat + (function + (lambda (data) + (concat (w3-form-encode-xwfu (car data)) "=" + (w3-form-encode-xwfu (cdr data))))) + pairs "&")) + +(defun nnweb-fetch-form (url pairs) + (let ((url-request-data (nnweb-encode-www-form-urlencoded pairs)) + (url-request-method "POST") + (url-request-extra-headers + '(("Content-type" . "application/x-www-form-urlencoded")))) + (url-insert-file-contents url) + (setq buffer-file-name nil)) + t) + +(defun nnweb-decode-entities () + (goto-char (point-min)) + (while (re-search-forward "&\\([a-z]+\\);" nil t) + (replace-match (char-to-string (or (cdr (assq (intern (match-string 1)) + w3-html-entities )) + ?#)) + t t))) + +(defun nnweb-remove-markup () + (goto-char (point-min)) + (while (search-forward "" nil t) + (point-max)))) + (goto-char (point-min)) + (while (re-search-forward "<[^>]+>" nil t) + (replace-match "" t t))) + +;;; +;;; DejaNews functions. +;;; + +(defun nnweb-dejanews-create-mapping () + "Perform the search and create an number-to-url alist." + (save-excursion + (set-buffer nnweb-buffer) + (erase-buffer) + (when (funcall (nnweb-definition 'search) nnweb-search) + (let ((i 0) + (more t) + (case-fold-search t) + (active (or (cadr (assoc nnweb-group nnweb-group-alist)) + (cons 1 0))) + Subject Score Date Newsgroup Author + map url) + (while more + ;; Go through all the article hits on this page. + (goto-char (point-min)) + (nnweb-decode-entities) + (goto-char (point-min)) + (while (re-search-forward "^ +[0-9]+\\." nil t) + (narrow-to-region + (point) + (cond ((re-search-forward "^ +[0-9]+\\." nil t) + (match-beginning 0)) + ((search-forward "\n\n" nil t) + (point)) + (t + (point-max)))) + (goto-char (point-min)) + (when (looking-at ".*HREF=\"\\([^\"]+\\)\"") + (setq url (match-string 1))) + (nnweb-remove-markup) + (goto-char (point-min)) + (while (search-forward "\t" nil t) + (replace-match " ")) + (goto-char (point-min)) + (while (re-search-forward "^ +\\([^:]+\\): +\\(.*\\)$" nil t) + (set (intern (match-string 1)) (match-string 2))) + (widen) + (when (string-match "#[0-9]+/[0-9]+ *$" Subject) + (setq Subject (substring Subject 0 (match-beginning 0)))) + (incf i) + (unless (nnweb-get-hashtb url) + (push + (list + (incf (cdr active)) + (make-full-mail-header + (cdr active) (concat "(" Newsgroup ") " Subject) Author Date + (concat "<" (nnweb-identifier url) "@dejanews>") + nil 0 (string-to-int Score) url)) + map) + (nnweb-set-hashtb (cadar map) (car map)))) + ;; See whether there is a "Get next 20 hits" button here. + (if (or (not (re-search-forward + "HREF=\"\\([^\"]+\\)\">Get next" nil t)) + (>= i nnweb-max-hits)) + (setq more nil) + ;; Yup -- fetch it. + (setq more (match-string 1)) + (erase-buffer) + (url-insert-file-contents more))) + ;; Return the articles in the right order. + (setq nnweb-articles + (sort (nconc nnweb-articles map) + (lambda (s1 s2) (< (car s1) (car s2))))))))) + +(defun nnweb-dejanews-wash-article () + (let ((case-fold-search t)) + (goto-char (point-min)) + (re-search-forward "
" nil t)
+    (delete-region (point-min) (point))
+    (re-search-forward "
" nil t) + (delete-region (point) (point-max)) + (nnweb-remove-markup) + (goto-char (point-min)) + (while (and (looking-at " *$") + (not (eobp))) + (gnus-delete-line)) + (while (looking-at "\\(^[^ ]+:\\) *") + (replace-match "\\1 " t) + (forward-line 1)) + (when (re-search-forward "\n\n+" nil t) + (replace-match "\n" t t)))) + +(defun nnweb-dejanews-search (search) + (nnweb-fetch-form + (nnweb-definition 'address) + `(("query" . ,search) + ("defaultOp" . "AND") + ("svcclass" . "dncurrent") + ("maxhits" . "100") + ("format" . "verbose") + ("threaded" . "0") + ("showsort" . "score") + ("agesign" . "1") + ("ageweight" . "1"))) + t) + +(defun nnweb-dejanews-identity (url) + "Return an unique identifier based on URL." + (if (string-match "recnum=\\([0-9]+\\)" url) + (match-string 1 url) + url)) + +;;; +;;; InReference +;;; + +(defun nnweb-reference-create-mapping () + "Perform the search and create an number-to-url alist." + (save-excursion + (set-buffer nnweb-buffer) + (erase-buffer) + (when (funcall (nnweb-definition 'search) nnweb-search) + (let ((i 0) + (more t) + (case-fold-search t) + (active (or (cadr (assoc nnweb-group nnweb-group-alist)) + (cons 1 0))) + Subject Score Date Newsgroups From Message-ID + map url) + (while more + ;; Go through all the article hits on this page. + (goto-char (point-min)) + (search-forward "
" nil t) + (delete-region (point-min) (point)) + ;(nnweb-decode-entities) + (goto-char (point-min)) + (while (re-search-forward "^ +[0-9]+\\." nil t) + (narrow-to-region + (point) + (if (re-search-forward "^$" nil t) + (match-beginning 0) + (point-max))) + (goto-char (point-min)) + (when (looking-at ".*href=\"\\([^\"]+\\)\"") + (setq url (match-string 1))) + (nnweb-remove-markup) + (goto-char (point-min)) + (while (search-forward "\t" nil t) + (replace-match " ")) + (goto-char (point-min)) + (while (re-search-forward "^\\([^:]+\\): \\(.*\\)$" nil t) + (set (intern (match-string 1)) (match-string 2))) + (widen) + (search-forward "" nil t) + (incf i) + (unless (nnweb-get-hashtb url) + (push + (list + (incf (cdr active)) + (make-full-mail-header + (cdr active) (concat "(" Newsgroups ") " Subject) From Date + Message-ID + nil 0 (string-to-int Score) url)) + map) + (nnweb-set-hashtb (cadar map) (car map)))) + (setq more nil)) + ;; Return the articles in the right order. + (setq nnweb-articles + (sort (nconc nnweb-articles map) + (lambda (s1 s2) (< (car s1) (car s2))))))))) + +(defun nnweb-reference-wash-article () + (let ((case-fold-search t)) + (goto-char (point-min)) + (re-search-forward "^
" nil t) + (delete-region (point-min) (point)) + (search-forward "
" nil t)
+    (forward-line -1)
+    (let ((body (point-marker)))
+      (search-forward "
" nil t) + (delete-region (point) (point-max)) + (nnweb-remove-markup) + (goto-char (point-min)) + (while (looking-at " *$") + (gnus-delete-line)) + (narrow-to-region (point-min) body) + (while (and (re-search-forward "^$" nil t) + (not (eobp))) + (gnus-delete-line)) + (goto-char (point-min)) + (while (looking-at "\\(^[^ ]+:\\) *") + (replace-match "\\1 " t) + (forward-line 1)) + (goto-char (point-min)) + (when (re-search-forward "^References:" nil t) + (narrow-to-region + (point) (if (re-search-forward "^$\\|^[^:]+:" nil t) + (match-beginning 0) + (point-max))) + (goto-char (point-min)) + (while (not (eobp)) + (unless (looking-at "References") + (insert "\t") + (forward-line 1))) + (goto-char (point-min)) + (while (search-forward "," nil t) + (replace-match " " t t))) + (widen) + (set-marker body nil)))) + +(defun nnweb-reference-search (search) + (prog1 + (url-insert-file-contents + (concat + (nnweb-definition 'address) + "?" + (nnweb-encode-www-form-urlencoded + `(("search" . "advanced") + ("querytext" . ,search) + ("subj" . "") + ("name" . "") + ("login" . "") + ("host" . "") + ("organization" . "") + ("groups" . "") + ("keywords" . "") + ("choice" . "Search") + ("startmonth" . "Jul") + ("startday" . "25") + ("startyear" . "1996") + ("endmonth" . "Aug") + ("endday" . "24") + ("endyear" . "1996") + ("mode" . "Quick") + ("verbosity" . "Verbose") + ("ranking" . "Relevance") + ("first" . "1") + ("last" . "25") + ("score" . "50"))))) + (setq buffer-file-name nil)) + t) + +;;; +;;; Alta Vista +;;; + +(defun nnweb-altavista-create-mapping () + "Perform the search and create an number-to-url alist." + (save-excursion + (set-buffer nnweb-buffer) + (erase-buffer) + (let ((part 0)) + (when (funcall (nnweb-definition 'search) nnweb-search part) + (let ((i 0) + (more t) + (case-fold-search t) + (active (or (cadr (assoc nnweb-group nnweb-group-alist)) + (cons 1 0))) + subject date from id group + map url) + (while more + ;; Go through all the article hits on this page. + (goto-char (point-min)) + (search-forward "
" nil t) + (delete-region (point-min) (match-beginning 0)) + (goto-char (point-min)) + (while (search-forward "
" nil t) + (replace-match "\n")) + (nnweb-decode-entities) + (goto-char (point-min)) + (while (re-search-forward ".*href=\"\\([^\"]+\\)\">\\([^>]*\\)
\\([^-]+\\)- \\([^<]+\\)<.*href=\"news:\\([^\"]+\\)\">.*\">\\(.+\\)

" + nil t) + (setq url (match-string 1) + subject (match-string 2) + date (match-string 3) + group (match-string 4) + id (concat "<" (match-string 5) ">") + from (match-string 6)) + (incf i) + (unless (nnweb-get-hashtb url) + (push + (list + (incf (cdr active)) + (make-full-mail-header + (cdr active) (concat "(" group ") " subject) from date + id nil 0 0 url)) + map) + (nnweb-set-hashtb (cadar map) (car map)))) + ;; See if we want more. + (when (or (not nnweb-articles) + (>= i nnweb-max-hits) + (not (funcall (nnweb-definition 'search) + nnweb-search (incf part)))) + (setq more nil))) + ;; Return the articles in the right order. + (setq nnweb-articles + (sort (nconc nnweb-articles map) + (lambda (s1 s2) (< (car s1) (car s2)))))))))) + +(defun nnweb-altavista-wash-article () + (goto-char (point-min)) + (let ((case-fold-search t)) + (when (re-search-forward "^" nil t) + (delete-region (point-min) (match-beginning 0))) + (goto-char (point-min)) + (while (looking-at "\\([^ ]+\\) + +\\(.*\\)$") + (replace-match "\\1: \\2" t) + (forward-line 1)) + (when (re-search-backward "^References:" nil t) + (narrow-to-region (point) (progn (forward-line 1) (point))) + (goto-char (point-min)) + (while (re-search-forward "[0-9]+" nil t) + (replace-match "<\\1> " t))) + (widen) + (nnweb-remove-markup))) + +(defun nnweb-altavista-search (search &optional part) + (prog1 + (url-insert-file-contents + (concat + (nnweb-definition 'address) + "?" + (nnweb-encode-www-form-urlencoded + `(("pg" . "aq") + ("what" . "news") + ,@(when part `(("stq" . ,(int-to-string (* part 30))))) + ("fmt" . "d") + ("q" . ,search) + ("r" . "") + ("d0" . "") + ("d1" . ""))))) + (setq buffer-file-name nil))) + +(provide 'nnweb) + +;;; nnweb.el ends here diff -r ad457d5f7d04 -r 0293115a14e9 lisp/gnus/parse-time.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus/parse-time.el Mon Aug 13 08:49:20 2007 +0200 @@ -0,0 +1,199 @@ +;;; parse-time.el --- Parsing time strings + +;; Copyright (C) 1996 by Free Software Foundation, Inc. + +;; Author: Erik Naggum +;; Keywords: util + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; With the introduction of the `encode-time', `decode-time', and +;; `format-time-string' functions, dealing with time became simpler in +;; Emacs. However, parsing time strings is still largely a matter of +;; heuristics and no common interface has been designed. + +;; `parse-time-string' parses a time in a string and returns a list of 9 +;; values, just like `decode-time', where unspecified elements in the +;; string are returned as nil. `encode-time' may be applied on these +;; valuse to obtain an internal time value. + +;;; Code: + +(require 'cl) ;and ah ain't kiddin' 'bout it + +(put 'parse-time-syntax 'char-table-extra-slots 0) + +(defvar parse-time-syntax (make-char-table 'parse-time-syntax)) +(defvar parse-time-digits (make-char-table 'parse-time-syntax)) + +;; Byte-compiler warnings +(defvar elt) +(defvar val) + +(unless (aref parse-time-digits ?0) + (loop for i from ?0 to ?9 + do (set-char-table-range parse-time-digits i (- i ?0)))) + +(unless (aref parse-time-syntax ?0) + (loop for i from ?0 to ?9 + do (set-char-table-range parse-time-syntax i ?0)) + (loop for i from ?A to ?Z + do (set-char-table-range parse-time-syntax i ?A)) + (loop for i from ?a to ?z + do (set-char-table-range parse-time-syntax i ?a)) + (set-char-table-range parse-time-syntax ?+ 1) + (set-char-table-range parse-time-syntax ?- -1) + (set-char-table-range parse-time-syntax ?: ?d) + ) + +(defsubst digit-char-p (char) + (aref parse-time-digits char)) + +(defsubst parse-time-string-chars (char) + (aref parse-time-syntax char)) + +(put 'parse-error 'error-conditions '(parse-error error)) +(put 'parse-error 'error-message "Parsing error") + +(defsubst parse-integer (string &optional start end) + "[CL] Parse and return the integer in STRING, or nil if none." + (let ((integer 0) + (digit 0) + (index (or start 0)) + (end (or end (length string)))) + (when (< index end) + (let ((sign (aref string index))) + (if (or (eq sign ?+) (eq sign ?-)) + (setq sign (parse-time-string-chars sign) + index (1+ index)) + (setq sign 1)) + (while (and (< index end) + (setq digit (digit-char-p (aref string index)))) + (setq integer (+ (* integer 10) digit) + index (1+ index))) + (if (/= index end) + (signal 'parse-error `("not an integer" ,(substring string (or start 0) end))) + (* sign integer)))))) + +(defun parse-time-tokenize (string) + "Tokenize STRING into substrings." + (let ((start nil) + (end (length string)) + (all-digits nil) + (list ()) + (index 0) + (c nil)) + (while (< index end) + (while (and (< index end) ;skip invalid characters + (not (setq c (parse-time-string-chars (aref string index))))) + (incf index)) + (setq start index all-digits (eq c ?0)) + (while (and (< (incf index) end) ;scan valid characters + (setq c (parse-time-string-chars (aref string index)))) + (setq all-digits (and all-digits (eq c ?0)))) + (if (<= index end) + (push (if all-digits (parse-integer string start index) + (substring string start index)) + list))) + (nreverse list))) + +(defvar parse-time-months '(("Jan" . 1) ("Feb" . 2) ("Mar" . 3) + ("Apr" . 4) ("May" . 5) ("Jun" . 6) + ("Jul" . 7) ("Aug" . 8) ("Sep" . 9) + ("Oct" . 10) ("Nov" . 11) ("Dec" . 12))) +(defvar parse-time-weekdays '(("Sun" . 0) ("Mon" . 1) ("Tue" . 2) + ("Wed" . 3) ("Thu" . 4) ("Fri" . 5) ("Sat" . 6))) +(defvar parse-time-zoneinfo `(("Z" 0) ("UT" 0) ("GMT" 0) + ("PST" ,(* -8 3600)) ("PDT" ,(* -7 3600) t) + ("MST" ,(* -7 3600)) ("MDT" ,(* -6 3600) t) + ("CST" ,(* -6 3600)) ("CDT" ,(* -5 3600) t) + ("EST" ,(* -5 3600)) ("EDT" ,(* -4 3600) t)) + "(zoneinfo seconds-off daylight-savings-time-p)") + +(defvar parse-time-rules + `(((6) parse-time-weekdays) + ((3) (1 31)) + ((4) parse-time-months) + ((5) (1970 2038)) + ((2 1 0) + ,#'(lambda () (and (stringp elt) + (= (length elt) 8) + (= (aref elt 2) ?:) + (= (aref elt 5) ?:))) + [0 2] [3 5] [6 8]) + ((8 7) parse-time-zoneinfo + ,#'(lambda () (car val)) + ,#'(lambda () (cadr val))) + ((8) + ,#'(lambda () + (and (stringp elt) + (= 5 (length elt)) + (or (= (aref elt 0) ?+) (= (aref elt 0) ?-)))) + ,#'(lambda () (* 60 (+ (parse-integer elt 3 5) + (* 60 (parse-integer elt 1 3))) + (if (= (aref elt 0) ?-) -1 1)))) + ((5 4 3) + ,#'(lambda () (and (stringp elt) (= (length elt) 10) (= (aref elt 4) ?-) (= (aref elt 7) ?-))) + [0 4] [5 7] [8 10]) + ((2 1) + ,#'(lambda () (and (stringp elt) (= (length elt) 5) (= (aref elt 2) ?:))) + [0 2] [3 5]) + ((5) (70 99) ,#'(lambda () (+ 1900 elt)))) + "(slots predicate extractor...)") + +(defun parse-time-string (string) + "Parse the time-string STRING into (SEC MIN HOUR DAY MON YEAR DOW DST TZ). +The values are identical to those of `decode-time', but any values that are +unknown are returned as nil." + (let ((time (list nil nil nil nil nil nil nil nil nil nil)) + (temp (parse-time-tokenize string))) + (while temp + (let ((elt (pop temp)) + (rules parse-time-rules) + (exit nil)) + (while (and (not (null rules)) (not exit)) + (let* ((rule (pop rules)) + (slots (pop rule)) + (predicate (pop rule)) + (val)) + (if (and (not (nth (car slots) time)) ;not already set + (setq val (cond ((and (consp predicate) + (not (eq (car predicate) 'lambda))) + (and (numberp elt) + (<= (car predicate) elt) + (<= elt (cadr predicate)) + elt)) + ((symbolp predicate) + (cdr (assoc elt (symbol-value predicate)))) + ((funcall predicate))))) + (progn + (setq exit t) + (while slots + (let ((new-val (and rule + (let ((this (pop rule))) + (if (vectorp this) + (parse-integer elt (aref this 0) (aref this 1)) + (funcall this)))))) + (rplaca (nthcdr (pop slots) time) (or new-val val)))))))))) + time)) + +(provide 'parse-time) + +;;; parse-time.el ends here diff -r ad457d5f7d04 -r 0293115a14e9 lisp/gnus/pop3.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus/pop3.el Mon Aug 13 08:49:20 2007 +0200 @@ -0,0 +1,430 @@ +;;; pop3.el --- Post Office Protocol (RFC 1460) interface + +;; Copyright (C) 1996, Free Software Foundation, Inc. + +;; Author: Richard L. Pieri +;; Keywords: mail, pop3 +;; Version: 1.3 + +;; 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 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; Most of the standard Post Office Protocol version 3 (RFC 1460) commands +;; are implemented. The LIST command has not been implemented due to lack +;; of actual usefulness. +;; The optional POP3 command TOP has not been implemented. + +;; This program was inspired by Kyle E. Jones's vm-pop program. + +;;; Code: + +(require 'mail-utils) +(provide 'pop3) + +(eval-and-compile + (if (not (fboundp 'md5)) (autoload 'md5 "md5"))) + +(defvar pop3-maildrop (or user-login-name (getenv "LOGNAME") (getenv "USER") nil) + "*POP3 maildrop.") +(defvar pop3-mailhost (or (getenv "MAILHOST") nil) + "*POP3 mailhost.") +(defvar pop3-port 110 + "*POP3 port.") + +(defvar pop3-password-required t + "*Non-nil if a password is required when connecting to POP server.") +(defvar pop3-password nil + "*Password to use when connecting to POP server.") + +(defvar pop3-authentication-scheme 'pass + "*POP3 authentication scheme. Defaults to 'pass, for the standard +USER/PASS authentication. Other valid values are 'apop.") + +(defvar pop3-timestamp nil + "Timestamp returned when initially connected to the POP server. +Used for APOP authentication.") + +(defvar pop3-read-point nil) +(defvar pop3-debug nil) + +(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) + ;; for debugging only + (if pop3-debug (switch-to-buffer (process-buffer process))) + (cond ((equal 'apop pop3-authentication-scheme) + (pop3-apop process pop3-maildrop)) + ((equal 'pass pop3-authentication-scheme) + (pop3-user process pop3-maildrop) + (pop3-pass process)) + (t (error "Invalid POP3 authentication scheme."))) + (setq message-count (car (pop3-stat process))) + (while (<= n message-count) + (message (format "Retrieving message %d of %d from %s..." + n message-count pop3-mailhost)) + (pop3-retr process n crashbuf) + (save-excursion + (set-buffer crashbuf) + (append-to-file (point-min) (point-max) crashbox)) + (pop3-dele process n) + (setq n (+ 1 n))) + (pop3-quit process) + (kill-buffer crashbuf) + ) + ) + +(defun pop3-open-server (mailhost port) + "Open TCP connection to MAILHOST. +Returns the process associated with the connection." + (let ((process-buffer + (get-buffer-create (format "trace of POP session to %s" mailhost))) + (process)) + (save-excursion + (set-buffer process-buffer) + (erase-buffer)) + (setq process + (open-network-stream "POP" process-buffer mailhost port)) + (setq pop3-read-point (point-min)) + (let ((response (pop3-read-response process t))) + (setq pop3-timestamp + (substring response (or (string-match "<" response) 0) + (+ 1 (or (string-match ">" response) -1))))) + 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)) +;; (if (= (aref command 0) ?P) +;; (insert "PASS \r\n") +;; (insert command "\r\n")) + (setq pop3-read-point (point)) + (goto-char (point-max)) + (process-send-string process command) + (process-send-string process "\r\n") + ) + +(defun pop3-read-response (process &optional return) + "Read the response from the server. +Return the response string if optional second argument is non-nil." + (let ((case-fold-search nil) + match-end) + (save-excursion + (set-buffer (process-buffer process)) + (goto-char pop3-read-point) + (while (not (search-forward "\r\n" nil t)) + (accept-process-output process) + (goto-char pop3-read-point)) + (setq match-end (point)) + (goto-char pop3-read-point) + (if (looking-at "-ERR") + (error (buffer-substring (point) (- match-end 2))) + (if (not (looking-at "+OK")) + (progn (setq pop3-read-point match-end) nil) + (setq pop3-read-point match-end) + (if return + (buffer-substring (point) match-end) + t) + ))))) + +(defun pop3-string-to-list (string &optional regexp) + "Chop up a string into a list." + (let ((list) + (regexp (or regexp " ")) + (string (if (string-match "\r" string) + (substring string 0 (match-beginning 0)) + string))) + (store-match-data nil) + (while string + (if (string-match regexp string) + (setq list (cons (substring string 0 (- (match-end 0) 1)) list) + string (substring string (match-end 0))) + (setq list (cons string list) + string nil))) + (nreverse list))) + +(defvar pop3-read-passwd nil) +(defun pop3-read-passwd (prompt) + (if (not pop3-read-passwd) + (if (load "passwd" t) + (setq pop3-read-passwd 'read-passwd) + (autoload 'ange-ftp-read-passwd "ange-ftp") + (setq pop3-read-passwd 'ange-ftp-read-passwd))) + (funcall pop3-read-passwd prompt)) + +(defun pop3-clean-region (start end) + (setq end (set-marker (make-marker) end)) + (save-excursion + (goto-char start) + (while (and (< (point) end) (search-forward "\r\n" end t)) + (replace-match "\n" t t)) + (goto-char start) + (while (and (< (point) end) (re-search-forward "^\\." end t)) + (replace-match "" t t) + (forward-char))) + (set-marker end nil)) + +(defun pop3-munge-message-separator (start end) + "Check to see if a message separator exists. If not, generate one." + (save-excursion + (save-restriction + (narrow-to-region start end) + (goto-char (point-min)) + (if (not (or (looking-at "From .?") ; Unix mail + (looking-at "\001\001\001\001\n") ; MMDF + (looking-at "BABYL OPTIONS:") ; Babyl + )) + (let ((from (mail-strip-quoted-names (mail-fetch-field "From"))) + (date (pop3-string-to-list (mail-fetch-field "Date"))) + (From_)) + ;; sample date formats I have seen + ;; Date: Tue, 9 Jul 1996 09:04:21 -0400 (EDT) + ;; Date: 08 Jul 1996 23:22:24 -0400 + ;; should be + ;; Tue Jul 9 09:04:21 1996 + (setq date + (cond ((string-match "[A-Z]" (nth 0 date)) + (format "%s %s %s %s %s" + (nth 0 date) (nth 2 date) (nth 1 date) + (nth 4 date) (nth 3 date))) + (t + ;; this really needs to be better but I don't feel + ;; like writing a date to day converter. + (format "Sun %s %s %s %s" + (nth 1 date) (nth 0 date) + (nth 3 date) (nth 2 date))) + )) + (setq From_ (format "From %s %s\n" from date)) + (while (string-match "," From_) + (setq From_ (concat (substring From_ 0 (match-beginning 0)) + (substring From_ (match-end 0))))) + (goto-char (point-min)) + (insert From_)))))) + +;; The Command Set + +;; AUTHORIZATION STATE + +(defun pop3-user (process user) + "Send USER information to POP3 server." + (pop3-send-command process (format "USER %s" user)) + (let ((response (pop3-read-response process t))) + (if (not (and response (string-match "+OK" response))) + (error (format "USER %s not valid." user))))) + +(defun pop3-pass (process) + "Send authentication information to the server." + (let ((pass pop3-password)) + (if (and pop3-password-required (not pass)) + (setq pass + (pop3-read-passwd (format "Password for %s: " pop3-maildrop)))) + (if pass + (progn + (pop3-send-command process (format "PASS %s" pass)) + (let ((response (pop3-read-response process t))) + (if (not (and response (string-match "+OK" response))) + (pop3-quit process))))) + )) + +(defun pop3-apop (process user) + "Send alternate authentication information to the server." + (if (not (fboundp 'md5)) (autoload 'md5 "md5")) + (let ((pass pop3-password)) + (if (and pop3-password-required (not pass)) + (setq pass + (pop3-read-passwd (format "Password for %s: " pop3-maildrop)))) + (if pass + (let ((hash (md5 (concat pop3-timestamp pass)))) + (pop3-send-command process (format "APOP %s %s" user hash)) + (let ((response (pop3-read-response process t))) + (if (not (and response (string-match "+OK" response))) + (pop3-quit process))))) + )) + +;; TRANSACTION STATE + +(defun pop3-stat (process) + "Return a list of the number of messages in the maildrop and the size +of the maildrop." + (pop3-send-command process "STAT") + (let ((response (pop3-read-response process t))) + (list (string-to-int (nth 1 (pop3-string-to-list response))) + (string-to-int (nth 2 (pop3-string-to-list response)))) + )) + +(defun pop3-list (process &optional msg) + "Scan listing of available messages. +This function currently does nothing.") + +(defun pop3-retr (process msg crashbuf) + "Retrieve message-id MSG from the server and place the contents in +buffer CRASHBUF." + (pop3-send-command process (format "RETR %s" msg)) + (pop3-read-response process) + (let ((start pop3-read-point) end) + (save-excursion + (set-buffer (process-buffer process)) + (while (not (re-search-forward "^\\.\r\n" nil t)) + (accept-process-output process) + ;; bill@att.com ... to save wear and tear on the heap + (if (> (buffer-size) 20000) (sleep-for 1)) + (if (> (buffer-size) 50000) (sleep-for 1)) + (if (> (buffer-size) 100000) (sleep-for 1)) + (if (> (buffer-size) 200000) (sleep-for 1)) + (if (> (buffer-size) 500000) (sleep-for 1)) + ;; bill@att.com + (goto-char start)) + (setq pop3-read-point (point-marker)) + (goto-char (match-beginning 0)) + (setq end (point-marker)) + (pop3-clean-region start end) + (pop3-munge-message-separator start end) + (save-excursion + (set-buffer crashbuf) + (erase-buffer)) + (copy-to-buffer crashbuf start end) + (delete-region start end) + ))) + +(defun pop3-dele (process msg) + "Mark message-id MSG as deleted." + (pop3-send-command process (format "DELE %s" msg)) + (pop3-read-response process)) + +(defun pop3-noop (process msg) + "No-operation." + (pop3-send-command process "NOOP") + (pop3-read-response process)) + +(defun pop3-last (process) + "Return highest accessed message-id number for the session." + (pop3-send-command process "LAST") + (let ((response (pop3-read-response process t))) + (string-to-int (nth 1 (pop3-string-to-list response))) + )) + +(defun pop3-rset (process) + "Remove all delete marks from current maildrop." + (pop3-send-command process "RSET") + (pop3-read-response process)) + +;; UPDATE + +(defun pop3-quit (process) + "Tell server to remove all messages marked as deleted, unlock the +maildrop, and close the connection." + (pop3-send-command process "QUIT") + (pop3-read-response process t) + (if process + (save-excursion + (set-buffer (process-buffer process)) + (goto-char (point-max)) + (delete-process process)))) + +;; Summary of POP3 (Post Office Protocol version 3) commands and responses + +;;; AUTHORIZATION STATE + +;; Initial TCP connection +;; Arguments: none +;; Restrictions: none +;; Possible responses: +;; +OK [POP3 server ready] + +;; USER name +;; Arguments: a server specific user-id (required) +;; Restrictions: authorization state [after unsuccessful USER or PASS +;; Possible responses: +;; +OK [valid user-id] +;; -ERR [invalid user-id] + +;; PASS string +;; Arguments: a server/user-id specific password (required) +;; Restrictions: authorization state, after successful USER +;; Possible responses: +;; +OK [maildrop locked and ready] +;; -ERR [invalid password] +;; -ERR [unable to lock maildrop] + +;;; TRANSACTION STATE + +;; STAT +;; Arguments: none +;; Restrictions: transaction state +;; Possible responses: +;; +OK nn mm [# of messages, size of maildrop] + +;; LIST [msg] +;; Arguments: a message-id (optional) +;; Restrictions: transaction state; msg must not be deleted +;; Possible responses: +;; +OK [scan listing follows] +;; -ERR [no such message] + +;; RETR msg +;; Arguments: a message-id (required) +;; Restrictions: transaction state; msg must not be deleted +;; Possible responses: +;; +OK [message contents follow] +;; -ERR [no such message] + +;; DELE msg +;; Arguments: a message-id (required) +;; Restrictions: transaction state; msg must not be deleted +;; Possible responses: +;; +OK [message deleted] +;; -ERR [no such message] + +;; NOOP +;; Arguments: none +;; Restrictions: transaction state +;; Possible responses: +;; +OK + +;; LAST +;; Arguments: none +;; Restrictions: transaction state +;; Possible responses: +;; +OK nn [highest numbered message accessed] + +;; RSET +;; Arguments: none +;; Restrictions: transaction state +;; Possible responses: +;; +OK [all delete marks removed] + +;;; UPDATE STATE + +;; QUIT +;; Arguments: none +;; Restrictions: none +;; Possible responses: +;; +OK [TCP connection closed] diff -r ad457d5f7d04 -r 0293115a14e9 lisp/gnus/score-mode.el --- a/lisp/gnus/score-mode.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/gnus/score-mode.el Mon Aug 13 08:49:20 2007 +0200 @@ -54,8 +54,7 @@ (interactive) (kill-all-local-variables) (use-local-map gnus-score-mode-map) - (when menu-bar-mode - (gnus-score-make-menu-bar)) + (gnus-score-make-menu-bar) (set-syntax-table emacs-lisp-mode-syntax-table) (setq major-mode 'gnus-score-mode) (setq mode-name "Score") diff -r ad457d5f7d04 -r 0293115a14e9 lisp/gnus/smiley.el --- a/lisp/gnus/smiley.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/gnus/smiley.el Mon Aug 13 08:49:20 2007 +0200 @@ -1,5 +1,5 @@ ;;; smiley.el --- displaying smiley faces -;; Copyright (C) 1996 Free Software Foundation, Inc. +;; Copyright (C) 1996,97 Free Software Foundation, Inc. ;; Author: Wes Hardaker ;; Keywords: fun @@ -33,18 +33,25 @@ ;; (require 'smiley) ;; (add-hook 'gnus-article-display-hook 'gnus-smiley-display t) -;; The smilies were drawn by Joe Reiss . +;; The smilies were drawn by Joe Reiss . (require 'annotations) (require 'messagexmas) -(eval-when-compile (require 'cl)) +(require 'cl) +(require 'custom) + +(defgroup smiley nil + "Turn :-)'s into real images (XEmacs)." + :group 'gnus-visual) -(defvar smiley-data-directory (message-xmas-find-glyph-directory "smilies") - "Location of the smiley faces files.") +(defcustom smiley-data-directory (message-xmas-find-glyph-directory "smilies") + "Location of the smiley faces files." + :type 'directory + :group 'smiley) -;; Notice the subtle differences in the regular expessions in the two alists below +;; Notice the subtle differences in the regular expressions in the two alists below -(defvar smiley-deformed-regexp-alist +(defcustom smiley-deformed-regexp-alist '(("\\(:-*[<«]+\\)\\W" 1 "FaceAngry.xpm") ("\\(:-+\\]+\\)\\W" 1 "FaceGoofy.xpm") ("\\(:-*D\\)\\W" 1 "FaceGrinning.xpm") @@ -58,16 +65,20 @@ ("\\(:-*p\\)\\W" 1 "FaceTalking.xpm") ("\\(:-*d\\)\\W" 1 "FaceTasty.xpm") ("\\(;-*[>)}»]+\\)\\W" 1 "FaceWinking.xpm") - ("\\(:-*[Vvµ]\\)\\W" 1 "FaceWry.xpm") + ("\\(:-*[Vvµ]\\)\\W" 1 "FaceWry.xpm") ("\\([:|]-*P\\)\\W" 1 "FaceYukky.xpm")) - "Normal and deformed faces for smilies.") + "Normal and deformed faces for smilies." + :type '(repeat (list regexp + (integer :tag "Match") + (string :tag "Image"))) + :group 'smiley) -(defvar smiley-nosey-regexp-alist +(defcustom smiley-nosey-regexp-alist '(("\\(:-+[<«]+\\)\\W" 1 "FaceAngry.xpm") ("\\(:-+\\]+\\)\\W" 1 "FaceGoofy.xpm") ("\\(:-+D\\)\\W" 1 "FaceGrinning.xpm") ("\\(:-+[}»]+\\)\\W" 1 "FaceHappy.xpm") - ("\\(:-*)+\\)\\W" 1 "FaceHappy.xpm") ;; The exception that confirms the rule + ("\\(:-*)+\\)\\W" 1 "FaceHappy.xpm") ("\\(:-+[/\\\"]+\\)\\W" 1 "FaceIronic.xpm") ("\\([8|]-+[|Oo%]\\)\\W" 1 "FaceKOed.xpm") ("\\([:|]-+#+\\)\\W" 1 "FaceNyah.xpm") @@ -78,30 +89,65 @@ ("\\(:-+d\\)\\W" 1 "FaceTasty.xpm") ("\\(;-+[>)}»]+\\)\\W" 1 "FaceWinking.xpm") ("\\(:-+[Vvµ]\\)\\W" 1 "FaceWry.xpm") + ("\\(][:8B]-[)>]\\)\\W" 1 "FaceDevilish.xpm") ("\\([:|]-+P\\)\\W" 1 "FaceYukky.xpm")) - "Smileys with noses. These get less false matches.") + "Smileys with noses. These get less false matches." + :type '(repeat (list regexp + (integer :tag "Match") + (string :tag "Image"))) + :group 'smiley) -(defvar smiley-regexp-alist smiley-deformed-regexp-alist +(defcustom smiley-regexp-alist smiley-deformed-regexp-alist "A list of regexps to map smilies to real images. Defaults to the content of smiley-deformed-regexp-alist. -An alternative smiley-nose-regexp-alist that -matches less aggresively is available.") +An alternative smiley-nosey-regexp-alist that +matches less aggressively is available. +If this is a symbol, take its value." + :type '(radio (variable-item smiley-deformed-regexp-alist) + (variable-item smiley-nosey-regexp-alist) + symbol + (repeat (list regexp + (integer :tag "Match") + (string :tag "Image")))) + :group 'smiley) -(defvar smiley-flesh-color "yellow" - "Flesh color.") +(defcustom smiley-flesh-color "yellow" + "Flesh color." + :type 'string + :group 'smiley) -(defvar smiley-features-color "black" - "Features color.") +(defcustom smiley-features-color "black" + "Features color." + :type 'string + :group 'smiley) + +(defcustom smiley-tongue-color "red" + "Tongue color." + :type 'string + :group 'smiley) -(defvar smiley-tongue-color "red" - "Tongue color.") +(defcustom smiley-circle-color "black" + "Circle color." + :type 'string + :group 'smiley) -(defvar smiley-circle-color "black" - "Circle color.") +(defcustom smiley-mouse-face 'highlight + "Face used for mouse highlighting in the smiley buffer. + +Smiley buttons will be displayed in this face when the cursor is +above them." + :type 'face + :group 'smiley) + (defvar smiley-glyph-cache nil) (defvar smiley-running-xemacs (string-match "XEmacs" emacs-version)) +(defvar smiley-map (make-sparse-keymap "smiley-keys") + "keymap to toggle smiley states") + +(define-key smiley-map [(button2)] 'smiley-toggle-extent) + (defun smiley-create-glyph (smiley pixmap) (and smiley-running-xemacs @@ -127,6 +173,23 @@ (interactive "r") (smiley-buffer (current-buffer) beg end)) +(defun smiley-toggle-extent (event) + "Toggle smiley at given point" + (interactive "e") + (let* ((ant (event-glyph-extent event)) + (pt (event-closest-point event)) + ext) + (if (annotationp ant) + (when (extentp (setq ext (extent-property ant 'smiley-extent))) + (set-extent-property ext 'invisible nil) + (hide-annotation ant)) + (when pt + (while (setq ext (extent-at pt (event-buffer event) nil ext 'at)) + (when (annotationp (setq ant + (extent-property ext 'smiley-annotation))) + (reveal-annotation ant) + (set-extent-property ext 'invisible t))))))) + ;;;###autoload (defun smiley-buffer (&optional buffer st nd) (interactive) @@ -135,7 +198,9 @@ (when buffer (set-buffer buffer)) (let ((buffer-read-only nil) - (alist smiley-regexp-alist) + (alist (if (symbolp smiley-regexp-alist) + (symbol-value smiley-regexp-alist) + smiley-regexp-alist)) entry regexp beg group file) (goto-char (or st (point-min))) (setq beg (point)) @@ -152,11 +217,21 @@ file))) (when glyph (mapcar 'delete-annotation (annotations-at end)) - (let ((ext (make-extent start end))) - (set-extent-property ext 'invisible t) + (let ((ext (make-extent start end)) + (ant (make-annotation glyph end 'text))) + ;; set text extent params (set-extent-property ext 'end-open t) - (set-extent-property ext 'intangible t)) - (make-annotation glyph end 'text) + (set-extent-property ext 'start-open t) + (set-extent-property ext 'invisible t) + (set-extent-property ext 'keymap smiley-map) + (set-extent-property ext 'mouse-face 'smiley-mouse-face) + (set-extent-property ext 'intangible t) + ;; set annotation params + (set-extent-property ant 'mouse-face 'smiley-mouse-face) + (set-extent-property ant 'keymap smiley-map) + ;; remember each other + (set-extent-property ant 'smiley-extent ext) + (set-extent-property ext 'smiley-annotation ant)) (when (smiley-end-paren-p start end) (make-annotation ")" end 'text)) (goto-char end))))))))) diff -r ad457d5f7d04 -r 0293115a14e9 lisp/gnus/widget-edit.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus/widget-edit.el Mon Aug 13 08:49:20 2007 +0200 @@ -0,0 +1,2127 @@ +;;; widget-edit.el --- Functions for creating and using widgets. +;; +;; Copyright (C) 1996 Free Software Foundation, Inc. +;; +;; Author: Per Abrahamsen +;; Keywords: extensions +;; Version: 1.20 +;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ + +;;; Commentary: +;; +;; See `widget.el'. + +;;; Code: + +(require 'widget) +(require 'cl) +(autoload 'pp-to-string "pp") +(autoload 'Info-goto-node "info") + +(if (string-match "XEmacs" emacs-version) + ;; XEmacs spell `intangible' as `atomic'. + (defun widget-make-intangible (from to side) + "Make text between FROM and TO atomic with regard to movement. +Third argument should be `start-open' if it should be sticky to the rear, +and `end-open' if it should sticky to the front." + (require 'atomic-extents) + (let ((ext (make-extent from to))) + ;; XEmacs doesn't understant different kinds of read-only, so + ;; we have to use extents instead. + (put-text-property from to 'read-only nil) + (set-extent-property ext 'read-only t) + (set-extent-property ext 'start-open nil) + (set-extent-property ext 'end-open nil) + (set-extent-property ext side t) + (set-extent-property ext 'atomic t))) + (defun widget-make-intangible (from to size) + "Make text between FROM and TO intangible." + (put-text-property from to 'intangible 'front))) + +;; The following should go away when bundled with Emacs. +(eval-and-compile + (condition-case () + (require 'custom) + (error nil)) + + (unless (and (featurep 'custom) (fboundp 'custom-declare-variable)) + ;; We have the old custom-library, hack around it! + (defmacro defgroup (&rest args) nil) + (defmacro defcustom (&rest args) nil) + (defmacro defface (&rest args) nil) + (when (fboundp 'copy-face) + (copy-face 'default 'widget-documentation-face) + (copy-face 'bold 'widget-button-face) + (copy-face 'italic 'widget-field-face)) + (defvar widget-mouse-face 'highlight) + (defvar widget-menu-max-size 40))) + +;;; Compatibility. + +(unless (fboundp 'event-point) + ;; XEmacs function missing in Emacs. + (defun event-point (event) + "Return the character position of the given mouse-motion, button-press, +or button-release event. If the event did not occur over a window, or did +not occur over text, then this returns nil. Otherwise, it returns an index +into the buffer visible in the event's window." + (posn-point (event-start event)))) + +(unless (fboundp 'error-message-string) + ;; Emacs function missing in XEmacs. + (defun error-message-string (obj) + "Convert an error value to an error message." + (let ((buf (get-buffer-create " *error-message*"))) + (erase-buffer buf) + (funcall (intern "display-error") obj buf) + (buffer-string buf)))) + +;;; Customization. + +(defgroup widgets nil + "Customization support for the Widget Library." + :link '(custom-manual "(widget)Top") + :link '(url-link :tag "Development Page" + "http://www.dina.kvl.dk/~abraham/custom/") + :prefix "widget-" + :group 'emacs) + +(defface widget-documentation-face '((((class color) + (background dark)) + (:foreground "lime green")) + (((class color) + (background light)) + (:foreground "dark green")) + (t nil)) + "Face used for documentation text." + :group 'widgets) + +(defface widget-button-face '((t (:bold t))) + "Face used for widget buttons." + :group 'widgets) + +(defcustom widget-mouse-face 'highlight + "Face used for widget buttons when the mouse is above them." + :type 'face + :group 'widgets) + +(defface widget-field-face '((((class grayscale color) + (background light)) + (:background "light gray")) + (((class grayscale color) + (background dark)) + (:background "dark gray")) + (t + (:italic t))) + "Face used for editable fields." + :group 'widgets) + +(defcustom widget-menu-max-size 40 + "Largest number of items allowed in a popup-menu. +Larger menus are read through the minibuffer." + :group 'widgets + :type 'integer) + +;;; Utility functions. +;; +;; These are not really widget specific. + +(defun widget-plist-member (plist prop) + ;; Return non-nil if PLIST has the property PROP. + ;; PLIST is a property list, which is a list of the form + ;; (PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol. + ;; Unlike `plist-get', this allows you to distinguish between a missing + ;; property and a property with the value nil. + ;; The value is actually the tail of PLIST whose car is PROP. + (while (and plist (not (eq (car plist) prop))) + (setq plist (cdr (cdr plist)))) + plist) + +(defun widget-princ-to-string (object) + ;; Return string representation of OBJECT, any Lisp object. + ;; No quoting characters are used; no delimiters are printed around + ;; the contents of strings. + (save-excursion + (set-buffer (get-buffer-create " *widget-tmp*")) + (erase-buffer) + (let ((standard-output (current-buffer))) + (princ object)) + (buffer-string))) + +(defun widget-clear-undo () + "Clear all undo information." + (buffer-disable-undo (current-buffer)) + (buffer-enable-undo)) + +(defun widget-choose (title items &optional event) + "Choose an item from a list. + +First argument TITLE is the name of the list. +Second argument ITEMS is an alist (NAME . VALUE). +Optional third argument EVENT is an input event. + +The user is asked to choose between each NAME from the items alist, +and the VALUE of the chosen element will be returned. If EVENT is a +mouse event, and the number of elements in items is less than +`widget-menu-max-size', a popup menu will be used, otherwise the +minibuffer." + (cond ((and (< (length items) widget-menu-max-size) + event (fboundp 'x-popup-menu) window-system) + ;; We are in Emacs-19, pressed by the mouse + (x-popup-menu event + (list title (cons "" items)))) + ((and (< (length items) widget-menu-max-size) + event (fboundp 'popup-menu) window-system) + ;; We are in XEmacs, pressed by the mouse + (let ((val (get-popup-menu-response + (cons "" + (mapcar + (function + (lambda (x) + (vector (car x) (list (car x)) t))) + items))))) + (setq val (and val + (listp (event-object val)) + (stringp (car-safe (event-object val))) + (car (event-object val)))) + (cdr (assoc val items)))) + (t + (cdr (assoc (completing-read (concat title ": ") + items nil t) + items))))) + +;;; Widget text specifications. +;; +;; These functions are for specifying text properties. + +(defun widget-specify-none (from to) + ;; Clear all text properties between FROM and TO. + (set-text-properties from to nil)) + +(defun widget-specify-text (from to) + ;; Default properties. + (add-text-properties from to (list 'read-only t + 'front-sticky t + 'start-open t + 'end-open t + 'rear-nonsticky nil))) + +(defun widget-specify-field (widget from to) + ;; Specify editable button for WIDGET between FROM and TO. + (widget-specify-field-update widget from to) + + ;; Make it possible to edit the front end of the field. + (add-text-properties (1- from) from (list 'rear-nonsticky t + 'end-open t + 'invisible t)) + (when (or (string-match "\\(.\\|\n\\)%v" (widget-get widget :format)) + (widget-get widget :hide-front-space)) + ;; WARNING: This is going to lose horrible if the character just + ;; before the field can be modified (e.g. if it belongs to a + ;; choice widget). We try to compensate by checking the format + ;; string, and hope the user hasn't changed the :create method. + (widget-make-intangible (- from 2) from 'end-open)) + + ;; Make it possible to edit back end of the field. + (add-text-properties to (1+ to) (list 'front-sticky nil + 'read-only t + 'start-open t)) + + (cond ((widget-get widget :size) + (put-text-property to (1+ to) 'invisible t) + (when (or (string-match "%v\\(.\\|\n\\)" (widget-get widget :format)) + (widget-get widget :hide-rear-space)) + ;; WARNING: This is going to lose horrible if the character just + ;; after the field can be modified (e.g. if it belongs to a + ;; choice widget). We try to compensate by checking the format + ;; string, and hope the user hasn't changed the :create method. + (widget-make-intangible to (+ to 2) 'start-open))) + ((string-match "XEmacs" emacs-version) + ;; XEmacs does not allow you to insert before a read-only + ;; character, even if it is start.open. + ;; XEmacs does allow you to delete an read-only extent, so + ;; making the terminating newline read only doesn't help. + ;; I tried putting an invisible intangible read-only space + ;; before the newline, which gave really weird effects. + ;; So for now, we just have trust the user not to delete the + ;; newline. + (put-text-property to (1+ to) 'read-only nil)))) + +(defun widget-specify-field-update (widget from to) + ;; Specify editable button for WIDGET between FROM and TO. + (let ((map (or (widget-get widget :keymap) + widget-keymap)) + (face (or (widget-get widget :value-face) + 'widget-field-face))) + (set-text-properties from to (list 'field widget + 'read-only nil + 'keymap map + 'local-map map + 'face face)) + (unless (widget-get widget :size) + (add-text-properties to (1+ to) (list 'field widget + 'face face + 'local-map map + 'keymap map))))) + +(defun widget-specify-button (widget from to) + ;; Specify button for WIDGET between FROM and TO. + (let ((face (widget-apply widget :button-face-get))) + (add-text-properties from to (list 'button widget + 'mouse-face widget-mouse-face + 'start-open t + 'end-open t + 'face face)))) + +(defun widget-specify-sample (widget from to) + ;; Specify sample for WIDGET between FROM and TO. + (let ((face (widget-apply widget :sample-face-get))) + (when face + (add-text-properties from to (list 'start-open t + 'end-open t + 'face face))))) + +(defun widget-specify-doc (widget from to) + ;; Specify documentation for WIDGET between FROM and TO. + (add-text-properties from to (list 'widget-doc widget + 'face 'widget-documentation-face))) + +(defmacro widget-specify-insert (&rest form) + ;; Execute FORM without inheriting any text properties. + `(save-restriction + (let ((inhibit-read-only t) + result + after-change-functions) + (insert "<>") + (narrow-to-region (- (point) 2) (point)) + (widget-specify-none (point-min) (point-max)) + (goto-char (1+ (point-min))) + (setq result (progn ,@form)) + (delete-region (point-min) (1+ (point-min))) + (delete-region (1- (point-max)) (point-max)) + (goto-char (point-max)) + result))) + +;;; Widget Properties. + +(defun widget-put (widget property value) + "In WIDGET set PROPERTY to VALUE. +The value can later be retrived with `widget-get'." + (setcdr widget (plist-put (cdr widget) property value))) + +(defun widget-get (widget property) + "In WIDGET, get the value of PROPERTY. +The value could either be specified when the widget was created, or +later with `widget-put'." + (cond ((widget-plist-member (cdr widget) property) + (plist-get (cdr widget) property)) + ((car widget) + (widget-get (get (car widget) 'widget-type) property)) + (t nil))) + +(defun widget-member (widget property) + "Non-nil iff there is a definition in WIDGET for PROPERTY." + (cond ((widget-plist-member (cdr widget) property) + t) + ((car widget) + (widget-member (get (car widget) 'widget-type) property)) + (t nil))) + +(defun widget-apply (widget property &rest args) + "Apply the value of WIDGET's PROPERTY to the widget itself. +ARGS are passed as extra argments to the function." + (apply (widget-get widget property) widget args)) + +(defun widget-value (widget) + "Extract the current value of WIDGET." + (widget-apply widget + :value-to-external (widget-apply widget :value-get))) + +(defun widget-value-set (widget value) + "Set the current value of WIDGET to VALUE." + (widget-apply widget + :value-set (widget-apply widget + :value-to-internal value))) + +(defun widget-match-inline (widget vals) + ;; In WIDGET, match the start of VALS. + (cond ((widget-get widget :inline) + (widget-apply widget :match-inline vals)) + ((and vals + (widget-apply widget :match (car vals))) + (cons (list (car vals)) (cdr vals))) + (t nil))) + +;;; Creating Widgets. + +;;;###autoload +(defun widget-create (type &rest args) + "Create widget of TYPE. +The optional ARGS are additional keyword arguments." + (let ((widget (apply 'widget-convert type args))) + (widget-apply widget :create) + widget)) + +(defun widget-create-child-and-convert (parent type &rest args) + "As part of the widget PARENT, create a child widget TYPE. +The child is converted, using the keyword arguments ARGS." + (let ((widget (apply 'widget-convert type args))) + (widget-put widget :parent parent) + (unless (widget-get widget :indent) + (widget-put widget :indent (+ (or (widget-get parent :indent) 0) + (or (widget-get widget :extra-offset) 0) + (widget-get parent :offset)))) + (widget-apply widget :create) + widget)) + +(defun widget-create-child (parent type) + "Create widget of TYPE." + (let ((widget (copy-list type))) + (widget-put widget :parent parent) + (unless (widget-get widget :indent) + (widget-put widget :indent (+ (or (widget-get parent :indent) 0) + (or (widget-get widget :extra-offset) 0) + (widget-get parent :offset)))) + (widget-apply widget :create) + widget)) + +(defun widget-create-child-value (parent type value) + "Create widget of TYPE with value VALUE." + (let ((widget (copy-list type))) + (widget-put widget :value (widget-apply widget :value-to-internal value)) + (widget-put widget :parent parent) + (unless (widget-get widget :indent) + (widget-put widget :indent (+ (or (widget-get parent :indent) 0) + (or (widget-get widget :extra-offset) 0) + (widget-get parent :offset)))) + (widget-apply widget :create) + widget)) + +;;;###autoload +(defun widget-delete (widget) + "Delete WIDGET." + (widget-apply widget :delete)) + +(defun widget-convert (type &rest args) + "Convert TYPE to a widget without inserting it in the buffer. +The optional ARGS are additional keyword arguments." + ;; Don't touch the type. + (let* ((widget (if (symbolp type) + (list type) + (copy-list type))) + (current widget) + (keys args)) + ;; First set the :args keyword. + (while (cdr current) ;Look in the type. + (let ((next (car (cdr current)))) + (if (and (symbolp next) (eq (aref (symbol-name next) 0) ?:)) + (setq current (cdr (cdr current))) + (setcdr current (list :args (cdr current))) + (setq current nil)))) + (while args ;Look in the args. + (let ((next (nth 0 args))) + (if (and (symbolp next) (eq (aref (symbol-name next) 0) ?:)) + (setq args (nthcdr 2 args)) + (widget-put widget :args args) + (setq args nil)))) + ;; Then Convert the widget. + (setq type widget) + (while type + (let ((convert-widget (plist-get (cdr type) :convert-widget))) + (if convert-widget + (setq widget (funcall convert-widget widget)))) + (setq type (get (car type) 'widget-type))) + ;; Finally set the keyword args. + (while keys + (let ((next (nth 0 keys))) + (if (and (symbolp next) (eq (aref (symbol-name next) 0) ?:)) + (progn + (widget-put widget next (nth 1 keys)) + (setq keys (nthcdr 2 keys))) + (setq keys nil)))) + ;; Convert the :value to internal format. + (if (widget-member widget :value) + (let ((value (widget-get widget :value))) + (widget-put widget + :value (widget-apply widget :value-to-internal value)))) + ;; Return the newly create widget. + widget)) + +(defun widget-insert (&rest args) + "Call `insert' with ARGS and make the text read only." + (let ((inhibit-read-only t) + after-change-functions + (from (point))) + (apply 'insert args) + (widget-specify-text from (point)))) + +;;; Keymap and Comands. + +(defvar widget-keymap nil + "Keymap containing useful binding for buffers containing widgets. +Recommended as a parent keymap for modes using widgets.") + +(if widget-keymap + () + (setq widget-keymap (make-sparse-keymap)) + (set-keymap-parent widget-keymap global-map) + (define-key widget-keymap "\t" 'widget-forward) + (define-key widget-keymap "\M-\t" 'widget-backward) + (define-key widget-keymap [(shift tab)] 'widget-backward) + (define-key widget-keymap [(shift tab)] 'widget-backward) + (define-key widget-keymap [backtab] 'widget-backward) + (if (string-match "XEmacs" (emacs-version)) + (define-key widget-keymap [button2] 'widget-button-click) + (define-key widget-keymap [menu-bar] 'nil) + (define-key widget-keymap [mouse-2] 'widget-button-click)) + (define-key widget-keymap "\C-m" 'widget-button-press)) + +(defvar widget-global-map global-map + "Keymap used for events the widget does not handle themselves.") +(make-variable-buffer-local 'widget-global-map) + +(defun widget-button-click (event) + "Activate button below mouse pointer." + (interactive "@e") + (widget-button-press (event-point event) event)) + +(defun widget-button-press (pos &optional event) + "Activate button at POS." + (interactive "@d") + (let* ((button (get-text-property pos 'button))) + (if button + (widget-apply button :action event) + (call-interactively + (lookup-key widget-global-map (this-command-keys)))))) + +(defun widget-move (arg) + "Move point to the ARG next field or button. +ARG may be negative to move backward." + (while (> arg 0) + (setq arg (1- arg)) + (let ((next (cond ((get-text-property (point) 'button) + (next-single-property-change (point) 'button)) + ((get-text-property (point) 'field) + (next-single-property-change (point) 'field)) + (t + (point))))) + (if (null next) ; Widget extends to end. of buffer + (setq next (point-min))) + (let ((button (next-single-property-change next 'button)) + (field (next-single-property-change next 'field))) + (cond ((or (get-text-property next 'button) + (get-text-property next 'field)) + (goto-char next)) + ((and button field) + (goto-char (min button field))) + (button (goto-char button)) + (field (goto-char field)) + (t + (let ((button (next-single-property-change (point-min) 'button)) + (field (next-single-property-change (point-min) 'field))) + (cond ((and button field) (goto-char (min button field))) + (button (goto-char button)) + (field (goto-char field)) + (t + (error "No buttons or fields found"))))))))) + (while (< arg 0) + (if (= (point-min) (point)) + (forward-char 1)) + (setq arg (1+ arg)) + (let ((previous (cond ((get-text-property (1- (point)) 'button) + (previous-single-property-change (point) 'button)) + ((get-text-property (1- (point)) 'field) + (previous-single-property-change (point) 'field)) + (t + (point))))) + (if (null previous) ; Widget extends to beg. of buffer + (setq previous (point-max))) + (let ((button (previous-single-property-change previous 'button)) + (field (previous-single-property-change previous 'field))) + (cond ((and button field) + (goto-char (max button field))) + (button (goto-char button)) + (field (goto-char field)) + (t + (let ((button (previous-single-property-change + (point-max) 'button)) + (field (previous-single-property-change + (point-max) 'field))) + (cond ((and button field) (goto-char (max button field))) + (button (goto-char button)) + (field (goto-char field)) + (t + (error "No buttons or fields found")))))))) + (let ((button (previous-single-property-change (point) 'button)) + (field (previous-single-property-change (point) 'field))) + (cond ((and button field) + (goto-char (max button field))) + (button (goto-char button)) + (field (goto-char field))))) + (widget-echo-help (point)) + (run-hooks 'widget-move-hook)) + +(defun widget-forward (arg) + "Move point to the next field or button. +With optional ARG, move across that many fields." + (interactive "p") + (run-hooks 'widget-forward-hook) + (widget-move arg)) + +(defun widget-backward (arg) + "Move point to the previous field or button. +With optional ARG, move across that many fields." + (interactive "p") + (run-hooks 'widget-backward-hook) + (widget-move (- arg))) + +;;; Setting up the buffer. + +(defvar widget-field-new nil) +;; List of all newly created editable fields in the buffer. +(make-variable-buffer-local 'widget-field-new) + +(defvar widget-field-list nil) +;; List of all editable fields in the buffer. +(make-variable-buffer-local 'widget-field-list) + +(defun widget-setup () + "Setup current buffer so editing string widgets works." + (let ((inhibit-read-only t) + (after-change-functions nil) + field) + (while widget-field-new + (setq field (car widget-field-new) + widget-field-new (cdr widget-field-new) + widget-field-list (cons field widget-field-list)) + (let ((from (widget-get field :value-from)) + (to (widget-get field :value-to))) + (widget-specify-field field from to) + (move-marker from (1- from)) + (move-marker to (1+ to))))) + (widget-clear-undo) + ;; We need to maintain text properties and size of the editing fields. + (make-local-variable 'after-change-functions) + (if widget-field-list + (setq after-change-functions '(widget-after-change)) + (setq after-change-functions nil))) + +(defvar widget-field-last nil) +;; Last field containing point. +(make-variable-buffer-local 'widget-field-last) + +(defvar widget-field-was nil) +;; The widget data before the change. +(make-variable-buffer-local 'widget-field-was) + +(defun widget-field-find (pos) + ;; Find widget whose editing field is located at POS. + ;; Return nil if POS is not inside and editing field. + ;; + ;; This is only used in `widget-field-modified', since ordinarily + ;; you would just test the field property. + (let ((fields widget-field-list) + field found) + (while fields + (setq field (car fields) + fields (cdr fields)) + (let ((from (widget-get field :value-from)) + (to (widget-get field :value-to))) + (if (and from to (< from pos) (> to pos)) + (setq fields nil + found field)))) + found)) + +(defun widget-after-change (from to old) + ;; Adjust field size and text properties. + (condition-case nil + (let ((field (widget-field-find from)) + (inhibit-read-only t)) + (cond ((null field)) + ((not (eq field (widget-field-find to))) + (debug) + (message "Error: `widget-after-change' called on two fields")) + (t + (let ((size (widget-get field :size))) + (if size + (let ((begin (1+ (widget-get field :value-from))) + (end (1- (widget-get field :value-to)))) + (widget-specify-field-update field begin end) + (cond ((< (- end begin) size) + ;; Field too small. + (save-excursion + (goto-char end) + (insert-char ?\ (- (+ begin size) end)) + (widget-specify-field-update field + begin + (+ begin size)))) + ((> (- end begin) size) + ;; Field too large and + (if (or (< (point) (+ begin size)) + (> (point) end)) + ;; Point is outside extra space. + (setq begin (+ begin size)) + ;; Point is within the extra space. + (setq begin (point))) + (save-excursion + (goto-char end) + (while (and (eq (preceding-char) ?\ ) + (> (point) begin)) + (delete-backward-char 1)))))) + (widget-specify-field-update field from to))) + (widget-apply field :notify field)))) + (error (debug)))) + +;;; Widget Functions +;; +;; These functions are used in the definition of multiple widgets. + +(defun widget-children-value-delete (widget) + "Delete all :children and :buttons in WIDGET." + (mapcar 'widget-delete (widget-get widget :children)) + (widget-put widget :children nil) + (mapcar 'widget-delete (widget-get widget :buttons)) + (widget-put widget :buttons nil)) + +(defun widget-types-convert-widget (widget) + "Convert :args as widget types in WIDGET." + (widget-put widget :args (mapcar 'widget-convert (widget-get widget :args))) + widget) + +;;; The `default' Widget. + +(define-widget 'default nil + "Basic widget other widgets are derived from." + :value-to-internal (lambda (widget value) value) + :value-to-external (lambda (widget value) value) + :create 'widget-default-create + :indent nil + :offset 0 + :format-handler 'widget-default-format-handler + :button-face-get 'widget-default-button-face-get + :sample-face-get 'widget-default-sample-face-get + :delete 'widget-default-delete + :value-set 'widget-default-value-set + :value-inline 'widget-default-value-inline + :menu-tag-get 'widget-default-menu-tag-get + :validate (lambda (widget) nil) + :action 'widget-default-action + :notify 'widget-default-notify) + +(defun widget-default-create (widget) + "Create WIDGET at point in the current buffer." + (widget-specify-insert + (let ((from (point)) + (tag (widget-get widget :tag)) + (doc (widget-get widget :doc)) + button-begin button-end + sample-begin sample-end + doc-begin doc-end + value-pos) + (insert (widget-get widget :format)) + (goto-char from) + ;; Parse % escapes in format. + (while (re-search-forward "%\\(.\\)" nil t) + (let ((escape (aref (match-string 1) 0))) + (replace-match "" t t) + (cond ((eq escape ?%) + (insert "%")) + ((eq escape ?\[) + (setq button-begin (point))) + ((eq escape ?\]) + (setq button-end (point))) + ((eq escape ?\{) + (setq sample-begin (point))) + ((eq escape ?\}) + (setq sample-end (point))) + ((eq escape ?n) + (when (widget-get widget :indent) + (insert "\n") + (insert-char ? (widget-get widget :indent)))) + ((eq escape ?t) + (if tag + (insert tag) + (let ((standard-output (current-buffer))) + (princ (widget-get widget :value))))) + ((eq escape ?d) + (when doc + (setq doc-begin (point)) + (insert doc) + (while (eq (preceding-char) ?\n) + (delete-backward-char 1)) + (insert "\n") + (setq doc-end (point)))) + ((eq escape ?v) + (if (and button-begin (not button-end)) + (widget-apply widget :value-create) + (setq value-pos (point)))) + (t + (widget-apply widget :format-handler escape))))) + ;; Specify button, sample, and doc, and insert value. + (and button-begin button-end + (widget-specify-button widget button-begin button-end)) + (and sample-begin sample-end + (widget-specify-sample widget sample-begin sample-end)) + (and doc-begin doc-end + (widget-specify-doc widget doc-begin doc-end)) + (when value-pos + (goto-char value-pos) + (widget-apply widget :value-create))) + (let ((from (copy-marker (point-min))) + (to (copy-marker (point-max)))) + (widget-specify-text from to) + (set-marker-insertion-type from t) + (set-marker-insertion-type to nil) + (widget-put widget :from from) + (widget-put widget :to to)))) + +(defun widget-default-format-handler (widget escape) + ;; We recognize the %h escape by default. + (let* ((buttons (widget-get widget :buttons)) + (doc-property (widget-get widget :documentation-property)) + (doc-try (cond ((widget-get widget :doc)) + ((symbolp doc-property) + (documentation-property (widget-get widget :value) + doc-property)) + (t + (funcall doc-property (widget-get widget :value))))) + (doc-text (and (stringp doc-try) + (> (length doc-try) 1) + doc-try))) + (cond ((eq escape ?h) + (when doc-text + (and (eq (preceding-char) ?\n) + (widget-get widget :indent) + (insert-char ? (widget-get widget :indent))) + ;; The `*' in the beginning is redundant. + (when (eq (aref doc-text 0) ?*) + (setq doc-text (substring doc-text 1))) + ;; Get rid of trailing newlines. + (when (string-match "\n+\\'" doc-text) + (setq doc-text (substring doc-text 0 (match-beginning 0)))) + (push (if (string-match "\n." doc-text) + ;; Allow multiline doc to be hiden. + (widget-create-child-and-convert + widget 'widget-help + :doc (progn + (string-match "\\`.*" doc-text) + (match-string 0 doc-text)) + :widget-doc doc-text + "?") + ;; A single line is just inserted. + (widget-create-child-and-convert + widget 'item :format "%d" :doc doc-text nil)) + buttons))) + (t + (error "Unknown escape `%c'" escape))) + (widget-put widget :buttons buttons))) + +(defun widget-default-button-face-get (widget) + ;; Use :button-face or widget-button-face + (or (widget-get widget :button-face) 'widget-button-face)) + +(defun widget-default-sample-face-get (widget) + ;; Use :sample-face. + (widget-get widget :sample-face)) + +(defun widget-default-delete (widget) + ;; Remove widget from the buffer. + (let ((from (widget-get widget :from)) + (to (widget-get widget :to)) + (inhibit-read-only t) + after-change-functions) + (widget-apply widget :value-delete) + (delete-region from to) + (set-marker from nil) + (set-marker to nil))) + +(defun widget-default-value-set (widget value) + ;; Recreate widget with new value. + (save-excursion + (goto-char (widget-get widget :from)) + (widget-apply widget :delete) + (widget-put widget :value value) + (widget-apply widget :create))) + +(defun widget-default-value-inline (widget) + ;; Wrap value in a list unless it is inline. + (if (widget-get widget :inline) + (widget-value widget) + (list (widget-value widget)))) + +(defun widget-default-menu-tag-get (widget) + ;; Use tag or value for menus. + (or (widget-get widget :menu-tag) + (widget-get widget :tag) + (widget-princ-to-string (widget-get widget :value)))) + +(defun widget-default-action (widget &optional event) + ;; Notify the parent when a widget change + (let ((parent (widget-get widget :parent))) + (when parent + (widget-apply parent :notify widget event)))) + +(defun widget-default-notify (widget child &optional event) + ;; Pass notification to parent. + (widget-default-action widget event)) + +;;; The `item' Widget. + +(define-widget 'item 'default + "Constant items for inclusion in other widgets." + :convert-widget 'widget-item-convert-widget + :value-create 'widget-item-value-create + :value-delete 'ignore + :value-get 'widget-item-value-get + :match 'widget-item-match + :match-inline 'widget-item-match-inline + :action 'widget-item-action + :format "%t\n") + +(defun widget-item-convert-widget (widget) + ;; Initialize :value from :args in WIDGET. + (let ((args (widget-get widget :args))) + (when args + (widget-put widget :value (widget-apply widget + :value-to-internal (car args))) + (widget-put widget :args nil))) + widget) + +(defun widget-item-value-create (widget) + ;; Insert the printed representation of the value. + (let ((standard-output (current-buffer))) + (princ (widget-get widget :value)))) + +(defun widget-item-match (widget value) + ;; Match if the value is the same. + (equal (widget-get widget :value) value)) + +(defun widget-item-match-inline (widget values) + ;; Match if the value is the same. + (let ((value (widget-get widget :value))) + (and (listp value) + (<= (length value) (length values)) + (let ((head (subseq values 0 (length value)))) + (and (equal head value) + (cons head (subseq values (length value)))))))) + +(defun widget-item-action (widget &optional event) + ;; Just notify itself. + (widget-apply widget :notify widget event)) + +(defun widget-item-value-get (widget) + ;; Items are simple. + (widget-get widget :value)) + +;;; The `push-button' Widget. + +(define-widget 'push-button 'item + "A pushable button." + :format "%[[%t]%]") + +;;; The `link' Widget. + +(define-widget 'link 'item + "An embedded link." + :help-echo "Push me to follow the link." + :format "%[_%t_%]") + +;;; The `info-link' Widget. + +(define-widget 'info-link 'link + "A link to an info file." + :action 'widget-info-link-action) + +(defun widget-info-link-action (widget &optional event) + "Open the info node specified by WIDGET." + (Info-goto-node (widget-value widget))) + +;;; The `url-link' Widget. + +(define-widget 'url-link 'link + "A link to an www page." + :action 'widget-url-link-action) + +(defun widget-url-link-action (widget &optional event) + "Open the url specified by WIDGET." + (require 'browse-url) + (funcall browse-url-browser-function (widget-value widget))) + +;;; The `editable-field' Widget. + +(define-widget 'editable-field 'default + "An editable text field." + :convert-widget 'widget-item-convert-widget + :format "%v" + :value "" + :action 'widget-field-action + :value-create 'widget-field-value-create + :value-delete 'widget-field-value-delete + :value-get 'widget-field-value-get + :match 'widget-field-match) + +;; History of field minibuffer edits. +(defvar widget-field-history nil) + +(defun widget-field-action (widget &optional event) + ;; Edit the value in the minibuffer. + (let ((tag (widget-apply widget :menu-tag-get)) + (invalid (widget-apply widget :validate))) + (when invalid + (error (widget-get invalid :error))) + (widget-value-set widget + (widget-apply widget + :value-to-external + (read-string (concat tag ": ") + (widget-apply + widget + :value-to-internal + (widget-value widget)) + 'widget-field-history))) + (widget-apply widget :notify widget event) + (widget-setup))) + +(defun widget-field-value-create (widget) + ;; Create an editable text field. + (insert " ") + (let ((size (widget-get widget :size)) + (value (widget-get widget :value)) + (from (point))) + (insert value) + (and size + (< (length value) size) + (insert-char ?\ (- size (length value)))) + (unless (memq widget widget-field-list) + (setq widget-field-new (cons widget widget-field-new))) + (widget-put widget :value-to (copy-marker (point))) + (set-marker-insertion-type (widget-get widget :value-to) nil) + (if (null size) + (insert ?\n) + (insert ?\ )) + (widget-put widget :value-from (copy-marker from)) + (set-marker-insertion-type (widget-get widget :value-from) t))) + +(defun widget-field-value-delete (widget) + ;; Remove the widget from the list of active editing fields. + (setq widget-field-list (delq widget widget-field-list)) + (set-marker (widget-get widget :value-from) nil) + (set-marker (widget-get widget :value-to) nil)) + +(defun widget-field-value-get (widget) + ;; Return current text in editing field. + (let ((from (widget-get widget :value-from)) + (to (widget-get widget :value-to)) + (size (widget-get widget :size)) + (old (current-buffer))) + (if (and from to) + (progn + (set-buffer (marker-buffer from)) + (setq from (1+ from) + to (1- to)) + (while (and size + (not (zerop size)) + (> to from) + (eq (char-after (1- to)) ?\ )) + (setq to (1- to))) + (prog1 (buffer-substring-no-properties from to) + (set-buffer old))) + (widget-get widget :value)))) + +(defun widget-field-match (widget value) + ;; Match any string. + (stringp value)) + +;;; The `text' Widget. + +(define-widget 'text 'editable-field + "A multiline text area.") + +;;; The `menu-choice' Widget. + +(define-widget 'menu-choice 'default + "A menu of options." + :convert-widget 'widget-types-convert-widget + :format "%[%t%]: %v" + :case-fold t + :tag "choice" + :void '(item :format "invalid (%t)\n") + :value-create 'widget-choice-value-create + :value-delete 'widget-children-value-delete + :value-get 'widget-choice-value-get + :value-inline 'widget-choice-value-inline + :action 'widget-choice-action + :error "Make a choice" + :validate 'widget-choice-validate + :match 'widget-choice-match + :match-inline 'widget-choice-match-inline) + +(defun widget-choice-value-create (widget) + ;; Insert the first choice that matches the value. + (let ((value (widget-get widget :value)) + (args (widget-get widget :args)) + current) + (while args + (setq current (car args) + args (cdr args)) + (when (widget-apply current :match value) + (widget-put widget :children (list (widget-create-child-value + widget current value))) + (widget-put widget :choice current) + (setq args nil + current nil))) + (when current + (let ((void (widget-get widget :void))) + (widget-put widget :children (list (widget-create-child-and-convert + widget void :value value))) + (widget-put widget :choice void))))) + +(defun widget-choice-value-get (widget) + ;; Get value of the child widget. + (widget-value (car (widget-get widget :children)))) + +(defun widget-choice-value-inline (widget) + ;; Get value of the child widget. + (widget-apply (car (widget-get widget :children)) :value-inline)) + +(defun widget-choice-action (widget &optional event) + ;; Make a choice. + (let ((args (widget-get widget :args)) + (old (widget-get widget :choice)) + (tag (widget-apply widget :menu-tag-get)) + (completion-ignore-case (widget-get widget :case-fold)) + current choices) + ;; Remember old value. + (if (and old (not (widget-apply widget :validate))) + (let* ((external (widget-value widget)) + (internal (widget-apply old :value-to-internal external))) + (widget-put old :value internal))) + ;; Find new choice. + (setq current + (cond ((= (length args) 0) + nil) + ((= (length args) 1) + (nth 0 args)) + ((and (= (length args) 2) + (memq old args)) + (if (eq old (nth 0 args)) + (nth 1 args) + (nth 0 args))) + (t + (while args + (setq current (car args) + args (cdr args)) + (setq choices + (cons (cons (widget-apply current :menu-tag-get) + current) + choices))) + (widget-choose tag (reverse choices) event)))) + (when current + (widget-value-set widget + (widget-apply current :value-to-external + (widget-get current :value))) + (widget-apply widget :notify widget event) + (widget-setup))) + ;; Notify parent. + (widget-apply widget :notify widget event) + (widget-clear-undo)) + +(defun widget-choice-validate (widget) + ;; Valid if we have made a valid choice. + (let ((void (widget-get widget :void)) + (choice (widget-get widget :choice)) + (child (car (widget-get widget :children)))) + (if (eq void choice) + widget + (widget-apply child :validate)))) + +(defun widget-choice-match (widget value) + ;; Matches if one of the choices matches. + (let ((args (widget-get widget :args)) + current found) + (while (and args (not found)) + (setq current (car args) + args (cdr args) + found (widget-apply current :match value))) + found)) + +(defun widget-choice-match-inline (widget values) + ;; Matches if one of the choices matches. + (let ((args (widget-get widget :args)) + current found) + (while (and args (null found)) + (setq current (car args) + args (cdr args) + found (widget-match-inline current values))) + found)) + +;;; The `toggle' Widget. + +(define-widget 'toggle 'menu-choice + "Toggle between two states." + :convert-widget 'widget-toggle-convert-widget + :format "%v" + :on "on" + :off "off") + +(defun widget-toggle-convert-widget (widget) + ;; Create the types representing the `on' and `off' states. + (let ((on-type (widget-get widget :on-type)) + (off-type (widget-get widget :off-type))) + (unless on-type + (setq on-type + (list 'choice-item + :value t + :match (lambda (widget value) value) + :tag (widget-get widget :on)))) + (unless off-type + (setq off-type + (list 'choice-item :value nil :tag (widget-get widget :off)))) + (widget-put widget :args (list on-type off-type))) + widget) + +;;; The `checkbox' Widget. + +(define-widget 'checkbox 'toggle + "A checkbox toggle." + :convert-widget 'widget-item-convert-widget + :on-type '(choice-item :format "%[[X]%]" t) + :off-type '(choice-item :format "%[[ ]%]" nil)) + +;;; The `checklist' Widget. + +(define-widget 'checklist 'default + "A multiple choice widget." + :convert-widget 'widget-types-convert-widget + :format "%v" + :offset 4 + :entry-format "%b %v" + :menu-tag "checklist" + :greedy nil + :value-create 'widget-checklist-value-create + :value-delete 'widget-children-value-delete + :value-get 'widget-checklist-value-get + :validate 'widget-checklist-validate + :match 'widget-checklist-match + :match-inline 'widget-checklist-match-inline) + +(defun widget-checklist-value-create (widget) + ;; Insert all values + (let ((alist (widget-checklist-match-find widget (widget-get widget :value))) + (args (widget-get widget :args))) + (while args + (widget-checklist-add-item widget (car args) (assq (car args) alist)) + (setq args (cdr args))) + (widget-put widget :children (nreverse (widget-get widget :children))))) + +(defun widget-checklist-add-item (widget type chosen) + ;; Create checklist item in WIDGET of type TYPE. + ;; If the item is checked, CHOSEN is a cons whose cdr is the value. + (and (eq (preceding-char) ?\n) + (widget-get widget :indent) + (insert-char ? (widget-get widget :indent))) + (widget-specify-insert + (let* ((children (widget-get widget :children)) + (buttons (widget-get widget :buttons)) + (from (point)) + child button) + (insert (widget-get widget :entry-format)) + (goto-char from) + ;; Parse % escapes in format. + (while (re-search-forward "%\\([bv%]\\)" nil t) + (let ((escape (aref (match-string 1) 0))) + (replace-match "" t t) + (cond ((eq escape ?%) + (insert "%")) + ((eq escape ?b) + (setq button (widget-create-child-and-convert + widget 'checkbox :value (not (null chosen))))) + ((eq escape ?v) + (setq child + (cond ((not chosen) + (widget-create-child widget type)) + ((widget-get type :inline) + (widget-create-child-value + widget type (cdr chosen))) + (t + (widget-create-child-value + widget type (car (cdr chosen))))))) + (t + (error "Unknown escape `%c'" escape))))) + ;; Update properties. + (and button child (widget-put child :button button)) + (and button (widget-put widget :buttons (cons button buttons))) + (and child (widget-put widget :children (cons child children)))))) + +(defun widget-checklist-match (widget values) + ;; All values must match a type in the checklist. + (and (listp values) + (null (cdr (widget-checklist-match-inline widget values))))) + +(defun widget-checklist-match-inline (widget values) + ;; Find the values which match a type in the checklist. + (let ((greedy (widget-get widget :greedy)) + (args (copy-list (widget-get widget :args))) + found rest) + (while values + (let ((answer (widget-checklist-match-up args values))) + (cond (answer + (let ((vals (widget-match-inline answer values))) + (setq found (append found (car vals)) + values (cdr vals) + args (delq answer args)))) + (greedy + (setq rest (append rest (list (car values))) + values (cdr values))) + (t + (setq rest (append rest values) + values nil))))) + (cons found rest))) + +(defun widget-checklist-match-find (widget vals) + ;; Find the vals which match a type in the checklist. + ;; Return an alist of (TYPE MATCH). + (let ((greedy (widget-get widget :greedy)) + (args (copy-list (widget-get widget :args))) + found) + (while vals + (let ((answer (widget-checklist-match-up args vals))) + (cond (answer + (let ((match (widget-match-inline answer vals))) + (setq found (cons (cons answer (car match)) found) + vals (cdr match) + args (delq answer args)))) + (greedy + (setq vals (cdr vals))) + (t + (setq vals nil))))) + found)) + +(defun widget-checklist-match-up (args vals) + ;; Rerturn the first type from ARGS that matches VALS. + (let (current found) + (while (and args (null found)) + (setq current (car args) + args (cdr args) + found (widget-match-inline current vals))) + (if found + current + nil))) + +(defun widget-checklist-value-get (widget) + ;; The values of all selected items. + (let ((children (widget-get widget :children)) + child result) + (while children + (setq child (car children) + children (cdr children)) + (if (widget-value (widget-get child :button)) + (setq result (append result (widget-apply child :value-inline))))) + result)) + +(defun widget-checklist-validate (widget) + ;; Ticked chilren must be valid. + (let ((children (widget-get widget :children)) + child button found) + (while (and children (not found)) + (setq child (car children) + children (cdr children) + button (widget-get child :button) + found (and (widget-value button) + (widget-apply child :validate)))) + found)) + +;;; The `option' Widget + +(define-widget 'option 'checklist + "An widget with an optional item." + :inline t) + +;;; The `choice-item' Widget. + +(define-widget 'choice-item 'item + "Button items that delegate action events to their parents." + :action 'widget-choice-item-action + :format "%[%t%] \n") + +(defun widget-choice-item-action (widget &optional event) + ;; Tell parent what happened. + (widget-apply (widget-get widget :parent) :action event)) + +;;; The `radio-button' Widget. + +(define-widget 'radio-button 'toggle + "A radio button for use in the `radio' widget." + :notify 'widget-radio-button-notify + :on-type '(choice-item :format "%[(*)%]" t) + :off-type '(choice-item :format "%[( )%]" nil)) + +(defun widget-radio-button-notify (widget child &optional event) + ;; Notify the parent. + (widget-apply (widget-get widget :parent) :action widget event)) + +;;; The `radio-button-choice' Widget. + +(define-widget 'radio-button-choice 'default + "Select one of multiple options." + :convert-widget 'widget-types-convert-widget + :offset 4 + :format "%v" + :entry-format "%b %v" + :menu-tag "radio" + :value-create 'widget-radio-value-create + :value-delete 'widget-children-value-delete + :value-get 'widget-radio-value-get + :value-inline 'widget-radio-value-inline + :value-set 'widget-radio-value-set + :error "You must push one of the buttons" + :validate 'widget-radio-validate + :match 'widget-choice-match + :match-inline 'widget-choice-match-inline + :action 'widget-radio-action) + +(defun widget-radio-value-create (widget) + ;; Insert all values + (let ((args (widget-get widget :args)) + arg) + (while args + (setq arg (car args) + args (cdr args)) + (widget-radio-add-item widget arg)))) + +(defun widget-radio-add-item (widget type) + "Add to radio widget WIDGET a new radio button item of type TYPE." + ;; (setq type (widget-convert type)) + (and (eq (preceding-char) ?\n) + (widget-get widget :indent) + (insert-char ? (widget-get widget :indent))) + (widget-specify-insert + (let* ((value (widget-get widget :value)) + (children (widget-get widget :children)) + (buttons (widget-get widget :buttons)) + (from (point)) + (chosen (and (null (widget-get widget :choice)) + (widget-apply type :match value))) + child button) + (insert (widget-get widget :entry-format)) + (goto-char from) + ;; Parse % escapes in format. + (while (re-search-forward "%\\([bv%]\\)" nil t) + (let ((escape (aref (match-string 1) 0))) + (replace-match "" t t) + (cond ((eq escape ?%) + (insert "%")) + ((eq escape ?b) + (setq button (widget-create-child-and-convert + widget 'radio-button + :value (not (null chosen))))) + ((eq escape ?v) + (setq child (if chosen + (widget-create-child-value + widget type value) + (widget-create-child widget type)))) + (t + (error "Unknown escape `%c'" escape))))) + ;; Update properties. + (when chosen + (widget-put widget :choice type)) + (when button + (widget-put child :button button) + (widget-put widget :buttons (nconc buttons (list button)))) + (when child + (widget-put widget :children (nconc children (list child)))) + child))) + +(defun widget-radio-value-get (widget) + ;; Get value of the child widget. + (let ((chosen (widget-radio-chosen widget))) + (and chosen (widget-value chosen)))) + +(defun widget-radio-chosen (widget) + "Return the widget representing the chosen radio button." + (let ((children (widget-get widget :children)) + current found) + (while children + (setq current (car children) + children (cdr children)) + (let* ((button (widget-get current :button)) + (value (widget-apply button :value-get))) + (when value + (setq found current + children nil)))) + found)) + +(defun widget-radio-value-inline (widget) + ;; Get value of the child widget. + (let ((children (widget-get widget :children)) + current found) + (while children + (setq current (car children) + children (cdr children)) + (let* ((button (widget-get current :button)) + (value (widget-apply button :value-get))) + (when value + (setq found (widget-apply current :value-inline) + children nil)))) + found)) + +(defun widget-radio-value-set (widget value) + ;; We can't just delete and recreate a radio widget, since children + ;; can be added after the original creation and won't be recreated + ;; by `:create'. + (let ((children (widget-get widget :children)) + current found) + (while children + (setq current (car children) + children (cdr children)) + (let* ((button (widget-get current :button)) + (match (and (not found) + (widget-apply current :match value)))) + (widget-value-set button match) + (if match + (widget-value-set current value)) + (setq found (or found match)))))) + +(defun widget-radio-validate (widget) + ;; Valid if we have made a valid choice. + (let ((children (widget-get widget :children)) + current found button) + (while (and children (not found)) + (setq current (car children) + children (cdr children) + button (widget-get current :button) + found (widget-apply button :value-get))) + (if found + (widget-apply current :validate) + widget))) + +(defun widget-radio-action (widget child event) + ;; Check if a radio button was pressed. + (let ((children (widget-get widget :children)) + (buttons (widget-get widget :buttons)) + current) + (when (memq child buttons) + (while children + (setq current (car children) + children (cdr children)) + (let* ((button (widget-get current :button))) + (cond ((eq child button) + (widget-value-set button t)) + ((widget-value button) + (widget-value-set button nil))))))) + ;; Pass notification to parent. + (widget-apply widget :notify child event)) + +;;; The `insert-button' Widget. + +(define-widget 'insert-button 'push-button + "An insert button for the `editable-list' widget." + :tag "INS" + :action 'widget-insert-button-action) + +(defun widget-insert-button-action (widget &optional event) + ;; Ask the parent to insert a new item. + (widget-apply (widget-get widget :parent) + :insert-before (widget-get widget :widget))) + +;;; The `delete-button' Widget. + +(define-widget 'delete-button 'push-button + "A delete button for the `editable-list' widget." + :tag "DEL" + :action 'widget-delete-button-action) + +(defun widget-delete-button-action (widget &optional event) + ;; Ask the parent to insert a new item. + (widget-apply (widget-get widget :parent) + :delete-at (widget-get widget :widget))) + +;;; The `editable-list' Widget. + +(define-widget 'editable-list 'default + "A variable list of widgets of the same type." + :convert-widget 'widget-types-convert-widget + :offset 12 + :format "%v%i\n" + :format-handler 'widget-editable-list-format-handler + :entry-format "%i %d %v" + :menu-tag "editable-list" + :value-create 'widget-editable-list-value-create + :value-delete 'widget-children-value-delete + :value-get 'widget-editable-list-value-get + :validate 'widget-editable-list-validate + :match 'widget-editable-list-match + :match-inline 'widget-editable-list-match-inline + :insert-before 'widget-editable-list-insert-before + :delete-at 'widget-editable-list-delete-at) + +(defun widget-editable-list-format-handler (widget escape) + ;; We recognize the insert button. + (cond ((eq escape ?i) + (and (widget-get widget :indent) + (insert-char ? (widget-get widget :indent))) + (widget-create-child-and-convert widget 'insert-button)) + (t + (widget-default-format-handler widget escape)))) + +(defun widget-editable-list-value-create (widget) + ;; Insert all values + (let* ((value (widget-get widget :value)) + (type (nth 0 (widget-get widget :args))) + (inlinep (widget-get type :inline)) + children) + (widget-put widget :value-pos (copy-marker (point))) + (set-marker-insertion-type (widget-get widget :value-pos) t) + (while value + (let ((answer (widget-match-inline type value))) + (if answer + (setq children (cons (widget-editable-list-entry-create + widget + (if inlinep + (car answer) + (car (car answer))) + t) + children) + value (cdr answer)) + (setq value nil)))) + (widget-put widget :children (nreverse children)))) + +(defun widget-editable-list-value-get (widget) + ;; Get value of the child widget. + (apply 'append (mapcar (lambda (child) (widget-apply child :value-inline)) + (widget-get widget :children)))) + +(defun widget-editable-list-validate (widget) + ;; All the chilren must be valid. + (let ((children (widget-get widget :children)) + child found) + (while (and children (not found)) + (setq child (car children) + children (cdr children) + found (widget-apply child :validate))) + found)) + +(defun widget-editable-list-match (widget value) + ;; Value must be a list and all the members must match the type. + (and (listp value) + (null (cdr (widget-editable-list-match-inline widget value))))) + +(defun widget-editable-list-match-inline (widget value) + (let ((type (nth 0 (widget-get widget :args))) + (ok t) + found) + (while (and value ok) + (let ((answer (widget-match-inline type value))) + (if answer + (setq found (append found (car answer)) + value (cdr answer)) + (setq ok nil)))) + (cons found value))) + +(defun widget-editable-list-insert-before (widget before) + ;; Insert a new child in the list of children. + (save-excursion + (let ((children (widget-get widget :children)) + (inhibit-read-only t) + after-change-functions) + (cond (before + (goto-char (widget-get before :entry-from))) + (t + (goto-char (widget-get widget :value-pos)))) + (let ((child (widget-editable-list-entry-create + widget nil nil))) + (when (< (widget-get child :entry-from) (widget-get widget :from)) + (set-marker (widget-get widget :from) + (widget-get child :entry-from))) + (widget-specify-text (widget-get child :entry-from) + (widget-get child :entry-to)) + (if (eq (car children) before) + (widget-put widget :children (cons child children)) + (while (not (eq (car (cdr children)) before)) + (setq children (cdr children))) + (setcdr children (cons child (cdr children))))))) + (widget-setup) + (widget-apply widget :notify widget)) + +(defun widget-editable-list-delete-at (widget child) + ;; Delete child from list of children. + (save-excursion + (let ((buttons (copy-list (widget-get widget :buttons))) + button + (inhibit-read-only t) + after-change-functions) + (while buttons + (setq button (car buttons) + buttons (cdr buttons)) + (when (eq (widget-get button :widget) child) + (widget-put widget + :buttons (delq button (widget-get widget :buttons))) + (widget-delete button)))) + (let ((entry-from (widget-get child :entry-from)) + (entry-to (widget-get child :entry-to)) + (inhibit-read-only t) + after-change-functions) + (widget-delete child) + (delete-region entry-from entry-to) + (set-marker entry-from nil) + (set-marker entry-to nil)) + (widget-put widget :children (delq child (widget-get widget :children)))) + (widget-setup) + (widget-apply widget :notify widget)) + +(defun widget-editable-list-entry-create (widget value conv) + ;; Create a new entry to the list. + (let ((type (nth 0 (widget-get widget :args))) + child delete insert) + (widget-specify-insert + (save-excursion + (and (widget-get widget :indent) + (insert-char ? (widget-get widget :indent))) + (insert (widget-get widget :entry-format))) + ;; Parse % escapes in format. + (while (re-search-forward "%\\(.\\)" nil t) + (let ((escape (aref (match-string 1) 0))) + (replace-match "" t t) + (cond ((eq escape ?%) + (insert "%")) + ((eq escape ?i) + (setq insert (widget-create-child-and-convert + widget 'insert-button))) + ((eq escape ?d) + (setq delete (widget-create-child-and-convert + widget 'delete-button))) + ((eq escape ?v) + (if conv + (setq child (widget-create-child-value + widget type value)) + (setq child (widget-create-child widget type)))) + (t + (error "Unknown escape `%c'" escape))))) + (widget-put widget + :buttons (cons delete + (cons insert + (widget-get widget :buttons)))) + (let ((entry-from (copy-marker (point-min))) + (entry-to (copy-marker (point-max)))) + (widget-specify-text entry-from entry-to) + (set-marker-insertion-type entry-from t) + (set-marker-insertion-type entry-to nil) + (widget-put child :entry-from entry-from) + (widget-put child :entry-to entry-to))) + (widget-put insert :widget child) + (widget-put delete :widget child) + child)) + +;;; The `group' Widget. + +(define-widget 'group 'default + "A widget which group other widgets inside." + :convert-widget 'widget-types-convert-widget + :format "%v" + :value-create 'widget-group-value-create + :value-delete 'widget-children-value-delete + :value-get 'widget-editable-list-value-get + :validate 'widget-editable-list-validate + :match 'widget-group-match + :match-inline 'widget-group-match-inline) + +(defun widget-group-value-create (widget) + ;; Create each component. + (let ((args (widget-get widget :args)) + (value (widget-get widget :value)) + arg answer children) + (while args + (setq arg (car args) + args (cdr args) + answer (widget-match-inline arg value) + value (cdr answer)) + (and (eq (preceding-char) ?\n) + (widget-get widget :indent) + (insert-char ? (widget-get widget :indent))) + (push (cond ((null answer) + (widget-create-child widget arg)) + ((widget-get arg :inline) + (widget-create-child-value widget arg (car answer))) + (t + (widget-create-child-value widget arg (car (car answer))))) + children)) + (widget-put widget :children (nreverse children)))) + +(defun widget-group-match (widget values) + ;; Match if the components match. + (and (listp values) + (let ((match (widget-group-match-inline widget values))) + (and match (null (cdr match)))))) + +(defun widget-group-match-inline (widget vals) + ;; Match if the components match. + (let ((args (widget-get widget :args)) + argument answer found) + (while args + (setq argument (car args) + args (cdr args) + answer (widget-match-inline argument vals)) + (if answer + (setq vals (cdr answer) + found (append found (car answer))) + (setq vals nil + args nil))) + (if answer + (cons found vals) + nil))) + +;;; The `widget-help' Widget. + +(define-widget 'widget-help 'push-button + "The widget documentation button." + :format "%[[%t]%] %d" + :help-echo "Push me to toggle the documentation." + :action 'widget-help-action) + +(defun widget-help-action (widget &optional event) + "Toggle documentation for WIDGET." + (let ((old (widget-get widget :doc)) + (new (widget-get widget :widget-doc))) + (widget-put widget :doc new) + (widget-put widget :widget-doc old)) + (widget-value-set widget (widget-value widget))) + +;;; The Sexp Widgets. + +(define-widget 'const 'item + "An immutable sexp." + :format "%t\n%d") + +(define-widget 'function-item 'item + "An immutable function name." + :format "%v\n%h" + :documentation-property (lambda (symbol) + (condition-case nil + (documentation symbol t) + (error nil)))) + +(define-widget 'variable-item 'item + "An immutable variable name." + :format "%v\n%h" + :documentation-property 'variable-documentation) + +(define-widget 'string 'editable-field + "A string" + :tag "String" + :format "%[%t%]: %v") + +(define-widget 'regexp 'string + "A regular expression." + ;; Should do validation. + :tag "Regexp") + +(define-widget 'file 'string + "A file widget. +It will read a file name from the minibuffer when activated." + :format "%[%t%]: %v" + :tag "File" + :action 'widget-file-action) + +(defun widget-file-action (widget &optional event) + ;; Read a file name from the minibuffer. + (let* ((value (widget-value widget)) + (dir (file-name-directory value)) + (file (file-name-nondirectory value)) + (menu-tag (widget-apply widget :menu-tag-get)) + (must-match (widget-get widget :must-match)) + (answer (read-file-name (concat menu-tag ": (defalt `" value "') ") + dir nil must-match file))) + (widget-value-set widget (abbreviate-file-name answer)) + (widget-apply widget :notify widget event) + (widget-setup))) + +(define-widget 'directory 'file + "A directory widget. +It will read a directory name from the minibuffer when activated." + :tag "Directory") + +(define-widget 'symbol 'string + "A lisp symbol." + :value nil + :tag "Symbol" + :match (lambda (widget value) (symbolp value)) + :value-to-internal (lambda (widget value) + (if (symbolp value) + (symbol-name value) + value)) + :value-to-external (lambda (widget value) + (if (stringp value) + (intern value) + value))) + +(define-widget 'function 'sexp + ;; Should complete on functions. + "A lisp function." + :tag "Function") + +(define-widget 'variable 'symbol + ;; Should complete on variables. + "A lisp variable." + :tag "Variable") + +(define-widget 'sexp 'string + "An arbitrary lisp expression." + :tag "Lisp expression" + :value nil + :validate 'widget-sexp-validate + :match (lambda (widget value) t) + :value-to-internal 'widget-sexp-value-to-internal + :value-to-external (lambda (widget value) (read value))) + +(defun widget-sexp-value-to-internal (widget value) + ;; Use pp for printer representation. + (let ((pp (pp-to-string value))) + (while (string-match "\n\\'" pp) + (setq pp (substring pp 0 -1))) + (if (or (string-match "\n\\'" pp) + (> (length pp) 40)) + (concat "\n" pp) + pp))) + +(defun widget-sexp-validate (widget) + ;; Valid if we can read the string and there is no junk left after it. + (save-excursion + (let ((buffer (set-buffer (get-buffer-create " *Widget Scratch*")))) + (erase-buffer) + (insert (widget-apply widget :value-get)) + (goto-char (point-min)) + (condition-case data + (let ((value (read buffer))) + (if (eobp) + (if (widget-apply widget :match value) + nil + (widget-put widget :error (widget-get widget :type-error)) + widget) + (widget-put widget + :error (format "Junk at end of expression: %s" + (buffer-substring (point) + (point-max)))) + widget)) + (error (widget-put widget :error (error-message-string data)) + widget))))) + +(define-widget 'integer 'sexp + "An integer." + :tag "Integer" + :value 0 + :type-error "This field should contain an integer" + :value-to-internal (lambda (widget value) + (if (integerp value) + (prin1-to-string value) + value)) + :match (lambda (widget value) (integerp value))) + +(define-widget 'character 'string + "An character." + :tag "Character" + :value 0 + :size 1 + :format "%{%t%}: %v\n" + :type-error "This field should contain a character" + :value-to-internal (lambda (widget value) + (if (integerp value) + (char-to-string value) + value)) + :value-to-external (lambda (widget value) + (if (stringp value) + (aref value 0) + value)) + :match (lambda (widget value) (integerp value))) + +(define-widget 'number 'sexp + "A floating point number." + :tag "Number" + :value 0.0 + :type-error "This field should contain a number" + :value-to-internal (lambda (widget value) + (if (numberp value) + (prin1-to-string value) + value)) + :match (lambda (widget value) (numberp value))) + +(define-widget 'list 'group + "A lisp list." + :tag "List" + :format "%{%t%}:\n%v") + +(define-widget 'vector 'group + "A lisp vector." + :tag "Vector" + :format "%{%t%}:\n%v" + :match 'widget-vector-match + :value-to-internal (lambda (widget value) (append value nil)) + :value-to-external (lambda (widget value) (apply 'vector value))) + +(defun widget-vector-match (widget value) + (and (vectorp value) + (widget-group-match widget + (widget-apply :value-to-internal widget value)))) + +(define-widget 'cons 'group + "A cons-cell." + :tag "Cons-cell" + :format "%{%t%}:\n%v" + :match 'widget-cons-match + :value-to-internal (lambda (widget value) + (list (car value) (cdr value))) + :value-to-external (lambda (widget value) + (cons (nth 0 value) (nth 1 value)))) + +(defun widget-cons-match (widget value) + (and (consp value) + (widget-group-match widget + (widget-apply widget :value-to-internal value)))) + +(define-widget 'choice 'menu-choice + "A union of several sexp types." + :tag "Choice" + :format "%[%t%]: %v") + +(define-widget 'radio 'radio-button-choice + "A union of several sexp types." + :tag "Choice" + :format "%{%t%}:\n%v") + +(define-widget 'repeat 'editable-list + "A variable length homogeneous list." + :tag "Repeat" + :format "%{%t%}:\n%v%i\n") + +(define-widget 'set 'checklist + "A list of members from a fixed set." + :tag "Set" + :format "%{%t%}:\n%v") + +(define-widget 'boolean 'toggle + "To be nil or non-nil, that is the question." + :tag "Boolean" + :format "%{%t%}: %v") + +;;; The `color' Widget. + +(define-widget 'color-item 'choice-item + "A color name (with sample)." + :format "%v (%[sample%])\n" + :button-face-get 'widget-color-item-button-face-get) + +(defun widget-color-item-button-face-get (widget) + ;; We create a face from the value. + (require 'facemenu) + (condition-case nil + (facemenu-get-face (intern (concat "fg:" (widget-value widget)))) + (error 'default))) + +(define-widget 'color 'push-button + "Choose a color name (with sample)." + :format "%[%t%]: %v" + :tag "Color" + :value "default" + :value-create 'widget-color-value-create + :value-delete 'widget-children-value-delete + :value-get 'widget-color-value-get + :value-set 'widget-color-value-set + :action 'widget-color-action + :match 'widget-field-match + :tag "Color") + +(defvar widget-color-choice-list nil) +;; Variable holding the possible colors. + +(defun widget-color-choice-list () + (unless widget-color-choice-list + (setq widget-color-choice-list + (mapcar '(lambda (color) (list color)) + (x-defined-colors)))) + widget-color-choice-list) + +(defun widget-color-value-create (widget) + (let ((child (widget-create-child-and-convert + widget 'color-item (widget-get widget :value)))) + (widget-put widget :children (list child)))) + +(defun widget-color-value-get (widget) + ;; Pass command to first child. + (widget-apply (car (widget-get widget :children)) :value-get)) + +(defun widget-color-value-set (widget value) + ;; Pass command to first child. + (widget-apply (car (widget-get widget :children)) :value-set value)) + +(defvar widget-color-history nil + "History of entered colors") + +(defun widget-color-action (widget &optional event) + ;; Prompt for a color. + (let* ((tag (widget-apply widget :menu-tag-get)) + (prompt (concat tag ": ")) + (answer (cond ((string-match "XEmacs" emacs-version) + (read-color prompt)) + ((fboundp 'x-defined-colors) + (completing-read (concat tag ": ") + (widget-color-choice-list) + nil nil nil 'widget-color-history)) + (t + (read-string prompt (widget-value widget)))))) + (unless (zerop (length answer)) + (widget-value-set widget answer) + (widget-apply widget :notify widget event) + (widget-setup)))) + +;;; The Help Echo + +(defun widget-echo-help-mouse () + "Display the help message for the widget under the mouse. +Enable with (run-with-idle-timer 1 t 'widget-echo-help-mouse)" + (let* ((pos (mouse-position)) + (frame (car pos)) + (x (car (cdr pos))) + (y (cdr (cdr pos))) + (win (window-at x y frame)) + (where (coordinates-in-window-p (cons x y) win))) + (when (consp where) + (save-window-excursion + (progn ; save-excursion + (select-window win) + (let* ((result (compute-motion (window-start win) + '(0 . 0) + (window-end win) + where + (window-width win) + (cons (window-hscroll) 0) + win))) + (when (and (eq (nth 1 result) x) + (eq (nth 2 result) y)) + (widget-echo-help (nth 0 result)))))))) + (unless track-mouse + (setq track-mouse t) + (add-hook 'post-command-hook 'widget-stop-mouse-tracking))) + +(defun widget-stop-mouse-tracking (&rest args) + "Stop the mouse tracking done while idle." + (remove-hook 'post-command-hook 'widget-stop-mouse-tracking) + (setq track-mouse nil)) + +(defun widget-at (pos) + "The button or field at POS." + (or (get-text-property pos 'button) + (get-text-property pos 'field))) + +(defun widget-echo-help (pos) + "Display the help echo for widget at POS." + (let* ((widget (widget-at pos)) + (help-echo (and widget (widget-get widget :help-echo)))) + (cond ((stringp help-echo) + (message "%s" help-echo)) + ((and (symbolp help-echo) (fboundp help-echo) + (stringp (setq help-echo (funcall help-echo widget)))) + (message "%s" help-echo))))) + +;;; The End: + +(provide 'widget-edit) + +;; widget-edit.el ends here diff -r ad457d5f7d04 -r 0293115a14e9 lisp/gnus/widget.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus/widget.el Mon Aug 13 08:49:20 2007 +0200 @@ -0,0 +1,70 @@ +;;; widget.el --- a library of user interface components. +;; +;; Copyright (C) 1996 Free Software Foundation, Inc. +;; +;; Author: Per Abrahamsen +;; Keywords: help, extensions, faces, hypermedia +;; Version: 1.20 +;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ + +;;; Commentary: +;; +;; If you want to use this code, please visit the URL above. +;; +;; This file only contain the code needed to define new widget types. +;; Everything else is autoloaded from `widget-edit.el'. + +;;; Code: + +(eval-when-compile (require 'cl)) + +(defmacro define-widget-keywords (&rest keys) + (` + (eval-and-compile + (let ((keywords (quote (, keys)))) + (while keywords + (or (boundp (car keywords)) + (set (car keywords) (car keywords))) + (setq keywords (cdr keywords))))))) + +(define-widget-keywords :sample-face :sample-face-get :case-fold + :widget-doc + :create :convert-widget :format :value-create :offset :extra-offset + :tag :doc :from :to :args :value :value-from :value-to :action + :value-set :value-delete :match :parent :delete :menu-tag-get + :value-get :choice :void :menu-tag :on :off :on-type :off-type + :notify :entry-format :button :children :buttons :insert-before + :delete-at :format-handler :widget :value-pos :value-to-internal + :indent :size :value-to-external :validate :error :directory + :must-match :type-error :value-inline :inline :match-inline :greedy + :button-face-get :button-face :value-face :keymap :entry-from + :entry-to :help-echo :documentation-property :hide-front-space + :hide-rear-space) + +;; These autoloads should be deleted when the file is added to Emacs. +(autoload 'widget-create "widget-edit") +(autoload 'widget-insert "widget-edit") + +;;;###autoload +(defun define-widget (name class doc &rest args) + "Define a new widget type named NAME from CLASS. + +NAME and CLASS should both be symbols, CLASS should be one of the +existing widget types, or nil to create the widget from scratch. + +After the new widget has been defined, the following two calls will +create identical widgets: + +* (widget-create NAME) + +* (apply 'widget-create CLASS ARGS) + +The third argument DOC is a documentation string for the widget." + (put name 'widget-type (cons class args)) + (put name 'widget-documentation doc)) + +;;; The End. + +(provide 'widget) + +;; widget.el ends here diff -r ad457d5f7d04 -r 0293115a14e9 lisp/iso/iso-acc.el --- a/lisp/iso/iso-acc.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/iso/iso-acc.el Mon Aug 13 08:49:20 2007 +0200 @@ -3,11 +3,11 @@ ;; Copyright (C) 1993, 1994, 1996 Free Software Foundation, Inc. ;; Author: Johan Vromans -;; Version: 1.7 (modified) +;; Version: 1.8 ;; Maintainer: FSF ;; Keywords: i18n -;; Adapted for XEmacs 19.14 by Alexandre Oliva -;; Last update: Oct 10, 1996 +;; Adapted to XEmacs 19.14 by Alexandre Oliva +;; Last update: Jan 25, 1997 ;; This file is part of GNU Emacs. @@ -74,7 +74,8 @@ ;; needed to work on GNU Emacs (had to use this function on XEmacs) (if (fboundp 'character-to-event) () - (defun character-to-event (ch &optional event console meta) ch)) + (defun character-to-event (ch &optional event console meta) + (if (listp ch) (car ch) ch))) ;; needed for compatibility with XEmacs 19.14 and GNU Emacs 19.30 (if (fboundp 'this-single-command-keys) () @@ -84,26 +85,6 @@ (this-command-keys)) (defun this-single-command-keys () (this-command-keys)))) -(if (string-match "Lucid" (version)) - (progn - (global-set-key [quoted-insert-for-iso-acc] 'quoted-insert) - (defun iso-generate-char (char) - "inserts the octal representation of char into unread-command-events,\nand then returns the pseudo-key quoted-insert-for-iso-acc (which should be mapped to quoted-insert).\n\nCan be used in keymaps to generate characters from 128 to 255." - (setq unread-command-events - (append - (mapcar 'character-to-event (list - (+ 48 (/ char 64)) - (+ 48 (% (/ char 8) 8)) - (+ 48 (% char 8)))) - unread-command-events)) - [quoted-insert-for-iso-acc]) - ) - (defun iso-generate-char (char) - "Just returns a vector with the given character.\n\nNot necessary in the GNU Emacs implementation" - (vector char)) - ) - - (defvar iso-languages '(("portuguese" (?' (?A . ?\301) (?E . ?\311) (?I . ?\315) (?O . ?\323) (?U . ?\332) @@ -248,11 +229,15 @@ (delete-region (1- (point)) (point))))) (entry (cdr (assq second-char list)))) (if entry - ;; Found it: return the mapped char - (iso-generate-char entry) + ;; Found it: insert the accented character and + ;; return a do-nothing key + (vector (character-to-event (list entry))) ;; Otherwise, advance and schedule the second key for execution. - (setq unread-command-events (list (character-to-event second-char))) - (vector first-char)))) + (setq unread-command-events (append + (list + (character-to-event (list second-char))) + unread-command-events)) + (vector (character-to-event (list first-char)))))) ;; It is a matter of taste if you want the minor mode indicated ;; in the mode line... @@ -298,12 +283,14 @@ ;; Enable electric accents. (setq iso-accents-mode t))) +(defvar iso-accents-mode-map nil) + (defun iso-accents-customize (language) "Customize the ISO accents machinery for a particular language. It selects the customization based on the specifications in the `iso-languages' variable." (interactive (list (completing-read "Language: " iso-languages nil t))) - (let ((table (assoc language iso-languages)) tail) + (let ((table (assoc language iso-languages)) tail acc) (if (not table) (error "Unknown language '%s'" language) (setq iso-language language @@ -312,14 +299,57 @@ (substitute-key-definition 'iso-accents-accent-key nil key-translation-map) (setq key-translation-map (make-sparse-keymap))) + (setq iso-accents-mode-map (make-sparse-keymap)) + (let ((pair (assoc 'iso-accents-mode minor-mode-map-alist))) + (if pair + (setcdr pair iso-accents-mode-map) + (let ((l minor-mode-map-alist)) + (while (cdr l) + (setq l (cdr l))) + (setcdr l (list (cons 'iso-accents-mode iso-accents-mode-map)))))) ;; Set up translations for all the characters that are used as ;; accent prefixes in this language. (setq tail iso-accents-list) (while tail - (define-key key-translation-map (vector (car (car tail))) + (define-key key-translation-map + (vector (character-to-event (list (car (car tail))))) 'iso-accents-accent-key) + (setq acc (cdr (car tail))) + (while acc + (define-key iso-accents-mode-map + (vector (character-to-event (list (cdr (car acc))))) + 'iso-accents-self-insert-unless-redefined) + (setq acc (cdr acc))) (setq tail (cdr tail)))))) +(defun iso-accents-self-insert-unless-redefined (prompt) + "Temporarily disables iso-accents-mode, and checks for additional bindings of the keys that produced its invocation. If no such binding is found, 'self-insert-command is returned" + (interactive "p") + (let* ((iso-accents-mode nil) + (bind (key-binding (this-command-keys))) + (repeat t) result) + (while repeat + (setq result + (cond ((or (null bind) + (eq bind 'self-insert-command)) + (setq repeat nil) + (self-insert-command prompt)) + ((commandp bind) + (setq repeat nil) + (call-interactively bind)) + ((or (stringp bind) + (keymapp bind)) + (setq repeat nil) + bind) + ((and (consp bind) + (stringp (car bind))) + (setq bind (cdr bind))) + ((and (consp bind) + (keymapp (car bind))) + (setq bind (lookup-key (car bind) (cdr bind)))) + (t (error "Invalid key binding"))))) + result)) + (defun iso-accentuate (start end) "Convert two-character sequences in region into accented characters. Noninteractively, this operates on text from START to END. diff -r ad457d5f7d04 -r 0293115a14e9 lisp/iso/iso8859-1.el --- a/lisp/iso/iso8859-1.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/iso/iso8859-1.el Mon Aug 13 08:49:20 2007 +0200 @@ -14,8 +14,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;; created by jwz, 19-aug-92. diff -r ad457d5f7d04 -r 0293115a14e9 lisp/modes/bibtex.el --- a/lisp/modes/bibtex.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/modes/bibtex.el Mon Aug 13 08:49:20 2007 +0200 @@ -24,8 +24,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; TODO distribute texinfo file. diff -r ad457d5f7d04 -r 0293115a14e9 lisp/modes/imenu.el --- a/lisp/modes/imenu.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/modes/imenu.el Mon Aug 13 08:49:20 2007 +0200 @@ -805,12 +805,13 @@ (interactive "sImenu menu item name: ") (let ((newmap (make-sparse-keymap)) (menu-bar (lookup-key (current-local-map) [menu-bar]))) - (define-key newmap [menu-bar] - (append (make-sparse-keymap) menu-bar)) - (define-key newmap [menu-bar index] - (cons name (nconc (make-sparse-keymap "Imenu") - (make-sparse-keymap)))) - (use-local-map (append newmap (current-local-map)))) + (when menu-bar + (define-key newmap [menu-bar] + (append (make-sparse-keymap) menu-bar)) + (define-key newmap [menu-bar index] + (cons name (nconc (make-sparse-keymap "Imenu") + (make-sparse-keymap)))) + (use-local-map (append newmap (current-local-map))))) (add-hook 'menu-bar-update-hook 'imenu-update-menubar)) (defvar imenu-buffer-menubar nil) diff -r ad457d5f7d04 -r 0293115a14e9 lisp/modes/ksh-mode.el --- a/lisp/modes/ksh-mode.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/modes/ksh-mode.el Mon Aug 13 08:49:20 2007 +0200 @@ -15,15 +15,16 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;; $Source: /afs/informatik.uni-tuebingen.de/local/web/xemacs/xemacs-cvs/XEmacs/xemacs-19/lisp/modes/ksh-mode.el,v $ -- ;; ;; LCD Archive Entry: ;; ksh-mode|Gary F. Ellison|Gary.F.Ellison@ATT.COM ;; |Mode for editing sh/ksh/bash scripts -;; |$Date: 1996/12/18 03:44:42 $|$Revision: 1.1.1.2 $|~/modes/ksh-mode.el.Z| +;; |$Date: 1997/02/02 05:05:40 $|$Revision: 1.2 $|~/modes/ksh-mode.el.Z| ;; Author: Gary F. Ellison ;; AT&T Laboratories @@ -32,10 +33,10 @@ ;; ;; Maintainer: Gary F. Ellison ;; Created: Fri Jun 19 -;; $Revision: 1.1.1.2 $ +;; $Revision: 1.2 $ ;; Keywords: shell, korn, bourne, sh, ksh, bash ;; -;; Delta On $Date: 1996/12/18 03:44:42 $ +;; Delta On $Date: 1997/02/02 05:05:40 $ ;; Last Modified By: Gary Ellison ;; Last Modified On: Mon Sep 11 12:26:47 1995 ;; Update Count : 35 @@ -230,7 +231,7 @@ ;; Conception of this mode. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defconst ksh-mode-version "$Revision: 1.1.1.2 $" +(defconst ksh-mode-version "$Revision: 1.2 $" "*Version numbers of this version of ksh-mode") ;; @@ -467,7 +468,7 @@ ;;;###autoload (defun ksh-mode () - "ksh-mode $Revision: 1.1.1.2 $ - Major mode for editing (Bourne, Korn or Bourne again) + "ksh-mode $Revision: 1.2 $ - Major mode for editing (Bourne, Korn or Bourne again) shell scripts. Special key bindings and commands: \\{ksh-mode-map} diff -r ad457d5f7d04 -r 0293115a14e9 lisp/modes/list-mode.el --- a/lisp/modes/list-mode.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/modes/list-mode.el Mon Aug 13 08:49:20 2007 +0200 @@ -15,8 +15,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;; Cleanup, merging with FSF by Ben Wing, January 1996 diff -r ad457d5f7d04 -r 0293115a14e9 lisp/modes/m4-mode.el --- a/lisp/modes/m4-mode.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/modes/m4-mode.el Mon Aug 13 08:49:20 2007 +0200 @@ -28,7 +28,7 @@ ;; It also sets the font-lock syntax stuff for colorization ;; By Drew Csillag (drew@staff.prodigy.com) -;; $Id: m4-mode.el,v 1.1.1.1 1996/12/18 03:53:17 steve Exp $ +;; $Id: m4-mode.el,v 1.2 1997/02/02 05:05:40 steve Exp $ ;; History: @@ -69,7 +69,7 @@ ;;; Code: ;;path to the m4 program -(defvar m4-program "/usr/local/bin/m4") +(defvar m4-program "/usr/bin/m4") ;;thank god for make-regexp.el! (defvar m4-font-lock-keywords diff -r ad457d5f7d04 -r 0293115a14e9 lisp/modes/mail-abbrevs.el --- a/lisp/modes/mail-abbrevs.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/modes/mail-abbrevs.el Mon Aug 13 08:49:20 2007 +0200 @@ -17,8 +17,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; This file ensures that, when the point is in a To:, CC:, BCC:, or From: ;;; field, word-abbrevs are defined for each of your mail aliases. These diff -r ad457d5f7d04 -r 0293115a14e9 lisp/modes/old-c++-mode.el --- a/lisp/modes/old-c++-mode.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/modes/old-c++-mode.el Mon Aug 13 08:49:20 2007 +0200 @@ -24,8 +24,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;; Introduction ;; ============ diff -r ad457d5f7d04 -r 0293115a14e9 lisp/modes/old-c-mode.el --- a/lisp/modes/old-c-mode.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/modes/old-c-mode.el Mon Aug 13 08:49:20 2007 +0200 @@ -17,8 +17,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Synched up with: FSF 19.30. diff -r ad457d5f7d04 -r 0293115a14e9 lisp/modes/pascal.el --- a/lisp/modes/pascal.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/modes/pascal.el Mon Aug 13 08:49:20 2007 +0200 @@ -18,8 +18,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Synched up with: FSF 19.30. diff -r ad457d5f7d04 -r 0293115a14e9 lisp/modes/perl-mode.el --- a/lisp/modes/perl-mode.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/modes/perl-mode.el Mon Aug 13 08:49:20 2007 +0200 @@ -23,8 +23,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Synched up with: FSF 19.30. diff -r ad457d5f7d04 -r 0293115a14e9 lisp/modes/picture.el --- a/lisp/modes/picture.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/modes/picture.el Mon Aug 13 08:49:20 2007 +0200 @@ -18,8 +18,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Synched up with: FSF 19.30. diff -r ad457d5f7d04 -r 0293115a14e9 lisp/modes/postscript.el --- a/lisp/modes/postscript.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/modes/postscript.el Mon Aug 13 08:49:20 2007 +0200 @@ -15,8 +15,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Synched up with: Not in FSF. diff -r ad457d5f7d04 -r 0293115a14e9 lisp/modes/prolog.el --- a/lisp/modes/prolog.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/modes/prolog.el Mon Aug 13 08:49:20 2007 +0200 @@ -18,8 +18,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Synched up with: Not synched with FSF, we appear to have a newer version diff -r ad457d5f7d04 -r 0293115a14e9 lisp/modes/rexx-mode.el --- a/lisp/modes/rexx-mode.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/modes/rexx-mode.el Mon Aug 13 08:49:20 2007 +0200 @@ -16,8 +16,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Synched up with: Not in FSF. diff -r ad457d5f7d04 -r 0293115a14e9 lisp/modes/rsz-minibuf.el --- a/lisp/modes/rsz-minibuf.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/modes/rsz-minibuf.el Mon Aug 13 08:49:20 2007 +0200 @@ -10,7 +10,7 @@ ;;; Keywords: minibuffer, window, frames, display ;;; Status: Known to work in FSF GNU Emacs 19.23 and Lucid Emacs 19.9. -;;; $Id: rsz-minibuf.el,v 1.1.1.1 1996/12/18 03:30:55 steve Exp $ +;;; $Id: rsz-minibuf.el,v 1.2 1997/02/02 05:05:42 steve Exp $ ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by @@ -159,10 +159,16 @@ (add-hook 'minibuffer-exit-hook 'resize-minibuffer-frame-restore nil t) (make-local-hook 'post-command-hook) - (add-hook 'post-command-hook 'resize-minibuffer-frame nil t)))) + (add-hook 'post-command-hook 'resize-minibuffer-frame nil t) + (unless (and (boundp 'icomplete-mode) + icomplete-mode) + (resize-minibuffer-frame))))) (t (make-local-hook 'post-command-hook) - (add-hook 'post-command-hook 'resize-minibuffer-window nil t)))))) + (add-hook 'post-command-hook 'resize-minibuffer-window nil t) + (unless (and (boundp 'icomplete-mode) + icomplete-mode) + (resize-minibuffer-window))))))) (defun resize-minibuffer-count-window-lines (&optional start end) "Return number of window lines occupied by text in region. diff -r ad457d5f7d04 -r 0293115a14e9 lisp/modes/sendmail.el --- a/lisp/modes/sendmail.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/modes/sendmail.el Mon Aug 13 08:49:20 2007 +0200 @@ -18,8 +18,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Synched up with: FSF 19.30. diff -r ad457d5f7d04 -r 0293115a14e9 lisp/modes/simula.el --- a/lisp/modes/simula.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/modes/simula.el Mon Aug 13 08:49:20 2007 +0200 @@ -21,8 +21,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Synched up with: FSF 19.30. diff -r ad457d5f7d04 -r 0293115a14e9 lisp/modes/tex-mode.el --- a/lisp/modes/tex-mode.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/modes/tex-mode.el Mon Aug 13 08:49:20 2007 +0200 @@ -19,8 +19,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. (require 'comint) @@ -64,12 +65,18 @@ "*User defined LaTeX block names. Combined with `standard-latex-block-names' for minibuffer completion.") +(defvar tex-latex-document-regex "documentstyle\\|documentclass" + "matches the first command of a LaTeX document") + (defvar slitex-run-command "slitex" "*Command used to run SliTeX subjob. If this string contains an asterisk (*), it will be replaced by the filename; if not, the name of the file, preceded by blank, will be added to this string.") +(defvar tex-slitex-document-regex "documentstyle{slides}" + "Matches the first command of a slitex document") + (defvar tex-bibtex-command "bibtex" "*Command used by `tex-bibtex-file' to gather bibliographic data. If this string contains an asterisk (*), it will be replaced by the @@ -214,8 +221,8 @@ (beginning-of-line) (search-forward "%" search-end t)))))) (if (and slash (not comment)) - (setq mode (if (looking-at "documentstyle") - (if (looking-at "documentstyle{slides}") + (setq mode (if (looking-at tex-latex-document-regex) + (if (looking-at tex-slitex-document-regex) 'slitex-mode 'latex-mode) 'plain-tex-mode)))) diff -r ad457d5f7d04 -r 0293115a14e9 lisp/modes/texinfo.el --- a/lisp/modes/texinfo.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/modes/texinfo.el Mon Aug 13 08:49:20 2007 +0200 @@ -20,8 +20,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Synched up with: FSF 19.30. diff -r ad457d5f7d04 -r 0293115a14e9 lisp/modes/view.el --- a/lisp/modes/view.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/modes/view.el Mon Aug 13 08:49:20 2007 +0200 @@ -355,7 +355,7 @@ (scroll-up lines))) (cond ((pos-visible-in-window-p (point-max)) (goto-char (point-max)) - (message "%" + (message "%s" (substitute-command-keys "End. Type \\[view-exit] to quit viewing.")))) (move-to-window-line -1) diff -r ad457d5f7d04 -r 0293115a14e9 lisp/modes/vrml-mode.el --- a/lisp/modes/vrml-mode.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/modes/vrml-mode.el Mon Aug 13 08:49:20 2007 +0200 @@ -19,8 +19,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Synched up with: Not in FSF. diff -r ad457d5f7d04 -r 0293115a14e9 lisp/modes/xpm-mode.el --- a/lisp/modes/xpm-mode.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/modes/xpm-mode.el Mon Aug 13 08:49:20 2007 +0200 @@ -24,8 +24,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Synched up with: Not in FSF. diff -r ad457d5f7d04 -r 0293115a14e9 lisp/mu/mu-cite.el --- a/lisp/mu/mu-cite.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/mu/mu-cite.el Mon Aug 13 08:49:20 2007 +0200 @@ -1,15 +1,15 @@ ;;; mu-cite.el --- yet another citation tool for GNU Emacs -;; Copyright (C) 1995,1996 Free Software Foundation, Inc. +;; Copyright (C) 1995,1996,1997 Free Software Foundation, Inc. ;; Author: MORIOKA Tomohiko ;; MINOURA Makoto ;; Shuhei KOBAYASHI ;; Maintainer: Shuhei KOBAYASHI -;; Version: $Revision: 1.3 $ +;; Version: $Revision: 1.4 $ ;; Keywords: mail, news, citation -;; This file is part of tl (Tiny Library). +;; This file is part of MU (Message Utilities). ;; This program is free software; you can redistribute it and/or ;; modify it under the terms of the GNU General Public License as @@ -54,7 +54,7 @@ ;;; (defconst mu-cite/RCS-ID - "$Id: mu-cite.el,v 1.3 1996/12/29 00:15:00 steve Exp $") + "$Id: mu-cite.el,v 1.4 1997/02/02 05:05:45 steve Exp $") (defconst mu-cite/version (get-version-string mu-cite/RCS-ID)) @@ -390,45 +390,74 @@ ;;; @ message editing utilities ;;; + +(defvar citation-mark-chars ">}|" + "*String of characters for citation delimiter. [mu-cite.el]") -(defvar cited-prefix-regexp "^[^ \t>]*[>|]+[ \t#]*" - "*Regexp to match the citation prefix.") +(defun detect-paragraph-cited-prefix () + (save-excursion + (goto-char (point-min)) + (let ((i 0) + (prefix + (buffer-substring + (progn (beginning-of-line)(point)) + (progn (end-of-line)(point)) + )) + str ret) + (while (and (= (forward-line) 0) + (setq str (buffer-substring + (progn (beginning-of-line)(point)) + (progn (end-of-line)(point)))) + (setq ret (string-compare-from-top prefix str)) + ) + (setq prefix + (if (stringp ret) + ret + (second ret))) + (setq i (1+ i)) + ) + (cond ((> i 1) prefix) + ((> i 0) + (goto-char (point-min)) + (save-restriction + (narrow-to-region (point) + (+ (point)(length prefix))) + (goto-char (point-max)) + (if (re-search-backward + (concat "[" citation-mark-chars "]") nil t) + (progn + (goto-char (match-end 0)) + (if (looking-at "[ \t]+") + (goto-char (match-end 0)) + ) + (buffer-substring (point-min)(point)) + ) + prefix))) + ((progn + (goto-char (point-max)) + (re-search-backward (concat "[" citation-mark-chars "]") + nil t) + ) + (goto-char (match-end 0)) + (if (looking-at "[ \t]+") + (goto-char (match-end 0)) + ) + (buffer-substring (point-min)(point)) + ) + (t "")) + ))) (defun fill-cited-region (beg end) (interactive "*r") (save-excursion (save-restriction (goto-char end) - (while (not (eolp)) - (backward-char) - ) - (setq end (point)) + (and (search-backward "\n" nil t) + (setq end (match-end 0)) + ) (narrow-to-region beg end) - (goto-char (point-min)) - (let* ((fill-prefix - (let* ((str1 (buffer-substring - (progn (beginning-of-line)(point)) - (progn (end-of-line)(point)) - )) - (str2 (let ((p0 (point))) - (forward-line) - (if (> (count-lines p0 (point)) 0) - (buffer-substring - (progn (beginning-of-line)(point)) - (progn (end-of-line)(point)) - )))) - (ret (string-compare-from-top str1 str2)) - ) - (if ret - (let ((prefix (nth 1 ret))) - (if (string-match cited-prefix-regexp prefix) - (substring prefix 0 (match-end 0)) - prefix)) - (goto-char (point-min)) - (if (re-search-forward cited-prefix-regexp nil t) - (buffer-substring (match-beginning 0) (match-end 0)) - )))) - (pat (concat "\n" fill-prefix)) + (let* ((fill-prefix (detect-paragraph-cited-prefix)) + (pat (concat fill-prefix "\n")) ) (goto-char (point-min)) (while (search-forward pat nil t) @@ -450,8 +479,6 @@ (fill-region (point-min) (point-max)) )))) -(defvar citation-mark-chars ">}|") - (defun compress-cited-prefix () (interactive) (save-excursion diff -r ad457d5f7d04 -r 0293115a14e9 lisp/packages/add-log.el --- a/lisp/packages/add-log.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/packages/add-log.el Mon Aug 13 08:49:20 2007 +0200 @@ -17,8 +17,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Synched up with: FSF 19.34. diff -r ad457d5f7d04 -r 0293115a14e9 lisp/packages/array.el --- a/lisp/packages/array.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/packages/array.el Mon Aug 13 08:49:20 2007 +0200 @@ -19,8 +19,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Synched up with: FSF 19.34. diff -r ad457d5f7d04 -r 0293115a14e9 lisp/packages/auto-save.el --- a/lisp/packages/auto-save.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/packages/auto-save.el Mon Aug 13 08:49:20 2007 +0200 @@ -18,8 +18,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Synched up with: Not in FSF. diff -r ad457d5f7d04 -r 0293115a14e9 lisp/packages/blink-cursor.el --- a/lisp/packages/blink-cursor.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/packages/blink-cursor.el Mon Aug 13 08:49:20 2007 +0200 @@ -17,8 +17,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Synched up with: Not in FSF. diff -r ad457d5f7d04 -r 0293115a14e9 lisp/packages/blink-paren.el --- a/lisp/packages/blink-paren.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/packages/blink-paren.el Mon Aug 13 08:49:20 2007 +0200 @@ -17,8 +17,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Synched up with: Not in FSF. diff -r ad457d5f7d04 -r 0293115a14e9 lisp/packages/chistory.el --- a/lisp/packages/chistory.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/packages/chistory.el Mon Aug 13 08:49:20 2007 +0200 @@ -18,8 +18,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Synched up with: FSF 19.34. diff -r ad457d5f7d04 -r 0293115a14e9 lisp/packages/cmuscheme.el --- a/lisp/packages/cmuscheme.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/packages/cmuscheme.el Mon Aug 13 08:49:20 2007 +0200 @@ -19,8 +19,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Synched up with: FSF 19.34. diff -r ad457d5f7d04 -r 0293115a14e9 lisp/packages/compare-w.el --- a/lisp/packages/compare-w.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/packages/compare-w.el Mon Aug 13 08:49:20 2007 +0200 @@ -17,8 +17,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Synched up with: FSF 19.34. diff -r ad457d5f7d04 -r 0293115a14e9 lisp/packages/compile.el --- a/lisp/packages/compile.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/packages/compile.el Mon Aug 13 08:49:20 2007 +0200 @@ -125,24 +125,24 @@ ;; We'll insist that the number be followed by a colon or closing ;; paren, because otherwise this matches just about anything ;; containing a number with spaces around it. - ("\n\ + ("\ \\([a-zA-Z]?:?[^:( \t\n]+\\)[:(][ \t]*\\([0-9]+\\)\\([) \t]\\|\ :\\([^0-9\n]\\|\\([0-9]+:\\)\\)\\)" 1 2 5) ;; Microsoft C/C++: ;; keyboard.c(537) : warning C4005: 'min' : macro redefinition ;; d:\tmp\test.c(23) : error C2143: syntax error : missing ';' before 'if' - ("\n\\(\\([a-zA-Z]:\\)?[^:( \t\n-]+\\)[:(][ \t]*\\([0-9]+\\)[:) \t]" 1 3) + ("\\(\\([a-zA-Z]:\\)?[^:( \t\n-]+\\)[:(][ \t]*\\([0-9]+\\)[:) \t]" 1 3) ;; Borland C++: ;; Error ping.c 15: Unable to open include file 'sys/types.h' ;; Warning ping.c 68: Call to function 'func' with no prototype - ("\n\\(Error\\|Warning\\) \\([a-zA-Z]?:?[^:( \t\n]+\\)\ + ("\\(Error\\|Warning\\) \\([a-zA-Z]?:?[^:( \t\n]+\\)\ \\([0-9]+\\)\\([) \t]\\|:[^0-9\n]\\)" 2 3) ;; 4.3BSD lint pass 2 ;; strcmp: variable # of args. llib-lc(359) :: /usr/src/foo/foo.c(8) - ("[ \t:]\\([a-zA-Z]?:?[^:( \t\n]+\\)[:(](+[ \t]*\\([0-9]+\\))[:) \t]*$" + ("[^\n]*[ \t:]\\([a-zA-Z]?:?[^:( \t\n]+\\)[:(](+[ \t]*\\([0-9]+\\))[:) \t]*$" 1 2) ;; 4.3BSD lint pass 3 @@ -150,26 +150,26 @@ ;; This used to be ;; ("[ \t(]+\\([a-zA-Z]?:?[^:( \t\n]+\\)[:( \t]+\\([0-9]+\\)[:) \t]+" 1 2) ;; which is regexp Impressionism - it matches almost anything! - ("([ \t]*\\([a-zA-Z]?:?[^:( \t\n]+\\)[:(][ \t]*\\([0-9]+\\))" 1 2) + ("[^\n]*([ \t]*\\([a-zA-Z]?:?[^:( \t\n]+\\)[:(][ \t]*\\([0-9]+\\))" 1 2) ;; MIPS lint pass; looks good for SunPro lint also ;; TrimMask (255) in solomon.c may be indistinguishable from TrimMasks (93) in solomon.c due to truncation - ("[^ ]+ (\\([0-9]+\\)) in \\([^ ]+\\)" 2 1) + ("[^ \n]+ (\\([0-9]+\\)) in \\([^ \n]+\\)" 2 1) ;; name defined but never used: LinInt in cmap_calc.c(199) - ("in \\([^(]+\\)(\\([0-9]+\\))$" 1 2) + ("[^\n]*in \\([^(\n]+\\)(\\([0-9]+\\))$" 1 2) ;; Ultrix 3.0 f77: ;; fort: Severe: addstf.f, line 82: Missing operator or delimiter symbol ;; Some SGI cc version: ;; cfe: Warning 835: foo.c, line 2: something - ("\n\\(cfe\\|fort\\): [^:\n]*: \\([^ \n]*\\), line \\([0-9]+\\):" 2 3) + ("\\(cfe\\|fort\\): [^:\n]*: \\([^ \n]*\\), line \\([0-9]+\\):" 2 3) ;; Error on line 3 of t.f: Execution error unclassifiable statement ;; Unknown who does this: ;; Line 45 of "foo.c": bloofle undefined ;; Absoft FORTRAN 77 Compiler 3.1.3 ;; error on line 19 of fplot.f: spelling error? ;; warning on line 17 of fplot.f: data type is undefined for variable d - ("\\(\n\\|on \\)[Ll]ine[ \t]+\\([0-9]+\\)[ \t]+\ + ("\\(\\|[^\n]* on \\)[Ll]ine[ \t]+\\([0-9]+\\)[ \t]+\ of[ \t]+\"?\\([a-zA-Z]?:?[^\":\n]+\\)\"?:" 3 2) ;; Apollo cc, 4.3BSD fc: @@ -184,58 +184,66 @@ ;; "foo.adb", line 2(11): warning: file name does not match ... ;; IBM AIX xlc compiler: ;; "src/swapping.c", line 30.34: 1506-342 (W) "/*" detected in comment. - ("\"\\([^,\" \n\t]+\\)\", lines? \ + ("[^\n]*\"\\([^,\" \n\t]+\\)\", lines? \ \\([0-9]+\\)\\([\(.]\\([0-9]+\\)\)?\\)?[:., (-]" 1 2 4) ;; MIPS RISC CC - the one distributed with Ultrix: ;; ccom: Error: foo.c, line 2: syntax error ;; DEC AXP OSF/1 cc ;; /usr/lib/cmplrs/cc/cfe: Error: foo.c: 1: blah blah - ("rror: \\([^,\" \n\t]+\\)[,:] \\(line \\)?\\([0-9]+\\):" 1 3) + ("[^\n]*rror: \\([^,\" \n\t]+\\)[,:] \\(line \\)?\\([0-9]+\\):" 1 3) ;; IBM AIX PS/2 C version 1.1: ;; ****** Error number 140 in line 8 of file errors.c ****** - ("in line \\([0-9]+\\) of file \\([^ \n]+[^. \n]\\)\\.? " 2 1) + ("[^\n]*in line \\([0-9]+\\) of file \\([^ \n]+[^. \n]\\)\\.? " 2 1) ;; IBM AIX lint is too painful to do right this way. File name ;; prefixes entire sections rather than being on each line. ;; Lucid Compiler, lcc 3.x ;; E, file.cc(35,52) Illegal operation on pointers - ("\n[EW], \\([^(\n]*\\)(\\([0-9]+\\),[ \t]*\\([0-9]+\\)" 1 2 3) + ("[EW], \\([^(\n]*\\)(\\([0-9]+\\),[ \t]*\\([0-9]+\\)" 1 2 3) ;; GNU messages with program name and optional column number. - ("\n[a-zA-Z]?:?[^0-9 \n\t:]+:[ \t]*\\([^ \n\t:]+\\):\ + ("[a-zA-Z]?:?[^0-9 \n\t:]+:[ \t]*\\([^ \n\t:]+\\):\ \\([0-9]+\\):\\(\\([0-9]+\\)[: \t]\\)?" 1 2 4) + ;; GNU messages with program name and optional column number + ;; and a severity letter after that. nsgmls makes them. + ("[^0-9 \n\t:]+:[ \t]*\\([^ \n\t:]+\\):\ +\\([0-9]+\\):\\(\\([0-9]+\\):\\)?[A-Za-z]:" 1 2 4) + ;; jwz: ;; IRIX 5.2 ;; cfe: Warning 712: foo.c, line 2: illegal combination of pointer and ... - (" \\([^ \n,\"]+\\), line \\([0-9]+\\):" 1 2) + ("[^\n]* \\([^ \n,\"]+\\), line \\([0-9]+\\):" 1 2) ;; IRIX 5.2 ;; cfe: Warning 600: xfe.c: 170: Not in a conditional directive while ... - (": \\([^ \n,\"]+\\): \\([0-9]+\\):" 1 2) + ("[^\n]*: \\([^ \n,\"]+\\): \\([0-9]+\\):" 1 2) ;; Cray C compiler error messages - ("\n\\(cc\\| cft\\)-[0-9]+ c\\(c\\|f77\\): ERROR \\([^,\n]+, \\)* File = \\([^,\n]+\\), Line = \\([0-9]+\\)" 4 5) + ("\\(cc\\| cft\\)-[0-9]+ c\\(c\\|f77\\): ERROR \\([^,\n]+, \\)* File = \\([^,\n]+\\), Line = \\([0-9]+\\)" 4 5) ;; IBM C/C++ Tools 2.01: ;; foo.c(2:0) : informational EDC0804: Function foo is not referenced. ;; foo.c(3:8) : warning EDC0833: Implicit return statement encountered. ;; foo.c(5:5) : error EDC0350: Syntax error. - ("\n\\([^( \n\t]+\\)(\\([0-9]+\\):\\([0-9]+\\)) : " 1 2 3) + ("\\([^( \n\t]+\\)(\\([0-9]+\\):\\([0-9]+\\)) : " 1 2 3) ;; Sun ada (VADS, Solaris): ;; /home3/xdhar/rcds_rc/main.a, line 361, char 6:syntax error: "," inserted - ("\n\\([^, ]+\\), line \\([0-9]+\\), char \\([0-9]+\\)[:., \(-]" 1 2 3) + ("\\([^, \n\t]+\\), line \\([0-9]+\\), char \\([0-9]+\\)[:., \(-]" 1 2 3) ) - "Alist that specifies how to match errors in compiler output. + "Alist that specifies how to match errors in compiler output. Each elt has the form (REGEXP FILE-IDX LINE-IDX [COLUMN-IDX FILE-FORMAT...]) -If REGEXP matches, the FILE-IDX'th subexpression gives the file name, and -the LINE-IDX'th subexpression gives the line number. If COLUMN-IDX is -given, the COLUMN-IDX'th subexpression gives the column number on that line. -If any FILE-FORMAT is given, each is a format string to produce a file name to -try; %s in the string is replaced by the text matching the FILE-IDX'th -subexpression.") +If REGEXP matches constrained to the beginning of the line, the +FILE-IDX'th subexpression gives the file name, and the LINE-IDX'th +subexpression gives the line number. If COLUMN-IDX is given, the +COLUMN-IDX'th subexpression gives the column number on that line. If +any FILE-FORMAT is given, each is a format string to produce a file name +to try; %s in the string is replaced by the text matching the +FILE-IDX'th subexpression. Note previously REGEXP was not constrained +to the beginning of the line, so old patterns without leading `^' or `\\n' +may now require a leading `.*'.") (defvar compilation-read-command t "If not nil, M-x compile reads the compilation command to use. @@ -272,14 +280,14 @@ buffer-file-name))))))") (defvar compilation-enter-directory-regexp - ": Entering directory `\\(.*\\)'$" + "[^\n]*: Entering directory `\\([^\n]*\\)'$" "Regular expression matching lines that indicate a new current directory. This must contain one \\(, \\) pair around the directory name. The default value matches lines printed by the `-w' option of GNU Make.") (defvar compilation-leave-directory-regexp - ": Leaving directory `\\(.*\\)'$" + "[^\n]*: Leaving directory `\\([^\n]*\\)'$" "Regular expression matching lines that indicate restoring current directory. This may contain one \\(, \\) pair around the name of the directory being moved from. If it does not, the last directory entered \(by a @@ -1569,7 +1577,16 @@ ;; We don't just pass LIMIT-SEARCH to re-search-forward ;; because we want to find matches containing LIMIT-SEARCH ;; but which extend past it. - (re-search-forward regexp nil t)) + ;; Instead of using re-search-forward, + ;; we use this loop which tries only at each line. + (progn + (while (and (not (eobp)) + (not (looking-at regexp))) + (forward-line 1)) + (not (eobp)))) + + ;; Move to the end of the match we just found. + (goto-char (match-end 0)) ;; Figure out which constituent regexp matched. (cond ((match-beginning enter-group) diff -r ad457d5f7d04 -r 0293115a14e9 lisp/packages/detexinfo.el --- a/lisp/packages/detexinfo.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/packages/detexinfo.el Mon Aug 13 08:49:20 2007 +0200 @@ -17,8 +17,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Synched up with: Not in FSF. diff -r ad457d5f7d04 -r 0293115a14e9 lisp/packages/file-part.el --- a/lisp/packages/file-part.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/packages/file-part.el Mon Aug 13 08:49:20 2007 +0200 @@ -17,8 +17,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Synched up with: Not in FSF. diff -r ad457d5f7d04 -r 0293115a14e9 lisp/packages/font-lock.el --- a/lisp/packages/font-lock.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/packages/font-lock.el Mon Aug 13 08:49:20 2007 +0200 @@ -554,7 +554,10 @@ (t (remove-hook 'after-change-functions 'font-lock-after-change-function t) - (remove-hook 'pre-idle-hook 'font-lock-pre-idle-hook) + ;; We have no business doing this here, since + ;; pre-idle-hook is global. Other buffers may + ;; still be in font-lock mode. -dkindred@cs.cmu.edu + ;; (remove-hook 'pre-idle-hook 'font-lock-pre-idle-hook) )) (set (make-local-variable 'font-lock-mode) on-p) (cond (on-p diff -r ad457d5f7d04 -r 0293115a14e9 lisp/packages/func-menu.el --- a/lisp/packages/func-menu.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/packages/func-menu.el Mon Aug 13 08:49:20 2007 +0200 @@ -1,8 +1,8 @@ ;;; func-menu.el --- Jump to a function within a buffer. ;;; ;;; David Hughes -;;; Last modified: David Hughes 2nd May 1996 -;;; Version: 2.43 +;;; Last modified: David Hughes 13th January 1997 +;;; Version: 2.45 ;;; Keywords: tools, c, lisp ;;; ;;; This program is free software; you can redistribute it and/or modify @@ -43,8 +43,8 @@ ;;; addition, the name of the function before point is optionally displayed in ;;; the modeline. ;;; -;;; Support for non X Windows versions of Emacs: -;;; ============================================ +;;; Support for non X Window versions of Emacs: +;;; =========================================== ;;; This package can also be used for non X versions of Emacs. In this case, ;;; only modeline display and completing read input from the minibuffer are ;;; possible. @@ -58,6 +58,15 @@ ;;; Acknowledgements: ;;; ================= ;;; +;;; Fix to fume-function-name-regexp-c +;;; Jonathan Edwards +;;; +;;; Speedup for fume-cc-inside-comment +;;; Peter Pezaris +;;; +;;; Made menu placement more flexible +;;; Bob Weiner +;;; ;;; Fortran90 regexp ;;; John Turner ;;; @@ -65,6 +74,7 @@ ;;; Andy Piper ;;; ;;; Java support +;;; Bob Weiner ;;; Heddy Boubaker ;;; ;;; Patch for fume-rescan-buffer{-trigger} @@ -140,6 +150,7 @@ ;;; Thomas Plass ;;; ;;; Extensions to fume-function-name-regexp-lisp +;;; Vladimir Alexiev ;;; Kari Heinola ;;; Milo A. Chan ;;; Jack Repenning @@ -162,7 +173,7 @@ ;;; Philippe Queinnec ;;; ;;; Assembly support -;;; Bob Weiner +;;; Bob Weiner ;;; ;;; Removal of cl dependencies ;;; Russell Ritchie @@ -202,14 +213,14 @@ ;;;;;;;;;;;;;;;;;;;;;;;; Environment Initialisation ;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defconst fume-version "2.43") +(defconst fume-version "2.45") (defconst fume-developer "David Hughes ") (defun fume-about () (interactive) (sit-for 0) - (message "Func-Menu version %s, ¨ 1996 %s" fume-version fume-developer)) + (message "Func-Menu version %s, © 1996 %s" fume-version fume-developer)) (defconst fume-running-xemacs (string-match "XEmacs\\|Lucid" emacs-version)) @@ -365,11 +376,11 @@ (cond ((fboundp 'add-submenu) (defconst fume-add-submenu 'add-submenu) (defun fume-munge-menu-args (menu-name submenu before) - (list nil (cons menu-name submenu) before))) + (list fume-menu-path (cons menu-name submenu) before))) (t (defconst fume-add-submenu 'add-menu) (defun fume-munge-menu-args (menu-name submenu before) - (list nil menu-name submenu before)))) + (list fume-menu-path menu-name submenu before)))) (defun fume-add-submenu (menu-name submenu before) (apply fume-add-submenu (fume-munge-menu-args menu-name submenu before))) @@ -397,10 +408,16 @@ (defvar fume-buffer-name "*Function List*" "Name of buffer used to list functions when fume-list-functions called") -(fume-defvar-local - fume-menubar-menu-name "Functions" +(defvar fume-menubar-menu-name "Functions" "*Set this to the string you want to appear in the menubar") +;;; Bob Weiner +(defvar fume-menu-path nil + "Menubar menu under which the function menu should be installed. +Nil means install it on the menubar itself. Otherwise, it should be a list +of strings, each string names a successively deeper menu under which the +new menu should be located.") + (defvar fume-menubar-menu-location "Buffers" "*Set this nil if you want the menu to appear last on the menubar. Otherwise set this to the menu you want \"Functions\" to appear in front of.") @@ -520,21 +537,16 @@ ;;; Lisp ;;; -;;; Jack Repenning -;;; Cedric Beust +;;; Vladimir Alexiev (defvar fume-function-name-regexp-lisp (concat - "\\(^(defun+\\s-*[#:?A-Za-z0-9_+->]+\\s-*(\\)" - "\\|" - "\\(^(defsubst+\\s-*[#:?A-Za-z0-9_+->]+\\s-*(\\)" - "\\|" - "\\(^(defmacro+\\s-*[#:?A-Za-z0-9_+->]+\\s-*(\\)" - "\\|" - "\\(^(defadvice+\\s-*[#:?A-Za-z0-9_+->]+\\s-*(\\)" - "\\|" - "\\(^(de+\\s-*[#:?A-Za-z0-9_+->]+\\s-*(\\)" - "\\|" - "\\(^(dmd+\\s-*[#:?A-Za-z0-9_+->]+\\s-*(\\)" + "^[ \t]*" ; Allow whitespace |(or (fboundp 'foo) + ; for the construct | (defun foo () + "(\\(def[^vc][a-z]*\\)" ; Allow (def* except (defvar, (defconst + "\\s-+" ; At least one whitespace + "'?[#:?A-Za-z0-9_+>-]+" ; Allow (defalias 'foo 'bar) + "\\s-*" ; Whitespace + "\\(nil\\|(\\)" ; nil or (arg list ) "Expression to get lisp function names") @@ -543,11 +555,11 @@ ;;; Danny Bar-Dov (defvar fume-function-name-regexp-c (concat - "^[a-zA-Z0-9]+\\s-?" ; type specs; there can be no - "\\([a-zA-Z0-9_*]+\\s-+\\)?" ; more than 3 tokens, right? + "^[a-zA-Z0-9_]+\\s-?" ; type specs; there can be no + "\\([a-zA-Z0-9_*]+\\s-+\\)?" ; more than 3 tokens, right? "\\([a-zA-Z0-9_*]+\\s-+\\)?" - "\\([*&]+\\s-*\\)?" ; pointer - "\\([a-zA-Z0-9_*]+\\)[ \t\n]*(" ; name + "\\([*&]+\\s-*\\)?" ; pointer + "\\([a-zA-Z0-9_*]+\\)[ \t\n]*(" ; name ) "Expression to get C function names") @@ -787,6 +799,7 @@ (defvar fume-function-name-regexp-make "^\\(\\(\\$\\s(\\)?\\(\\w\\|\\.\\)+\\(:sh\\)?\\(\\s)\\)?\\)\\s *\\(::?\\|\\+?=\\)" "Expression to get makefile target names") +(add-hook 'makefile-mode-hook 'fume-add-menubar-entry) ;;; Directory Listings ;;; @@ -819,6 +832,12 @@ "^\\(task\\|function\\|module\\|primitive\\)[ \t]+\\([A-Za-z0-9_+-]*\\)[ \t]*(?" "Expression to get verilog module names") +;;; Idl +;;; +;;; Lubos Pochman +(defvar fume-function-name-regexp-idl + (cons "^\\s *\\([pP][rR][oO]\\|[fF][uU][nN][cC][tT][iI][oO][nN]\\)\\s +\\([A-Za-z][A-Za-z0-9_$]*\\)" 2) + "Expression to get Idl function Names") ;;; Assembly (defvar fume-function-name-regexp-asm @@ -919,6 +938,9 @@ ;; Verilog (verilog-mode . fume-function-name-regexp-verilog) + ;; Idl + (idl-mode . fume-function-name-regexp-idl) + ;; Assembly (asm-mode . fume-function-name-regexp-asm) ) @@ -937,7 +959,11 @@ ;; Search for the function (if (re-search-forward fume-function-name-regexp nil t) (let ((char (progn - (backward-up-list 1) + (if (string-match + "[({[]" + (char-to-string (char-after (1- (point))))) + (backward-char) + (forward-word -1)) (save-excursion (goto-char (scan-sexps (point) 1)) (skip-chars-forward "[ \t\n]") @@ -985,6 +1011,7 @@ (cons (buffer-substring beg end) beg)))) ;;; Specialised routine to get the next C function name in the buffer. +;;; Modified 16/12/96: Jerome Bertorelle ;;; (defun fume-find-next-c-function-name (buffer) "Searches for the next C function in BUFFER." @@ -999,7 +1026,7 @@ (following-char))))) ;; Skip this function name if it is a prototype declaration. (if (eq char ?\;) - (fume-find-next-function-name buffer) + (fume-find-next-c-function-name buffer) (let (beg name) ;; Get the function name and position @@ -1018,63 +1045,44 @@ (format "%s %s" name (buffer-substring beg (point)))))))) - ;; kludge to avoid 'void' in menu - (if (string-match "^void\\s-*" name) - (fume-find-next-function-name buffer) + ;; kludge to avoid 'void' etc in menu + (if (string-match "^void$\\|^if$\\|^switch$\\|^while$" name) + (fume-find-next-c-function-name buffer) (cons name beg))))))) +;;; Peter Pezaris +;;; (defun fume-cc-inside-comment () - (let ((here (point)) - (bol-point (save-excursion (beginning-of-line) (point)))) - (or - (save-excursion (and (re-search-backward "\/\/" bol-point t 1) t)) - (save-excursion - (and - (re-search-backward "\\(/[*]\\)\\|\\([*]/\\)" (point-min) t 1) - (looking-at "/[*]") - (goto-char here) - (or (beginning-of-line 1) t) - (re-search-forward "[ \t]*/?[*][ \t]*" here t 1) - t))))) + (memq (buffer-syntactic-context) '(comment block-comment))) ;;; ;;; ;;; +;;; - speedup, David Hughes 24th November 1996 ;;; (defun fume-match-find-next-function-name (buffer) - "General next function name in BUFFER finder using match. -The regexp is assumed to be a two item list the car of which is the regexp to -use, and the cdr of which is the match position of the function name." + ;; General next function name in BUFFER finder using match. + ;; The regexp is assumed to be a two item list the car of which is the regexp + ;; to use, and the cdr of which is the match position of the function name (set-buffer buffer) - (let ((result nil) - (continue t) - (regexp (car fume-function-name-regexp))) - (while continue - ;; Search for the function - (if (re-search-forward regexp nil t) - (if (fume-cc-inside-comment) - () ; skip spurious finds in comments - (let ((first-token (save-excursion - (re-search-backward regexp nil t) - (prog1 (fume-what-looking-at) - (re-search-forward regexp nil t)))) - (last-char (progn - (backward-up-list 1) - (save-excursion - (goto-char (scan-sexps (point) 1)) - (following-char))))) - ;; Skip function name if it's a prototype or typedef declaration - (if (or (eq last-char ?\;) (string= first-token "typedef")) - nil - (setq result - ;; Get function name and position including scope - (cons (buffer-substring - (match-beginning (cdr fume-function-name-regexp)) - (point)) - (match-beginning (cdr fume-function-name-regexp))) - continue nil)))) - (setq continue nil))) - result)) + (let ((r (car fume-function-name-regexp)) + (p (cdr fume-function-name-regexp))) + (catch 'found + (while (re-search-forward r nil t) + (catch 'skip + (if (fume-cc-inside-comment) (throw 'skip t)) + (save-excursion + (re-search-backward r nil t) + (if (string= "typedef" (fume-what-looking-at)) (throw 'skip t)) + (re-search-forward r nil t)) + (backward-up-list 1) + (save-excursion + (goto-char (scan-sexps (point) 1)) + (if (eq ?\; (following-char)) (throw 'skip t))) ; skip prototypes + (throw + 'found + (cons (buffer-substring (setq p (match-beginning p)) (point)) p)))) + nil))) ;;; Specialised routine to find the next Perl function ;;; @@ -1083,6 +1091,7 @@ (fume-find-next-sexp buffer)) ;;; Specialised routine to find the next Java function +;;; Bob Weiner ;;; Heddy Boubaker ;;; (defun fume-find-next-java-function-name (buffer) @@ -1095,12 +1104,15 @@ (forward-sexp) (if (and (looking-at "[^;(]*{") (not (fume-cc-inside-comment))) - ;; This is a method definition and we're not - ;; in a comment. + ;; This is a method definition and we're not in a comment (let ((str (buffer-substring beg end))) - (or (string-match "if\\|switch\\|catch\\|for\\|while" str) - ;; These constructs look like methods definitions - ;; but are not. + ;; Bob Weiner added exact match + ;; delimiters so function names that happen to contain + ;; any of these terms are not eliminated. The old version + ;; would ignore "notify()" since it contained "if". + (or (string-match "\\`\\(if\\|switch\\|catch\\|for\\|while\\)\\'" + str) + ;; These constructs look like method definitions but are not (cons str beg))) (fume-find-next-java-function-name buffer))))) @@ -1370,8 +1382,20 @@ (end (match-end 2))) (cons (buffer-substring beg end) beg)))) +;;; Specialised routine to get the next idl function in the buffer +;;; +;;; Lubos Pochman +(defun fume-find-next-idl-function-name (buffer) + "Searches for the next idl function in BUFFER." + (set-buffer buffer) + (if (re-search-forward (car fume-function-name-regexp-idl) nil t) + (let ((beg (match-beginning (cdr fume-function-name-regexp-idl))) + (end (match-end (cdr fume-function-name-regexp-idl)))) + (cons (buffer-substring beg end) beg)))) + + ;;; Assembly -;;; Bob Weiner +;;; Bob Weiner ;;; (defun fume-find-next-asm-function-name (buffer) "Searches for the next assembler function in BUFFER." @@ -1417,6 +1441,7 @@ (sgml-mode . fume-find-next-sgml-element-name) (tcl-mode . fume-match-find-next-function-name) (verilog-mode . fume-find-next-verilog-function-name) + (idl-mode . fume-find-next-idl-function-name) ) "The connection between a mode and the defun that finds function names. @@ -1426,12 +1451,10 @@ ;;;;;;;;;;;;;;;;;;;;;;;; General utility functions ;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Routine to refresh the modeline +;;; modeline refresh routine ;;; -(if (fboundp 'redraw-modeline) ; faster built-in method - (defalias 'fume-refresh-modeline 'redraw-modeline) - (defun fume-refresh-modeline () ; use old kludge method - (set-buffer-modified-p (buffer-modified-p)))) +(or (fboundp 'redraw-modeline) + (defun redraw-modeline () (set-buffer-modified-p (buffer-modified-p)))) ;;; Smart mouse positioning ;;; @@ -1464,18 +1487,18 @@ ;;; Routines to add/remove/update function menu from menubar ;;; -(defsubst fume-add-menubar-entry () +(defun fume-add-menubar-entry () (interactive) (save-window-excursion (function-menu t))) -(defsubst fume-remove-menubar-entry () +(defun fume-remove-menubar-entry () (interactive) (cond ((and fume-running-xemacs current-menubar) (delete-menu-item (list fume-menubar-menu-name)) ;; force update of the menubar - (fume-refresh-modeline)))) + (redraw-modeline)))) -(defsubst fume-update-menubar-entry () +(defun fume-update-menubar-entry () "Returns t if menubar was updated. Nil otherwise" (and fume-running-xemacs fume-not-tty @@ -1483,7 +1506,7 @@ (fume-add-menubar-entry) t)) -(defsubst fume-trim-string (string) +(defun fume-trim-string (string) "Returns STRING with leading and trailing whitespace removed." (if (string-match "^[ \t]*" (setq string (format "%s" string))) (setq string (substring string (match-end 0)))) @@ -1493,52 +1516,55 @@ (defvar fume-syntax-table nil) -(defsubst fume-what-looking-at () - (let (name - (orig-syntax-table (copy-syntax-table (syntax-table)))) - (if fume-syntax-table - () - (setq fume-syntax-table (copy-syntax-table)) - (modify-syntax-entry ?: "w" fume-syntax-table)) - (unwind-protect - (progn - (set-syntax-table fume-syntax-table) - (save-excursion - (while (looking-at "\\sw\\|\\s_") (forward-char 1)) - (if (re-search-backward "\\sw\\|\\s_" nil t) - (let ((beg (progn (forward-char 1) (point)))) - (forward-sexp -1) - (while (looking-at "\\s'") (forward-char 1)) - (setq name (buffer-substring beg (point))))))) - (set-syntax-table orig-syntax-table) - name))) +(defun fume-what-looking-at (&optional check-primary-selection-p) + (or (and check-primary-selection-p + primary-selection-extent + (condition-case () + (prog1 (buffer-substring (region-beginning) (region-end)) + (and zmacs-regions (zmacs-deactivate-region) (sit-for 0))) + (error nil))) + (let (name + (orig-syntax-table (copy-syntax-table (syntax-table)))) + (if fume-syntax-table + () + (setq fume-syntax-table (copy-syntax-table)) + (modify-syntax-entry ?: "w" fume-syntax-table)) + (unwind-protect + (progn + (set-syntax-table fume-syntax-table) + (save-excursion + (while (looking-at "\\sw\\|\\s_") (forward-char 1)) + (if (re-search-backward "\\sw\\|\\s_" nil t) + (let ((beg (progn (forward-char 1) (point)))) + (forward-sexp -1) + (while (looking-at "\\s'") (forward-char 1)) + (setq name (buffer-substring beg (point))))))) + (set-syntax-table orig-syntax-table) + name)))) -;;; Find function name that point is in. -;;; The trick is to start from the end... +;;; Find function name that point is in +;;; (trick is to start from the end) ;;; -(defsubst fume-function-before-point () +(defun fume-function-before-point () (if (or fume-modeline-funclist (fume-rescan-buffer) fume-modeline-funclist) - (let (result - (pt (point))) + (let ((p (point))) (save-excursion (catch 'found (mapcar (function - (lambda (p) - (goto-char (cdr p)) + (lambda (x) + (goto-char (cdr x)) (beginning-of-line 1) - (if (>= pt (point)) - (throw 'found (setq result (car p)))))) - fume-modeline-funclist)) - result)))) + (if (>= p (point)) (throw 'found (car x))))) + fume-modeline-funclist) nil))))) ;;; Routines to add a buffer local post command hook ;;; -(defsubst fume-post-command-hook-p (hook) +(defun fume-post-command-hook-p (hook) (memq hook (if fume-use-local-post-command-hook local-post-command-hook post-command-hook))) -(defsubst fume-add-post-command-hook (hook &optional append) +(defun fume-add-post-command-hook (hook &optional append) (or (fume-post-command-hook-p hook) (cond (fume-use-local-post-command-hook (add-hook 'local-post-command-hook hook append)) @@ -1550,7 +1576,7 @@ (make-local-variable 'post-command-hook) (add-hook 'post-command-hook hook append))))) -(defsubst fume-remove-post-command-hook (hook) +(defun fume-remove-post-command-hook (hook) (and (fume-post-command-hook-p hook) (cond (fume-use-local-post-command-hook (remove-hook 'local-post-command-hook hook)) @@ -1561,7 +1587,7 @@ ;;; Routine to install the modeline feature ;;; -(defsubst fume-maybe-install-modeline-feature () +(defun fume-maybe-install-modeline-feature () (cond ((and fume-display-in-modeline-p (fume-set-defaults)) (or fume-modeline-funclist (fume-post-command-hook-p 'fume-tickle-modeline) @@ -1594,8 +1620,8 @@ (cond ((not fume-display-in-modeline-p) (fume-remove-post-command-hook 'fume-tickle-modeline) (fume-add-post-command-hook 'fume-maybe-install-modeline-feature))) - ;; force an update of the mode line - (fume-refresh-modeline)) + ;; force update of the modeline + (redraw-modeline)) (fume-defvar-local fume-modeline-buffer-identification-0 nil "Storage for original modeline-buffer-identification") @@ -1645,18 +1671,18 @@ ;;; Sort function to sort items depending on their function-name ;;; An item looks like (NAME . POSITION). ;;; -(defsubst fume-sort-by-name (item1 item2) +(defun fume-sort-by-name (item1 item2) (or (string-lessp (car item1) (car item2)) (string-equal (car item1) (car item2)))) ;;; Sort function to sort items depending on their position ;;; -(defsubst fume-sort-by-position (item1 item2) +(defun fume-sort-by-position (item1 item2) (<= (cdr item1) (cdr item2))) ;;; Support function to calculate relative position in buffer ;;; -(defsubst fume-relative-position () +(defun fume-relative-position () (let ((pos (point)) (total (buffer-size))) (if (> total 50000) @@ -1668,7 +1694,7 @@ ;;; Split LIST into sublists of max length N ;;; Example (fume-split '(1 2 3 4 5 6 7 8) 3)-> '((1 2 3) (4 5 6) (7 8)) ;;; -(defsubst fume-split (list n) +(defun fume-split (list n) (let ((i 0) result sublist @@ -1782,7 +1808,7 @@ (let ((fume-scanning-message nil)) (fume-rescan-buffer)))))) -(defsubst fume-install-rescan-buffer-trigger () +(defun fume-install-rescan-buffer-trigger () (cond ((not (fume-post-command-hook-p 'fume-rescan-buffer-trigger)) (fume-add-post-command-hook 'fume-rescan-buffer-trigger 'append) ;; Make narrow-to-region tickle func-menu @@ -1864,6 +1890,9 @@ ;; Reset dirty flag (setq fume-funclist-dirty-p nil)) +(defun fume-scan-buffer () + (or fume-funclist (progn (fume-set-defaults) (fume-rescan-buffer)))) + ;;; Routine to position cursor ;;; (defun fume-goto-function (fn pos) @@ -1921,12 +1950,14 @@ ;;; Interface for Key bindings ;;; -(defun function-menu (&optional use-menubar) +(defun function-menu (&optional use-menubar return-only) "Pop up a menu of functions for selection with the mouse. +Jumps to the selected function. A mark is set at the old position, +so you can easily go back with C-u \\[set-mark-command]. With a prefix arg adds the menu to the current menubar. -Jumps to the selected function. A mark is set at the old position, -so you can easily go back with C-u \\[set-mark-command]." +Optional second argument, RETURN-ONLY if non-nil simply returns +the basic menu of functions." (interactive "P") (setq use-menubar @@ -1982,51 +2013,60 @@ (or (> count 1) (setq function-menu-items (cdr (car function-menu-items)))) - (setq function-menu - (` ((,@ function-menu-items) - "----" - ["Display full list of functions" - fume-list-functions t] - [(, (concat "Rescan buffer : " (buffer-name))) - (fume-rescan-buffer (, (null use-menubar))) t] - "----" - ["Toggle modeline display" - fume-toggle-modeline-display t] - ["Toggle buffer auto rescanning" - fume-toggle-auto-rescanning t] - ["About Func-Menu" fume-about t]))) + (if return-only + nil + (setq function-menu + (` ((,@ function-menu-items) + "----" + ["Display full list of functions" + fume-list-functions t] + [(, (concat "Rescan buffer : " (buffer-name))) + (fume-rescan-buffer (, (null use-menubar))) t] + "----" + ["Toggle modeline display" + fume-toggle-modeline-display t] + ["Toggle buffer auto rescanning" + fume-toggle-auto-rescanning t] + ["About Func-Menu" fume-about t]))) - (cond (use-menubar - (fume-remove-menubar-entry) - (set-buffer-menubar (copy-sequence current-menubar)) - (fume-add-submenu - fume-menubar-menu-name - (` ((,@ function-menu) - "----" - ["Remove Function Menu from menubar" - fume-remove-menubar-entry t])) - fume-menubar-menu-location)) + (cond (use-menubar + (fume-remove-menubar-entry) + (set-buffer-menubar (copy-sequence current-menubar)) + (fume-add-submenu + fume-menubar-menu-name + (` ((,@ function-menu) + "----" + ["Remove Function Menu from menubar" + fume-remove-menubar-entry t])) + fume-menubar-menu-location)) - ((and fume-not-tty ; trap tty segmentation faults... - (not (popup-menu-up-p))) - (or (fume-update-menubar-entry) - (setq function-menu - (cons - ["Put Function Menu into menubar" - (function-menu t) t] - (cons "----" function-menu)))) + ((and fume-not-tty ; trap tty segmentation faults... + (not (popup-menu-up-p))) + (or (fume-update-menubar-entry) + (setq function-menu + (cons + ["Put Function Menu into menubar" + (function-menu t) t] + (cons "----" function-menu)))) - (if fume-auto-position-popup - (fume-set-mouse-position)) + (if fume-auto-position-popup + (fume-set-mouse-position)) - (popup-menu (cons "Functions" function-menu))))))))) + (popup-menu + (cons fume-menubar-menu-name function-menu))))) + + ;; Return basic function menu for display by another function + function-menu-items))))) (defun fume-mouse-function-goto (event) "Goto function clicked on or prompt in minibuffer (with completion)." (interactive "@e") - (goto-char (event-point event)) - (let ((fume-no-prompt-on-valid-default t)) - (fume-prompt-function-goto))) + (let ((orig-pos (point))) + (goto-char (event-point event)) + (let ((fume-no-prompt-on-valid-default t)) + (fume-prompt-function-goto)) + (or (= orig-pos (point)) + (push-mark orig-pos (null fume-scanning-message))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;; Keyboard access to func-menu for tty users ;;;;;;;;;;;;;; @@ -2045,34 +2085,28 @@ "Goto function prompted for in minibuffer (with completion). With prefix arg, jumps to function in a different window." (interactive "P") - (and (interactive-p) current-prefix-arg (setq other-window-p t)) - (let* ((default-name (fume-what-looking-at)) + (let* ((default-name (fume-what-looking-at t)) (OrigBuffer (current-buffer)) - (TargetBuffer - (if (eq major-mode 'fume-list-mode) fume-list-srcbuffer OrigBuffer)) - (fume-no-prompt-on-valid-default - (or fume-no-prompt-on-valid-default - (eq major-mode 'fume-list-mode)))) + (flistMode (eq major-mode 'fume-list-mode)) + (no-prompt (or flistMode fume-no-prompt-on-valid-default)) + (TargetBuffer (if flistMode fume-list-srcbuffer OrigBuffer))) (switch-to-buffer TargetBuffer) - ;; Create funclist and set defaults - (cond ((null fume-funclist) - (fume-set-defaults) - (fume-rescan-buffer))) + (fume-scan-buffer) ;; Create funclist and set defaults if required (let* (;; verify default-name is a valid function name (default-exists-p (assoc default-name fume-funclist)) ;; Prompt for function name in minibuffer, unless there is a valid ;; function name at point & fume-no-prompt-on-valid-default set to t (function-name - (if (and default-exists-p - fume-no-prompt-on-valid-default) + (if (and default-exists-p no-prompt) "" - (completing-read - (format "Goto function%s%s: " - (if other-window-p " other window" "") - (if default-exists-p - (concat " (" default-name ")") - "")) - fume-funclist nil t))) + (let ((this-command last-command)) ; preserve last-command + (completing-read + (format "Goto function%s%s: " + (if other-window-p " other window" "") + (if default-exists-p + (concat " (" default-name ")") + "")) + fume-funclist nil t)))) ;; Use default function name if just RET was pressed (function-name (if (and default-exists-p (string= "" function-name)) default-name @@ -2082,7 +2116,10 @@ (cond ((not (string= "" function-name)) (if other-window-p (cond ((prog1 (one-window-p) - (switch-to-buffer-other-window TargetBuffer)) + (if (not (windowp other-window-p)) + (switch-to-buffer-other-window TargetBuffer) + (select-window other-window-p) + (switch-to-buffer TargetBuffer))) (other-window 1) (shrink-window-if-larger-than-buffer) (other-window 1))) @@ -2097,26 +2134,24 @@ (defun fume-prompt-function-goto-other-window () (interactive) - (let ((current-prefix-arg 1)) - (call-interactively 'fume-prompt-function-goto))) + (fume-prompt-function-goto t)) -(defun fume-list-functions-show-fn-other-window () +(defun fume-list-functions-show-fn-other-window (&optional window) (interactive) (beginning-of-line) (select-window - (prog1 (selected-window) - (fume-prompt-function-goto-other-window)))) + (prog1 (selected-window) (fume-prompt-function-goto (or window t))))) -(defun fume-list-functions-show-prev-fn-other-window () +(defun fume-list-functions-show-prev-fn-other-window (&optional window) (interactive) (forward-line -1) - (fume-list-functions-show-fn-other-window)) + (fume-list-functions-show-fn-other-window window)) -(defun fume-list-functions-show-next-fn-other-window () +(defun fume-list-functions-show-next-fn-other-window (&optional window) (interactive) (forward-line 1) (beginning-of-line) - (fume-list-functions-show-fn-other-window)) + (fume-list-functions-show-fn-other-window window)) (defun fume-list-functions-help () (interactive) @@ -2185,6 +2220,7 @@ (defun fume-list-functions (&optional this-window) "Creates a temporary buffer listing functions found in the current buffer" (interactive "P") + (fume-scan-buffer) ;; Create funclist and set defaults if required (let ((func-near-point (format "^%s$" (fume-function-before-point)))) (cond ((or fume-function-name-regexp (fume-maybe-install-modeline-feature)) (save-excursion @@ -2229,3 +2265,5 @@ (error "Func-Menu is not operative in this buffer"))))) (provide 'func-menu) + +;;; end of file diff -r ad457d5f7d04 -r 0293115a14e9 lisp/packages/generic-sc.el --- a/lisp/packages/generic-sc.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/packages/generic-sc.el Mon Aug 13 08:49:20 2007 +0200 @@ -18,8 +18,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Synched up with: Not in FSF. diff -r ad457d5f7d04 -r 0293115a14e9 lisp/packages/hyper-apropos.el --- a/lisp/packages/hyper-apropos.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/packages/hyper-apropos.el Mon Aug 13 08:49:20 2007 +0200 @@ -336,8 +336,9 @@ buffer-read-only t truncate-lines t hypropos-last-regexp regexp - modeline-buffer-identification (concat "Hyper Apropos: " - "\"" regexp "\"")) + modeline-buffer-identification + (list (cons modeline-buffer-id-left-extent "Hyper Apropos: ") + (cons modeline-buffer-id-right-extent (concat "\"" regexp "\"")))) (setq mode-motion-hook 'mode-motion-highlight-line) (use-local-map hypropos-map) (run-hooks 'hyper-apropos-mode-hook)) diff -r ad457d5f7d04 -r 0293115a14e9 lisp/packages/info.el --- a/lisp/packages/info.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/packages/info.el Mon Aug 13 08:49:20 2007 +0200 @@ -21,8 +21,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Synched up with: Not synched with FSF. @@ -833,17 +834,19 @@ (defun Info-set-mode-line () (setq modeline-buffer-identification - (concat - "Info: (" - (if Info-current-file - (let ((name (file-name-nondirectory Info-current-file))) - (if (string-match "\\.info$" name) - (substring name 0 -5) - name)) - "") - ")" - (or Info-current-node "")))) - + (list (cons modeline-buffer-id-left-extent "Info: ") + (cons modeline-buffer-id-right-extent + (concat + "(" + (if Info-current-file + (let ((name (file-name-nondirectory Info-current-file))) + (if (string-match "\\.info$" name) + (substring name 0 -5) + name)) + "") + ")" + (or Info-current-node "")))))) + ;; Go to an info node specified with a filename-and-nodename string ;; of the sort that is found in pointers in nodes. diff -r ad457d5f7d04 -r 0293115a14e9 lisp/packages/lispm-fonts.el --- a/lisp/packages/lispm-fonts.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/packages/lispm-fonts.el Mon Aug 13 08:49:20 2007 +0200 @@ -17,8 +17,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Synched up with: Not in FSF. diff -r ad457d5f7d04 -r 0293115a14e9 lisp/packages/man.el --- a/lisp/packages/man.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/packages/man.el Mon Aug 13 08:49:20 2007 +0200 @@ -16,8 +16,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;; Mostly rewritten by Alan K. Stebbens 11-apr-90. ;; @@ -606,7 +607,8 @@ ;; overran by a couple of chars. (setq truncate-lines t) ;; turn off horizontal scrollbars in this buffer - (set-specifier scrollbar-height (cons (current-buffer) 0)) + (when (featurep 'scrollbar) + (set-specifier scrollbar-height (cons (current-buffer) 0))) (run-hooks 'Manual-mode-hook)) (defun Manual-last-page () diff -r ad457d5f7d04 -r 0293115a14e9 lisp/packages/netunam.el --- a/lisp/packages/netunam.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/packages/netunam.el Mon Aug 13 08:49:20 2007 +0200 @@ -18,8 +18,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Synched up with: Not in FSF. ;;; #### Chuck -- maybe we should nuke this file. I somehow or diff -r ad457d5f7d04 -r 0293115a14e9 lisp/packages/pending-del.el --- a/lisp/packages/pending-del.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/packages/pending-del.el Mon Aug 13 08:49:20 2007 +0200 @@ -17,8 +17,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Synched up with: Not in FSF. diff -r ad457d5f7d04 -r 0293115a14e9 lisp/packages/ps-print.el --- a/lisp/packages/ps-print.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/packages/ps-print.el Mon Aug 13 08:49:20 2007 +0200 @@ -2,51 +2,160 @@ ;; Copyright (C) 1993, 1994, 1995, 1996 Free Software Foundation, Inc. -;; Author: Jim Thompson -;; Maintainer: duthen@cegelec-red.fr (Jacques Duthen Prestataire) -;; Keywords: print, PostScript - -;; This file is part of XEmacs. - -;; XEmacs is free software; you can redistribute it and/or modify it -;; under the terms of the GNU General Public License as published by +;; Author: Jim Thompson (was ) +;; Maintainer: Jacques Duthen +;; Keywords: print, PostScript +;; Time-stamp: <97/01/29 23:21:25 tjchol01> +;; Version: 3.05 + +(defconst ps-print-version "3.05" + "ps-print.el, v 3.05 <97/01/17 duthen> + +Jack's last change version -- this file may have been edited as part of +Emacs without changes to the version number. When reporting bugs, +please also report the version of Emacs, if any, that ps-print was +distributed with. + +Please send all bug fixes and enhancements to + Jacques Duthen . +") + +;; 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 2, or (at your option) ;; any later version. -;; XEmacs 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. +;; 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 XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA -;; 02111-1307, USA. +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;; LCD Archive Entry: ;; ps-print|James C. Thompson|thompson@wg2.waii.com| ;; Jim's Pretty-Good PostScript Generator for Emacs 19 (ps-print)| ;; 26-Feb-1994|2.8|~/packages/ps-print.el| +;; 3.05 [jack] <97/01/16 duthen> +;; Ben Wing took ps-print.el from the official 19.34 +;; GNU distribution: +;; -rw-rw-r-- 1 duthen 69315 Jul 22 1996 ps-print.el +;; He patched it for XEmacs. +;; Steven L Baur sent me this version which has +;; 26 diffs with 19.34. +;; I merge these 26 diffs into my 3.04 version. + +;; `ps-paper-type': ###autoload. +;; `ps-print-color-p' `ps-color-values': Replace pixel-components by +;; color-instance-rgb-components for XEmacs. +;; `ps-color-device': New function to dynamically test the device +;; color capability, added where ps-print-color-p is tested. +;; `ps-xemacs-face-kind-p': Fixed. +;; `ps-do-despool': Permit dynamic evaluation at print time of +;; ps-lpr-switches. +;; `ps-eval-switch' `ps-flatten-list' `ps-flatten-list-1': New for +;; the previous feature. +;; `ps-gnus-print-article-from-summary': Updated for Gnus 5. + + +;; 3.04 [jack] after [simon] Oct 8, 1996 Simon Marshall +;; `ps-print-version': +;; Fix value. +;; `cl' `lisp-float-type': +;; Require them. +;; `ps-number-of-columns' `ps-*-font-size': +;; Try to select defaults better suited when `ps-landscape-mode' is non-nil. +;; `ps-*-faces': +;; Change default for Font Lock mode faces when `ps-print-color-p' is nil. +;; `ps-right-header': +;; Replace `time-stamp-yy/mm/dd' by `time-stamp-mon-dd-yyyy'. +;; `ps-end-file' `ps-begin-page': +;; Fix bug in page count for Ghostview. +;; `ps-generate-postscript-with-faces': +;; Replace `ps-sorter' by `car-less-than-car'. +;; `ps-plot' `ps-generate': +;; Replace `%d' by `%3d'. + +;; 3.03 [jack] Sept 27, 1996 Jacques Duthen +;; Merge 31 diffs between 19.29 and 19.34 + +;; 3.02 [jack] June 26, 1996 Jacques Duthen +;; Add new page dimensions to `ps-page-dimensions-database' for `paper-type' +;; Improve landscape mode `ps-landscape-mode' and multiple columns +;; printing `ps-number-of-columns': +;; The text and the margins are no more scaled. +;; Simplify the semantics of `ps-inter-column' (space between columns). +;; Add error checking for negative `ps-print-width' and `ps-print-height'. +;; Change the semantics of `ps-top-margin' which is now the TOP MARGIN, +;; and add `ps-header-offset' instead of having `ps-top-margin' split in 2. +;; Add `ps-header-font-family', `ps-header-font-size' and +;; `ps-header-title-font-size' to control the header. +;; Add `ps-header-line-pad'. +;; Change the semantics of `ps-font-info-database' to have symbolic +;; font families. +;; Add new fonts to `ps-font-info-database': `Courier' `Helvetica' +;; `Times' `Palatino' `Helvetica-Narrow' `NewCenturySchlbk' +;; Make public `ps-font-family' and `ps-font-size' so that the user +;; can directly control the text font and size without loading ps-print. +;; Add error checking for unknown font families and a message giving +;; the exhaustive list of available font families. +;; Document how to install a new font family. +;; Add `/ReportAllFontInfo' to get all the font families of the printer. +;; Add the possibility to make `mixed' font families. +;; Add `ps-setup' to get the current setup. +;; Add tools `ps-line-lengths' `ps-nb-pages-buffer' `ps-nb-pages-region' +;; to help choose the font size. +;; Split `ps-print-prologue' in two to insert info from header fonts +;; Replace indexes by macro `ps-page-dimensions-get-width' +;; to get access to the dimensions list. +;; Add `ps-select-font' inside `ps-get-page-dimensions'. +;; Fix the "clumsy" `ps-page-height' management. +;; Move `ps-get-page-dimensions' to the beginning of `ps-begin-file' +;; to get early error checking. +;; Add sample setup `ps-jack-setup'. +;; +;; Rewrite a lot of postscript code and add comments inside it +;; (maybe they should not (or optionally) be included in the generated +;; Postscript). +;; Translate the origin to (lm, bm) to simplify the other moves. +;; Fix bug in `/HeaderOffset' with `/PrintStartY'. +;; Fix bug in `/SetHeaderLines'. +;; Change `/ReportFontInfo' for use by `/ReportAllFontInfo'. + +;; 3.01 [jack] June 4, 1996 Jacques Duthen +;; Manage float value for every variable representing a size. +;; Add `ps-font-info-database' `ps-inter-column' + +;; 3.00 [jack] May 17, 1996 Jacques Duthen +;; based on 2.8 Jim's Pretty-Good version: +;; Add `ps-landscape-mode' and `ps-number-of-columns' +;; for dumb multi-column landscape mode. + ;; Baseline-version: 2.8. (Jim's last change version -- this ;; file may have been edited as part of Emacs without changes to the ;; version number. When reporting bugs, please also report the ;; version of Emacs, if any, that ps-print was distributed with.) -;;; Synched up with: FSF 19.34. - ;;; Commentary: ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; About ps-print ;; -------------- +;; ;; This package provides printing of Emacs buffers on PostScript ;; printers; the buffer's bold and italic text attributes are ;; preserved in the printer output. Ps-print is intended for use with ;; Emacs 19 or Lucid Emacs, together with a fontifying package such as ;; font-lock or hilit. ;; +;; ;; Using ps-print ;; -------------- ;; @@ -78,7 +187,7 @@ ;; spool - The PostScript image is saved temporarily in an ;; Emacs buffer. Many images may be spooled locally ;; before printing them. To send the spooled images -;; to the printer, use the command ps-despool. +;; to the printer, use the command `ps-despool'. ;; ;; The spooling mechanism was designed for printing lots of small ;; files (mail messages or netnews articles) to save paper that would @@ -86,7 +195,7 @@ ;; your output at the printer (it's easier to pick up one 50-page ;; printout than to find 50 single-page printouts). ;; -;; Ps-print has a hook in the kill-emacs-hooks so that you won't +;; Ps-print has a hook in the `kill-emacs-hooks' so that you won't ;; accidentally quit from Emacs while you have unprinted PostScript ;; waiting in the spool buffer. If you do attempt to exit with ;; spooled PostScript, you'll be asked if you want to print it, and if @@ -123,6 +232,7 @@ ;; ;; ;; Invoking Ps-Print +;; ----------------- ;; ;; To print your buffer, type ;; @@ -138,16 +248,16 @@ ;; to the printer; you will be prompted for the name of the file to ;; save the image to. The prefix argument is ignored by the commands ;; that spool their images, but you may save the spooled images to a -;; file by giving a prefix argument to ps-despool: +;; file by giving a prefix argument to `ps-despool': ;; ;; C-u M-x ps-despool ;; -;; When invoked this way, ps-despool will prompt you for the name of +;; When invoked this way, `ps-despool' will prompt you for the name of ;; the file to save to. ;; -;; Any of the ps-print- commands can be bound to keys; I recommend -;; binding ps-spool-buffer-with-faces, ps-spool-region-with-faces, and -;; ps-despool. Here are the bindings I use on my Sun 4 keyboard: +;; Any of the `ps-print-' commands can be bound to keys; I recommend +;; binding `ps-spool-buffer-with-faces', `ps-spool-region-with-faces', +;; and `ps-despool'. Here are the bindings I use on my Sun 4 keyboard: ;; ;; (global-set-key 'f22 'ps-spool-buffer-with-faces) ;f22 is prsc ;; (global-set-key '(shift f22) 'ps-spool-region-with-faces) @@ -155,111 +265,153 @@ ;; ;; ;; The Printer Interface +;; --------------------- ;; -;; The variables ps-lpr-command and ps-lpr-switches determine what +;; The variables `ps-lpr-command' and `ps-lpr-switches' determine what ;; command is used to send the PostScript images to the printer, and -;; what arguments to give the command. These are analogous to lpr- -;; command and lpr-switches. +;; what arguments to give the command. These are analogous to +;; `lpr-command' and `lpr-switches'. ;; -;; NOTE: ps-lpr-command and ps-lpr-switches take their initial values -;; from the variables lpr-command and lpr-switches. If you have -;; lpr-command set to invoke a pretty-printer such as enscript, -;; then ps-print won't work properly. ps-lpr-command must name +;; Make sure that they contain appropriate values for your system; +;; see the usage notes below and the documentation of these variables. +;; +;; NOTE: `ps-lpr-command' and `ps-lpr-switches' take their initial values +;; from the variables `lpr-command' and `lpr-switches'. If you have +;; `lpr-command' set to invoke a pretty-printer such as `enscript', +;; then ps-print won't work properly. `ps-lpr-command' must name ;; a program that does not format the files it prints. ;; ;; -;; How Ps-Print Deals With Fonts -;; -;; The ps-print-*-with-faces commands attempt to determine which faces -;; should be printed in bold or italic, but their guesses aren't -;; always right. For example, you might want to map colors into faces -;; so that blue faces print in bold, and red faces in italic. +;; The Page Layout +;; --------------- ;; -;; It is possible to force ps-print to consider specific faces bold or -;; italic, no matter what font they are displayed in, by setting the -;; variables ps-bold-faces and ps-italic-faces. These variables -;; contain lists of faces that ps-print should consider bold or -;; italic; to set them, put code like the following into your .emacs -;; file: +;; All dimensions are floats in PostScript points. +;; 1 inch == 2.54 cm == 72 points +;; 1 cm == (/ 1 2.54) inch == (/ 72 2.54) points ;; -;; (setq ps-bold-faces '(my-blue-face)) -;; (setq ps-italic-faces '(my-red-face)) -;; -;; Faces like bold-italic that are both bold and italic should go in -;; *both* lists. +;; The variable `ps-paper-type' determines the size of paper ps-print +;; formats for; it should contain one of the symbols: +;; `a4' `a3' `letter' `legal' `letter-small' `tabloid' +;; `ledger' `statement' `executive' `a4small' `b4' `b5' ;; -;; Ps-print does not attempt to guess the sizes of fonts; all text is -;; rendered using the Courier font family, in 10 point size. To -;; change the font family, change the variables ps-font, ps-font-bold, -;; ps-font-italic, and ps-font-bold-italic; fixed-pitch fonts work -;; best, but are not required. To change the font size, change the -;; variable ps-font-size. -;; -;; If you change the font family or size, you MUST also change the -;; variables ps-line-height, ps-avg-char-width, and ps-space-width, or -;; ps-print cannot correctly place line and page breaks. +;; The variable `ps-landscape-mode' determines the orientation +;; of the printing on the page: +;; nil means `portrait' mode, non-nil means `landscape' mode. +;; There is no oblique mode yet, though this is easy to do in ps. + +;; In landscape mode, the text is NOT scaled: you may print 70 lines +;; in portrait mode and only 50 lignes in landscape mode. +;; The margins represent margins in the printed paper: +;; the top margin is the margin between the top of the page +;; and the printed header, whatever the orientation is. ;; -;; Ps-print keeps internal lists of which fonts are bold and which are -;; italic; these lists are built the first time you invoke ps-print. -;; For the sake of efficiency, the lists are built only once; the same -;; lists are referred in later invocations of ps-print. -;; -;; Because these lists are built only once, it's possible for them to -;; get out of sync, if a face changes, or if new faces are added. To -;; get the lists back in sync, you can set the variable -;; ps-build-face-reference to t, and the lists will be rebuilt the -;; next time ps-print is invoked. +;; The variable `ps-number-of-columns' determines the number of columns +;; both in landscape and portrait mode. +;; You can use: +;; - (the standard) one column portrait mode +;; - (my favorite) two columns landscape mode (which spares trees) +;; but also +;; - one column landscape mode for files with very long lines. +;; - multi-column portrait or landscape mode ;; ;; -;; How Ps-Print Deals With Color +;; Horizontal layout +;; ----------------- +;; +;; The horizontal layout is determined by the variables +;; `ps-left-margin' `ps-inter-column' `ps-right-margin' +;; as follows: +;; +;; ------------------------------------------ +;; | | | | | | | | +;; | lm | text | ic | text | ic | text | rm | +;; | | | | | | | | +;; ------------------------------------------ +;; +;; If `ps-number-of-columns' is 1, `ps-inter-column' is not relevant. +;; Usually, lm = rm > 0 and ic = lm +;; If (ic < 0), the text of adjacent columns can overlap. +;; +;; +;; Vertical layout +;; --------------- ;; -;; Ps-print detects faces with foreground and background colors -;; defined and embeds color information in the PostScript image. The -;; default foreground and background colors are defined by the -;; variables ps-default-fg and ps-default-bg. On black-and-white -;; printers, colors are displayed in grayscale. To turn off color -;; output, set ps-print-color-p to nil. +;; The vertical layout is determined by the variables +;; `ps-bottom-margin' `ps-top-margin' `ps-header-offset' +;; as follows: +;; +;; |--------| |--------| +;; | tm | | tm | +;; |--------| |--------| +;; | header | | | +;; |--------| | | +;; | ho | | | +;; |--------| or | text | +;; | | | | +;; | text | | | +;; | | | | +;; |--------| |--------| +;; | bm | | bm | +;; |--------| |--------| +;; +;; If `ps-print-header' is nil, `ps-header-offset' is not relevant. +;; The margins represent margins in the printed paper: +;; the top margin is the margin between the top of the page +;; and the printed header, whatever the orientation is. ;; ;; ;; Headers +;; ------- ;; -;; Ps-print can print headers at the top of each page; the default +;; Ps-print can print headers at the top of each column; the default ;; headers contain the following four items: on the left, the name of ;; the buffer and, if the buffer is visiting a file, the file's -;; directory; on the right, the page number and date of printing. The -;; default headers look something like this: +;; directory; on the right, the page number and date of printing. +;; The default headers look something like this: ;; ;; ps-print.el 1/21 ;; /home/jct/emacs-lisp/ps/new 94/12/31 ;; ;; When printing on duplex printers, left and right are reversed so -;; that the page numbers are toward the outside. +;; that the page numbers are toward the outside (cf. `ps-spool-duplex'). +;; +;; Headers are configurable: +;; To turn them off completely, set `ps-print-header' to nil. +;; To turn off the header's gaudy framing box, +;; set `ps-print-header-frame' to nil. ;; -;; Headers are configurable. To turn them off completely, set -;; ps-print-header to nil. To turn off the header's gaudy framing -;; box, set ps-print-header-frame to nil. Page numbers are printed in -;; "n/m" format, indicating page n of m pages; to omit the total page -;; count and just print the page number, set ps-show-n-of-n to nil. +;; The font family and size of text in the header are determined +;; by the variables `ps-header-font-family', `ps-header-font-size' and +;; `ps-header-title-font-size' (see below). +;; +;; The variable `ps-header-line-pad' determines the portion of a header +;; title line height to insert between the header frame and the text +;; it contains, both in the vertical and horizontal directions: +;; .5 means half a line. + +;; Page numbers are printed in `n/m' format, indicating page n of m pages; +;; to omit the total page count and just print the page number, +;; set `ps-show-n-of-n' to nil. ;; ;; The amount of information in the header can be changed by changing -;; the number of lines. To show less, set ps-header-lines to 1, and +;; the number of lines. To show less, set `ps-header-lines' to 1, and ;; the header will show only the buffer name and page number. To show -;; more, set ps-header-lines to 3, and the header will show the time of +;; more, set `ps-header-lines' to 3, and the header will show the time of ;; printing below the date. ;; ;; To change the content of the headers, change the variables -;; ps-left-header and ps-right-header. These variables are lists, -;; specifying top-to-bottom the text to display on the left or right -;; side of the header. Each element of the list should be a string or -;; a symbol. Strings are inserted directly into the PostScript -;; arrays, and should contain the PostScript string delimiters '(' and -;; ')'. +;; `ps-left-header' and `ps-right-header'. +;; These variables are lists, specifying top-to-bottom the text +;; to display on the left or right side of the header. +;; Each element of the list should be a string or a symbol. +;; Strings are inserted directly into the PostScript arrays, +;; and should contain the PostScript string delimiters '(' and ')'. ;; ;; Symbols in the header format lists can either represent functions ;; or variables. Functions are called, and should return a string to ;; show in the header. Variables should contain strings to display in ;; the header. In either case, function or variable, the PostScript -;; string delimeters are added by ps-print, and should not be part of +;; string delimiters are added by ps-print, and should not be part of ;; the returned value. ;; ;; Here's an example: say we want the left header to display the text @@ -277,56 +429,217 @@ ;; ;; (setq larry-var "Larry") ;; -;; and a literal for "Curly". Here's how ps-left-header should be +;; and a literal for "Curly". Here's how `ps-left-header' should be ;; set: ;; ;; (setq ps-left-header (list 'moe-func 'larry-var "(Curly)")) ;; ;; Note that Curly has the PostScript string delimiters inside his -;; quotes -- those aren't misplaced lisp delimiters! Without them, -;; PostScript would attempt to call the undefined function Curly, -;; which would result in a PostScript error. Since most printers -;; don't report PostScript errors except by aborting the print job, -;; this kind of error can be hard to track down. Consider yourself -;; warned. +;; quotes -- those aren't misplaced lisp delimiters! +;; +;; Without them, PostScript would attempt to call the undefined +;; function Curly, which would result in a PostScript error. +;; +;; Since most printers don't report PostScript errors except by +;; aborting the print job, this kind of error can be hard to track down. +;; +;; Consider yourself warned! ;; ;; ;; Duplex Printers +;; --------------- ;; ;; If you have a duplex-capable printer (one that prints both sides of -;; the paper), set ps-spool-duplex to t. Ps-print will insert blank -;; pages to make sure each buffer starts on the correct side of the -;; paper. Don't forget to set ps-lpr-switches to select duplex -;; printing for your printer. +;; the paper), set `ps-spool-duplex' to t. +;; Ps-print will insert blank pages to make sure each buffer starts +;; on the correct side of the paper. +;; Don't forget to set `ps-lpr-switches' to select duplex printing +;; for your printer. +;; +;; +;; Font managing +;; ------------- +;; +;; Ps-print now knows rather precisely some fonts: +;; the variable `ps-font-info-database' contains information +;; for a list of font families (currently mainly `Courier' `Helvetica' +;; `Times' `Palatino' `Helvetica-Narrow' `NewCenturySchlbk'). +;; Each font family contains the font names for standard, bold, italic +;; and bold-italic characters, a reference size (usually 10) and the +;; corresponding line height, width of a space and average character width. ;; +;; The variable `ps-font-family' determines which font family +;; is to be used for ordinary text. +;; If its value does not correspond to a known font family, +;; an error message is printed into the `*Messages*' buffer, +;; which lists the currently available font families. ;; -;; Paper Size +;; The variable `ps-font-size' determines the size (in points) +;; of the font for ordinary text, when generating Postscript. +;; Its value is a float. +;; +;; Similarly, the variable `ps-header-font-family' determines +;; which font family is to be used for text in the header. +;; The variable `ps-header-font-size' determines the font size, +;; in points, for text in the header. +;; The variable `ps-header-title-font-size' determines the font size, +;; in points, for the top line of text in the header. +;; +;; +;; Adding a new font family +;; ------------------------ +;; +;; To use a new font family, you MUST first teach ps-print +;; this font, i.e., add its information to `ps-font-info-database', +;; otherwise ps-print cannot correctly place line and page breaks. +;; +;; For example, assuming `Helvetica' is unknown, +;; you first need to do the following ONLY ONCE: +;; +;; - create a new buffer +;; - generate the PostScript image to a file (C-u M-x ps-print-buffer) +;; - open this file and find the line: +;; `% 3 cm 20 cm moveto 10 /Courier ReportFontInfo showpage' +;; - delete the leading `%' (which is the Postscript comment character) +;; - replace in this line `Courier' by the new font (say `Helvetica') +;; to get the line: +;; `3 cm 20 cm moveto 10 /Helvetica ReportFontInfo showpage' +;; - send this file to the printer (or to ghostscript). +;; You should read the following on the output page: +;; +;; For Helvetica 10 point, the line height is 11.56, the space width is 2.78 +;; and a crude estimate of average character width is 5.09243 +;; +;; - Add these values to the `ps-font-info-database': +;; (setq ps-font-info-database +;; (append +;; '((Helvetica ; the family name +;; "Helvetica" "Helvetica-Bold" "Helvetica-Oblique" "Helvetica-BoldOblique" +;; 10.0 11.56 2.78 5.09243)) +;; ps-font-info-database)) +;; - Now you can use this font family with any size: +;; (setq ps-font-family 'Helvetica) +;; - if you want to use this family in another emacs session, you must +;; put into your `~/.emacs': +;; (require 'ps-print) +;; (setq ps-font-info-database (append ...))) +;; if you don't want to load ps-print, you have to copy the whole value: +;; (setq ps-font-info-database '( )) +;; or, if you can wait until the `ps-print-hook' is implemented, do: +;; (add-hook 'ps-print-hook '(setq ps-font-info-database (append ...))) +;; This does not work yet, since there is no `ps-print-hook' yet. ;; -;; The variable ps-paper-type determines the size of paper ps-print -;; formats for; it should contain one of the symbols ps-letter, -;; ps-legal, or ps-a4. The default is ps-letter. +;; You can create new `mixed' font families like: +;; (my-mixed-family +;; "Courier-Bold" "Helvetica" +;; "Zapf-Chancery-MediumItalic" "NewCenturySchlbk-BoldItalic" +;; 10.0 10.55 6.0 6.0) +;; Now you can use your new font family with any size: +;; (setq ps-font-family 'my-mixed-family) +;; +;; You can get information on all the fonts resident in YOUR printer +;; by uncommenting the line: +;; % 3 cm 20 cm moveto ReportAllFontInfo showpage +;; +;; The postscript file should be sent to YOUR postscript printer. +;; If you send it to ghostscript or to another postscript printer, +;; you may get slightly different results. +;; Anyway, as ghostscript fonts are autoload, you won't get +;; much font info. +;; +;; +;; How Ps-Print Deals With Faces +;; ----------------------------- +;; +;; The ps-print-*-with-faces commands attempt to determine which faces +;; should be printed in bold or italic, but their guesses aren't +;; always right. For example, you might want to map colors into faces +;; so that blue faces print in bold, and red faces in italic. +;; +;; It is possible to force ps-print to consider specific faces bold or +;; italic, no matter what font they are displayed in, by setting the +;; variables `ps-bold-faces' and `ps-italic-faces'. These variables +;; contain lists of faces that ps-print should consider bold or +;; italic; to set them, put code like the following into your .emacs +;; file: +;; +;; (setq ps-bold-faces '(my-blue-face)) +;; (setq ps-italic-faces '(my-red-face)) +;; +;; Faces like bold-italic that are both bold and italic should go in +;; *both* lists. ;; -;; Make sure that the variables ps-lpr-command and ps-lpr-switches -;; contain appropriate values for your system; see the usage notes -;; below and the documentation of these variables. -;; +;; Ps-print keeps internal lists of which fonts are bold and which are +;; italic; these lists are built the first time you invoke ps-print. +;; For the sake of efficiency, the lists are built only once; the same +;; lists are referred in later invocations of ps-print. +;; +;; Because these lists are built only once, it's possible for them to +;; get out of sync, if a face changes, or if new faces are added. To +;; get the lists back in sync, you can set the variable +;; `ps-build-face-reference' to t, and the lists will be rebuilt the +;; next time ps-print is invoked. +;; +;; +;; How Ps-Print Deals With Color +;; ----------------------------- +;; +;; Ps-print detects faces with foreground and background colors +;; defined and embeds color information in the PostScript image. +;; The default foreground and background colors are defined by the +;; variables `ps-default-fg' and `ps-default-bg'. +;; On black-and-white printers, colors are displayed in grayscale. +;; To turn off color output, set `ps-print-color-p' to nil. +;; +;; +;; Utilities +;; --------- +;; +;; Some tools are provided to help you customize your font setup. +;; +;; `ps-setup' returns (some part of) the current setup. +;; +;; To avoid wrapping too many lines, you may want to adjust the +;; left and right margins and the font size. On UN*X systems, do: +;; pr -t file | awk '{printf "%3d %s\n", length($0), $0}' | sort -r | head +;; to determine the longest lines of your file. +;; Then, the command `ps-line-lengths' will give you the correspondence +;; between a line length (number of characters) and the maximum font +;; size which doesn't wrap such a line with the current ps-print setup. +;; +;; The commands `ps-nb-pages-buffer' and `ps-nb-pages-region' display +;; the correspondence between a number of pages and the maximum font +;; size which allow the number of lines of the current buffer or of +;; its current region to fit in this number of pages. +;; Note: line folding is not taken into account in this process +;; and could change the results. +;; +;; ;; New since version 1.5 ;; --------------------- +;; ;; Color output capability. -;; ;; Automatic detection of font attributes (bold, italic). +;; Configurable headers with page numbers. +;; Slightly faster. +;; Support for different paper sizes. +;; Better conformance to PostScript Document Structure Conventions. ;; -;; Configurable headers with page numbers. ;; -;; Slightly faster. +;; New since version 2.8 +;; --------------------- +;; +;; [jack] 960517 Jacques Duthen ;; -;; Support for different paper sizes. -;; -;; Better conformance to PostScript Document Structure Conventions. +;; Font familiy and float size for text and header. +;; Landscape mode. +;; Multiple columns. +;; Tools for page setup. ;; ;; ;; Known bugs and limitations of ps-print: ;; -------------------------------------- +;; ;; Although color printing will work in XEmacs 19.12, it doesn't work ;; well; in particular, bold or italic fonts don't print in the right ;; background color. @@ -335,12 +648,12 @@ ;; ;; Automatic font-attribute detection doesn't work well, especially ;; with hilit19 and older versions of get-create-face. Users having -;; problems with auto-font detection should use the lists ps-italic- -;; faces and ps-bold-faces and/or turn off automatic detection by -;; setting ps-auto-font-detect to nil. +;; problems with auto-font detection should use the lists +;; `ps-italic-faces' and `ps-bold-faces' and/or turn off automatic +;; detection by setting `ps-auto-font-detect' to nil. ;; ;; Automatic font-attribute detection doesn't work with XEmacs 19.12 -;; in tty mode; use the lists ps-italic-faces and ps-bold-faces +;; in tty mode; use the lists `ps-italic-faces' and `ps-bold-faces' ;; instead. ;; ;; Still too slow; could use some hand-optimization. @@ -354,18 +667,30 @@ ;; ;; Epoch and Emacs 18 not supported. At all. ;; +;; Fixed-pitch fonts work better for line folding, but are not required. ;; -;; Features to add: -;; --------------- -;; 2-up and 4-up capability. +;; `ps-nb-pages-buffer' and `ps-nb-pages-region' don't take care +;; of folding lines. +;; +;; +;; Things to change: +;; ---------------- ;; -;; Line numbers. -;; -;; Wide-print (landscape) capability. +;; Add `ps-print-hook' (I don't know how to do that (yet!)). +;; Add 4-up capability (really needed?). +;; Add line numbers (should not be too hard). +;; Add `ps-non-bold-faces' and `ps-non-italic-faces' (should be easy). +;; Put one header per page over the columns (easy but needed?). +;; Improve the memory management for big files (hard?). +;; `ps-nb-pages-buffer' and `ps-nb-pages-region' should take care +;; of folding lines. ;; ;; ;; Acknowledgements ;; ---------------- +;; Thanks to Jim Thompson for the 2.8 version I started from. +;; [jack] +;; ;; Thanks to Kevin Rodgers for adding support for ;; color and the invisible property. ;; @@ -391,39 +716,116 @@ ;;; Code: -(defconst ps-print-version "2.8" - "ps-print.el,v 2.8 1995/05/04 12:06:10 jct Exp - -Jim's last change version -- this file may have been edited as part of -Emacs without changes to the version number. When reporting bugs, -please also report the version of Emacs, if any, that ps-print was -distributed with. - -Please send all bug fixes and enhancements to - Jim Thompson .") +(eval-when-compile + (require 'cl)) + +(unless (featurep 'lisp-float-type) + (error "`ps-print' requires floating point support")) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; User Variables: +;;; Interface to the command system + (defvar ps-lpr-command lpr-command "*The shell command for printing a PostScript file.") (defvar ps-lpr-switches lpr-switches "*A list of extra switches to pass to `ps-lpr-command'.") -(defvar ps-spool-duplex nil ; Not many people have duplex - ; printers, so default to nil. - "*Non-nil indicates spooling is for a two-sided printer. -For a duplex printer, the `ps-spool-*' commands will insert blank pages -as needed between print jobs so that the next buffer printed will -start on the right page. Also, if headers are turned on, the headers -will be reversed on duplex printers so that the page numbers fall to -the left on even-numbered pages.") +;;; Page layout + +;; All page dimensions are in PostScript points. +;; 1 inch == 2.54 cm == 72 points +;; 1 cm == (/ 1 2.54) inch == (/ 72 2.54) points + +;; Letter 8.5 inch x 11.0 inch +;; Legal 8.5 inch x 14.0 inch +;; A4 8.26 inch x 11.69 inch = 21.0 cm x 29.7 cm + +;; LetterSmall 7.68 inch x 10.16 inch +;; Tabloid 11.0 inch x 17.0 inch +;; Ledger 17.0 inch x 11.0 inch +;; Statement 5.5 inch x 8.5 inch +;; Executive 7.5 inch x 10.0 inch +;; A3 11.69 inch x 16.5 inch = 29.7 cm x 42.0 cm +;; A4Small 7.47 inch x 10.85 inch +;; B4 10.125 inch x 14.33 inch +;; B5 7.16 inch x 10.125 inch + +(defvar ps-page-dimensions-database + (list (list 'a4 (/ (* 72 21.0) 2.54) (/ (* 72 29.7) 2.54)) + (list 'a3 (/ (* 72 29.7) 2.54) (/ (* 72 42.0) 2.54)) + (list 'letter (* 72 8.5) (* 72 11.0)) + (list 'legal (* 72 8.5) (* 72 14.0)) + (list 'letter-small (* 72 7.68) (* 72 10.16)) + (list 'tabloid (* 72 11.0) (* 72 17.0)) + (list 'ledger (* 72 17.0) (* 72 11.0)) + (list 'statement (* 72 5.5) (* 72 8.5)) + (list 'executive (* 72 7.5) (* 72 10.0)) + (list 'a4small (* 72 7.47) (* 72 10.85)) + (list 'b4 (* 72 10.125) (* 72 14.33)) + (list 'b5 (* 72 7.16) (* 72 10.125))) + "*List associating a symbolic paper type to its width and height. +see `ps-paper-type'.") ;;;###autoload -(defvar ps-paper-type 'ps-letter - "*Specifies the size of paper to format for. Should be one of -`ps-letter', `ps-legal', or `ps-a4'.") +(defvar ps-paper-type 'letter + "*Specifies the size of paper to format for. +Should be one of the paper types defined in `ps-page-dimensions-database', for +example `letter', `legal' or `a4'.") + +(defvar ps-landscape-mode 'nil + "*Non-nil means print in landscape mode.") + +(defvar ps-number-of-columns (if ps-landscape-mode 2 1) + "*Specifies the number of columns") + +;;; Horizontal layout + +;; ------------------------------------------ +;; | | | | | | | | +;; | lm | text | ic | text | ic | text | rm | +;; | | | | | | | | +;; ------------------------------------------ + +(defvar ps-left-margin (/ (* 72 2.0) 2.54) ; 2 cm + "*Left margin in points (1/72 inch).") + +(defvar ps-right-margin (/ (* 72 2.0) 2.54) ; 2 cm + "*Right margin in points (1/72 inch).") + +(defvar ps-inter-column (/ (* 72 2.0) 2.54) ; 2 cm + "*Horizontal space between columns in points (1/72 inch).") + +;;; Vertical layout + +;; |--------| +;; | tm | +;; |--------| +;; | header | +;; |--------| +;; | ho | +;; |--------| +;; | text | +;; |--------| +;; | bm | +;; |--------| + +(defvar ps-bottom-margin (/ (* 72 1.5) 2.54) ; 1.5 cm + "*Bottom margin in points (1/72 inch).") + +(defvar ps-top-margin (/ (* 72 1.5) 2.54) ; 1.5 cm + "*Top margin in points (1/72 inch).") + +(defvar ps-header-offset (/ (* 72 1.0) 2.54) ; 1.0 cm + "*Vertical space in points (1/72 inch) between the main text and the header.") + +(defvar ps-header-line-pad 0.15 + "*Portion of a header title line height to insert between the header frame +and the text it contains, both in the vertical and horizontal directions.") + +;;; Header setup (defvar ps-print-header t "*Non-nil means print a header at the top of each page. @@ -435,19 +837,114 @@ (defvar ps-print-header-frame t "*Non-nil means draw a gaudy frame around the header.") +(defvar ps-header-lines 2 + "*Number of lines to display in page header, when generating Postscript.") +(make-variable-buffer-local 'ps-header-lines) + (defvar ps-show-n-of-n t "*Non-nil means show page numbers as N/M, meaning page N of M. Note: page numbers are displayed as part of headers, see variable `ps-print-headers'.") +(defvar ps-spool-duplex nil ; Not many people have duplex + ; printers, so default to nil. + "*Non-nil indicates spooling is for a two-sided printer. +For a duplex printer, the `ps-spool-*' commands will insert blank pages +as needed between print jobs so that the next buffer printed will +start on the right page. Also, if headers are turned on, the headers +will be reversed on duplex printers so that the page numbers fall to +the left on even-numbered pages.") + +;;; Fonts + +(defvar ps-font-info-database + '((Courier ; the family key + "Courier" "Courier-Bold" "Courier-Oblique" "Courier-BoldOblique" + 10.0 10.55 6.0 6.0) + (Helvetica ; the family key + "Helvetica" "Helvetica-Bold" "Helvetica-Oblique" "Helvetica-BoldOblique" + 10.0 11.56 2.78 5.09243) + (Times + "Times-Roman" "Times-Bold" "Times-Italic" "Times-BoldItalic" + 10.0 11.0 2.5 4.71432) + (Palatino + "Palatino-Roman" "Palatino-Bold" "Palatino-Italic" "Palatino-BoldItalic" + 10.0 12.1 2.5 5.08676) + (Helvetica-Narrow + "Helvetica-Narrow" "Helvetica-Narrow-Bold" + "Helvetica-Narrow-Oblique" "Helvetica-Narrow-BoldOblique" + 10.0 11.56 2.2796 4.17579) + (NewCenturySchlbk + "NewCenturySchlbk-Roman" "NewCenturySchlbk-Bold" + "NewCenturySchlbk-Italic" "NewCenturySchlbk-BoldItalic" + 10.0 12.15 2.78 5.31162) + ;; got no bold for the next ones + (AvantGarde-Book + "AvantGarde-Book" "AvantGarde-Book" + "AvantGarde-BookOblique" "AvantGarde-BookOblique" + 10.0 11.77 2.77 5.45189) + (AvantGarde-Demi + "AvantGarde-Demi" "AvantGarde-Demi" + "AvantGarde-DemiOblique" "AvantGarde-DemiOblique" + 10.0 12.72 2.8 5.51351) + (Bookman-Demi + "Bookman-Demi" "Bookman-Demi" + "Bookman-DemiItalic" "Bookman-DemiItalic" + 10.0 11.77 3.4 6.05946) + (Bookman-Light + "Bookman-Light" "Bookman-Light" + "Bookman-LightItalic" "Bookman-LightItalic" + 10.0 11.79 3.2 5.67027) + ;; got no bold and no italic for the next ones + (Symbol + "Symbol" "Symbol" "Symbol" "Symbol" + 10.0 13.03 2.5 3.24324) + (Zapf-Dingbats + "Zapf-Dingbats" "Zapf-Dingbats" "Zapf-Dingbats" "Zapf-Dingbats" + 10.0 9.63 2.78 2.78) + (Zapf-Chancery-MediumItalic + "Zapf-Chancery-MediumItalic" "Zapf-Chancery-MediumItalic" + "Zapf-Chancery-MediumItalic" "Zapf-Chancery-MediumItalic" + 10.0 11.45 2.2 4.10811) +) + "*Font info database: font family (the key), name, bold, italic, bold-italic, +reference size, line height, space width, average character width. +To get the info for another specific font (say Helvetica), do the following: +- create a new buffer +- generate the PostScript image to a file (C-u M-x ps-print-buffer) +- open this file and delete the leading `%' (which is the Postscript + comment character) from the line + `% 3 cm 20 cm moveto 10 /Courier ReportFontInfo showpage' + to get the line + `3 cm 20 cm moveto 10 /Helvetica ReportFontInfo showpage' +- add the values to `ps-font-info-database'. +You can get all the fonts of YOUR printer using `ReportAllFontInfo'.") + +(defvar ps-font-family 'Courier + "Font family name for ordinary text, when generating Postscript.") + +(defvar ps-font-size (if ps-landscape-mode 7 8.5) + "Font size, in points, for ordinary text, when generating Postscript.") + +(defvar ps-header-font-family 'Helvetica + "Font family name for text in the header, when generating Postscript.") + +(defvar ps-header-font-size (if ps-landscape-mode 10 12) + "Font size, in points, for text in the header, when generating Postscript.") + +(defvar ps-header-title-font-size (if ps-landscape-mode 12 14) + "Font size, in points, for the top line of text in the header, +when generating Postscript.") + +;;; Colors + ;;;###autoload ;;; The 19.33 fsf version includes a test on pixel components instead ;;; of color-instance-rgb-components -(defvar ps-print-color-p (and (or (fboundp 'x-color-values) ; fsf - (fboundp 'color-instance-rgb-components)) +(defvar ps-print-color-p (or (fboundp 'x-color-values) ; fsf + (fboundp 'color-instance-rgb-components)) ; xemacs - (fboundp 'float)) -; Printing color requires both floating point and x-color-values. +; Printing color requires x-color-values. "*If non-nil, print the buffer's text in color.") (defvar ps-default-fg '(0.0 0.0 0.0) @@ -456,64 +953,42 @@ (defvar ps-default-bg '(1.0 1.0 1.0) "*RGB values of the default background color. Defaults to white.") -(defvar ps-font-size 10 - "*Font size, in points, for generating Postscript.") - -(defvar ps-font "Courier" - "*Font family name for ordinary text, when generating Postscript.") - -(defvar ps-font-bold "Courier-Bold" - "*Font family name for bold text, when generating Postscript.") - -(defvar ps-font-italic "Courier-Oblique" - "*Font family name for italic text, when generating Postscript.") - -(defvar ps-font-bold-italic "Courier-BoldOblique" - "*Font family name for bold italic text, when generating Postscript.") - -(defvar ps-avg-char-width (if (fboundp 'float) 5.6 6) - "*The average width, in points, of a character, for generating Postscript. -This is the value that ps-print uses to determine the length, -x-dimension, of the text it has printed, and thus affects the point at -which long lines wrap around. If you change the font or -font size, you will probably have to adjust this value to match.") - -(defvar ps-space-width (if (fboundp 'float) 5.6 6) - "*The width of a space character, for generating Postscript. -This value is used in expanding tab characters.") - -(defvar ps-line-height (if (fboundp 'float) 11.29 11) - "*The height of a line, for generating Postscript. -This is the value that ps-print uses to determine the height, -y-dimension, of the lines of text it has printed, and thus affects the -point at which page-breaks are placed. If you change the font or font -size, you will probably have to adjust this value to match. The -line-height is *not* the same as the point size of the font.") - (defvar ps-auto-font-detect t "*Non-nil means automatically detect bold/italic face attributes. nil means rely solely on the lists `ps-bold-faces', `ps-italic-faces', and `ps-underlined-faces'.") -(defvar ps-bold-faces '() +(defvar ps-bold-faces + (unless ps-print-color-p + '(font-lock-function-name-face + font-lock-builtin-face + font-lock-variable-name-face + font-lock-keyword-face + font-lock-warning-face)) "*A list of the \(non-bold\) faces that should be printed in bold font. This applies to generating Postscript.") -(defvar ps-italic-faces '() +(defvar ps-italic-faces + (unless ps-print-color-p + '(font-lock-variable-name-face + font-lock-string-face + font-lock-comment-face + font-lock-warning-face)) "*A list of the \(non-italic\) faces that should be printed in italic font. This applies to generating Postscript.") -(defvar ps-underlined-faces '() +(defvar ps-underlined-faces + (unless ps-print-color-p + '(font-lock-function-name-face + font-lock-type-face + font-lock-reference-face + font-lock-warning-face)) "*A list of the \(non-underlined\) faces that should be printed underlined. This applies to generating Postscript.") -(defvar ps-header-lines 2 - "*Number of lines to display in page header, when generating Postscript.") -(make-variable-buffer-local 'ps-header-lines) - (defvar ps-left-header (list 'ps-get-buffer-name 'ps-header-dirpart) - "*The items to display on the right part of the page header. + "*The items to display (each on a line) on the left part of the page header. This applies to generating Postscript. The value should be a list of strings and symbols, each representing an @@ -531,8 +1006,8 @@ (make-variable-buffer-local 'ps-left-header) (defvar ps-right-header - (list "/pagenumberstring load" 'time-stamp-yy/mm/dd 'time-stamp-hh:mm:ss) - "*The items to display on the left part of the page header. + (list "/pagenumberstring load" 'time-stamp-mon-dd-yyyy 'time-stamp-hh:mm:ss) + "*The items to display (each on a line) on the right part of the page header. This applies to generating Postscript. See the variable `ps-left-header' for a description of the format of @@ -542,7 +1017,7 @@ (defvar ps-razzle-dazzle t "*Non-nil means report progress while formatting buffer.") -(defvar ps-adobe-tag "%!PS-Adobe-1.0\n" +(defvar ps-adobe-tag "%!PS-Adobe-3.0\n" "*Contains the header line identifying the output as PostScript. By default, `ps-adobe-tag' contains the standard identifier. Some printers require slightly different versions of this line.") @@ -689,6 +1164,85 @@ (interactive (list (ps-print-preprint current-prefix-arg))) (ps-do-despool filename)) +;;;###autoload +(defun ps-line-lengths () + "*Display the correspondence between a line length and a font size, +using the current ps-print setup. +Try: pr -t file | awk '{printf \"%3d %s\n\", length($0), $0}' | sort -r | head" + (interactive) + (ps-line-lengths-internal)) + +;;;###autoload +(defun ps-nb-pages-buffer (nb-lines) + "*Display an approximate correspondence between a font size and the number +of pages the current buffer would require to print +using the current ps-print setup." + (interactive (list (count-lines (point-min) (point-max)))) + (ps-nb-pages nb-lines)) + +;;;###autoload +(defun ps-nb-pages-region (nb-lines) + "*Display an approximate correspondence between a font size and the number +of pages the current region would require to print +using the current ps-print setup." + (interactive (list (count-lines (mark) (point)))) + (ps-nb-pages nb-lines)) + +;;;###autoload +(defun ps-setup () + "*Return the current setup" + (format " + (setq ps-print-color-p %s + ps-lpr-command \"%s\" + ps-lpr-switches %s + + ps-paper-type '%s + ps-landscape-mode %s + ps-number-of-columns %s + + ps-left-margin %s + ps-right-margin %s + ps-inter-column %s + ps-bottom-margin %s + ps-top-margin %s + ps-header-offset %s + ps-header-line-pad %s + ps-print-header %s + ps-print-header-frame %s + ps-header-lines %s + ps-show-n-of-n %s + ps-spool-duplex %s + + ps-font-family '%s + ps-font-size %s + ps-header-font-family '%s + ps-header-font-size %s + ps-header-title-font-size %s) +" + ps-print-color-p + ps-lpr-command + ps-lpr-switches + ps-paper-type + ps-landscape-mode + ps-number-of-columns + ps-left-margin + ps-right-margin + ps-inter-column + ps-bottom-margin + ps-top-margin + ps-header-offset + ps-header-line-pad + ps-print-header + ps-print-header-frame + ps-header-lines + ps-show-n-of-n + ps-spool-duplex + ps-font-family + ps-font-size + ps-header-font-family + ps-header-font-size + ps-header-title-font-size)) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Utility functions and variables: @@ -705,7 +1259,10 @@ (require 'faces)) ; face-font, face-underline-p, ; x-font-regexp -(defun xemacs-color-device () +;; Return t if the device (which can be changed during an emacs +;; session) can handle colors. +;; This is function is not yet implemented for GNU emacs. +(defun ps-color-device () (if (and (eq ps-print-emacs-type 'xemacs) (>= emacs-minor-version 12)) (eq (device-class) 'color) @@ -713,12 +1270,41 @@ (require 'time-stamp) -(defvar ps-print-prologue "% ISOLatin1Encoding stolen from ps_init.ps in GhostScript 2.6.1.4: -% If the ISOLatin1Encoding vector isn't known, define it. +(defvar ps-font nil + "Font family name for ordinary text, when generating Postscript.") + +(defvar ps-font-bold nil + "Font family name for bold text, when generating Postscript.") + +(defvar ps-font-italic nil + "Font family name for italic text, when generating Postscript.") + +(defvar ps-font-bold-italic nil + "Font family name for bold italic text, when generating Postscript.") + +(defvar ps-avg-char-width nil + "The average width, in points, of a character, for generating Postscript. +This is the value that ps-print uses to determine the length, +x-dimension, of the text it has printed, and thus affects the point at +which long lines wrap around.") + +(defvar ps-space-width nil + "The width of a space character, for generating Postscript. +This value is used in expanding tab characters.") + +(defvar ps-line-height nil + "The height of a line, for generating Postscript. +This is the value that ps-print uses to determine the height, +y-dimension, of the lines of text it has printed, and thus affects the +point at which page-breaks are placed. +The line-height is *not* the same as the point size of the font.") + +(defvar ps-print-prologue-1 + "% ISOLatin1Encoding stolen from ps_init.ps in GhostScript 2.6.1.4: /ISOLatin1Encoding where { pop } { -% Define the ISO Latin-1 encoding vector. -% The first half is the same as the standard encoding, -% except for minus instead of hyphen at code 055. +% -- The ISO Latin-1 encoding vector isn't known, so define it. +% -- The first half is the same as the standard encoding, +% -- except for minus instead of hyphen at code 055. /ISOLatin1Encoding StandardEncoding 0 45 getinterval aload pop /minus @@ -726,12 +1312,12 @@ %*** NOTE: the following are missing in the Adobe documentation, %*** but appear in the displayed table: %*** macron at 0225, dieresis at 0230, cedilla at 0233, space at 0240. -% ^Px +% 0200 (128) /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /dotlessi /grave /acute /circumflex /tilde /macron /breve /dotaccent /dieresis /.notdef /ring /cedilla /.notdef /hungarumlaut /ogonek /caron -% ^Tx +% 0240 (160) /space /exclamdown /cent /sterling /currency /yen /brokenbar /section /dieresis /copyright /ordfeminine /guillemotleft @@ -740,7 +1326,7 @@ /acute /mu /paragraph /periodcentered /cedilla /onesuperior /ordmasculine /guillemotright /onequarter /onehalf /threequarters /questiondown -% ^Xx +% 0300 (192) /Agrave /Aacute /Acircumflex /Atilde /Adieresis /Aring /AE /Ccedilla /Egrave /Eacute /Ecircumflex /Edieresis @@ -749,7 +1335,7 @@ /Ocircumflex /Otilde /Odieresis /multiply /Oslash /Ugrave /Uacute /Ucircumflex /Udieresis /Yacute /Thorn /germandbls -% ^\\x +% 0340 (224) /agrave /aacute /acircumflex /atilde /adieresis /aring /ae /ccedilla /egrave /eacute /ecircumflex /edieresis @@ -763,21 +1349,16 @@ /reencodeFontISO { %def dup - length 5 add dict % Make a new font (a new dict - % the same size as the old - % one) with room for our new - % symbols. - - begin % Make the new font the - % current dictionary. + length 5 add dict % Make a new font (a new dict the same size + % as the old one) with room for our new symbols. + + begin % Make the new font the current dictionary. { 1 index /FID ne { def } { pop pop } ifelse - } forall % Copy each of the symbols - % from the old dictionary to - % the new except for the font - % ID. + } forall % Copy each of the symbols from the old dictionary + % to the new one except for the font ID. /Encoding ISOLatin1Encoding def % Override the encoding with % the ISOLatin1 encoding. @@ -785,14 +1366,27 @@ % Use the font's bounding box to determine the ascent, descent, % and overall height; don't forget that these values have to be % transformed using the font's matrix. - FontBBox - FontMatrix transform /Ascent exch def pop + +% ^ (x2 y2) +% | | +% | v +% | +----+ - - +% | | | ^ +% | | | | Ascent (usually > 0) +% | | | | +% (0 0) -> +--+----+--------> +% | | | +% | | v Descent (usually < 0) +% (x1 y1) --> +----+ - - + + FontBBox % -- x1 y1 x2 y2 + FontMatrix transform /Ascent exch def pop FontMatrix transform /Descent exch def pop - /FontHeight Ascent Descent sub def - - % Define these in case they're not in the FontInfo (also, here - % they're easier to get to. - /UnderlinePosition 1 def + /FontHeight Ascent Descent sub def % use `sub' because descent < 0 + + % Define these in case they're not in the FontInfo + % (also, here they're easier to get to. + /UnderlinePosition 1 def /UnderlineThickness 1 def % Get the underline position and thickness if they're defined. @@ -813,28 +1407,22 @@ } if - currentdict % Leave the new font on the - % stack - - end % Stop using the font as the - % current dictionary. - - definefont % Put the font into the font - % dictionary - - pop % Discard the returned font. + currentdict % Leave the new font on the stack + end % Stop using the font as the current dictionary. + definefont % Put the font into the font dictionary + pop % Discard the returned font. } bind def -/Font { +/DefFont { % Font definition findfont exch scalefont reencodeFontISO } def -/F { % Font select +/F { % Font selection findfont - dup /Ascent get /Ascent exch def - dup /Descent get /Descent exch def - dup /FontHeight get /FontHeight exch def - dup /UnderlinePosition get /UnderlinePosition exch def + dup /Ascent get /Ascent exch def + dup /Descent get /Descent exch def + dup /FontHeight get /FontHeight exch def + dup /UnderlinePosition get /UnderlinePosition exch def dup /UnderlineThickness get /UnderlineThickness exch def setfont } def @@ -847,15 +1435,23 @@ { mark 4 1 roll ] /bgcolor exch def } if } def +% B width C +% +-----------+ +% | Ascent (usually > 0) +% A + + +% | Descent (usually < 0) +% +-----------+ +% E width D + /dobackground { % width -- - currentpoint + currentpoint % -- width x y gsave newpath - moveto - 0 Ascent rmoveto - dup 0 rlineto - 0 Descent Ascent sub rlineto - neg 0 rlineto + moveto % A (x y) + 0 Ascent rmoveto % B + dup 0 rlineto % C + 0 Descent Ascent sub rlineto % D + neg 0 rlineto % E closepath bgcolor aload pop setrgbcolor fill @@ -878,20 +1474,23 @@ grestore } def -/eolbg { - currentpoint pop - PrintWidth LeftMargin add exch sub dobackground +/eolbg { % dobackground until right margin + PrintWidth % -- x-eol + currentpoint pop % -- cur-x + sub % -- width until eol + dobackground } def -/eolul { - currentpoint exch pop - PrintWidth LeftMargin add exch dounderline +/eolul { % idem for underline + PrintWidth % -- x-eol + currentpoint exch pop % -- x-eol cur-y + dounderline } def /SL { % Soft Linefeed bg { eolbg } if ul { eolul } if - currentpoint LineHeight sub LeftMargin exch moveto pop + 0 currentpoint exch pop LineHeight sub moveto } def /HL /SL load def % Hard Linefeed @@ -912,18 +1511,48 @@ /W { ul { sp1 } if - ( ) stringwidth % Get the width of a space - pop % Discard the Y component - mul % Multiply the width of a - % space by the number of - % spaces to plot + ( ) stringwidth % Get the width of a space in the current font. + pop % Discard the Y component. + mul % Multiply the width of a space + % by the number of spaces to plot bg { dup dobackground } if 0 rmoveto ul { dounderline } if } def +/BeginDoc { + % ---- save the state of the document (useful for ghostscript!) + /docState save def + % ---- [jack] Kludge: my ghostscript window is 21x27.7 instead of 21x29.7 + /JackGhostscript where { + pop 1 27.7 29.7 div scale + } if + LandscapeMode { + % ---- translate to bottom-right corner of Portrait page + LandscapePageHeight 0 translate + 90 rotate + } if + /ColumnWidth PrintWidth InterColumn add def + % ---- translate to lower left corner of TEXT + LeftMargin BottomMargin translate + % ---- define where printing will start + /f0 F % this installs Ascent + /PrintStartY PrintHeight Ascent sub def + /ColumnIndex 1 def +} def + +/EndDoc { + % ---- on last page but not last column, spit out the page + ColumnIndex 1 eq not { showpage } if + % ---- restore the state of the document (useful for ghostscript!) + docState restore +} def + /BeginDSCPage { - /vmstate save def + % ---- when 1st column, save the state of the page + ColumnIndex 1 eq { /pageState save def } if + % ---- save the state of the column + /columnState save def } def /BeginPage { @@ -931,71 +1560,90 @@ PrintHeaderFrame { HeaderFrame } if HeaderText } if - LeftMargin - BottomMargin PrintHeight add - moveto % move to where printing will - % start. + 0 PrintStartY moveto % move to where printing will start } def /EndPage { bg { eolbg } if ul { eolul } if - showpage % Spit out a page } def /EndDSCPage { - vmstate restore + ColumnIndex NumberOfColumns eq { + % ---- on last column, spit out the page + showpage + % ---- restore the state of the page + pageState restore + /ColumnIndex 1 def + } { % else + % ---- restore the state of the current column + columnState restore + % ---- and translate to the next column + ColumnWidth 0 translate + /ColumnIndex ColumnIndex 1 add def + } ifelse } def /ul false def /UL { /ul exch def } def -/h0 14 /Helvetica-Bold Font -/h1 12 /Helvetica Font - -/h1 F - -/HeaderLineHeight FontHeight def -/HeaderDescent Descent def -/HeaderPad 2 def - -/SetHeaderLines { - /HeaderOffset TopMargin 2 div def +/SetHeaderLines { % nb-lines -- /HeaderLines exch def - /HeaderHeight HeaderLines HeaderLineHeight mul HeaderPad 2 mul add def - /PrintHeight PrintHeight HeaderHeight sub def + % ---- bottom up + HeaderPad + HeaderLines 1 sub HeaderLineHeight mul add + HeaderTitleLineHeight add + HeaderPad add + /HeaderHeight exch def } def -/HeaderFrameStart { - LeftMargin BottomMargin PrintHeight add HeaderOffset add +% |---------| +% | tm | +% |---------| +% | header | +% |-+-------| <-- (x y) +% | ho | +% |---------| +% | text | +% |-+-------| <-- (0 0) +% | bm | +% |---------| + +/HeaderFrameStart { % -- x y + 0 PrintHeight HeaderOffset add } def /HeaderFramePath { - PrintWidth 0 rlineto - 0 HeaderHeight rlineto - PrintWidth neg 0 rlineto - 0 HeaderHeight neg rlineto + PrintWidth 0 rlineto + 0 HeaderHeight rlineto + PrintWidth neg 0 rlineto + 0 HeaderHeight neg rlineto } def /HeaderFrame { gsave 0.4 setlinewidth + % ---- fill a black rectangle (the shadow of the next one) HeaderFrameStart moveto 1 -1 rmoveto HeaderFramePath 0 setgray fill + % ---- do the next rectangle ... HeaderFrameStart moveto HeaderFramePath - gsave 0.9 setgray fill grestore - gsave 0 setgray stroke grestore + gsave 0.9 setgray fill grestore % filled with grey + gsave 0 setgray stroke grestore % drawn with black grestore } def /HeaderStart { HeaderFrameStart - exch HeaderPad add exch - HeaderLineHeight HeaderLines 1 sub mul add HeaderDescent sub HeaderPad add + exch HeaderPad add exch % horizontal pad + % ---- bottom up + HeaderPad add % vertical pad + HeaderDescent sub + HeaderLineHeight HeaderLines 1 sub mul add } def /strcat { @@ -1015,10 +1663,14 @@ /HeaderText { HeaderStart moveto - HeaderLinesRight HeaderLinesLeft + HeaderLinesRight HeaderLinesLeft % -- rightLines leftLines + + % ---- hack: `PN 1 and' == `PN 2 modulo' + + % ---- if duplex and even page number, then exchange left and right Duplex PageNumber 1 and 0 eq and { exch } if - { + { % ---- process the left lines aload pop exch F gsave @@ -1030,7 +1682,7 @@ HeaderStart moveto - { + { % ---- process the right lines aload pop exch F gsave @@ -1045,15 +1697,14 @@ /ReportFontInfo { 2 copy - /t0 3 1 roll Font + /t0 3 1 roll DefFont /t0 F /lh FontHeight def /sw ( ) stringwidth pop def /aw (01234567890abcdefghijklmnopqrstuvwxyz) dup length exch stringwidth pop exch div def - /t1 12 /Helvetica-Oblique Font + /t1 12 /Helvetica-Oblique DefFont /t1 F - 72 72 moveto gsave (For ) show 128 string cvs show @@ -1066,13 +1717,43 @@ (,) show grestore 0 FontHeight neg rmoveto - (and a crude estimate of average character width is ) show - aw 32 string cvs show - (.) show - showpage + gsave + (and a crude estimate of average character width is ) show + aw 32 string cvs show + (.) show + grestore + 0 FontHeight neg rmoveto +} def + +/cm { % cm to point + 72 mul 2.54 div +} def + +/ReportAllFontInfo { + FontDirectory + { % key = font name value = font dictionary + pop 10 exch ReportFontInfo + } forall } def -% 10 /Courier ReportFontInfo +% 3 cm 20 cm moveto 10 /Courier ReportFontInfo showpage +% 3 cm 20 cm moveto ReportAllFontInfo showpage + +") + +(defvar ps-print-prologue-2 + " +% ---- These lines must be kept together because... + +/h0 F +/HeaderTitleLineHeight FontHeight def + +/h1 F +/HeaderLineHeight FontHeight def +/HeaderDescent Descent def + +% ---- ...because `F' has a side-effect on `FontHeight' and `Descent' + ") ;; Start Editing Here: @@ -1095,64 +1776,39 @@ (defvar ps-razchunk 0) -(defvar ps-color-format (if (eq ps-print-emacs-type 'emacs) - - ;;Emacs understands the %f format; we'll - ;;use it to limit color RGB values to - ;;three decimals to cut down some on the - ;;size of the PostScript output. - "%0.3f %0.3f %0.3f" - - ;; Lucid emacsen will have to make do with - ;; %s (princ) for floats. - "%s %s %s")) +(defvar ps-color-format + (if (eq ps-print-emacs-type 'emacs) + + ;;Emacs understands the %f format; we'll + ;;use it to limit color RGB values to + ;;three decimals to cut down some on the + ;;size of the PostScript output. + "%0.3f %0.3f %0.3f" + + ;; Lucid emacsen will have to make do with + ;; %s (princ) for floats. + "%s %s %s")) ;; These values determine how much print-height to deduct when headers ;; are turned on. This is a pretty clumsy way of handling it, but ;; it'll do for now. -(defvar ps-header-title-line-height (if (fboundp 'float) 16.0 16));Helvetica 14 -(defvar ps-header-line-height (if (fboundp 'float) 13.7 14));Helvetica 12 -(defvar ps-header-pad 2) - -;; LetterSmall 7.68 inch 10.16 inch -;; Tabloid 11.0 inch 17.0 inch -;; Ledger 17.0 inch 11.0 inch -;; Statement 5.5 inch 8.5 inch -;; Executive 7.5 inch 10.0 inch -;; A3 11.69 inch 16.5 inch -;; A4Small 7.47 inch 10.85 inch -;; B4 10.125 inch 14.33 inch -;; B5 7.16 inch 10.125 inch - -;; All page dimensions are in PostScript points. - -(defvar ps-left-margin 72) ; 1 inch -(defvar ps-right-margin 72) ; 1 inch -(defvar ps-bottom-margin 36) ; 1/2 inch -(defvar ps-top-margin 72) ; 1 inch - -;; Letter 8.5 inch x 11.0 inch -(defvar ps-letter-page-height 792) ; 11 inches -(defvar ps-letter-page-width 612) ; 8.5 inches - -;; Legal 8.5 inch x 14.0 inch -(defvar ps-legal-page-height 1008) ; 14.0 inches -(defvar ps-legal-page-width 612) ; 8.5 inches - -;; A4 8.26 inch x 11.69 inch -(defvar ps-a4-page-height 842) ; 11.69 inches -(defvar ps-a4-page-width 595) ; 8.26 inches - -(defvar ps-pages-alist - (list (list 'ps-letter ps-letter-page-width ps-letter-page-height) - (list 'ps-legal ps-legal-page-width ps-legal-page-height) - (list 'ps-a4 ps-a4-page-width ps-a4-page-height))) - -;; Define some constants to index into the page lists. -(defvar ps-page-width-i 1) -(defvar ps-page-height-i 2) - -(defvar ps-page-dimensions nil) + +(defvar ps-header-font) +(defvar ps-header-title-font) + +(defvar ps-header-line-height) +(defvar ps-header-title-line-height) +(defvar ps-header-pad 0 + "Vertical and horizontal space in points (1/72 inch) between the header frame +and the text it contains.") + +;; Define accessors to the dimensions list. + +(defmacro ps-page-dimensions-get-width (dims) `(nth 0 ,dims)) +(defmacro ps-page-dimensions-get-height (dims) `(nth 1 ,dims)) + +(defvar ps-landscape-page-height) + (defvar ps-print-width nil) (defvar ps-print-height nil) @@ -1163,15 +1819,239 @@ (defvar ps-ref-italic-faces nil) (defvar ps-ref-underlined-faces nil) +(defvar ps-print-color-scale nil) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Internal functions +(defun ps-line-lengths-internal () + "Display the correspondence between a line length and a font size, +using the current ps-print setup. +Try: pr -t file | awk '{printf \"%3d %s\n\", length($0), $0}' | sort -r | head" + (let ((buf (get-buffer-create "*Line-lengths*")) + (ifs ps-font-size) ; initial font size + (icw ps-avg-char-width) ; initial character width + (print-width (progn (ps-get-page-dimensions) + ps-print-width)) + (ps-setup (ps-setup)) ; setup for the current buffer + (fs-min 5) ; minimum font size + cw-min ; minimum character width + nb-cpl-max ; maximum nb of characters per line + (fs-max 14) ; maximum font size + cw-max ; maximum character width + nb-cpl-min ; minimum nb of characters per line + fs ; current font size + cw ; current character width + nb-cpl ; current nb of characters per line + ) + (setq cw-min (/ (* icw fs-min) ifs) + nb-cpl-max (floor (/ print-width cw-min)) + cw-max (/ (* icw fs-max) ifs) + nb-cpl-min (floor (/ print-width cw-max))) + (setq nb-cpl nb-cpl-min) + (set-buffer buf) + (goto-char (point-max)) + (if (not (bolp)) (insert "\n")) + (insert ps-setup) + (insert "nb char per line / font size\n") + (while (<= nb-cpl nb-cpl-max) + (setq cw (/ print-width (float nb-cpl)) + fs (/ (* ifs cw) icw)) + (insert (format "%3s %s\n" nb-cpl fs)) + (setq nb-cpl (1+ nb-cpl))) + (insert "\n") + (display-buffer buf 'not-this-window))) + +(defun ps-nb-pages (nb-lines) + "Display an approximate correspondence between a font size and the number +of pages the number of lines would require to print +using the current ps-print setup." + (let ((buf (get-buffer-create "*Nb-Pages*")) + (ifs ps-font-size) ; initial font size + (ilh ps-line-height) ; initial line height + (page-height (progn (ps-get-page-dimensions) + ps-print-height)) + (ps-setup (ps-setup)) ; setup for the current buffer + (fs-min 4) ; minimum font size + lh-min ; minimum line height + nb-lpp-max ; maximum nb of lines per page + nb-page-min ; minimum nb of pages + (fs-max 14) ; maximum font size + lh-max ; maximum line height + nb-lpp-min ; minimum nb of lines per page + nb-page-max ; maximum nb of pages + fs ; current font size + lh ; current line height + nb-lpp ; current nb of lines per page + nb-page ; current nb of pages + ) + (setq lh-min (/ (* ilh fs-min) ifs) + nb-lpp-max (floor (/ page-height lh-min)) + nb-page-min (ceiling (/ (float nb-lines) nb-lpp-max)) + lh-max (/ (* ilh fs-max) ifs) + nb-lpp-min (floor (/ page-height lh-max)) + nb-page-max (ceiling (/ (float nb-lines) nb-lpp-min))) + (setq nb-page nb-page-min) + (set-buffer buf) + (goto-char (point-max)) + (if (not (bolp)) (insert "\n")) + (insert ps-setup) + (insert (format "%d lines\n" nb-lines)) + (insert "nb page / font size\n") + (while (<= nb-page nb-page-max) + (setq nb-lpp (ceiling (/ nb-lines (float nb-page))) + lh (/ page-height nb-lpp) + fs (/ (* ifs lh) ilh)) + (insert (format "%s %s\n" nb-page fs)) + (setq nb-page (1+ nb-page))) + (insert "\n") + (display-buffer buf 'not-this-window))) + +(defun ps-select-font () + "Choose the font name and size (scaling data)." + (let ((assoc (assq ps-font-family ps-font-info-database)) + l fn fb fi bi sz lh sw aw) + (if (null assoc) + (error "Don't have data to scale font %s. Known fonts families are %s" + ps-font-family + (mapcar 'car ps-font-info-database))) + (setq l (cdr assoc) + fn (prog1 (car l) (setq l (cdr l))) ; need `pop' + fb (prog1 (car l) (setq l (cdr l))) + fi (prog1 (car l) (setq l (cdr l))) + bi (prog1 (car l) (setq l (cdr l))) + sz (prog1 (car l) (setq l (cdr l))) + lh (prog1 (car l) (setq l (cdr l))) + sw (prog1 (car l) (setq l (cdr l))) + aw (prog1 (car l) (setq l (cdr l)))) + + (setq ps-font fn) + (setq ps-font-bold fb) + (setq ps-font-italic fi) + (setq ps-font-bold-italic bi) + ;; These data just need to be rescaled: + (setq ps-line-height (/ (* lh ps-font-size) sz)) + (setq ps-space-width (/ (* sw ps-font-size) sz)) + (setq ps-avg-char-width (/ (* aw ps-font-size) sz)) + ps-font-family)) + +(defun ps-select-header-font () + "Choose the font name and size (scaling data) for the header." + (let ((assoc (assq ps-header-font-family ps-font-info-database)) + l fn fb fi bi sz lh sw aw) + (if (null assoc) + (error "Don't have data to scale font %s. Known fonts families are %s" + ps-font-family + (mapcar 'car ps-font-info-database))) + (setq l (cdr assoc) + fn (prog1 (car l) (setq l (cdr l))) ; need `pop' + fb (prog1 (car l) (setq l (cdr l))) + fi (prog1 (car l) (setq l (cdr l))) + bi (prog1 (car l) (setq l (cdr l))) + sz (prog1 (car l) (setq l (cdr l))) + lh (prog1 (car l) (setq l (cdr l))) + sw (prog1 (car l) (setq l (cdr l))) + aw (prog1 (car l) (setq l (cdr l)))) + + ;; Font name + (setq ps-header-font fn) + (setq ps-header-title-font fb) + ;; Line height: These data just need to be rescaled: + (setq ps-header-title-line-height (/ (* lh ps-header-title-font-size) sz)) + (setq ps-header-line-height (/ (* lh ps-header-font-size) sz)) + ps-header-font-family)) + (defun ps-get-page-dimensions () - (setq ps-page-dimensions (assq ps-paper-type ps-pages-alist)) - (let ((ps-page-width (nth ps-page-width-i ps-page-dimensions)) - (ps-page-height (nth ps-page-height-i ps-page-dimensions))) - (setq ps-print-height (- ps-page-height ps-top-margin ps-bottom-margin)) - (setq ps-print-width (- ps-page-width ps-left-margin ps-right-margin)))) + (let ((page-dimensions (cdr (assq ps-paper-type ps-page-dimensions-database))) + page-width page-height) + (cond + ((null page-dimensions) + (error "`ps-paper-type' must be one of:\n%s" + (mapcar 'car ps-page-dimensions-database))) + ((< ps-number-of-columns 1) + (error "The number of columns %d should not be negative"))) + + (ps-select-font) + (ps-select-header-font) + + (setq page-width (ps-page-dimensions-get-width page-dimensions) + page-height (ps-page-dimensions-get-height page-dimensions)) + + ;; Landscape mode + (if ps-landscape-mode + ;; exchange width and height + (setq page-width (prog1 page-height (setq page-height page-width)))) + + ;; It is used to get the lower right corner (only in landscape mode) + (setq ps-landscape-page-height page-height) + + ;; | lm | text | ic | text | ic | text | rm | + ;; page-width == lm + n * pw + (n - 1) * ic + rm + ;; => pw == (page-width - lm -rm - (n - 1) * ic) / n + (setq ps-print-width + (/ (- page-width + ps-left-margin ps-right-margin + (* (1- ps-number-of-columns) ps-inter-column)) + ps-number-of-columns)) + (if (<= ps-print-width 0) + (error "Bad horizontal layout: +page-width == %s +ps-left-margin == %s +ps-right-margin == %s +ps-inter-column == %s +ps-number-of-columns == %s +| lm | text | ic | text | ic | text | rm | +page-width == lm + n * print-width + (n - 1) * ic + rm +=> print-width == %d !" + page-width + ps-left-margin + ps-right-margin + ps-inter-column + ps-number-of-columns + ps-print-width)) + + (setq ps-print-height + (- page-height ps-bottom-margin ps-top-margin)) + (if (<= ps-print-height 0) + (error "Bad vertical layout: +ps-top-margin == %s +ps-bottom-margin == %s +page-height == bm + print-height + tm +=> print-height == %d !" + ps-top-margin + ps-bottom-margin + ps-print-height)) + ;; If headers are turned on, deduct the height of the header from + ;; the print height. + (cond + (ps-print-header + (setq ps-header-pad + (* ps-header-line-pad ps-header-title-line-height)) + (setq ps-print-height + (- ps-print-height + ps-header-offset + ps-header-pad + ps-header-title-line-height + (* ps-header-line-height (- ps-header-lines 1)) + ps-header-pad)))) + (if (<= ps-print-height 0) + (error "Bad vertical layout: +ps-top-margin == %s +ps-bottom-margin == %s +ps-header-offset == %s +ps-header-pad == %s +header-height == %s +page-height == bm + print-height + tm - ho - hh +=> print-height == %d !" + ps-top-margin + ps-bottom-margin + ps-header-offset + ps-header-pad + (+ ps-header-pad + ps-header-title-line-height + (* ps-header-line-height (- ps-header-lines 1)) + ps-header-pad) + ps-print-height)))) (defun ps-print-preprint (&optional filename) (if (and filename @@ -1234,7 +2114,7 @@ (ps-flush-output) ;; Check to see that the file exists and is readable; if not, throw - ;; and error. + ;; an error. (if (not (file-readable-p fname)) (error "Could not read file `%s'" fname)) @@ -1284,6 +2164,7 @@ (ps-output (format "/%s %s def\n" name (if bool "true" "false")))) (defun ps-begin-file () + (ps-get-page-dimensions) (setq ps-showpage-count 0) (ps-output ps-adobe-tag) @@ -1292,37 +2173,56 @@ (ps-output "%%Creator: " (user-full-name) "\n") (ps-output "%%CreationDate: " (time-stamp-hh:mm:ss) " " (time-stamp-mon-dd-yyyy) "\n") - (ps-output "%% DocumentFonts: Helvetica Helvetica-Bold " - ps-font " " ps-font-bold " " ps-font-italic " " - ps-font-bold-italic "\n") (ps-output "%%Pages: (atend)\n") (ps-output "%%EndComments\n\n") - (ps-output-boolean "Duplex" ps-spool-duplex) - (ps-output-boolean "PrintHeader" ps-print-header) + (ps-output "%%BeginProlog\n") + (ps-output-boolean "LandscapeMode" ps-landscape-mode) + (ps-output (format "/NumberOfColumns %d def\n" ps-number-of-columns)) + + (ps-output (format "/LandscapePageHeight %s def\n" ps-landscape-page-height)) + (ps-output (format "/PrintWidth %s def\n" ps-print-width)) + (ps-output (format "/PrintHeight %s def\n" ps-print-height)) + + (ps-output (format "/LeftMargin %s def\n" ps-left-margin)) + (ps-output (format "/RightMargin %s def\n" ps-right-margin)) ; not used + (ps-output (format "/InterColumn %s def\n" ps-inter-column)) + + (ps-output (format "/BottomMargin %s def\n" ps-bottom-margin)) + (ps-output (format "/TopMargin %s def\n" ps-top-margin)) ; not used + (ps-output (format "/HeaderOffset %s def\n" ps-header-offset)) + (ps-output (format "/HeaderPad %s def\n" ps-header-pad)) + + (ps-output-boolean "PrintHeader" ps-print-header) (ps-output-boolean "PrintHeaderFrame" ps-print-header-frame) - (ps-output-boolean "ShowNofN" ps-show-n-of-n) - - (ps-output (format "/LeftMargin %d def\n" ps-left-margin)) - (ps-output (format "/RightMargin %d def\n" ps-right-margin)) - (ps-output (format "/BottomMargin %d def\n" ps-bottom-margin)) - (ps-output (format "/TopMargin %d def\n" ps-top-margin)) - - (ps-get-page-dimensions) - (ps-output (format "/PrintWidth %d def\n" ps-print-width)) - (ps-output (format "/PrintHeight %d def\n" ps-print-height)) - - (ps-output (format "/LineHeight %s def\n" ps-line-height)) - - (ps-output ps-print-prologue) - - (ps-output (format "/f0 %d /%s Font\n" ps-font-size ps-font)) - (ps-output (format "/f1 %d /%s Font\n" ps-font-size ps-font-bold)) - (ps-output (format "/f2 %d /%s Font\n" ps-font-size ps-font-italic)) - (ps-output (format "/f3 %d /%s Font\n" ps-font-size - ps-font-bold-italic)) - - (ps-output "%%EndPrologue\n")) + (ps-output-boolean "ShowNofN" ps-show-n-of-n) + (ps-output-boolean "Duplex" ps-spool-duplex) + + (ps-output (format "/LineHeight %s def\n" ps-line-height)) + + (ps-output ps-print-prologue-1) + (ps-output "%%EndProlog\n\n") + + + (ps-output "%%BeginSetup\n") + + ;; Header fonts + (ps-output ; /h0 14 /Helvetica-Bold Font + (format "/h0 %s /%s DefFont\n" ps-header-title-font-size ps-header-title-font)) + (ps-output ; /h1 12 /Helvetica Font + (format "/h1 %s /%s DefFont\n" ps-header-font-size ps-header-font)) + + (ps-output ps-print-prologue-2) + + ;; Text fonts + (ps-output (format "/f0 %s /%s DefFont\n" ps-font-size ps-font)) + (ps-output (format "/f1 %s /%s DefFont\n" ps-font-size ps-font-bold)) + (ps-output (format "/f2 %s /%s DefFont\n" ps-font-size ps-font-italic)) + (ps-output (format "/f3 %s /%s DefFont\n" ps-font-size ps-font-bold-italic)) + + (ps-output "\nBeginDoc\n\n") + (ps-output "%%EndSetup\n") +) (defun ps-header-dirpart () (let ((fname (buffer-file-name))) @@ -1333,17 +2233,24 @@ ""))) (defun ps-get-buffer-name () - ;; Indulge me this little easter egg: - (if (string= (buffer-name) "ps-print.el") - "Hey, Cool! It's ps-print.el!!!" - (buffer-name))) + (cond + ;; Indulge Jim this little easter egg: + ((string= (buffer-name) "ps-print.el") + "Hey, Cool! It's ps-print.el!!!") + ;; Indulge Jack this other little easter egg: + ((string= (buffer-name) "sokoban.el") + "Super! C'est sokoban.el!") + (t (buffer-name)))) (defun ps-begin-job () (setq ps-page-count 0)) (defun ps-end-file () - (ps-output "%%Trailer\n") - (ps-output "%%Pages: " (format "%d\n" ps-showpage-count))) + (ps-output "\n\n%%Trailer\n") + (ps-output (format "%%%%Pages: %d\n" (1+ (/ (1- ps-page-count) + ps-number-of-columns)))) + (ps-output "EndDoc\n") + (ps-output "%%EOF\n")) (defun ps-next-page () (ps-end-page) @@ -1352,36 +2259,28 @@ (defun ps-begin-page (&optional dummypage) (ps-get-page-dimensions) - (setq ps-width-remaining ps-print-width) + (setq ps-width-remaining ps-print-width) (setq ps-height-remaining ps-print-height) - ;; If headers are turned on, deduct the height of the header from - ;; the print height remaining. Clumsy clumsy clumsy. - (if ps-print-header - (setq ps-height-remaining - (- ps-height-remaining - ps-header-title-line-height - (* ps-header-line-height (- ps-header-lines 1)) - (* 2 ps-header-pad)))) - - (setq ps-page-count (+ ps-page-count 1)) - - (ps-output "\n%%Page: " - (format "%d %d\n" ps-page-count (+ 1 ps-showpage-count))) + ;; Print only when a new real page begins. + (when (zerop (mod ps-page-count ps-number-of-columns)) + (ps-output (format "\n%%%%Page: %d %d\n" + (1+ (/ ps-page-count ps-number-of-columns)) + (1+ (/ ps-page-count ps-number-of-columns))))) + (ps-output "BeginDSCPage\n") - (ps-output (format "/PageNumber %d def\n" ps-page-count)) + (ps-output (format "/PageNumber %d def\n" (incf ps-page-count))) (ps-output "/PageCount 0 def\n") - (if ps-print-header - (progn - (ps-generate-header "HeaderLinesLeft" ps-left-header) - (ps-generate-header "HeaderLinesRight" ps-right-header) - (ps-output (format "%d SetHeaderLines\n" ps-header-lines)))) + (when ps-print-header + (ps-generate-header "HeaderLinesLeft" ps-left-header) + (ps-generate-header "HeaderLinesRight" ps-right-header) + (ps-output (format "%d SetHeaderLines\n" ps-header-lines))) (ps-output "BeginPage\n") - (ps-set-font ps-current-font) - (ps-set-bg ps-current-bg) - (ps-set-color ps-current-color) + (ps-set-font ps-current-font) + (ps-set-bg ps-current-bg) + (ps-set-color ps-current-color) (ps-set-underline ps-current-underline-p)) (defun ps-end-page () @@ -1401,17 +2300,19 @@ (defun ps-next-line () (if (< ps-height-remaining ps-line-height) (ps-next-page) - (setq ps-width-remaining ps-print-width) + (setq ps-width-remaining ps-print-width) (setq ps-height-remaining (- ps-height-remaining ps-line-height)) (ps-hard-lf))) (defun ps-continue-line () (if (< ps-height-remaining ps-line-height) (ps-next-page) - (setq ps-width-remaining ps-print-width) + (setq ps-width-remaining ps-print-width) (setq ps-height-remaining (- ps-height-remaining ps-line-height)) (ps-soft-lf))) +;; [jack] Why hard and soft ? + (defun ps-hard-lf () (ps-output "HL\n")) @@ -1430,7 +2331,7 @@ (to (car wrappoint)) (string (buffer-substring from to))) (ps-output-string string) - (ps-output " S\n") ; + (ps-output " S\n") wrappoint)) (defun ps-basic-plot-whitespace (from to &optional bg-color) @@ -1461,14 +2362,12 @@ (if (< q-todo 100) (/ (* 100 q-done) q-todo) (/ q-done (/ q-todo 100)))) - (message "Formatting...%d%%" foo)))))) + (message "Formatting...%3d%%" foo)))))) (defun ps-set-font (font) (setq ps-current-font font) (ps-output (format "/f%d F\n" ps-current-font))) -(defvar ps-print-color-scale nil) - (defun ps-set-bg (color) (if (setq ps-current-bg color) (ps-output (format ps-color-format (nth 0 color) (nth 1 color) @@ -1548,11 +2447,8 @@ (defun ps-color-values (x-color) (cond ((fboundp 'x-color-values) (x-color-values x-color)) - ;; From fsf 19.33 - ;; ((fboundp 'pixel-components) - ;; (pixel-components x-color)) ((and (fboundp 'color-instance-rgb-components) - (xemacs-color-device)) + (ps-color-device)) (color-instance-rgb-components (if (color-instance-p x-color) x-color (if (color-specifier-p x-color) @@ -1597,13 +2493,13 @@ (foreground (nth 3 face-attr)) (background (nth 4 face-attr)) (fg-color (if (and ps-print-color-p - (xemacs-color-device) + (ps-color-device) foreground) (mapcar 'ps-color-value (ps-color-values foreground)) ps-default-color)) (bg-color (if (and ps-print-color-p - (xemacs-color-device) + (ps-color-device) background) (mapcar 'ps-color-value (ps-color-values background))))) @@ -1630,9 +2526,6 @@ (memq face kind-list)))) (defun ps-xemacs-face-kind-p (face kind kind-regex kind-list) - ;; fsf 19.33: - ;; (let* ((frame-font (or (face-font face) (face-font 'default))) - ;; (kind-cons (assq kind (x-font-properties frame-font))) (let* ((frame-font (or (face-font-instance face) (face-font-instance 'default))) (kind-cons (and frame-font @@ -1694,17 +2587,14 @@ (list (extent-end-position extent) 'pull extent))) nil) -(defun ps-sorter (a b) - (< (car a) (car b))) - (defun ps-extent-sorter (a b) (< (extent-priority a) (extent-priority b))) (defun ps-print-ensure-fontified (start end) (if (and (boundp 'lazy-lock-mode) lazy-lock-mode) (if (fboundp 'lazy-lock-fontify-region) - (lazy-lock-fontify-region start end) - (lazy-lock-fontify-buffer)))) + (lazy-lock-fontify-region start end) ; the new + (lazy-lock-fontify-buffer)))) ; the old (defun ps-generate-postscript-with-faces (from to) ;; Build the reference lists of faces if necessary. @@ -1717,7 +2607,7 @@ ;; that ps-print can be dumped into emacs. This expression can't be ;; evaluated at dump-time because X isn't initialized. (setq ps-print-color-scale - (if (and ps-print-color-p (xemacs-color-device)) + (if (and ps-print-color-p (ps-color-device)) (float (car (ps-color-values "white"))) 1.0)) ;; Generate some PostScript. @@ -1726,13 +2616,13 @@ (let ((face 'default) (position to)) (ps-print-ensure-fontified from to) - (cond ((or (eq ps-print-emacs-type 'lucid) (eq ps-print-emacs-type 'xemacs)) + (cond ((or (eq ps-print-emacs-type 'lucid) + (eq ps-print-emacs-type 'xemacs)) ;; Build the list of extents... (let ((a (cons 'dummy nil)) record type extent extent-list) (map-extents 'ps-mapper nil from to a) - (setq a (cdr a)) - (setq a (sort a 'ps-sorter)) + (setq a (sort (cdr a) 'car-less-than-car)) (setq extent-list nil) @@ -1843,7 +2733,7 @@ (save-restriction (narrow-to-region from to) (if ps-razzle-dazzle - (message "Formatting...%d%%" (setq ps-razchunk 0))) + (message "Formatting...%3d%%" (setq ps-razchunk 0))) (set-buffer buffer) (setq ps-source-buffer buffer) (setq ps-spool-buffer (get-buffer-create ps-spool-buffer-name)) @@ -1860,7 +2750,7 @@ (set-marker safe-marker (point-max)) (goto-char (point-min)) - (if (looking-at (regexp-quote "%!PS-Adobe-1.0")) + (if (looking-at (regexp-quote ps-adobe-tag)) nil (setq needs-begin-file t)) (save-excursion @@ -1899,13 +2789,10 @@ (if ps-razzle-dazzle (message "Formatting...done"))))) -;; XEmacs change -(require 'message) ; Until We can get some sensible autoloads, or - ; message-flatten-list gets put somewhere decent. ;; Permit dynamic evaluation at print time of ps-lpr-switches (defun ps-do-despool (filename) (if (or (not (boundp 'ps-spool-buffer)) - (not ps-spool-buffer)) + (not (symbol-value 'ps-spool-buffer))) (message "No spooled PostScript to print") (ps-end-file) (ps-flush-output) @@ -1926,15 +2813,8 @@ (if (and (eq system-type 'ms-dos) (stringp dos-ps-printer)) (write-region (point-min) (point-max) dos-ps-printer t 0) (let ((binary-process-input t) ; for MS-DOS - (ps-lpr-sw (message-flatten-list ; XEmacs - (mapcar '(lambda (arg) ; Dynamic evaluation - (cond ((stringp arg) arg) - ((functionp arg) (apply arg nil)) - ((symbolp arg) (eval arg)) - ((consp arg) (apply (car arg) - (cdr arg))) - (t nil))) - ps-lpr-switches)))) + (ps-lpr-sw ; Dynamic evaluation + (ps-flatten-list (mapcar 'ps-eval-switch ps-lpr-switches)))) (apply 'call-process-region (point-min) (point-max) ps-lpr-command nil (if (fboundp 'start-process) 0 nil) @@ -1944,6 +2824,32 @@ (message "Printing...done"))) (kill-buffer ps-spool-buffer))) +;; Dynamic evaluation +(defun ps-eval-switch (arg) + (cond ((stringp arg) arg) + ((functionp arg) (apply arg nil)) + ((symbolp arg) (symbol-value arg)) + ((consp arg) (apply (car arg) (cdr arg))) + (t nil))) + +;; `ps-flatten-list' is defined here (copied from "message.el" and +;; enhanced to handle dotted pairs as well) until we can get some +;; sensible autoloads, or `flatten-list' gets put somewhere decent. + +;; (ps-flatten-list '((a . b) c (d . e) (f g h) i . j)) +;; => (a b c d e f g h i j) + +(defun ps-flatten-list (&rest list) + (ps-flatten-list-1 list)) + +(defun ps-flatten-list-1 (list) + (cond + ((null list) (list)) + ((consp list) + (append (ps-flatten-list-1 (car list)) + (ps-flatten-list-1 (cdr list)))) + (t (list list)))) + (defun ps-kill-emacs-check () (let (ps-buffer) (if (and (setq ps-buffer (get-buffer ps-spool-buffer-name)) @@ -2057,9 +2963,9 @@ ;; same thing for vm. (defun ps-vm-print-message-from-summary () (interactive) - (if vm-mail-buffer + (if (and (boundp 'vm-mail-buffer) (symbol-value 'vm-mail-buffer)) (save-excursion - (set-buffer vm-mail-buffer) + (set-buffer (symbol-value 'vm-mail-buffer)) (ps-spool-buffer-with-faces)))) ;; A hook to bind to bind to gnus-summary-setup-buffer to locally bind @@ -2092,8 +2998,8 @@ ;; WARNING! The following function is a *sample* only, and is *not* ;; meant to be used as a whole unless you understand what the effects -;; will be! (In fact, this is a copy if my setup for ps-print -- I'd -;; be very surprised if it was useful to *anybody*, without +;; will be! (In fact, this is a copy of Jim's setup for ps-print -- +;; I'd be very surprised if it was useful to *anybody*, without ;; modification.) (defun ps-jts-ps-setup () @@ -2108,7 +3014,43 @@ (setq ps-spool-duplex t) (setq ps-print-color-p nil) (setq ps-lpr-command "lpr") - (setq ps-lpr-switches '("-Jjct,duplex_long"))) + (setq ps-lpr-switches '("-Jjct,duplex_long")) + 'ps-jts-ps-setup) + +;; WARNING! The following function is a *sample* only, and is *not* +;; meant to be used as a whole unless it corresponds to your needs. +;; (In fact, this is a copy of Jack's setup for ps-print -- +;; I would not be that surprised if it was useful to *anybody*, +;; without modification.) + +(defun ps-jack-setup () + (setq ps-print-color-p 'nil + ps-lpr-command "lpr" + ps-lpr-switches (list) + + ps-paper-type 'a4 + ps-landscape-mode 't + ps-number-of-columns 2 + + ps-left-margin (/ (* 72 1.0) 2.54) ; 1.0 cm + ps-right-margin (/ (* 72 1.0) 2.54) ; 1.0 cm + ps-inter-column (/ (* 72 1.0) 2.54) ; 1.0 cm + ps-bottom-margin (/ (* 72 1.5) 2.54) ; 1.5 cm + ps-top-margin (/ (* 72 1.5) 2.54) ; 1.5 cm + ps-header-offset (/ (* 72 1.0) 2.54) ; 1.0 cm + ps-header-line-pad .15 + ps-print-header t + ps-print-header-frame t + ps-header-lines 2 + ps-show-n-of-n t + ps-spool-duplex nil + + ps-font-family 'Courier + ps-font-size 5.5 + ps-header-font-family 'Helvetica + ps-header-font-size 6 + ps-header-title-font-size 8) + 'ps-jack-setup) (provide 'ps-print) diff -r ad457d5f7d04 -r 0293115a14e9 lisp/packages/shell-font.el --- a/lisp/packages/shell-font.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/packages/shell-font.el Mon Aug 13 08:49:20 2007 +0200 @@ -14,8 +14,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Synched up with: Not in FSF. diff -r ad457d5f7d04 -r 0293115a14e9 lisp/packages/supercite.el --- a/lisp/packages/supercite.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/packages/supercite.el Mon Aug 13 08:49:20 2007 +0200 @@ -24,8 +24,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Synched up with: FSF 19.28. diff -r ad457d5f7d04 -r 0293115a14e9 lisp/packages/tar-mode.el --- a/lisp/packages/tar-mode.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/packages/tar-mode.el Mon Aug 13 08:49:20 2007 +0200 @@ -22,8 +22,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Synched up with: Not synched with FSF. diff -r ad457d5f7d04 -r 0293115a14e9 lisp/packages/terminal.el --- a/lisp/packages/terminal.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/packages/terminal.el Mon Aug 13 08:49:20 2007 +0200 @@ -18,8 +18,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Synched up with: Not synched with FSF. diff -r ad457d5f7d04 -r 0293115a14e9 lisp/packages/texnfo-tex.el --- a/lisp/packages/texnfo-tex.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/packages/texnfo-tex.el Mon Aug 13 08:49:20 2007 +0200 @@ -26,8 +26,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Synched up with: Not in FSF. diff -r ad457d5f7d04 -r 0293115a14e9 lisp/packages/vc-hooks.el --- a/lisp/packages/vc-hooks.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/packages/vc-hooks.el Mon Aug 13 08:49:20 2007 +0200 @@ -23,8 +23,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Synched up with: FSF 19.28. diff -r ad457d5f7d04 -r 0293115a14e9 lisp/packages/vc.el --- a/lisp/packages/vc.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/packages/vc.el Mon Aug 13 08:49:20 2007 +0200 @@ -20,8 +20,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Synched up with: It's not clear at this point. ;;; mly synched this with FSF at version 5.4. Stig did a whole lot diff -r ad457d5f7d04 -r 0293115a14e9 lisp/packages/xscheme.el --- a/lisp/packages/xscheme.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/packages/xscheme.el Mon Aug 13 08:49:20 2007 +0200 @@ -16,15 +16,16 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Synched up with: Not synched with FSF. ;;; Requires C-Scheme release 5 or later ;;; Changes to Control-G handler require runtime version 13.85 or later -;;; $Header: /afs/informatik.uni-tuebingen.de/local/web/xemacs/xemacs-cvs/XEmacs/xemacs-19/lisp/packages/xscheme.el,v 1.1.1.2 1996/12/18 03:45:01 steve Exp $ +;;; $Header: /afs/informatik.uni-tuebingen.de/local/web/xemacs/xemacs-cvs/XEmacs/xemacs-19/lisp/packages/xscheme.el,v 1.2 1997/02/02 05:05:58 steve Exp $ (require 'scheme) diff -r ad457d5f7d04 -r 0293115a14e9 lisp/pcl-cvs/pcl-cvs-xemacs.el --- a/lisp/pcl-cvs/pcl-cvs-xemacs.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/pcl-cvs/pcl-cvs-xemacs.el Mon Aug 13 08:49:20 2007 +0200 @@ -15,8 +15,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;; This simply adds a menu of the common CVS commands to the menubar and to diff -r ad457d5f7d04 -r 0293115a14e9 lisp/prim/about.el --- a/lisp/prim/about.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/prim/about.el Mon Aug 13 08:49:20 2007 +0200 @@ -1,7 +1,7 @@ ;;; about.el --- the About The Authors page (shameless self promotion). ;;; -;; Copyright (c) 1995, 1996 XEmacs Advocacy Organization. +;; Copyright (c) 1995, 1996, 1997 XEmacs Advocacy Organization. ;; This file is part of XEmacs. @@ -16,8 +16,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Synched up with: Not in FSF. @@ -36,6 +37,7 @@ ;;; and Chuck Thompson ;;; More hacking for 19.12 by Chuck Thompson and Ben Wing. ;;; 19.13 and 19.14 updating done by Chuck Thompson. +;;; 19.15 and 20.0 updating done by Steve Baur. (require 'browse-url) (defvar about-xref-map (let ((map (make-sparse-keymap))) @@ -76,7 +78,7 @@ (view-mode nil 'kill-buffer) ;; assume the new view-less (let* ((buffer-read-only nil) (emacs-short-version (concat emacs-major-version "." emacs-minor-version)) - (emacs-about-version (format "version %s; June 1996" emacs-short-version)) + (emacs-about-version (format "version %s; March 1997" emacs-short-version)) (indent-tabs-mode t) ) (erase-buffer) @@ -125,11 +127,17 @@ (insert "XEmacs is the result of the time and effort of many people. The developers responsible for the " emacs-short-version " release are: + * ") (about-xref "Steve Baur" 'steve "Find out more about Steve Baur") (insert " + * ") (about-xref "Martin Buchholz" 'mrb "Find out more about Martin Buchholz") (insert " + + * ") (about-xref "And many other contributors..." 'others "Read about the legion of XEmacs hackers") (insert " + + Chuck Thompson was Mr. XEmacs from 19.11 through 19.14. Ben Wing + was crucial to each of those releases. + * ") (about-xref "Chuck Thompson" 'cthomp "Find out more about Chuck Thompson") (insert " * ") (about-xref "Ben Wing" 'wing "Find out more about Ben Wing") (insert " - * ") (about-xref "And many other contributors..." 'others "Read about the legion of XEmacs hackers") (insert " - Jamie Zawinski was Mr. Lucid Emacs from 19.0 through 19.10, the last release actually named Lucid Emacs. Richard Mlynarik was crucial to most of those releases. @@ -148,7 +156,7 @@ (toggle-read-only 0) (let ((rest (if who-to-load (list who-to-load) - '(cthomp wing stig jwz mly vladimir baw piper bw wmperry))) + '(steve mrb cthomp wing stig jwz mly vladimir baw piper bw wmperry))) (got-error nil)) (while rest (let* ((who (car rest)) @@ -198,7 +206,7 @@ (goto-char (point-max)) (insert "\n ") - (let ((rest '(cthomp wing stig linebreak jwz mly vladimir linebreak baw piper bw linebreak wmperry)) + (let ((rest '(steve mrb cthomp wing stig linebreak jwz mly vladimir linebreak baw piper bw linebreak wmperry)) (got-error nil)) (while rest (if (eq (car rest) 'linebreak) @@ -279,6 +287,8 @@ ((eq xref 'bw) "About Bob Weiner") ((eq xref 'piper) "About Andy Piper") ((eq xref 'stig) "About Jonathan Stigelman") + ((eq xref 'steve) "About Steve Baur") + ((eq xref 'mrb) "About Martin Buchholz") ((eq xref 'others) "About Everyone") ((eq xref 'features) "New XEmacs Features") ((eq xref 'history) "XEmacs History") @@ -513,6 +523,38 @@ (about-xref "here" prev-page "Return to previous page") (insert " to go back to the previous page.\n") ) + ((eq xref 'steve) + (about-face "Steve Baur" 'bold) + (insert " + + Steve took over the maintenance of XEmacs in November of 1996 + (it seemed like a good idea at the time ...). In real life he is a + network administrator and Unix systems programmer for Miranova + Systems, Inc. + + Steve's main contributions to XEmacs have been reviving the FAQ, + testing and integrating patches, tracking down and fixing bugs, and + answering hundreds of questions on Usenet.") + + (insert "\n\n\tClick ") + (about-xref "here" prev-page "Return to previous page") + (insert " to go back to the previous page.\n") + ) + ((eq xref 'mrb) + (about-face "Martin Buchholz" 'bold) + (insert " + + Martin Buchholz + Technical lead for XEmacs at DevPro (formerly SunPro), a + division of Sun Microsystems. Martin used to do XEmacs as a + `hobby' while at IBM, and was crazy enough to try to do it + for a living at Sun. Martin is currently working mostly on + Internationalization.") + + (insert "\n\n\tClick ") + (about-xref "here" prev-page "Return to previous page") + (insert " to go back to the previous page.\n") + ) ((eq xref 'cthomp) (about-face "Chuck Thompson" 'bold) (insert " @@ -625,13 +667,15 @@ ((eq xref 'bw) (about-face "Bob Weiner" 'bold) - (insert " + (insert " Author of the Hyperbole everyday information management hypertext system and the OO-Browser multi-language code browser. He also designed the InfoDock integrated tool framework for software engineers. It runs atop XEmacs and is - available from \"/anonymous@ftp.xemacs.org:pub/infodock\". + available from his firm, InfoDock Associates, which offers custom + development and support packages for corporate users of XEmacs, + GNU Emacs and InfoDock. See \"http://www.infodock.com>\". His interests include user interfaces, information management, CASE tools, communications and enterprise integration.") @@ -675,16 +719,12 @@ (about-face "William Perry" 'bold) (insert " - Author of Emacs-w3, the builtin web browser that comes with XEmacs, - and various additions to the C code (e.g. the database support, - the PNG support, some of the GIF/JPEG support, the strikethru - face attribute support). + Author of Emacs-w3, the builtin web browser that comes with XEmacs, + and various additions to the C code (e.g. the database support, + the PNG support, some of the GIF/JPEG support, the strikethru + face attribute support). - He is currently working on adding really cool stylesheets to the - web, which will stress the new capabilities of XEmacs to the limit. - - He only gets paid for working on an HTTP server for Spry, but will - hack emacs for beer.") + He is currently working at Aventail, Corp. on SOCKS v5 servers.") (insert "\n\n\tClick ") (about-xref "here" prev-page "Return to previous page") @@ -704,13 +744,6 @@ These are some of the contributors; we have no doubt forgotten someone; we apologize! You can see some of our faces further below. - Martin Buchholz - Technical lead for XEmacs at DevPro (formerly SunPro), a - division of Sun Microsystems. Martin used to do XEmacs as a - `hobby' while at IBM, and was crazy enough to try to do it - for a living at Sun. Martin is currently working mostly on - Internationalization. - ") (about-xref "Vladimir Ivanovic" 'vladimir "Find out more about Vladimir Ivanovic") (insert " Former technical lead for XEmacs at Sun Microsystems. He is now with Microtec Research Inc., working on embedded systems @@ -733,23 +766,22 @@ Created the prototype for the toolbars. Has been the first to make use of many of the new XEmacs graphics features. - ") (about-xref "Bob Weiner" 'bw "Find out more about Bob Weiner") (insert " + ") (about-xref "Bob Weiner" 'bw "Find out more about Bob Weiner") (insert " Author of the Hyperbole everyday information management hypertext system and the OO-Browser multi-language code browser. He also designed the InfoDock integrated tool framework for software engineers. It runs atop XEmacs and is - available from \"/anonymous@ftp.xemacs.org:pub/infodock\". + available from his firm, InfoDock Associates, which offers custom + development and support packages for corporate users of XEmacs, + GNU Emacs and InfoDock. See \"http://www.infodock.com>\". His interests include user interfaces, information management, - CASE tools, communications and enterprise integration. + CASE tools, communications and enterprise integration. - ") (about-xref "William Perry" 'wmperry "Find out more about Bill Perry") (insert " - Author of W3, a package for browsing the World Wide Web - which is included in the standard XEmacs distribution. - Although W3 runs on all versions of Emacs, Bill has been - quick to take advantage of the unique features of XEmacs - (such as embedded images and windows). Thus, the XEmacs - version of W3 is significantly more powerful than versions - running in other Emacs variants. + ") (about-xref "William Perry" 'wmperry "Find out more about Bill Perry") (insert " + Author of Emacs-w3, the builtin web browser that comes with XEmacs, + and various additions to the C code (e.g. the database support, + the PNG support, some of the GIF/JPEG support, the strikethru + face attribute support). Kyle Jones Author of VM (View Mail), a mail-reading package that is @@ -814,9 +846,9 @@ Mark Allender Butch Anton Fred Appelman + Erik \"The Pope\" Arneson Tor Arntsen Mike Battaglia - Steven L Baur Neal Becker Paul Bibilo Jan Borchers @@ -832,16 +864,23 @@ Philippe Charton Peter Cheng Jin S. Choi + Tomasz J. Cholewo Serenella Ciongoli Richard Cognot Andy Cohen + Andrew J Cosgriff + Nick J. Crabtree Christopher Davis + Soren Dayton Michael Diers William G. Dubuque Samuel J. Eaton Carl Edman Dave Edmondson + Jonathan Edwards Eric Eide + EKR + Oscar Figueiredo David Fletcher Paul Flinders Jered J Floyd @@ -849,6 +888,7 @@ Benjamin Fried Barry Friedman Lew Gaiter III + Itay Gat Tim Geisler Dave Gillespie Christian F. Goetze @@ -862,6 +902,7 @@ Magnus Hammerin ChangGil Han Derek Harding + Michael Harnois John Haxby Jareth \"JHod\" Hein Benedikt Heinen @@ -874,12 +915,19 @@ Robin Jeffries Philip Johnson J. Kean Johnston + Andreas Kaempf Doug Keller + Hunter Kelly Gregor Kennedy Michael Kifer Yasuhiko Kiuchi + Greg Klanderman + Valdis Kletnieks + Jens Krinke + Mats Larsson Jens Lautenbacher Simon Leinen + Carsten Leonhardt James LewisMoss Mats Lidell Matt Liggett @@ -887,42 +935,52 @@ Robert Lipe Damon Lipparelli Hamish Macdonald - Ian MacKinnon + Ian MacKinnon Patrick MacRoberts Tonny Madsen Ketil Z Malde Steve March + Pekka Marjola Simon Marshall Dave Mason Jaye Mathisen Michael Meissner David M. Meyer Brad Miller + Jeff Miller + David Moore John Morey Rob Mori Heiko Muenkel Arup Mukherjee Colas Nahaboo Lynn D. Newton + Casey Nielson Georg Nikodym + Hrvoje Niksic Andy Norman Joseph J. Nuspl Jr. Kim Nyberg David Ofelt + Tore Olsen Greg Onufer Achim Oppelt Sudeep Kumar Palat Marc Paquette Jens-U H Petersen + Joel Peterson Thomas A. Peterson Peter Pezaris Tibor Polgar + Frederic Poncin E. Rehmi Post + Colin Rafferty Paul M Reilly Jack Repenning Daniel Rich Roland Rieke Russell Ritchie + Roland Mike Russell Jan Sandquist Marty Sasaki @@ -932,7 +990,9 @@ Cotton Seed Axel Seibert Odd-Magne Sekkingstad + Vinnie Shelton John Shen + Murata Shuuichirou Jeffrey Sparkes Michael Sperber Manoj Srivastava @@ -943,6 +1003,7 @@ Morioka Tomohiko Raymond L. Toy John Turner + Juan E. Villacis Vladimir Vukicevic Peter Ware Yoav Weiss diff -r ad457d5f7d04 -r 0293115a14e9 lisp/prim/advocacy.el --- a/lisp/prim/advocacy.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/prim/advocacy.el Mon Aug 13 08:49:20 2007 +0200 @@ -17,8 +17,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;;###autoload (defvar xemacs-praise-sound-file "sounds/im_so_happy.au" diff -r ad457d5f7d04 -r 0293115a14e9 lisp/prim/auto-autoloads.el --- a/lisp/prim/auto-autoloads.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/prim/auto-autoloads.el Mon Aug 13 08:49:20 2007 +0200 @@ -1114,13 +1114,18 @@ ;;;*** -;;;### (autoloads (ediff-toggle-multiframe) "ediff-util" "ediff/ediff-util.el") +;;;### (autoloads (ediff-toggle-use-toolbar ediff-toggle-multiframe) "ediff-util" "ediff/ediff-util.el") (autoload 'ediff-toggle-multiframe "ediff-util" "\ -Switch from the multiframe display to single-frame display and back. -For a permanent change, set the variable `ediff-window-setup-function', +Switch from multiframe display to single-frame display and back. +To change the default, set the variable `ediff-window-setup-function', which see." t nil) +(autoload 'ediff-toggle-use-toolbar "ediff-util" "\ +Enable or disable Ediff toolbar. +Works only in versions of Emacs that support toolbars. +To change the default, set the variable `ediff-use-toolbar-p', which see." t nil) + ;;;*** ;;;### (autoloads (ediff-documentation ediff-version ediff-revision ediff-patch-buffer ediff-patch-file run-ediff-from-cvs-buffer ediff-merge-revisions-with-ancestor ediff-merge-revisions ediff-merge-buffers-with-ancestor ediff-merge-buffers ediff-merge-files-with-ancestor ediff-merge-files ediff-regions-linewise ediff-regions-wordwise ediff-windows-linewise ediff-windows-wordwise ediff-merge-directory-revisions-with-ancestor ediff-merge-directory-revisions ediff-merge-directories-with-ancestor ediff-merge-directories ediff-directories3 ediff-directory-revisions ediff-directories ediff-buffers3 ediff-buffers ediff-files3 ediff-files) "ediff" "ediff/ediff.el") @@ -1809,6 +1814,172 @@ ;;;*** +;;;### (autoloads (custom-make-dependencies custom-menu-update custom-buffer-create customize-apropos customize-customized customize-face customize-variable customize) "custom-edit" "gnus/custom-edit.el") + +(autoload 'customize "custom-edit" "\ +Customize SYMBOL, which must be a customization group." t nil) + +(autoload 'customize-variable "custom-edit" "\ +Customize SYMBOL, which must be a variable." t nil) + +(autoload 'customize-face "custom-edit" "\ +Customize FACE." t nil) + +(autoload 'customize-customized "custom-edit" "\ +Customize all already customized user options." t nil) + +(autoload 'customize-apropos "custom-edit" "\ +Customize all user options matching REGEXP. +If ALL (e.g., started with a prefix key), include options which are not +user-settable." t nil) + +(autoload 'custom-buffer-create "custom-edit" "\ +Create a buffer containing OPTIONS. +OPTIONS should be an alist of the form ((SYMBOL WIDGET)...), where +SYMBOL is a customization option, and WIDGET is a widget for editing +that option." nil nil) + +(autoload 'custom-menu-update "custom-edit" "\ +Update customize menu." t nil) + +(autoload 'custom-make-dependencies "custom-edit" "\ +Batch function to extract custom dependencies from .el files. +Usage: emacs -batch *.el -f custom-make-dependencies > deps.el" nil nil) + +;;;*** + +;;;### (autoloads (custom-set-faces custom-set-variables custom-initialize-faces custom-add-to-group defgroup custom-declare-group defface custom-declare-face defcustom custom-declare-variable) "custom" "gnus/custom.el") + +(autoload 'custom-declare-variable "custom" "\ +Like `defcustom', but SYMBOL and VALUE are evaluated as notmal arguments." nil nil) + +(autoload 'defcustom "custom" "\ +Declare SYMBOL as a customizable variable that defaults to VALUE. +DOC is the variable documentation. + +Neither SYMBOL nor VALUE needs to be quoted. +If SYMBOL is not already bound, initialize it to VALUE. +The remaining arguments should have the form + + [KEYWORD VALUE]... + +The following KEYWORD's are defined: + +:type VALUE should be a widget type. +:options VALUE should be a list of valid members of the widget type. +:group VALUE should be a customization group. + Add SYMBOL to that group. + +Read the section about customization in the emacs lisp manual for more +information." nil 'macro) + +(autoload 'custom-declare-face "custom" "\ +Like `defface', but FACE is evaluated as a normal argument." nil nil) + +(autoload 'defface "custom" "\ +Declare FACE as a customizable face that defaults to SPEC. +FACE does not need to be quoted. + +Third argument DOC is the face documentation. + +If FACE has been set with `custom-set-face', set the face attributes +as specified by that function, otherwise set the face attributes +according to SPEC. + +The remaining arguments should have the form + + [KEYWORD VALUE]... + +The following KEYWORD's are defined: + +:group VALUE should be a customization group. + Add FACE to that group. + +SPEC should be an alist of the form ((DISPLAY ATTS)...). + +ATTS is a list of face attributes and their values. The possible +attributes are defined in the variable `custom-face-attributes'. +Alternatively, ATTS can be a face in which case the attributes of that +face is used. + +The ATTS of the first entry in SPEC where the DISPLAY matches the +frame should take effect in that frame. DISPLAY can either be the +symbol `t', which will match all frames, or an alist of the form +\((REQ ITEM...)...) + +For the DISPLAY to match a FRAME, the REQ property of the frame must +match one of the ITEM. The following REQ are defined: + +`type' (the value of (window-system)) + Should be one of `x' or `tty'. + +`class' (the frame's color support) + Should be one of `color', `grayscale', or `mono'. + +`background' (what color is used for the background text) + Should be one of `light' or `dark'. + +Read the section about customization in the emacs lisp manual for more +information." nil 'macro) + +(autoload 'custom-declare-group "custom" "\ +Like `defgroup', but SYMBOL is evaluated as a normal argument." nil nil) + +(autoload 'defgroup "custom" "\ +Declare SYMBOL as a customization group containing MEMBERS. +SYMBOL does not need to be quoted. + +Third arg DOC is the group documentation. + +MEMBERS should be an alist of the form ((NAME WIDGET)...) where +NAME is a symbol and WIDGET is a widget is a widget for editing that +symbol. Useful widgets are `custom-variable' for editing variables, +`custom-face' for edit faces, and `custom-group' for editing groups. + +The remaining arguments should have the form + + [KEYWORD VALUE]... + +The following KEYWORD's are defined: + +:group VALUE should be a customization group. + Add SYMBOL to that group. + +Read the section about customization in the emacs lisp manual for more +information." nil 'macro) + +(autoload 'custom-add-to-group "custom" "\ +To existing GROUP add a new OPTION of type WIDGET, +If there already is an entry for that option, overwrite it." nil nil) + +(autoload 'custom-initialize-faces "custom" "\ +Initialize all custom faces for FRAME. +If FRAME is nil or omitted, initialize them for all frames." nil nil) + +(autoload 'custom-set-variables "custom" "\ +Initialize variables according to user preferences. + +The arguments should be a list where each entry has the form: + + (SYMBOL VALUE [NOW]) + +The unevaluated VALUE is stored as the saved value for SYMBOL. +If NOW is present and non-nil, VALUE is also evaluated and bound as +the default value for the SYMBOL." nil nil) + +(autoload 'custom-set-faces "custom" "\ +Initialize faces according to user preferences. +The arguments should be a list where each entry has the form: + + (FACE SPEC [NOW]) + +SPEC will be stored as the saved value for FACE. If NOW is present +and non-nil, FACE will also be created according to SPEC. + +See `defface' for the format of SPEC." nil nil) + +;;;*** + ;;;### (autoloads (gnus-earcon-display) "earcon" "gnus/earcon.el") (autoload 'gnus-earcon-display "earcon" "\ @@ -1816,10 +1987,20 @@ ;;;*** +;;;### (autoloads (gnus-audio-play) "gnus-audio" "gnus/gnus-audio.el") + +(autoload 'gnus-audio-play "gnus-audio" "\ +Play a sound through the speaker." t nil) + +;;;*** + ;;;### (autoloads (gnus-cache-generate-nov-databases gnus-cache-generate-active gnus-jog-cache) "gnus-cache" "gnus/gnus-cache.el") (autoload 'gnus-jog-cache "gnus-cache" "\ -Go through all groups and put the articles into the cache." t nil) +Go through all groups and put the articles into the cache. + +Usage: +$ emacs -batch -l ~/.emacs -l gnus -f gnus-jog-cache" t nil) (autoload 'gnus-cache-generate-active "gnus-cache" "\ Generate the cache active file." t nil) @@ -1829,6 +2010,35 @@ ;;;*** +;;;### (autoloads (gnus-fetch-group) "gnus-group" "gnus/gnus-group.el") + +(autoload 'gnus-fetch-group "gnus-group" "\ +Start Gnus if necessary and enter GROUP. +Returns whether the fetching was successful or not." t nil) + +;;;*** + +;;;### (autoloads (gnus-batch-score) "gnus-kill" "gnus/gnus-kill.el") + +(defalias 'gnus-batch-kill 'gnus-batch-score) + +(autoload 'gnus-batch-score "gnus-kill" "\ +Run batched scoring. +Usage: emacs -batch -l gnus -f gnus-batch-score ... +Newsgroups is a list of strings in Bnews format. If you want to score +the comp hierarchy, you'd say \"comp.all\". If you would not like to +score the alt hierarchy, you'd say \"!alt.all\"." t nil) + +;;;*** + +;;;### (autoloads (gnus-change-server) "gnus-move" "gnus/gnus-move.el") + +(autoload 'gnus-change-server "gnus-move" "\ +Move from FROM-SERVER to TO-SERVER. +Update the .newsrc.eld file to reflect the change of nntp server." t nil) + +;;;*** + ;;;### (autoloads (gnus-sound-play) "gnus-sound" "gnus/gnus-sound.el") (autoload 'gnus-sound-play "gnus-sound" "\ @@ -1850,14 +2060,32 @@ ;;;*** -;;;### (autoloads (gnus-batch-score gnus-fetch-group gnus gnus-other-frame gnus-slave gnus-no-server gnus-slave-no-server gnus-add-configuration gnus-update-format) "gnus" "gnus/gnus.el") - -(autoload 'gnus-update-format "gnus" "\ +;;;### (autoloads (gnus-update-format) "gnus-spec" "gnus/gnus-spec.el") + +(autoload 'gnus-update-format "gnus-spec" "\ Update the format specification near point." t nil) -(autoload 'gnus-add-configuration "gnus" "\ +;;;*** + +;;;### (autoloads (gnus-declare-backend gnus-unload) "gnus-start" "gnus/gnus-start.el") + +(autoload 'gnus-unload "gnus-start" "\ +Unload all Gnus features." t nil) + +(autoload 'gnus-declare-backend "gnus-start" "\ +Declare backend NAME with ABILITIES as a Gnus backend." nil nil) + +;;;*** + +;;;### (autoloads (gnus-add-configuration) "gnus-win" "gnus/gnus-win.el") + +(autoload 'gnus-add-configuration "gnus-win" "\ Add the window configuration CONF to `gnus-buffer-configuration'." nil nil) +;;;*** + +;;;### (autoloads (gnus gnus-other-frame gnus-slave gnus-no-server gnus-slave-no-server) "gnus" "gnus/gnus.el") + (autoload 'gnus-slave-no-server "gnus" "\ Read network news as a slave, without connecting to local server" t nil) @@ -1881,193 +2109,31 @@ startup level. If ARG is non-nil and not a positive number, Gnus will prompt the user for the name of an NNTP server to use." t nil) -(autoload 'gnus-fetch-group "gnus" "\ -Start Gnus if necessary and enter GROUP. -Returns whether the fetching was successful or not." t nil) - -(defalias 'gnus-batch-kill 'gnus-batch-score) - -(autoload 'gnus-batch-score "gnus" "\ -Run batched scoring. -Usage: emacs -batch -l gnus -f gnus-batch-score ... -Newsgroups is a list of strings in Bnews format. If you want to score -the comp hierarchy, you'd say \"comp.all\". If you would not like to -score the alt hierarchy, you'd say \"!alt.all\"." t nil) - ;;;*** ;;;### (autoloads (unbold-region bold-region message-news-other-frame message-news-other-window message-mail-other-frame message-mail-other-window message-bounce message-resend message-forward message-recover message-supersede message-cancel-news message-followup message-wide-reply message-reply message-news message-mail message-mode) "message" "gnus/message.el") -(defvar message-fcc-handler-function 'rmail-output "\ -*A function called to save outgoing articles. -This function will be called with the name of the file to store the -article in. The default function is `rmail-output' which saves in Unix -mailbox format.") - -(defvar message-courtesy-message "The following message is a courtesy copy of an article\nthat has been posted as well.\n\n" "\ -*This is inserted at the start of a mailed copy of a posted message. -If this variable is nil, no such courtesy message will be added.") - -(defvar message-ignored-bounced-headers "^\\(Received\\|Return-Path\\):" "\ -*Regexp that matches headers to be removed in resent bounced mail.") - -(defvar message-from-style 'default "\ -*Specifies how \"From\" headers look. - -If `nil', they contain just the return address like: - king@grassland.com -If `parens', they look like: - king@grassland.com (Elvis Parsley) -If `angles', they look like: - Elvis Parsley - -Otherwise, most addresses look like `angles', but they look like -`parens' if `angles' would need quoting and `parens' would not.") - -(defvar message-syntax-checks nil "\ -Controls what syntax checks should not be performed on outgoing posts. -To disable checking of long signatures, for instance, add - `(signature . disabled)' to this list. - -Don't touch this variable unless you really know what you're doing. - -Checks include subject-cmsg multiple-headers sendsys message-id from -long-lines control-chars size new-text redirected-followup signature -approved sender empty empty-headers message-id from subject.") - -(defvar message-required-news-headers '(From Newsgroups Subject Date Message-ID (optional . Organization) Lines (optional . X-Newsreader)) "\ -*Headers to be generated or prompted for when posting an article. -RFC977 and RFC1036 require From, Date, Newsgroups, Subject, -Message-ID. Organization, Lines, In-Reply-To, Expires, and -X-Newsreader are optional. If don't you want message to insert some -header, remove it from this list.") - -(defvar message-required-mail-headers '(From Subject Date (optional . In-Reply-To) Message-ID Lines (optional . X-Mailer)) "\ -*Headers to be generated or prompted for when mailing a message. -RFC822 required that From, Date, To, Subject and Message-ID be -included. Organization, Lines and X-Mailer are optional.") - -(defvar message-deletable-headers '(Message-ID Date) "\ -*Headers to be deleted if they already exist and were generated by message previously.") - -(defvar message-ignored-news-headers "^NNTP-Posting-Host:\\|^Xref:\\|^Bcc:\\|^Gcc:\\|^Fcc:" "\ -*Regexp of headers to be removed unconditionally before posting.") - -(defvar message-ignored-mail-headers "^Gcc:\\|^Fcc:" "\ -*Regexp of headers to be removed unconditionally before mailing.") - -(defvar message-ignored-supersedes-headers "^Path:\\|^Date\\|^NNTP-Posting-Host:\\|^Xref:\\|^Lines:\\|^Received:\\|^X-From-Line:\\|Return-Path:\\|^Supersedes:" "\ -*Header lines matching this regexp will be deleted before posting. -It's best to delete old Path and Date headers before posting to avoid -any confusion.") - -(defvar message-signature-separator "^-- *$" "\ -Regexp matching the signature separator.") - -(defvar message-interactive nil "\ -Non-nil means when sending a message wait for and display errors. -nil means let mailer mail back a message to report errors.") - -(defvar message-generate-new-buffers t "\ -*Non-nil means that a new message buffer will be created whenever `mail-setup' is called. -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.") - -(defvar message-kill-buffer-on-exit nil "\ -*Non-nil means that the message buffer will be killed after sending a message.") - -(defvar message-user-organization-file "/usr/lib/news/organization" "\ -*Local news organization file.") - -(defvar message-signature-before-forwarded-message t "\ -*If non-nil, put the signature before any included forwarded message.") - -(defvar message-included-forward-headers "^From:\\|^Newsgroups:\\|^Subject:\\|^Date:\\|^Followup-To:\\|^Reply-To:\\|^Organization:\\|^Summary:\\|^Keywords:\\|^To:\\|^Cc:\\|^Posted-To:\\|^Mail-Copies-To:\\|^Apparently-To:\\|^Gnus-Warning:\\|^Resent-\\|^Message-ID:\\|^References:" "\ -*Regexp matching headers to be included in forwarded messages.") - -(defvar message-ignored-resent-headers "^Return-receipt" "\ -*All headers that match this regexp will be deleted when resending a message.") - -(defvar message-ignored-cited-headers "." "\ -Delete these headers from the messages you yank.") - -(defvar message-send-mail-function 'message-send-mail-with-sendmail "\ -Function to call to send the current buffer as mail. -The headers should be delimited by a line whose contents match the -variable `mail-header-separator'. - -Legal values include `message-send-mail-with-mh' and -`message-send-mail-with-sendmail', which is the default.") - -(defvar message-send-news-function 'message-send-news "\ -Function to call to send the current buffer as news. -The headers should be delimited by a line whose contents match the -variable `mail-header-separator'.") - -(defvar message-reply-to-function nil "\ -Function that should return a list of headers. -This function should pick out addresses from the To, Cc, and From headers -and respond with new To and Cc headers.") - -(defvar message-wide-reply-to-function nil "\ -Function that should return a list of headers. -This function should pick out addresses from the To, Cc, and From headers -and respond with new To and Cc headers.") - -(defvar message-followup-to-function nil "\ -Function that should return a list of headers. -This function should pick out addresses from the To, Cc, and From headers -and respond with new To and Cc headers.") - -(defvar message-use-followup-to 'ask "\ -*Specifies what to do with Followup-To header. -If nil, ignore the header. If it is t, use its value, but query before -using the \"poster\" value. If it is the symbol `ask', query the user -whether to ignore the \"poster\" value. If it is the symbol `use', -always use the value.") - -(defvar message-post-method (cond ((and (boundp 'gnus-post-method) gnus-post-method) gnus-post-method) ((boundp 'gnus-select-method) gnus-select-method) (t '(nnspool ""))) "\ -Method used to post news.") - -(defvar message-generate-headers-first nil "\ -*If non-nil, generate all possible headers before composing.") - -(defvar message-citation-line-function 'message-insert-citation-line "\ -*Function called to insert the \"Whomever writes:\" line.") - -(defvar message-yank-prefix "> " "\ -*Prefix inserted on the lines of yanked messages. -nil means use indentation.") - -(defvar message-cite-function 'message-cite-original "\ -*Function for citing an original message.") - -(defvar message-indent-citation-function 'message-indent-citation "\ -*Function for modifying a citation just inserted in the mail buffer. -This can also be a list of functions. Each function can find the -citation between (point) and (mark t). And each function should leave -point and mark around the citation text as modified.") - -(defvar message-signature t "\ -*String to be inserted at the end of the message buffer. -If t, the `message-signature-file' file will be inserted instead. -If a function, the result from the function will be used instead. -If a form, the result from the form will be used instead.") - -(defvar message-signature-file "~/.signature" "\ -*File containing the text inserted at end of message. buffer.") - -(defvar message-default-headers nil "\ -*A string containing header lines to be inserted in outgoing messages. -It is inserted before you edit the message, so you can edit or delete -these lines.") - -(defvar message-default-mail-headers nil "\ -*A string of header lines to be inserted in outgoing mails.") - -(defvar message-default-news-headers nil "\ -*A string of header lines to be inserted in outgoing news articles.") +(defcustom message-fcc-handler-function 'message-output "*A function called to save outgoing articles.\nThis function will be called with the name of the file to store the\narticle in. The default function is `rmail-output' which saves in Unix\nmailbox format." :type '(radio (function-item rmail-output) (function :tag "Other")) :group 'message-sending) + +(defcustom message-from-style 'default "*Specifies how \"From\" headers look.\n\nIf `nil', they contain just the return address like:\n king@grassland.com\nIf `parens', they look like:\n king@grassland.com (Elvis Parsley)\nIf `angles', they look like:\n Elvis Parsley \n\nOtherwise, most addresses look like `angles', but they look like\n`parens' if `angles' would need quoting and `parens' would not." :type '(choice (const :tag "simple" nil) (const parens) (const angles) (const default)) :group 'message-headers) + +(defcustom message-signature-separator "^-- *$" "Regexp matching the signature separator." :type 'regexp :group 'message-various) + +(defcustom message-user-organization-file "/usr/lib/news/organization" "*Local news organization file." :type 'file :group 'message-headers) + +(defcustom message-send-mail-function 'message-send-mail-with-sendmail "Function to call to send the current buffer as mail.\nThe headers should be delimited by a line whose contents match the\nvariable `mail-header-separator'.\n\nLegal values include `message-send-mail-with-sendmail' (the default),\n`message-send-mail-with-mh' and `message-send-mail-with-qmail'." :type '(radio (function-item message-send-mail-with-sendmail) (function-item message-send-mail-with-mh) (function-item message-send-mail-with-qmail) (function :tag "Other")) :group 'message-sending :group 'message-mail) + +(defcustom message-citation-line-function 'message-insert-citation-line "*Function called to insert the \"Whomever writes:\" line." :type 'function :group 'message-insertion) + +(defcustom message-yank-prefix "> " "*Prefix inserted on the lines of yanked messages.\nnil means use indentation." :type 'string :group 'message-insertion) + +(defcustom message-cite-function (if (and (boundp 'mail-citation-hook) mail-citation-hook) mail-citation-hook 'message-cite-original) "*Function for citing an original message." :type '(radio (function-item message-cite-original) (function-item sc-cite-original) (function :tag "Other")) :group 'message-insertion) + +(defcustom message-indent-citation-function 'message-indent-citation "*Function for modifying a citation just inserted in the mail buffer.\nThis can also be a list of functions. Each function can find the\ncitation between (point) and (mark t). And each function should leave\npoint and mark around the citation text as modified." :type 'function :group 'message-insertion) + +(defcustom message-signature t "*String to be inserted at the end of the message buffer.\nIf t, the `message-signature-file' file will be inserted instead.\nIf a function, the result from the function will be used instead.\nIf a form, the result from the form will be used instead." :type 'sexp :group 'message-insertion) + +(defcustom message-signature-file "~/.signature" "*File containing the text inserted at end of message buffer." :type 'file :group 'message-insertion) (autoload 'message-mode "message" "\ Major mode for editing mail and news to be sent. @@ -2076,10 +2142,10 @@ C-c C-f move to a header field (and create it if there isn't): C-c C-f C-t move to To C-c C-f C-s move to Subject C-c C-f C-c move to Cc C-c C-f C-b move to Bcc - C-c C-f C-f move to Fcc C-c C-f C-r move to Reply-To + C-c C-f C-w move to Fcc C-c C-f C-r move to Reply-To C-c C-f C-u move to Summary C-c C-f C-n move to Newsgroups C-c C-f C-k move to Keywords C-c C-f C-d move to Distribution - C-c C-f C-o move to Followup-To + C-c C-f C-f move to Followup-To C-c C-t message-insert-to (add a To header to a news followup) C-c C-n message-insert-newsgroups (add a Newsgroup header to a news reply) C-c C-b message-goto-body (move to beginning of message text). @@ -2087,7 +2153,8 @@ C-c C-w message-insert-signature (insert `message-signature-file' file). C-c C-y message-yank-original (insert current message, if any). C-c C-q message-fill-yanked-message (fill what was yanked). -C-c C-r message-ceasar-buffer-body (rot13 the message body)." t nil) +C-c C-e message-elide-region (elide the text between point and mark). +C-c C-r message-caesar-buffer-body (rot13 the message body)." t nil) (autoload 'message-mail "message" "\ Start editing a mail message to be sent." t nil) @@ -2098,9 +2165,12 @@ (autoload 'message-reply "message" "\ Start editing a reply to the article in the current buffer." t nil) -(autoload 'message-wide-reply "message" nil t nil) - -(autoload 'message-followup "message" nil t nil) +(autoload 'message-wide-reply "message" "\ +Make a \"wide\" reply to the message in the current buffer." t nil) + +(autoload 'message-followup "message" "\ +Follow up to the message in the current buffer. +If TO-NEWSGROUPS, use that as the new Newsgroups line." t nil) (autoload 'message-cancel-news "message" "\ Cancel an article you posted." t nil) @@ -2151,6 +2221,24 @@ ;;;*** +;;;### (autoloads nil "messcompat" "gnus/messcompat.el") + +(defvar message-signature-file mail-signature-file "\ +*File containing the text inserted at end of message. buffer.") + +;;;*** + +;;;### (autoloads (nndoc-add-type) "nndoc" "gnus/nndoc.el") + +(autoload 'nndoc-add-type "nndoc" "\ +Add document DEFINITION to the list of nndoc document definitions. +If POSITION is nil or `last', the definition will be added +as the last checked definition, if t or `first', add as the +first definition, and if any other symbol, add after that +symbol in the alist." nil nil) + +;;;*** + ;;;### (autoloads (nnfolder-generate-active-file) "nnfolder" "gnus/nnfolder.el") (autoload 'nnfolder-generate-active-file "nnfolder" "\ @@ -3563,7 +3651,7 @@ ;;;### (autoloads (ksh-mode) "ksh-mode" "modes/ksh-mode.el") (autoload 'ksh-mode "ksh-mode" "\ -ksh-mode $Revision: 1.3 $ - Major mode for editing (Bourne, Korn or Bourne again) +ksh-mode $Revision: 1.4 $ - Major mode for editing (Bourne, Korn or Bourne again) shell scripts. Special key bindings and commands: \\{ksh-mode-map} @@ -4780,7 +4868,7 @@ (autoload 'vhdl-mode "vhdl-mode" "\ Major mode for editing VHDL code. -vhdl-mode $Revision: 1.3 $ +vhdl-mode $Revision: 1.4 $ To submit a problem report, enter `\\[vhdl-submit-bug-report]' from a vhdl-mode buffer. This automatically sets up a mail buffer with version information already added. You just need to add a description of the @@ -6839,13 +6927,14 @@ ;;;*** -;;;### (autoloads (ps-despool ps-spool-region-with-faces ps-spool-region ps-spool-buffer-with-faces ps-spool-buffer ps-print-region-with-faces ps-print-region ps-print-buffer-with-faces ps-print-buffer) "ps-print" "packages/ps-print.el") - -(defvar ps-paper-type 'ps-letter "\ -*Specifies the size of paper to format for. Should be one of -`ps-letter', `ps-legal', or `ps-a4'.") - -(defvar ps-print-color-p (and (or (fboundp 'x-color-values) (fboundp 'color-instance-rgb-components)) (fboundp 'float)) "\ +;;;### (autoloads (ps-setup ps-nb-pages-region ps-nb-pages-buffer ps-line-lengths ps-despool ps-spool-region-with-faces ps-spool-region ps-spool-buffer-with-faces ps-spool-buffer ps-print-region-with-faces ps-print-region ps-print-buffer-with-faces ps-print-buffer) "ps-print" "packages/ps-print.el") + +(defvar ps-paper-type 'letter "\ +*Specifies the size of paper to format for. +Should be one of the paper types defined in `ps-page-dimensions-database', for +example `letter', `legal' or `a4'.") + +(defvar ps-print-color-p (or (fboundp 'x-color-values) (fboundp 'color-instance-rgb-components)) "\ *If non-nil, print the buffer's text in color.") (autoload 'ps-print-buffer "ps-print" "\ @@ -6917,6 +7006,25 @@ the PostScript image in a file with that name. If FILENAME is a number, prompt the user for the name of the file to save in." t nil) +(autoload 'ps-line-lengths "ps-print" "\ +*Display the correspondence between a line length and a font size, +using the current ps-print setup. +Try: pr -t file | awk '{printf \"%3d %s +\", length($0), $0}' | sort -r | head" t nil) + +(autoload 'ps-nb-pages-buffer "ps-print" "\ +*Display an approximate correspondence between a font size and the number +of pages the current buffer would require to print +using the current ps-print setup." t nil) + +(autoload 'ps-nb-pages-region "ps-print" "\ +*Display an approximate correspondence between a font size and the number +of pages the current region would require to print +using the current ps-print setup." t nil) + +(autoload 'ps-setup "ps-print" "\ +*Return the current setup" nil nil) + ;;;*** ;;;### (autoloads (remote-compile) "rcompile" "packages/rcompile.el") @@ -8195,12 +8303,15 @@ --[[text/plain]] This is also a plain text. But, it is explicitly specified as is. - --[[text/plain; charset=ISO-2022-JP]] - ...Japanese text here.... - --[[text/richtext]] -

This is a richtext.
- --[[image/gif][base64]]^M...image encoded in base64 here... - --[[audio/basic][base64]]^M...audio encoded in base64 here... + --[[text/plain; charset=ISO-8859-1]] + This is also a plain text. But charset is specified as + iso-8859-1. + + ¡Hola! Buenos días. ¿Cómo está usted? + --[[text/enriched]] + This is a enriched text. + --[[image/gif][base64]]...image encoded in base64 here... + --[[audio/basic][base64]]...audio encoded in base64 here... User customizable variables (not documented all of them): mime-prefix @@ -9070,6 +9181,12 @@ ;;;*** +;;;### (autoloads nil "timezone" "utils/timezone.el") + +(define-error 'invalid-date "Invalid date string") + +;;;*** + ;;;### (autoloads (tq-create) "tq" "utils/tq.el") (autoload 'tq-create "tq" "\ @@ -9324,13 +9441,8 @@ (autoload 'w3-fetch "w3" "\ Retrieve a document over the World Wide Web. -The World Wide Web is a global hypertext system started by CERN in -Switzerland in 1991. - -The document should be specified by its fully specified -Uniform Resource Locator. The document will be parsed, printed, or -passed to an external viewer as appropriate. Variable -`mm-mime-info' specifies viewers for particular file types." t nil) +Defaults to URL of the current document, if any. +With prefix argument, use the URL of the hyperlink under point instead." t nil) (autoload 'w3-maybe-follow-link-mouse "w3" "\ Maybe follow a hypertext link under point. diff -r ad457d5f7d04 -r 0293115a14e9 lisp/prim/buffer.el --- a/lisp/prim/buffer.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/prim/buffer.el Mon Aug 13 08:49:20 2007 +0200 @@ -16,8 +16,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Synched up with: FSF 19.30 buffer.c. diff -r ad457d5f7d04 -r 0293115a14e9 lisp/prim/case-table.el --- a/lisp/prim/case-table.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/prim/case-table.el Mon Aug 13 08:49:20 2007 +0200 @@ -16,8 +16,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Synched up with: Not synched with FSF. diff -r ad457d5f7d04 -r 0293115a14e9 lisp/prim/cmdloop.el --- a/lisp/prim/cmdloop.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/prim/cmdloop.el Mon Aug 13 08:49:20 2007 +0200 @@ -15,8 +15,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Synched up with: FSF 19.30. (Some of the stuff below is in FSF's subr.el.) diff -r ad457d5f7d04 -r 0293115a14e9 lisp/prim/cmdloop1.el --- a/lisp/prim/cmdloop1.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/prim/cmdloop1.el Mon Aug 13 08:49:20 2007 +0200 @@ -14,8 +14,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Synched up with: Not in FSF. diff -r ad457d5f7d04 -r 0293115a14e9 lisp/prim/console.el --- a/lisp/prim/console.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/prim/console.el Mon Aug 13 08:49:20 2007 +0200 @@ -18,8 +18,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Synched up with: Not in FSF. diff -r ad457d5f7d04 -r 0293115a14e9 lisp/prim/device.el --- a/lisp/prim/device.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/prim/device.el Mon Aug 13 08:49:20 2007 +0200 @@ -18,8 +18,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Synched up with: Not in FSF. diff -r ad457d5f7d04 -r 0293115a14e9 lisp/prim/dialog.el --- a/lisp/prim/dialog.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/prim/dialog.el Mon Aug 13 08:49:20 2007 +0200 @@ -14,8 +14,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Synched up with: Not in FSF. diff -r ad457d5f7d04 -r 0293115a14e9 lisp/prim/disp-table.el --- a/lisp/prim/disp-table.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/prim/disp-table.el Mon Aug 13 08:49:20 2007 +0200 @@ -20,8 +20,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Synched up with: Not synched with FSF. diff -r ad457d5f7d04 -r 0293115a14e9 lisp/prim/events.el --- a/lisp/prim/events.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/prim/events.el Mon Aug 13 08:49:20 2007 +0200 @@ -18,8 +18,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Synched up with: Not in FSF. diff -r ad457d5f7d04 -r 0293115a14e9 lisp/prim/extents.el --- a/lisp/prim/extents.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/prim/extents.el Mon Aug 13 08:49:20 2007 +0200 @@ -17,8 +17,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Synched up with: Not in FSF. diff -r ad457d5f7d04 -r 0293115a14e9 lisp/prim/faces.el --- a/lisp/prim/faces.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/prim/faces.el Mon Aug 13 08:49:20 2007 +0200 @@ -31,8 +31,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Synched up with: Not synched with FSF. Almost completely divergent. ;;; Some stuff in FSF's faces.el is in our x-faces.el. diff -r ad457d5f7d04 -r 0293115a14e9 lisp/prim/files.el --- a/lisp/prim/files.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/prim/files.el Mon Aug 13 08:49:20 2007 +0200 @@ -769,40 +769,41 @@ directory where the file was found. If you *do not* want that, add the logical name to this list as a string.") -;(defun find-buffer-visiting (filename) -; "Return the buffer visiting file FILENAME (a string). -;This is like `get-file-buffer', except that it checks for any buffer -;visiting the same file, possibly under a different name. -;If there is no such live buffer, return nil." -; (let ((buf (get-file-buffer filename)) -; (truename (abbreviate-file-name (file-truename filename)))) -; (or buf -; (let ((list (buffer-list)) found) -; (while (and (not found) list) -; (save-excursion -; (set-buffer (car list)) -; (if (and buffer-file-name -; (string= buffer-file-truename truename)) -; (setq found (car list)))) -; (setq list (cdr list))) -; found) -; (let ((number (nthcdr 10 (file-attributes truename))) -; (list (buffer-list)) found) -; (and buffer-file-numbers-unique -; number -; (while (and (not found) list) -; (save-excursion -; (set-buffer (car list)) -; (if (and buffer-file-name -; (equal buffer-file-number number) -; ;; Verify this buffer's file number -; ;; still belongs to its file. -; (file-exists-p buffer-file-name) -; (equal (nthcdr 10 (file-attributes buffer-file-name)) -; number)) -; (setq found (car list)))) -; (setq list (cdr list)))) -; found)))) +;; XEmacs -- why was this commented out?? -- Hrv +(defun find-buffer-visiting (filename) + "Return the buffer visiting file FILENAME (a string). +This is like `get-file-buffer', except that it checks for any buffer +visiting the same file, possibly under a different name. +If there is no such live buffer, return nil." + (let ((buf (get-file-buffer filename)) + (truename (abbreviate-file-name (file-truename filename)))) + (or buf + (let ((list (buffer-list)) found) + (while (and (not found) list) + (save-excursion + (set-buffer (car list)) + (if (and buffer-file-name + (string= buffer-file-truename truename)) + (setq found (car list)))) + (setq list (cdr list))) + found) + (let ((number (nthcdr 10 (file-attributes truename))) + (list (buffer-list)) found) + (and buffer-file-numbers-unique + number + (while (and (not found) list) + (save-excursion + (set-buffer (car list)) + (if (and buffer-file-name + (equal buffer-file-number number) + ;; Verify this buffer's file number + ;; still belongs to its file. + (file-exists-p buffer-file-name) + (equal (nthcdr 10 (file-attributes buffer-file-name)) + number)) + (setq found (car list)))) + (setq list (cdr list)))) + found)))) (defun insert-file-contents-literally (filename &optional visit beg end replace) "Like `insert-file-contents', q.v., but only reads in the file. @@ -1053,19 +1054,21 @@ ("\\.ltx\\'" . latex-mode) ("\\.el\\'" . emacs-lisp-mode) ("\\.l\\(i?sp\\)?\\'" . lisp-mode) - ("\\.f\\(or\\)?\\'" . fortran-mode) + ("\\.[Ff]\\(or\\)?\\'" . fortran-mode) ("\\.p\\(as\\)?\\'" . pascal-mode) ("\\.ad[abs]\\'" . ada-mode) ("\\.pl\\'" . perl-mode) + ("\\.pm\\'" . perl-mode) ("\\.\\([CH]\\|cc\\|hh\\)\\'" . c++-mode) ("\\.[ch]\\(pp\\|xx\\|\\+\\+\\)\\'" . c++-mode) ("\\.java\\'" . java-mode) ("\\.ma?k\\'" . makefile-mode) - ("[Mm]akefile\\(.in\\)?\\(.in\\)?\\'" . makefile-mode) + ("\\(M\\|m\\|GNUm\\)akefile\\(.in\\)?\\(.in\\)?\\'" . makefile-mode) ;;; Less common extensions come here ;;; so more common ones above are found faster. ("\\.texi\\(nfo\\)?\\'" . texinfo-mode) - ("\\.s\\'" . asm-mode) + ("\\.[Ss]\\'" . asm-mode) + ("\\.asm\\'" . asm-mode) ("[Cc]hange.?[Ll]og?\\(.[0-9]+\\)?\\'" . change-log-mode) ("\\$CHANGE_LOG\\$\\.TXT" . change-log-mode) ("\\.scm\\(\\.[0-9]*\\)?\\'" . scheme-mode) @@ -1090,10 +1093,12 @@ ("\\.\\(tcl\\|exp\\)\\'" . tcl-mode) ("\\.wrl\\'" . vrml-mode) ("\\.f90\\'" . f90-mode) + ("\\.lsp\\'" . lisp-mode) ("\\.awk\\'" . awk-mode) ("\\.prolog\\'" . prolog-mode) ("\\.tar\\'" . tar-mode) ("\\.\\(arc\\|zip\\|lzh\\|zoo\\)\\'" . archive-mode) + ("\\.\\(ARC\\|ZIP\\|LZH\\|ZOO\\)\\'" . archive-mode) ;; Mailer puts message to be edited in ;; /tmp/Re.... or Message ("^/tmp/Re" . text-mode) @@ -1128,15 +1133,18 @@ (defconst interpreter-mode-alist (mapcar 'purecopy - '(("^#!.*[acjkwz]sh" . sh-mode) + '(("^#!.*[acjkwz]sh" . sh-mode) ("^#!.*sh\\b" . sh-mode) - ("^#!.*\\b\\(scope\\|wish\\|tcl\\|expect\\)" . tcl-mode) - ("perl" . perl-mode) + ("^#!.*\\b\\(scope\\|wishx?\\|tcl\\|tclsh\\|expect\\)" . tcl-mode) ("python" . python-mode) - ("awk\\b" . awk-mode) + ("[mng]?awk\\b" . awk-mode) ("rexx" . rexx-mode) ("scm" . scheme-mode) ("^:" . sh-mode) + ("tail" . text-mode) + ("more" . text-mode) + ("less" . text-mode) + ("pg" . text-mode) )) "Alist mapping interpreter names to major modes. This alist is used to guess the major mode of a file based on the @@ -1250,7 +1258,7 @@ ;; Parse the -*- line into the `result' alist. (cond ((not (search-forward "-*-" end t)) ;; doesn't have one. - nil) + (setq force t)) ((looking-at "[ \t]*\\([^ \t\n\r:;]+\\)\\([ \t]*-\\*-\\)") ;; Antiquated form: "-*- ModeName -*-". (setq result @@ -1286,21 +1294,22 @@ (skip-chars-forward " \t;"))) (setq result (nreverse result)))))) - (let ((set-any-p (or force (hack-local-variables-p t))) - (mode-p nil)) - (while result - (let ((key (car (car result))) - (val (cdr (car result)))) - (cond ((eq key 'mode) - (setq mode-p t) - (funcall (intern (concat (downcase (symbol-name val)) - "-mode")))) - (set-any-p - (hack-one-local-variable key val)) - (t - nil))) - (setq result (cdr result))) - mode-p))) + (if result + (let ((set-any-p (or force (hack-local-variables-p t))) + (mode-p nil)) + (while result + (let ((key (car (car result))) + (val (cdr (car result)))) + (cond ((eq key 'mode) + (setq mode-p t) + (funcall (intern (concat (downcase (symbol-name val)) + "-mode")))) + (set-any-p + (hack-one-local-variable key val)) + (t + nil))) + (setq result (cdr result))) + mode-p)))) (defvar hack-local-variables-hook nil "Normal hook run after processing a file's local variables specs. diff -r ad457d5f7d04 -r 0293115a14e9 lisp/prim/frame.el --- a/lisp/prim/frame.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/prim/frame.el Mon Aug 13 08:49:20 2007 +0200 @@ -19,8 +19,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Synched up with: FSF 19.30. diff -r ad457d5f7d04 -r 0293115a14e9 lisp/prim/glyphs.el --- a/lisp/prim/glyphs.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/prim/glyphs.el Mon Aug 13 08:49:20 2007 +0200 @@ -20,8 +20,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Synched up with: Not in FSF. diff -r ad457d5f7d04 -r 0293115a14e9 lisp/prim/gui.el --- a/lisp/prim/gui.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/prim/gui.el Mon Aug 13 08:49:20 2007 +0200 @@ -14,8 +14,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. (defvar dialog-frame-plist '(width 60 height 20) "Plist of frame properties for initially creating a dialog frame. diff -r ad457d5f7d04 -r 0293115a14e9 lisp/prim/help.el --- a/lisp/prim/help.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/prim/help.el Mon Aug 13 08:49:20 2007 +0200 @@ -17,8 +17,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Synched up with: FSF 19.30. diff -r ad457d5f7d04 -r 0293115a14e9 lisp/prim/inc-vers.el --- a/lisp/prim/inc-vers.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/prim/inc-vers.el Mon Aug 13 08:49:20 2007 +0200 @@ -18,8 +18,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Synched up with: Not in FSF. diff -r ad457d5f7d04 -r 0293115a14e9 lisp/prim/isearch-mode.el --- a/lisp/prim/isearch-mode.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/prim/isearch-mode.el Mon Aug 13 08:49:20 2007 +0200 @@ -18,8 +18,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Synched up with: Not synched with FSF. diff -r ad457d5f7d04 -r 0293115a14e9 lisp/prim/itimer.el --- a/lisp/prim/itimer.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/prim/itimer.el Mon Aug 13 08:49:20 2007 +0200 @@ -16,8 +16,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Synched up with: Not in FSF. diff -r ad457d5f7d04 -r 0293115a14e9 lisp/prim/keydefs.el --- a/lisp/prim/keydefs.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/prim/keydefs.el Mon Aug 13 08:49:20 2007 +0200 @@ -14,8 +14,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;; All the global bindings should be here so that one can reload things ;; like files.el without trashing one's personal bindings. diff -r ad457d5f7d04 -r 0293115a14e9 lisp/prim/keymap.el --- a/lisp/prim/keymap.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/prim/keymap.el Mon Aug 13 08:49:20 2007 +0200 @@ -15,8 +15,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Synched up with: FSF 19.28. ;;; Note: FSF does not have a file keymap.el. This stuff is diff -r ad457d5f7d04 -r 0293115a14e9 lisp/prim/loadup-el.el --- a/lisp/prim/loadup-el.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/prim/loadup-el.el Mon Aug 13 08:49:20 2007 +0200 @@ -11,8 +11,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Synched up with: Not in FSF. diff -r ad457d5f7d04 -r 0293115a14e9 lisp/prim/macros.el --- a/lisp/prim/macros.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/prim/macros.el Mon Aug 13 08:49:20 2007 +0200 @@ -18,8 +18,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Synched up with: FSF 19.30. diff -r ad457d5f7d04 -r 0293115a14e9 lisp/prim/menubar.el --- a/lisp/prim/menubar.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/prim/menubar.el Mon Aug 13 08:49:20 2007 +0200 @@ -16,8 +16,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Synched up with: Not in FSF. (Completely divergent from FSF menu-bar.el) ;;; Some stuff in FSF menu-bar.el is in x-menubar.el diff -r ad457d5f7d04 -r 0293115a14e9 lisp/prim/mode-motion.el --- a/lisp/prim/mode-motion.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/prim/mode-motion.el Mon Aug 13 08:49:20 2007 +0200 @@ -14,8 +14,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Synched up with: Not in FSF. diff -r ad457d5f7d04 -r 0293115a14e9 lisp/prim/modeline.el --- a/lisp/prim/modeline.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/prim/modeline.el Mon Aug 13 08:49:20 2007 +0200 @@ -16,8 +16,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Synched up with: Not in FSF. diff -r ad457d5f7d04 -r 0293115a14e9 lisp/prim/mouse.el --- a/lisp/prim/mouse.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/prim/mouse.el Mon Aug 13 08:49:20 2007 +0200 @@ -18,8 +18,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Synched up with: Not synched with FSF. Almost completely divergent. diff -r ad457d5f7d04 -r 0293115a14e9 lisp/prim/objects.el --- a/lisp/prim/objects.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/prim/objects.el Mon Aug 13 08:49:20 2007 +0200 @@ -20,8 +20,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Synched up with: Not in FSF. diff -r ad457d5f7d04 -r 0293115a14e9 lisp/prim/obsolete.el --- a/lisp/prim/obsolete.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/prim/obsolete.el Mon Aug 13 08:49:20 2007 +0200 @@ -20,8 +20,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; The obsoleteness support used to be scattered throughout various ;;; source files. We put the stuff in one place to remove the junkiness diff -r ad457d5f7d04 -r 0293115a14e9 lisp/prim/process.el --- a/lisp/prim/process.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/prim/process.el Mon Aug 13 08:49:20 2007 +0200 @@ -16,8 +16,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Synched up with: FSF 19.30. diff -r ad457d5f7d04 -r 0293115a14e9 lisp/prim/profile.el --- a/lisp/prim/profile.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/prim/profile.el Mon Aug 13 08:49:20 2007 +0200 @@ -15,8 +15,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Synched up with: Not in FSF. diff -r ad457d5f7d04 -r 0293115a14e9 lisp/prim/scrollbar.el --- a/lisp/prim/scrollbar.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/prim/scrollbar.el Mon Aug 13 08:49:20 2007 +0200 @@ -14,8 +14,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Synched up with: Not in FSF. (Completely divergent from FSF scroll-bar.el) diff -r ad457d5f7d04 -r 0293115a14e9 lisp/prim/sound.el --- a/lisp/prim/sound.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/prim/sound.el Mon Aug 13 08:49:20 2007 +0200 @@ -16,8 +16,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Synched up with: Not in FSF. diff -r ad457d5f7d04 -r 0293115a14e9 lisp/prim/specifier.el --- a/lisp/prim/specifier.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/prim/specifier.el Mon Aug 13 08:49:20 2007 +0200 @@ -20,8 +20,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Synched up with: Not in FSF. diff -r ad457d5f7d04 -r 0293115a14e9 lisp/prim/startup.el --- a/lisp/prim/startup.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/prim/startup.el Mon Aug 13 08:49:20 2007 +0200 @@ -20,8 +20,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Synched up with: FSF 19.28. diff -r ad457d5f7d04 -r 0293115a14e9 lisp/prim/symbols.el --- a/lisp/prim/symbols.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/prim/symbols.el Mon Aug 13 08:49:20 2007 +0200 @@ -15,8 +15,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Synched up with: Not in FSF. diff -r ad457d5f7d04 -r 0293115a14e9 lisp/prim/syntax.el --- a/lisp/prim/syntax.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/prim/syntax.el Mon Aug 13 08:49:20 2007 +0200 @@ -14,8 +14,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Synched up with: FSF 19.28. ;;; Note: FSF does not have a file syntax.el. This stuff is diff -r ad457d5f7d04 -r 0293115a14e9 lisp/prim/toolbar.el --- a/lisp/prim/toolbar.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/prim/toolbar.el Mon Aug 13 08:49:20 2007 +0200 @@ -14,8 +14,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Synched up with: Not in FSF. diff -r ad457d5f7d04 -r 0293115a14e9 lisp/prim/undo-stack.el --- a/lisp/prim/undo-stack.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/prim/undo-stack.el Mon Aug 13 08:49:20 2007 +0200 @@ -16,8 +16,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Synched up with: Not in FSF. diff -r ad457d5f7d04 -r 0293115a14e9 lisp/prim/update-elc.el --- a/lisp/prim/update-elc.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/prim/update-elc.el Mon Aug 13 08:49:20 2007 +0200 @@ -11,8 +11,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Synched up with: Not in FSF. diff -r ad457d5f7d04 -r 0293115a14e9 lisp/prim/window.el --- a/lisp/prim/window.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/prim/window.el Mon Aug 13 08:49:20 2007 +0200 @@ -17,8 +17,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Synched up with: FSF 19.30. @@ -293,23 +294,25 @@ ; 'menu-bar-lines params) 0))) (unwind-protect - (progn - (select-window (or window w)) + (let ((shrinkee (or window w))) + (set-buffer (window-buffer shrinkee)) (goto-char (point-min)) (while (pos-visible-in-window-p (- (point-max) - (if ignore-final-newline 1 0))) + (if ignore-final-newline 1 0)) + shrinkee) ;; defeat file locking... don't try this at home, kids! (setq buffer-file-name nil) (insert ?\n) (setq n (1+ n))) (if (> n 0) (shrink-window (min (1- n) - (- (window-height) - window-min-height))))) + (- (window-height shrinkee) + window-min-height)) + nil + shrinkee))) (delete-region (point-min) (point)) (set-buffer-modified-p modified) (goto-char p) - (select-window w) ;; Make sure we unbind buffer-read-only ;; with the proper current buffer. (set-buffer buffer)))))) diff -r ad457d5f7d04 -r 0293115a14e9 lisp/psgml/psgml-html.el --- a/lisp/psgml/psgml-html.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/psgml/psgml-html.el Mon Aug 13 08:49:20 2007 +0200 @@ -17,8 +17,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Synched up with: FSF 19.30. @@ -30,9 +31,13 @@ ;;; Code: +(defvar html-auto-sgml-entity-conversion nil + "*Control automatic sgml entity to ISO-8859-1 conversion") + (require 'psgml) (require 'derived) -(require 'iso-sgml) +(when html-auto-sgml-entity-conversion + (require 'iso-sgml)) (require 'tempo) ;essential part of html-helper-mode ;;{{{ user variables @@ -198,6 +203,14 @@ (set (make-local-variable 'sgml-custom-markup) '(("" "\r"))) + + ;; Set up the syntax table. + (modify-syntax-entry ?< "(>" html-mode-syntax-table) + (modify-syntax-entry ?> ")<" html-mode-syntax-table) + (modify-syntax-entry ?\" ". " html-mode-syntax-table) + (modify-syntax-entry ?\\ ". " html-mode-syntax-table) + (modify-syntax-entry ?' "w " html-mode-syntax-table) + ; sigh ... need to call this now to get things working. (sgml-build-custom-menus) (add-submenu nil sgml-html-menu "SGML") diff -r ad457d5f7d04 -r 0293115a14e9 lisp/psgml/psgml-lfix.el diff -r ad457d5f7d04 -r 0293115a14e9 lisp/psgml/psgml.el --- a/lisp/psgml/psgml.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/psgml/psgml.el Mon Aug 13 08:49:20 2007 +0200 @@ -1,5 +1,5 @@ ;;; psgml.el --- SGML-editing mode with parsing support -;; $Id: psgml.el,v 1.2 1997/01/04 21:20:08 steve Exp $ +;; $Id: psgml.el,v 1.3 1997/02/02 05:06:12 steve Exp $ ;; Copyright (C) 1993, 1994, 1995, 1996 Lennart Staflin ;; Copyright (C) 1992 Free Software Foundation, Inc. @@ -72,19 +72,6 @@ "Abbrev table in use in sgml-mode.") (define-abbrev-table 'sgml-mode-abbrev-table ()) -;;; Wing addition -(defvar sgml-mode-syntax-table nil - "Syntax table used in sgml mode.") - -(if sgml-mode-syntax-table - () - (setq sgml-mode-syntax-table (make-syntax-table)) - (modify-syntax-entry ?< "(>" sgml-mode-syntax-table) - (modify-syntax-entry ?> ")<" sgml-mode-syntax-table) - (modify-syntax-entry ?\" ". " sgml-mode-syntax-table) - (modify-syntax-entry ?\\ ". " sgml-mode-syntax-table) - (modify-syntax-entry ?' "w " sgml-mode-syntax-table)) - (defvar sgml-running-xemacs (not (not (string-match "Lucid\\|XEmacs" emacs-version)))) @@ -455,7 +442,9 @@ ;;; Its error messages can be parsed by next-error. ;;; The -s option suppresses output. -(defvar sgml-validate-command "nsgmls -s %s %s" +(defvar sgml-validate-command (concat "nsgmls -s -m " + sgml-data-directory + "/CATALOG %s %s") "*The shell command to validate an SGML document. This is a `format' control string that by default should contain two diff -r ad457d5f7d04 -r 0293115a14e9 lisp/rmail/rmailedit.el --- a/lisp/rmail/rmailedit.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/rmail/rmailedit.el Mon Aug 13 08:49:20 2007 +0200 @@ -18,8 +18,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Code: diff -r ad457d5f7d04 -r 0293115a14e9 lisp/rmail/rmailkwd.el --- a/lisp/rmail/rmailkwd.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/rmail/rmailkwd.el Mon Aug 13 08:49:20 2007 +0200 @@ -18,8 +18,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Code: diff -r ad457d5f7d04 -r 0293115a14e9 lisp/rmail/rmailmsc.el --- a/lisp/rmail/rmailmsc.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/rmail/rmailmsc.el Mon Aug 13 08:49:20 2007 +0200 @@ -18,8 +18,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Code: diff -r ad457d5f7d04 -r 0293115a14e9 lisp/rmail/rmailout.el --- a/lisp/rmail/rmailout.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/rmail/rmailout.el Mon Aug 13 08:49:20 2007 +0200 @@ -18,8 +18,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Code: @@ -61,12 +62,14 @@ ;; If not suggestions, use same file as last time. (or answer rmail-last-rmail-file)))) (list (setq rmail-last-rmail-file - (read-file-name - (concat "Output message to Rmail file: (default " - (file-name-nondirectory default-file) - ") ") - (file-name-directory default-file) - default-file)) + (if default-file + (read-file-name + (concat "Output message to Rmail file: (default " + (file-name-nondirectory default-file) + ") ") + (file-name-directory default-file) + default-file) + (read-file-name "Output message to Rmail file: "))) (prefix-numeric-value current-prefix-arg)))) (or count (setq count 1)) (setq file-name diff -r ad457d5f7d04 -r 0293115a14e9 lisp/rmail/rmailsort.el --- a/lisp/rmail/rmailsort.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/rmail/rmailsort.el Mon Aug 13 08:49:20 2007 +0200 @@ -19,8 +19,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Code: diff -r ad457d5f7d04 -r 0293115a14e9 lisp/rmail/rmailsum.el --- a/lisp/rmail/rmailsum.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/rmail/rmailsum.el Mon Aug 13 08:49:20 2007 +0200 @@ -18,8 +18,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Commentary: diff -r ad457d5f7d04 -r 0293115a14e9 lisp/rmail/undigest.el --- a/lisp/rmail/undigest.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/rmail/undigest.el Mon Aug 13 08:49:20 2007 +0200 @@ -18,8 +18,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Synched up with: FSF 19.30. diff -r ad457d5f7d04 -r 0293115a14e9 lisp/rmail/unrmail.el --- a/lisp/rmail/unrmail.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/rmail/unrmail.el Mon Aug 13 08:49:20 2007 +0200 @@ -17,8 +17,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Code: diff -r ad457d5f7d04 -r 0293115a14e9 lisp/term/linux.el --- a/lisp/term/linux.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/term/linux.el Mon Aug 13 08:49:20 2007 +0200 @@ -17,8 +17,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;;; Code: diff -r ad457d5f7d04 -r 0293115a14e9 lisp/term/vt100-led.el --- a/lisp/term/vt100-led.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/term/vt100-led.el Mon Aug 13 08:49:20 2007 +0200 @@ -19,8 +19,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Code: diff -r ad457d5f7d04 -r 0293115a14e9 lisp/term/xterm.el --- a/lisp/term/xterm.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/term/xterm.el Mon Aug 13 08:49:20 2007 +0200 @@ -17,8 +17,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;;; Code: diff -r ad457d5f7d04 -r 0293115a14e9 lisp/tl/emu-e19.el --- a/lisp/tl/emu-e19.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/tl/emu-e19.el Mon Aug 13 08:49:20 2007 +0200 @@ -1,9 +1,9 @@ ;;; emu-e19.el --- emu module for Emacs 19 and XEmacs 19 -;; Copyright (C) 1995,1996 Free Software Foundation, Inc. +;; Copyright (C) 1995,1996,1997 Free Software Foundation, Inc. ;; Author: MORIOKA Tomohiko -;; Version: $Id: emu-e19.el,v 1.2 1996/12/29 00:15:08 steve Exp $ +;; Version: $Id: emu-e19.el,v 1.3 1997/02/02 05:06:16 steve Exp $ ;; Keywords: emulation, compatibility, mule, Latin-1 ;; This file is part of emu. @@ -135,6 +135,11 @@ (,@ body) ))) +(defmacro as-binary-output-file (&rest body) + (` (let ((emx-binary-mode t)) ; Stop CRLF to LF conversion in OS/2 + (,@ body) + ))) + ;;; @@ for old MULE emulation ;;; diff -r ad457d5f7d04 -r 0293115a14e9 lisp/tl/emu-x20.el --- a/lisp/tl/emu-x20.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/tl/emu-x20.el Mon Aug 13 08:49:20 2007 +0200 @@ -4,7 +4,7 @@ ;; Copyright (C) 1994,1995,1996 MORIOKA Tomohiko ;; Author: MORIOKA Tomohiko -;; Version: $Id: emu-x20.el,v 1.2 1996/12/22 00:29:30 steve Exp $ +;; Version: $Id: emu-x20.el,v 1.3 1997/02/02 05:06:17 steve Exp $ ;; Keywords: emulation, compatibility, Mule, XEmacs ;; This file is part of tl (Tiny Library). @@ -170,24 +170,24 @@ ;;; @ character ;;; -(defun char-bytes (chr) 1) +;(defun char-bytes (chr) 1) -(defun char-length (character) - "Return number of elements a CHARACTER occupies in a string or buffer. -\[emu-x20.el]" - 1) +;(defun char-length (character) +; "Return number of elements a CHARACTER occupies in a string or buffer. +;\[emu-x20.el]" +; 1) -(defun char-columns (character) - "Return number of columns a CHARACTER occupies when displayed. -\[emu-x20.el]" - (charset-columns (char-charset character)) - ) +;(defun char-columns (character) +; "Return number of columns a CHARACTER occupies when displayed. +;\[emu-x20.el]" +; (charset-columns (char-charset character)) +; ) ;;; @@ Mule emulating aliases ;;; ;;; You should not use them. -(defalias 'char-width 'char-columns) +;(defalias 'char-width 'char-columns) (defalias 'char-leading-char 'char-charset) @@ -206,34 +206,34 @@ ;;; @ string ;;; -(defun string-columns (string) - "Return number of columns STRING occupies when displayed. -\[emu-x20.el]" - (let ((col 0) - (len (length string)) - (i 0)) - (while (< i len) - (setq col (+ col (char-columns (aref string i)))) - (setq i (1+ i)) - ) - col)) +;(defun string-columns (string) +; "Return number of columns STRING occupies when displayed. +;\[emu-x20.el]" +; (let ((col 0) +; (len (length string)) +; (i 0)) +; (while (< i len) +; (setq col (+ col (char-columns (aref string i)))) +; (setq i (1+ i)) +; ) +; col)) -(defalias 'string-width 'string-columns) +;(defalias 'string-width 'string-columns) (defun string-to-int-list (str) (mapcar #'char-int str) ) -(defalias 'sref 'aref) +;(defalias 'sref 'aref) -(defun truncate-string (str width &optional start-column) - "Truncate STR to fit in WIDTH columns. -Optional non-nil arg START-COLUMN specifies the starting column. -\[emu-x20.el; Mule 2.3 emulating function]" - (or start-column - (setq start-column 0)) - (substring str start-column width) - ) +;(defun truncate-string (str width &optional start-column) +; "Truncate STR to fit in WIDTH columns. +;Optional non-nil arg START-COLUMN specifies the starting column. +;\[emu-x20.el; Mule 2.3 emulating function]" +; (or start-column +; (setq start-column 0)) +; (substring str start-column width) +; ) ;;; @ end diff -r ad457d5f7d04 -r 0293115a14e9 lisp/tl/file-detect.el --- a/lisp/tl/file-detect.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/tl/file-detect.el Mon Aug 13 08:49:20 2007 +0200 @@ -1,10 +1,10 @@ ;;; file-detect.el --- Emacs Lisp file detection utility -;; Copyright (C) 1996 Free Software Foundation, Inc. +;; Copyright (C) 1996,1997 Free Software Foundation, Inc. ;; Author: MORIOKA Tomohiko ;; Version: -;; $Id: file-detect.el,v 1.3 1996/12/29 00:15:09 steve Exp $ +;; $Id: file-detect.el,v 1.4 1997/02/02 05:06:17 steve Exp $ ;; Keywords: install, module ;; This file is part of tl (Tiny Library). @@ -65,6 +65,18 @@ )) ))) +(defun add-latest-path (pattern &optional all-paths) + "Add latest path matched by PATTERN to `load-path' +if it exists under `default-load-path' directories +and it does not exist in `load-path'. + +If optional argument ALL-PATHS is specified, it is searched from all +of load-path instead of default-load-path. [file-detect.el]" + (let ((path (get-latest-path pattern all-paths))) + (if path + (add-to-list 'load-path path) + ))) + (defun get-latest-path (pat &optional all-paths) "Return latest directory in default-load-path which is matched to regexp PAT. diff -r ad457d5f7d04 -r 0293115a14e9 lisp/tl/richtext.el --- a/lisp/tl/richtext.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/tl/richtext.el Mon Aug 13 08:49:20 2007 +0200 @@ -1,10 +1,10 @@ ;;; richtext.el -- read and save files in text/richtext format -;; Copyright (C) 1995,1996 Free Software Foundation, Inc. +;; Copyright (C) 1995,1996,1997 Free Software Foundation, Inc. ;; Author: MORIOKA Tomohiko ;; Created: 1995/7/15 -;; Version: $Id: richtext.el,v 1.2 1996/12/22 00:29:31 steve Exp $ +;; Version: $Id: richtext.el,v 1.3 1997/02/02 05:06:17 steve Exp $ ;; Keywords: wp, faces, MIME, multimedia ;; This file is not part of GNU Emacs yet. @@ -164,11 +164,8 @@ 'richtext-next-annotation) ;; Fill paragraphs - (if (or (and file-width ; possible reasons not to fill: - (= file-width (enriched-text-width))) ; correct wd. - (null enriched-fill-after-visiting) ; never fill - (and (eq 'ask enriched-fill-after-visiting) ; asked & declined - (not (y-or-n-p "Re-fill for current display width? ")))) + (if (and file-width ; possible reasons not to fill: + (= file-width (enriched-text-width))) ; correct wd. ;; Minimally, we have to insert indentation and justification. (enriched-insert-indentation) (if enriched-verbose (message "Filling paragraphs...")) diff -r ad457d5f7d04 -r 0293115a14e9 lisp/tl/tl-str.el --- a/lisp/tl/tl-str.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/tl/tl-str.el Mon Aug 13 08:49:20 2007 +0200 @@ -1,10 +1,9 @@ ;;; tl-str.el --- Emacs Lisp Library module about string -;; Copyright (C) 1995,1996 Free Software Foundation, Inc. +;; Copyright (C) 1995,1996,1997 Free Software Foundation, Inc. ;; Author: MORIOKA Tomohiko -;; Version: -;; $Id: tl-str.el,v 1.2 1996/12/22 00:29:33 steve Exp $ +;; Version: $Id: tl-str.el,v 1.3 1997/02/02 05:06:17 steve Exp $ ;; Keywords: string ;; This file is part of tl (Tiny Library). @@ -206,7 +205,8 @@ (substring filename 0 (match-beginning 0)) filename)) -(autoload 'replace-as-filename "filename") +(autoload 'replace-as-filename "filename" + "Return safety filename from STRING.") ;;; @ symbol diff -r ad457d5f7d04 -r 0293115a14e9 lisp/tm/gnus-art-mime.el --- a/lisp/tm/gnus-art-mime.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/tm/gnus-art-mime.el Mon Aug 13 08:49:20 2007 +0200 @@ -1,11 +1,11 @@ ;;; gnus-art-mime.el --- MIME extension for article mode of Gnus -;; Copyright (C) 1995,1996 Free Software Foundation, Inc. +;; Copyright (C) 1995,1996,1997 Free Software Foundation, Inc. ;; Author: MORIOKA Tomohiko ;; Created: 1996/8/6 ;; Version: -;; $Id: gnus-art-mime.el,v 1.2 1996/12/22 00:29:34 steve Exp $ +;; $Id: gnus-art-mime.el,v 1.3 1997/02/02 05:06:18 steve Exp $ ;; Keywords: news, MIME, multimedia, multilingual, encoded-word ;; This file is not part of GNU Emacs yet. @@ -46,7 +46,7 @@ ;;; RFC 1522 and it does not do unfolding. So gnus-mime defines own ;;; function using tm-ew-d. -(defun gnus-decode-rfc1522 () +(defun gnus-decode-encoded-word () (goto-char (point-min)) (if (re-search-forward "^[0-9]+\t" nil t) (progn @@ -63,6 +63,10 @@ (mime-eword/decode-region (point-min)(point-max) t) )) +(defalias 'gnus-decode-rfc1522 'gnus-decode-encoded-word) + +;; In addition, latest RFC about encoded-word is RFC 2047. (^_^; + ;;; @ article filter ;;; diff -r ad457d5f7d04 -r 0293115a14e9 lisp/tm/gnus-mime.el --- a/lisp/tm/gnus-mime.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/tm/gnus-mime.el Mon Aug 13 08:49:20 2007 +0200 @@ -1,10 +1,10 @@ ;;; gnus-mime.el --- MIME extensions for Gnus -;; Copyright (C) 1996 Free Software Foundation, Inc. +;; Copyright (C) 1996,1997 Free Software Foundation, Inc. ;; Author: MORIOKA Tomohiko ;; Created: 1996/8/6 -;; Version: $Revision: 1.3 $ +;; Version: $Revision: 1.4 $ ;; Keywords: news, MIME, multimedia, multilingual, encoded-word ;; This file is not part of GNU Emacs yet. @@ -33,7 +33,7 @@ ;;; (defconst gnus-mime-RCS-ID - "$Id: gnus-mime.el,v 1.3 1996/12/29 00:15:12 steve Exp $") + "$Id: gnus-mime.el,v 1.4 1997/02/02 05:06:18 steve Exp $") (defconst gnus-mime-version (get-version-string gnus-mime-RCS-ID)) @@ -64,12 +64,6 @@ ;;; (require 'gnus) -(autoload 'gnus-decode-rfc1522 "gnus-art-mime") -(autoload 'gnus-article-preview-mime-message "gnus-art-mime") -(autoload 'gnus-article-decode-encoded-word "gnus-art-mime") -(autoload 'gnus-set-summary-default-charset "gnus-sum-mime") -;;(autoload 'gnus-get-newsgroup-headers "gnus-sum-mime") -;;(autoload 'gnus-get-newsgroup-headers-xover "gnus-sum-mime") (require 'gnus-charset) @@ -101,17 +95,16 @@ (provide 'gnus-mime) -(if gnus-is-red-gnus-or-later - (progn - (call-after-loaded 'gnus-art (lambda () - (require 'gnus-art-mime) - )) - (call-after-loaded 'gnus-sum (lambda () - (require 'gnus-sum-mime) - )) - ) - (require 'gnus-mime-old) - ) +(or gnus-is-red-gnus-or-later + (require 'gnus-mime-old) + ) + +(call-after-loaded 'gnus-art (lambda () + (require 'gnus-art-mime) + )) +(call-after-loaded 'gnus-sum (lambda () + (require 'gnus-sum-mime) + )) (run-hooks 'gnus-mime-load-hook) diff -r ad457d5f7d04 -r 0293115a14e9 lisp/tm/gnus-sum-mime.el --- a/lisp/tm/gnus-sum-mime.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/tm/gnus-sum-mime.el Mon Aug 13 08:49:20 2007 +0200 @@ -1,11 +1,11 @@ ;;; gnus-sum-mime.el --- MIME extension for summary mode of Gnus -;; Copyright (C) 1995,1996 Free Software Foundation, Inc. +;; Copyright (C) 1995,1996,1997 Free Software Foundation, Inc. ;; Author: MORIOKA Tomohiko ;; Created: 1996/8/6 ;; Version: -;; $Id: gnus-sum-mime.el,v 1.3 1996/12/29 00:15:12 steve Exp $ +;; $Id: gnus-sum-mime.el,v 1.4 1997/02/02 05:06:18 steve Exp $ ;; Keywords: news, MIME, multimedia, multilingual, encoded-word ;; This file is not part of GNU Emacs yet. @@ -21,14 +21,14 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with this program; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;; Boston, MA 02111-1307, USA. ;;; Code: (require 'gnus-mime) -(require 'gnus-art-mime) +(require 'gnus-sum) ;;; @ summary filter diff -r ad457d5f7d04 -r 0293115a14e9 lisp/tm/message-mime.el --- a/lisp/tm/message-mime.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/tm/message-mime.el Mon Aug 13 08:49:20 2007 +0200 @@ -5,7 +5,7 @@ ;; Author: MORIOKA Tomohiko ;; Created: 1996/8/6 ;; Version: -;; $Id: message-mime.el,v 1.3 1996/12/29 00:15:12 steve Exp $ +;; $Id: message-mime.el,v 1.4 1997/02/02 05:06:18 steve Exp $ ;; Keywords: news, MIME, multimedia, multilingual, encoded-word ;; This file is not part of GNU Emacs yet. @@ -43,6 +43,12 @@ (concat message-included-forward-headers "\\|^Content-Type:")) ) +(or (string-match message-included-forward-headers + "Content-Transfer-Encoding:") + (setq message-included-forward-headers + (concat message-included-forward-headers + "\\|^Content-Transfer-Encoding:")) + ) ;;; @ for tm-edit ;;; diff -r ad457d5f7d04 -r 0293115a14e9 lisp/tm/mime-setup.el --- a/lisp/tm/mime-setup.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/tm/mime-setup.el Mon Aug 13 08:49:20 2007 +0200 @@ -1,10 +1,10 @@ ;;; mime-setup.el --- setup file for tm viewer and composer. -;; Copyright (C) 1995,1996 Free Software Foundation, Inc. +;; Copyright (C) 1995,1996,1997 Free Software Foundation, Inc. ;; Author: MORIOKA Tomohiko ;; Version: -;; $Id: mime-setup.el,v 1.2 1996/12/29 00:15:12 steve Exp $ +;; $Id: mime-setup.el,v 1.3 1997/02/02 05:06:18 steve Exp $ ;; Keywords: mail, news, MIME, multimedia, multilingual, encoded-word ;; This file is part of tm (Tools for MIME). @@ -102,13 +102,18 @@ (add-hook 'mu-cite/pre-cite-hook 'mime/decode-message-header) -;;; @ for RMAIL and VM +;;; @ for mail-mode, RMAIL and VM ;;; (add-hook 'mail-setup-hook 'mime/decode-message-header) (add-hook 'mail-setup-hook 'mime/editor-mode 'append) (add-hook 'mail-send-hook 'mime-editor/maybe-translate) - +(set-alist 'mime-editor/split-message-sender-alist + 'mail-mode (function + (lambda () + (interactive) + (funcall send-mail-function) + ))) ;;; @ for mh-e ;;; diff -r ad457d5f7d04 -r 0293115a14e9 lisp/tm/tm-def.el --- a/lisp/tm/tm-def.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/tm/tm-def.el Mon Aug 13 08:49:20 2007 +0200 @@ -3,7 +3,7 @@ ;; Copyright (C) 1995,1996 Free Software Foundation, Inc. ;; Author: MORIOKA Tomohiko -;; Version: $Id: tm-def.el,v 1.3 1996/12/29 00:15:13 steve Exp $ +;; Version: $Id: tm-def.el,v 1.4 1997/02/02 05:06:19 steve Exp $ ;; Keywords: mail, news, MIME, multimedia, definition ;; This file is part of tm (Tools for MIME). @@ -111,6 +111,9 @@ (defvar tm:mouse-face 'highlight "Face used for MIME-preview buffer mouse highlighting. [tm-def.el]") +(defvar tm:warning-face nil + "Face used for invalid encoded-word.") + (defun tm:add-button (from to func &optional data) "Create a button between FROM and TO with callback FUNC and data DATA." (and tm:button-face @@ -183,7 +186,7 @@ ;;; @@ Base64 ;;; -(defconst base64-token-regexp "[A-Za-z0-9+/=]") +(defconst base64-token-regexp "[A-Za-z0-9+/]") (defconst base64-token-padding-regexp "[A-Za-z0-9+/=]") (defconst mime/B-encoded-text-regexp diff -r ad457d5f7d04 -r 0293115a14e9 lisp/tm/tm-edit.el --- a/lisp/tm/tm-edit.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/tm/tm-edit.el Mon Aug 13 08:49:20 2007 +0200 @@ -1,12 +1,12 @@ ;;; tm-edit.el --- Simple MIME Composer for GNU Emacs -;; Copyright (C) 1993 .. 1996 Free Software Foundation, Inc. +;; Copyright (C) 1993,1994,1995,1996,1997 Free Software Foundation, Inc. ;; Author: UMEDA Masanobu ;; MORIOKA Tomohiko ;; Maintainer: MORIOKA Tomohiko ;; Created: 1994/08/21 renamed from mime.el -;; Version: $Revision: 1.4 $ +;; Version: $Revision: 1.5 $ ;; Keywords: mail, news, MIME, multimedia, multilingual ;; This file is part of tm (Tools for MIME). @@ -41,8 +41,8 @@ ;; resulted in RFC 1468 (ISO-2022-JP charset for MIME). In order to ;; enable multilingual capability in single text message in MIME, ;; charset of multilingual text written in Mule is declared as either -;; `ISO-2022-JP-2' [RFC 1554] or `ISO-2022-INT-1'. Mule is required -;; for reading the such messages. +;; `ISO-2022-JP-2' [RFC 1554]. Mule is required for reading the such +;; messages. ;; This MIME composer can work with Mail mode, mh-e letter Mode, and ;; News mode. First of all, you need the following autoload @@ -94,11 +94,11 @@ ;; ;;--[[text/plain]] ;; This is also a plain text. But, it is explicitly specified as is. +;;--[[text/plain; charset=ISO-8859-1]] +;; This is also a plain text. But charset is specified as iso-8859-1. ;; -;;--[[text/plain; charset=ISO-2022-JP]] -;; $B$3$l$O(B charset $B$r(B ISO-2022-JP $B$K;XDj$7$?F|K\8l$N(B plain $B%F%-%9%H$G$9(B. -;; -;;--[[text/richtext]] +;; ¡Hola! Buenos días. ¿Cómo está usted? +;;--[[text/enriched]] ;;
This is a richtext.
;; ;;--[[image/gif][base64]]^M...image encoded in base64 comes here... @@ -120,7 +120,7 @@ ;;; (defconst mime-editor/RCS-ID - "$Id: tm-edit.el,v 1.4 1997/01/04 21:20:11 steve Exp $") + "$Id: tm-edit.el,v 1.5 1997/02/02 05:06:19 steve Exp $") (defconst mime-editor/version (get-version-string mime-editor/RCS-ID)) @@ -741,12 +741,15 @@ --[[text/plain]] This is also a plain text. But, it is explicitly specified as is. - --[[text/plain; charset=ISO-2022-JP]] - ...Japanese text here.... - --[[text/richtext]] -
This is a richtext.
- --[[image/gif][base64]]^M...image encoded in base64 here... - --[[audio/basic][base64]]^M...audio encoded in base64 here... + --[[text/plain; charset=ISO-8859-1]] + This is also a plain text. But charset is specified as + iso-8859-1. + + ¡Hola! Buenos días. ¿Cómo está usted? + --[[text/enriched]] + This is a enriched text. + --[[image/gif][base64]]...image encoded in base64 here... + --[[audio/basic][base64]]...audio encoded in base64 here... User customizable variables (not documented all of them): mime-prefix @@ -850,7 +853,8 @@ ;; Restore previous state. (setq mime/editor-mode-flag nil) (cond (running-xemacs - (delete-menu-item (list mime-editor/menu-title))) + (if (featurep 'menubar) + (delete-menu-item (list mime-editor/menu-title)))) (t (use-local-map mime/editor-mode-old-local-map))) diff -r ad457d5f7d04 -r 0293115a14e9 lisp/tm/tm-ew-d.el --- a/lisp/tm/tm-ew-d.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/tm/tm-ew-d.el Mon Aug 13 08:49:20 2007 +0200 @@ -1,6 +1,6 @@ ;;; tm-ew-d.el --- RFC 2047 based encoded-word decoder for GNU Emacs -;; Copyright (C) 1995,1996 Free Software Foundation, Inc. +;; Copyright (C) 1995,1996,1997 Free Software Foundation, Inc. ;; Author: ENAMI Tsugutomo ;; MORIOKA Tomohiko @@ -9,7 +9,7 @@ ;; Original: 1992/07/20 ENAMI Tsugutomo's `mime.el'. ;; Renamed: 1993/06/03 to tiny-mime.el. ;; Renamed: 1995/10/03 from tiny-mime.el. (split off encoder) -;; Version: $Revision: 1.3 $ +;; Version: $Revision: 1.4 $ ;; Keywords: encoded-word, MIME, multilingual, header, mail, news ;; This file is part of tm (Tools for MIME). @@ -42,7 +42,7 @@ ;;; (defconst tm-ew-d/RCS-ID - "$Id: tm-ew-d.el,v 1.3 1997/01/11 22:10:18 steve Exp $") + "$Id: tm-ew-d.el,v 1.4 1997/02/02 05:06:19 steve Exp $") (defconst mime/eword-decoder-version (get-version-string tm-ew-d/RCS-ID)) @@ -123,10 +123,13 @@ (mime/unfolding) ) (goto-char (point-min)) - (while (re-search-forward "\\?=\\(\n*\\s +\\)+=\\?" nil t) - (replace-match "?==?") + (while (re-search-forward (concat "\\(" mime/encoded-word-regexp "\\)" + "\\(\n?[ \t]\\)+" + "\\(" mime/encoded-word-regexp "\\)") + nil t) + (replace-match "\\1\\6") + (goto-char (point-min)) ) - (goto-char (point-min)) (let (charset encoding text) (while (re-search-forward mime/encoded-word-regexp nil t) (insert (mime/decode-encoded-word @@ -195,8 +198,13 @@ )) (condition-case err (mime/decode-encoded-text charset encoding text must-unfold) - (error nil)) - )) + (error + (and (tl:add-text-properties 0 (length word) + (and tm:warning-face + (list 'face tm:warning-face)) + word) + word))) + )) word)) @@ -217,24 +225,31 @@ (let ((cs (mime-charset-to-coding-system charset))) (if cs (let ((dest - (cond ((and (string-equal "B" encoding) - (string-match mime/B-encoded-text-regexp string)) - (base64-decode-string string)) - ((and (string-equal "Q" encoding) - (string-match mime/Q-encoded-text-regexp string)) - (q-encoding-decode-string string)) - (t (message "Invalid encoded-word %s" encoding) - nil)))) + (cond + ((string-equal "B" encoding) + (if (and (string-match mime/B-encoded-text-regexp string) + (string-equal string (match-string 0 string))) + (base64-decode-string string) + (error "Invalid encoded-text %s" string))) + ((string-equal "Q" encoding) + (if (and (string-match mime/Q-encoded-text-regexp string) + (string-equal string (match-string 0 string))) + (q-encoding-decode-string string) + (error "Invalid encoded-text %s" string))) + (t + (error "Invalid encoding %s" encoding) + ))) + ) (if dest (progn (setq dest (decode-coding-string dest cs)) (if must-unfold (mapconcat (function (lambda (chr) - (if (eq chr ?\n) - "" - (char-to-string chr) - ) + (cond + ((eq chr ?\n) "") + ((eq chr ?\t) " ") + (t (char-to-string chr))) )) (std11-unfold-string dest) "") diff -r ad457d5f7d04 -r 0293115a14e9 lisp/tm/tm-pgp.el --- a/lisp/tm/tm-pgp.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/tm/tm-pgp.el Mon Aug 13 08:49:20 2007 +0200 @@ -1,11 +1,10 @@ ;;; tm-pgp.el --- tm-view internal methods for PGP. -;; Copyright (C) 1995,1996 Free Software Foundation, Inc. +;; Copyright (C) 1995,1996,1997 MORIOKA Tomohiko ;; Author: MORIOKA Tomohiko -;; Maintainer: MORIOKA Tomohiko ;; Created: 1995/12/7 -;; Version: $Id: tm-pgp.el,v 1.3 1996/12/29 00:15:14 steve Exp $ +;; Version: $Id: tm-pgp.el,v 1.4 1997/02/02 05:06:20 steve Exp $ ;; Keywords: mail, news, MIME, multimedia, PGP, security ;; This file is part of tm (Tools for MIME). @@ -29,22 +28,37 @@ ;; This module is based on 2 drafts about PGP MIME integration: -;; - draft-elkins-pem-pgp-04.txt -;; ``MIME Security with Pretty Good Privacy (PGP)'' +;; - RFC 2015: "MIME Security with Pretty Good Privacy (PGP)" ;; by Michael Elkins (1996/6) ;; -;; - draft-kazu-pgp-mime-00.txt -;; ``PGP MIME Integration'' -;; by Kazuhiko Yamamoto (1995/10) +;; - draft-kazu-pgp-mime-00.txt: "PGP MIME Integration" +;; by Kazuhiko Yamamoto +;; (1995/10; expired) ;; -;; These drafts may be contrary to each other. You should decide -;; which you support. +;; These drafts may be contrary to each other. You should decide +;; which you support. (Maybe you should use PGP/MIME) ;;; Code: -(require 'mailcrypt) (require 'tm-play) +(defvar pgp-verify-function + 'mc-verify "*PGP verify function.") + +(defvar pgp-decrypt-function + 'mc-decrypt "*PGP decrypt function.") + +(defvar pgp-fetch-key-function + 'mc-pgp-fetch-key "*PGP fetch key function.") + +(defvar pgp-snarf-keys-function + 'mc-snarf-keys "*PGP snarf keys function.") + +(autoload pgp-verify-function "mc-toplev") +(autoload pgp-decrypt-function "mc-toplev") +(autoload pgp-fetch-key-function "mc-toplev") +(autoload pgp-snarf-keys-function "mc-toplev") + ;;; @ internal method for application/pgp ;;; @@ -56,8 +70,9 @@ (new-name (format "%s-%s" (buffer-name) cnum)) (mother mime::article/preview-buffer) (mode major-mode) - code-converter str) - (setq str (buffer-substring beg end)) + code-converter + (str (buffer-substring beg end)) + ) (switch-to-buffer new-name) (erase-buffer) (insert str) @@ -65,7 +80,7 @@ (goto-char (point-min)) (re-search-forward "^-+BEGIN PGP SIGNED MESSAGE-+$" nil t) ) - (mc-verify) + (funcall pgp-verify-function) (goto-char (point-min)) (delete-region (point-min) @@ -91,7 +106,7 @@ (goto-char (point-min)) (re-search-forward "^-+BEGIN PGP MESSAGE-+$" nil t) ) - (as-binary-process (mc-decrypt)) + (as-binary-process (funcall pgp-decrypt-function)) (goto-char (point-min)) (delete-region (point-min) (and @@ -117,7 +132,7 @@ ;;; @ Internal method for application/pgp-signature ;;; -;;; It is based on draft-elkins-pem-pgp-02.txt +;;; It is based on RFC 2015. (defvar tm-pgp::default-language 'en "*Symbol of language for pgp. @@ -186,15 +201,7 @@ (while (re-search-forward "\n" nil t) (replace-match "\r\n") ) - (let ((mc-flag nil) ; for Mule - (file-coding-system *noconv*) - kanji-flag ; for NEmacs - (emx-binary-mode t) ; for OS/2 - jka-compr-compression-info-list ; for jka-compr - jam-zcat-filename-list ; for jam-zcat - require-final-newline) - (write-file orig-file) - ) + (as-binary-output-file (write-file orig-file)) (kill-buffer (current-buffer)) ) (save-excursion @@ -210,16 +217,7 @@ (set-buffer (setq kbuf (get-buffer-create mime/temp-buffer-name))) (insert str) (mime-decode-region (point-min)(point-max) encoding) - (let ((mc-flag nil) ; for Mule - (file-coding-system *noconv*) - kanji-flag ; for NEmacs - (emx-binary-mode t) ; for OS/2 - jka-compr-compression-info-list ; for jka-compr - jam-zcat-filename-list ; for jam-zcat - require-final-newline) - (write-file sig-file) - ) - ;;(get-buffer-create mime/output-buffer-name) + (as-binary-output-file (write-file sig-file)) (or (mime::article/call-pgp-to-check-signature mime/output-buffer-name orig-file) (let (pgp-id) @@ -243,7 +241,7 @@ (format "Key %s not found; attempt to fetch? " pgp-id)) ) (progn - (mc-pgp-fetch-key (cons nil pgp-id)) + (funcall pgp-fetch-key-function (cons nil pgp-id)) (mime::article/call-pgp-to-check-signature mime/output-buffer-name orig-file) )) @@ -264,7 +262,7 @@ ;;; @ Internal method for application/pgp-encrypted ;;; -;;; It is based on draft-elkins-pem-pgp-02.txt +;;; It is based on RFC 2015. (defun mime-article/decrypt-pgp (beg end cal) (let* ((cnum (mime-article/point-content-number beg)) @@ -290,9 +288,7 @@ ;;; @ Internal method for application/pgp-keys ;;; -;;; It is based on draft-elkins-pem-pgp-02.txt - -(autoload 'mc-snarf-keys "mc-toplev") +;;; It is based on RFC 2015. (defun mime-article/add-pgp-keys (beg end cal) (let* ((cnum (mime-article/point-content-number beg)) @@ -313,7 +309,7 @@ (delete-region (point-min) (match-end 0)) ) (mime-decode-region (point-min)(point-max) encoding) - (mc-snarf-keys) + (funcall pgp-snarf-keys-function) (kill-buffer (current-buffer)) )) diff -r ad457d5f7d04 -r 0293115a14e9 lisp/tm/tm-setup.el --- a/lisp/tm/tm-setup.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/tm/tm-setup.el Mon Aug 13 08:49:20 2007 +0200 @@ -1,9 +1,9 @@ ;;; tm-setup.el --- setup file for tm viewer. -;; Copyright (C) 1994,1995,1996 Free Software Foundation, Inc. +;; Copyright (C) 1994,1995,1996,1997 Free Software Foundation, Inc. ;; Author: MORIOKA Tomohiko -;; Version: $Id: tm-setup.el,v 1.2 1996/12/22 00:29:42 steve Exp $ +;; Version: $Id: tm-setup.el,v 1.3 1997/02/02 05:06:20 steve Exp $ ;; Keywords: mail, news, MIME, multimedia, multilingual, encoded-word ;; This file is part of tm (Tools for MIME). @@ -63,8 +63,16 @@ (autoload 'mime/decode-text/latex "tm-latex") ))) + ;; for image/* and X-Face -(if running-xemacs +(defvar mime-setup-enable-inline-image + (and window-system + (or running-xemacs + (and (featurep 'mule)(module-installed-p 'bitmap)) + )) + "*If it is non-nil, tm-setup sets up to use tm-image.") + +(if mime-setup-enable-inline-image (call-after-loaded 'tm-view (function (lambda () @@ -72,8 +80,13 @@ ))) ) + +(defvar mime-setup-enable-pgp + (module-installed-p 'mailcrypt) + "*If it is non-nil, tm-setup sets uf to use tm-pgp.") + ;; for PGP -(if (module-installed-p 'mailcrypt) +(if mime-setup-enable-pgp (call-after-loaded 'tm-view (function (lambda () diff -r ad457d5f7d04 -r 0293115a14e9 lisp/tm/tm-view.el --- a/lisp/tm/tm-view.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/tm/tm-view.el Mon Aug 13 08:49:20 2007 +0200 @@ -1,10 +1,10 @@ ;;; tm-view.el --- interactive MIME viewer for GNU Emacs -;; Copyright (C) 1995,1996 Free Software Foundation, Inc. +;; Copyright (C) 1995,1996,1997 Free Software Foundation, Inc. ;; Author: MORIOKA Tomohiko ;; Created: 1994/7/13 (1994/8/31 obsolete tm-body.el) -;; Version: $Revision: 1.2 $ +;; Version: $Revision: 1.3 $ ;; Keywords: mail, news, MIME, multimedia ;; This file is part of tm (Tools for MIME). @@ -42,7 +42,7 @@ ;;; (defconst mime-viewer/RCS-ID - "$Id: tm-view.el,v 1.2 1996/12/22 00:29:43 steve Exp $") + "$Id: tm-view.el,v 1.3 1997/02/02 05:06:20 steve Exp $") (defconst mime-viewer/version (get-version-string mime-viewer/RCS-ID)) (defconst mime/viewer-version mime-viewer/version) @@ -741,6 +741,10 @@ (define-key mime/viewer-mode-map "n" (function mime-viewer/next-content)) (define-key mime/viewer-mode-map + "\e\t" (function mime-viewer/previous-content)) + (define-key mime/viewer-mode-map + "\t" (function mime-viewer/next-content)) + (define-key mime/viewer-mode-map " " (function mime-viewer/scroll-up-content)) (define-key mime/viewer-mode-map "\M- " (function mime-viewer/scroll-down-content)) @@ -753,7 +757,7 @@ (define-key mime/viewer-mode-map "v" (function mime-viewer/play-content)) (define-key mime/viewer-mode-map - "e" (function mime-viewer/extract-content)) + "e" (function mime-viewer/extract-content)) (define-key mime/viewer-mode-map "\C-c\C-p" (function mime-viewer/print-content)) (define-key mime/viewer-mode-map @@ -808,11 +812,10 @@ --- ------- u Move to upper content -p Move to previous content -n Move to next content +p or M-TAB Move to previous content +n or TAB Move to next content SPC Scroll up or move to next content -M-SPC Scroll down or move to previous content -DEL Scroll down or move to previous content +M-SPC or DEL Scroll down or move to previous content RET Move to next line M-RET Move to previous line v Decode current content as `play mode' diff -r ad457d5f7d04 -r 0293115a14e9 lisp/tm/tm-vm.el --- a/lisp/tm/tm-vm.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/tm/tm-vm.el Mon Aug 13 08:49:20 2007 +0200 @@ -9,7 +9,7 @@ ;; Oscar Figueiredo ;; Maintainer: Oscar Figueiredo ;; Created: 1994/10/29 -;; Version: $Revision: 1.2 $ +;; Version: $Revision: 1.3 $ ;; Keywords: mail, MIME, multimedia, multilingual, encoded-word ;; This file is part of tm (Tools for MIME). @@ -42,24 +42,202 @@ (require 'vm-window)) (require 'tm-view) +(require 'vm-menu) + + +;;; @ Variables + +;;; @@ User customization variables + +(defvar tm-vm/use-vm-bindings t + "*If t, use VM compatible keybindings in MIME Preview buffers. +Otherwise TM generic bindings for content extraction/playing are +made available.") + +(defvar tm-vm/attach-to-popup-menus t + "*If t append MIME specific commands to VM's popup menus.") + +(defvar tm-vm/use-original-url-button nil + "*If it is t, use original URL button instead of tm's.") + +(defvar tm-vm/automatic-mime-preview t + "*If non-nil, automatically process and show MIME messages.") + +(defvar tm-vm/strict-mime t + "*If nil, do MIME processing even if there is no MIME-Version field.") + +(defvar tm-vm/use-ps-print (not (featurep 'mule)) + "*Use Postscript printing (ps-print) to print MIME messages.") + +(defvar tm-vm-load-hook nil + "*List of functions called after tm-vm is loaded.") + +(defvar tm-vm/select-message-hook nil + "*List of functions called every time a message is selected. +tm-vm uses `vm-select-message-hook', use tm-vm/select-message-hook instead. +When the hooks are run current buffer is either VM folder buffer with +the current message delimited by (point-min) and (point-max) or the MIME +Preview buffer.") + +(defvar tm-vm/forward-message-hook vm-forward-message-hook + "*List of functions called after a Mail mode buffer has been +created to forward a message in message/rfc822 type format. +If `vm-forwarding-digest-type' is \"rfc1521\", tm-vm runs this +hook instead of `vm-forward-message-hook'.") + +(defvar tm-vm/send-digest-hook nil + "*List of functions called after a Mail mode buffer has been +created to send a digest in multipart/digest type format. +If `vm-digest-send-type' is \"rfc1521\", tm-vm runs this hook +instead of `vm-send-digest-hook'.") + + +;;; @@ System/Information variables (defconst tm-vm/RCS-ID - "$Id: tm-vm.el,v 1.2 1996/12/22 00:29:43 steve Exp $") + "$Id: tm-vm.el,v 1.3 1997/02/02 05:06:20 steve Exp $") (defconst tm-vm/version (get-version-string tm-vm/RCS-ID)) +(defvar tm-vm/vm-emulation-map + (let ((map (make-sparse-keymap))) + (define-key map "h" 'vm-summarize) + ;(define-key map "\M-n" 'vm-next-unread-message) + ;(define-key map "\M-p" 'vm-previous-unread-message) + (define-key map "n" 'vm-next-message) + (define-key map "p" 'vm-previous-message) + (define-key map "N" 'vm-next-message-no-skip) + (define-key map "P" 'vm-previous-message-no-skip) + ;(define-key map "\C-\M-n" 'vm-move-message-forward) + ;(define-key map "\C-\M-p" 'vm-move-message-backward) + ;(define-key map "\t" 'vm-goto-message-last-seen) + ;(define-key map "\r" 'vm-goto-message) + ;(define-key map "^" 'vm-goto-parent-message) + (define-key map "t" 'vm-expose-hidden-headers) + (define-key map " " 'vm-scroll-forward) + (define-key map "b" 'vm-scroll-backward) + (define-key map "\C-?" 'vm-scroll-backward) + ;(define-key map "d" 'vm-delete-message) + ;(define-key map "\C-d" 'vm-delete-message-backward) + ;(define-key map "u" 'vm-undelete-message) + ;(define-key map "U" 'vm-unread-message) + ;(define-key map "e" 'vm-edit-message) + ;(define-key map "a" 'vm-set-message-attributes) + ;(define-key map "j" 'vm-discard-cached-data) + ;(define-key map "k" 'vm-kill-subject) + (define-key map "f" 'vm-followup) + (define-key map "F" 'vm-followup-include-text) + (define-key map "r" 'vm-reply) + (define-key map "R" 'vm-reply-include-text) + (define-key map "\M-r" 'vm-resend-bounced-message) + (define-key map "B" 'vm-resend-message) + (define-key map "z" 'vm-forward-message) + ;(define-key map "c" 'vm-continue-composing-message) + (define-key map "@" 'vm-send-digest) + ;(define-key map "*" 'vm-burst-digest) + (define-key map "m" 'vm-mail) + (define-key map "g" 'vm-get-new-mail) + ;(define-key map "G" 'vm-sort-messages) + (define-key map "v" 'vm-visit-folder) + ;(define-key map "s" 'vm-save-message) + ;(define-key map "w" 'vm-save-message-sans-headers) + ;(define-key map "A" 'vm-auto-archive-messages) + ;(define-key map "S" 'vm-save-folder) + ;(define-key map "|" 'vm-pipe-message-to-command) + ;(define-key map "#" 'vm-expunge-folder) + (define-key map "q" 'vm-quit) + (define-key map "x" 'vm-quit-no-change) + (define-key map "i" 'vm-iconify-frame) + (define-key map "?" 'vm-help) + (define-key map "\C-_" 'vm-undo) + (define-key map "\C-xu" 'vm-undo) + (define-key map "!" 'shell-command) + (define-key map "<" 'vm-beginning-of-message) + (define-key map ">" 'vm-end-of-message) + ;(define-key map "\M-s" 'vm-isearch-forward) + (define-key map "=" 'vm-summarize) + ;(define-key map "L" 'vm-load-init-file) + ;(define-key map "l" (make-sparse-keymap)) + ;(define-key map "la" 'vm-add-message-labels) + ;(define-key map "ld" 'vm-delete-message-labels) + ;(define-key map "V" (make-sparse-keymap)) + ;(define-key map "VV" 'vm-visit-virtual-folder) + ;(define-key map "VC" 'vm-create-virtual-folder) + ;(define-key map "VA" 'vm-apply-virtual-folder) + ;(define-key map "VM" 'vm-toggle-virtual-mirror) + ;(define-key map "V?" 'vm-virtual-help) + ;(define-key map "M" (make-sparse-keymap)) + ;(define-key map "MN" 'vm-next-command-uses-marks) + ;(define-key map "Mn" 'vm-next-command-uses-marks) + ;(define-key map "MM" 'vm-mark-message) + ;(define-key map "MU" 'vm-unmark-message) + ;(define-key map "Mm" 'vm-mark-all-messages) + ;(define-key map "Mu" 'vm-clear-all-marks) + ;(define-key map "MC" 'vm-mark-matching-messages) + ;(define-key map "Mc" 'vm-unmark-matching-messages) + ;(define-key map "MT" 'vm-mark-thread-subtree) + ;(define-key map "Mt" 'vm-unmark-thread-subtree) + ;(define-key map "MS" 'vm-mark-messages-same-subject) + ;(define-key map "Ms" 'vm-unmark-messages-same-subject) + ;(define-key map "MA" 'vm-mark-messages-same-author) + ;(define-key map "Ma" 'vm-unmark-messages-same-author) + ;(define-key map "M?" 'vm-mark-help) + ;(define-key map "W" (make-sparse-keymap)) + ;(define-key map "WW" 'vm-apply-window-configuration) + ;(define-key map "WS" 'vm-save-window-configuration) + ;(define-key map "WD" 'vm-delete-window-configuration) + ;(define-key map "W?" 'vm-window-help) + ;(define-key map "\C-t" 'vm-toggle-threads-display) + ;(define-key map "\C-x\C-s" 'vm-save-buffer) + ;(define-key map "\C-x\C-w" 'vm-write-file) + ;(define-key map "\C-x\C-q" 'vm-toggle-read-only) + ;(define-key map "%" 'vm-change-folder-type) + ;(define-key map "\M-C" 'vm-show-copying-restrictions) + ;(define-key map "\M-W" 'vm-show-no-warranty) + ;; suppress-keymap provides these, but now that we don't use + ;; suppress-keymap anymore... + (define-key map "0" 'digit-argument) + (define-key map "1" 'digit-argument) + (define-key map "2" 'digit-argument) + (define-key map "3" 'digit-argument) + (define-key map "4" 'digit-argument) + (define-key map "5" 'digit-argument) + (define-key map "6" 'digit-argument) + (define-key map "7" 'digit-argument) + (define-key map "8" 'digit-argument) + (define-key map "9" 'digit-argument) + (define-key map "-" 'negative-argument) + (if mouse-button-2 + (define-key map mouse-button-2 (function tm:button-dispatcher))) + (if (vm-menu-fsfemacs-menus-p) + (progn + (vm-menu-initialize-vm-mode-menu-map) + (define-key map [menu-bar] + (lookup-key vm-mode-menu-map [rootmenu vm])))) + map) + "VM emulation keymap for MIME-Preview buffers.") + +(defvar tm-vm/popup-menu + (let (fsfmenu + (dummy (make-sparse-keymap)) + (menu (append vm-menu-dispose-menu + (list "----" + (cons mime-viewer/menu-title + (mapcar (function + (lambda (item) + (vector (nth 1 item)(nth 2 item) t))) + mime-viewer/menu-list)))))) + (if running-xemacs + menu + (vm-easy-menu-define fsfmenu (list dummy) nil menu) + fsfmenu)) + "VM's popup menu + MIME specific commands") + (define-key vm-mode-map "Z" 'tm-vm/view-message) (define-key vm-mode-map "T" 'tm-vm/decode-message-header) (define-key vm-mode-map "\et" 'tm-vm/toggle-preview-mode) -(defvar tm-vm/use-original-url-button nil - "*If it is t, use original URL button instead of tm's.") -(defvar tm-vm-load-hook nil - "*List of functions called after tm-vm is loaded.") - - -;;; @ for MIME encoded-words -;;; +;;; @ MIME encoded-words (defvar tm-vm/use-tm-patch nil "Does not decode encoded-words in summary buffer if it is t. @@ -156,30 +334,9 @@ (vm-preview-current-message) (setq vbufs (cdr vbufs)))))) - -;;; @ automatic MIME preview -;;; - -(defvar tm-vm/automatic-mime-preview t - "*If non-nil, automatically process and show MIME messages.") - -(defvar tm-vm/strict-mime t - "*If nil, do MIME processing even if there is no MIME-Version field.") - -(defvar tm-vm/select-message-hook nil - "*List of functions called every time a message is selected. -tm-vm uses `vm-select-message-hook', use this hook instead.") - -(defvar tm-vm/system-state nil) - -(setq mime-viewer/content-header-filter-alist - (append '((vm-mode . tm-vm/header-filter) - (vm-virtual-mode . tm-vm/header-filter)) - mime-viewer/content-header-filter-alist)) - (defun tm-vm/header-filter () - "Filter headers in current buffer (assumed to be a message-like buffer) -according to vm-visible-headers and vm-invisible-header-regexp" + "Filter headers in current buffer according to vm-visible-headers and vm-invisible-header-regexp. +Current buffer is assumed to have a message-like structure." (goto-char (point-min)) (let ((visible-headers vm-visible-headers)) (if (or vm-use-lucid-highlighting @@ -190,6 +347,19 @@ vm-invisible-header-regexp) (mime/decode-message-header))) +(setq mime-viewer/content-header-filter-alist + (append '((vm-mode . tm-vm/header-filter) + (vm-virtual-mode . tm-vm/header-filter)) + mime-viewer/content-header-filter-alist)) + + + +;;; @ MIME Viewer + +;;; @@ MIME-Preview buffer management + +(defvar tm-vm/system-state nil) + (defun tm-vm/system-state () (save-excursion (if mime::preview/article-buffer @@ -197,51 +367,136 @@ (vm-select-folder-buffer)) tm-vm/system-state)) +(defun tm-vm/build-preview-buffer () + "Build the MIME Preview buffer for the current VM message. +Current buffer should be VM's folder buffer." + + (set (make-local-variable 'tm-vm/system-state) 'mime-viewing) + (setq vm-system-state 'reading) + + ;; Update message flags and store them in folder buffer before + ;; entering MIME viewer + (tm-vm/update-message-status) + + ;; We need to save window configuration because we may be working + ;; in summary window + (save-window-excursion + (save-restriction + (save-excursion + (widen) + (goto-char (vm-start-of (car vm-message-pointer))) + (forward-line) + (narrow-to-region (point) + (vm-end-of (car vm-message-pointer))) + + (let ((ml vm-message-list)) + (mime/viewer-mode nil nil nil nil nil nil) + (setq vm-mail-buffer mime::preview/article-buffer) + (setq vm-message-list ml)) + ;; Install VM toolbar for MIME-Preview buffer if not installed + (tm-vm/check-for-toolbar) + (if tm-vm/use-vm-bindings + (progn + (define-key tm-vm/vm-emulation-map "\C-c" (current-local-map)) + (use-local-map tm-vm/vm-emulation-map) + (vm-menu-install-menubar) + (if (and vm-use-menus + (vm-menu-support-possible-p)) + (setq mode-popup-menu tm-vm/popup-menu)))) + + ;; Highlight message (and display XFace if supported) + (if (or vm-highlighted-header-regexp + (and (vm-xemacs-p) vm-use-lucid-highlighting)) + (vm-highlight-headers)) + ;; Energize URLs and buttons + (if (and tm-vm/use-original-url-button + vm-use-menus (vm-menu-support-possible-p)) + (progn + (vm-energize-urls) + (vm-energize-headers))))))) + (defun tm-vm/sync-preview-buffer () - "Ensure that the MIME preview buffer, if it exists actually corresponds to -the current message. If no MIME Preview buffer is needed, delete it. If no + "Ensure that the MIME preview buffer, if it exists, actually corresponds to the current message. +If no MIME Preview buffer is needed then kill it. If no MIME Preview buffer exists nothing is done." ;; Current buffer should be message buffer when calling this function (let* ((mbuf (current-buffer)) (pbuf (and mime::article/preview-buffer - (get-buffer mime::article/preview-buffer))) - (win (or (and pbuf (vm-get-buffer-window pbuf)) - (vm-get-buffer-window mbuf))) - (frame (selected-frame))) + (get-buffer mime::article/preview-buffer)))) (if pbuf - ;; Go to the frame where pbuf or mbuf is (frame-per-composition t) - (save-excursion - (if win - (vm-select-frame (vm-window-frame win))) - ;; Rebuild MIME Preview buffer to ensure it corresponds to - ;; current message - (save-window-excursion - (save-selected-window - (save-excursion - (set-buffer mbuf) - (setq mime::article/preview-buffer nil) - (if pbuf (kill-buffer pbuf))) - (tm-vm/view-message))) + ;; A MIME Preview buffer exists then it may need to be synch'ed + (save-excursion + (set-buffer mbuf) + (if (and tm-vm/strict-mime + (not (vm-get-header-contents (car vm-message-pointer) + "MIME-Version:"))) + (progn + (setq mime::article/preview-buffer nil + tm-vm/system-state nil) + (if pbuf (kill-buffer pbuf))) + (tm-vm/build-preview-buffer))) ;; Return to previous frame - (vm-select-frame frame))))) + ))) + +(defun tm-vm/toggle-preview-mode () + "Toggle automatic MIME preview on or off. +In automatic MIME Preview mode each newly selected article is MIME processed if +it has MIME content without need for an explicit request from the user. This +behaviour is controlled by the variable tm-vm/automatic-mime-preview." + + (interactive) + (if tm-vm/automatic-mime-preview + (progn + (tm-vm/quit-view-message) + (setq tm-vm/automatic-mime-preview nil) + (message "Automatic MIME Preview is now disabled.")) + ;; Enable Automatic MIME Preview + (tm-vm/view-message) + (setq tm-vm/automatic-mime-preview t) + (message "Automatic MIME Preview is now enabled.") + )) + +;;; @@ Display functions + +(defun tm-vm/update-message-status () + "Update current message display and summary. +Remove 'unread' and 'new' flags. The MIME Preview buffer is not displayed, +tm-vm/display-preview-buffer should be called for that. This function is +display-configuration safe." + (if mime::preview/article-buffer + (set-buffer mime::preview/article-buffer) + (vm-select-folder-buffer)) + (if (or (and mime::article/preview-buffer + (get-buffer mime::article/preview-buffer) + (vm-get-visible-buffer-window mime::article/preview-buffer)) + (vm-get-visible-buffer-window (current-buffer))) + (progn + (if (vm-new-flag (car vm-message-pointer)) + (vm-set-new-flag (car vm-message-pointer) nil)) + (if (vm-unread-flag (car vm-message-pointer)) + (vm-set-unread-flag (car vm-message-pointer) nil)) + (vm-update-summary-and-mode-line) + (tm-vm/howl-if-eom)) + (vm-update-summary-and-mode-line))) (defun tm-vm/display-preview-buffer () + "Replace the VM message buffer with the MIME-Preview buffer if the VM message buffer is currently displayed or undisplay it if tm-vm/system-state is nil." (let* ((mbuf (current-buffer)) (mwin (vm-get-visible-buffer-window mbuf)) (pbuf (and mime::article/preview-buffer (get-buffer mime::article/preview-buffer))) (pwin (and pbuf (vm-get-visible-buffer-window pbuf)))) (if (and pbuf (tm-vm/system-state)) - ;; display preview buffer + ;; display preview buffer if preview-buffer exists (cond ((and mwin pwin) (vm-undisplay-buffer mbuf) - (tm-vm/show-current-message)) + (tm-vm/update-message-status)) ((and mwin (not pwin)) (set-window-buffer mwin pbuf) - (tm-vm/show-current-message)) + (tm-vm/update-message-status)) (pwin - (tm-vm/show-current-message)) + (tm-vm/update-message-status)) (t ;; don't display if neither mwin nor pwin was displayed before. )) @@ -257,477 +512,94 @@ (t ;; don't display if neither mwin nor pwin was displayed before. ))) - (set-buffer mbuf))) + (set-buffer mbuf))) (defun tm-vm/preview-current-message () - "Preview current message if it has MIME contents and -tm-vm/automatic-mime-preview is non nil. Installed on -vm-visit-folder-hook and vm-select-message-hook." + "Either preview message (view first lines only) or MIME-Preview it. +The message is previewed if message previewing is enabled see vm-preview-lines. +If not, MIME-Preview current message (ie. parse MIME +contents and display appropriately) if it has MIME contents and +tm-vm/automatic-mime-preview is non nil. Installed on vm-visit-folder-hook and +vm-select-message-hook." ;; assumed current buffer is folder buffer. (setq tm-vm/system-state nil) (if (get-buffer mime/output-buffer-name) (vm-undisplay-buffer mime/output-buffer-name)) - (if (and vm-message-pointer tm-vm/automatic-mime-preview) + (if (and vm-message-pointer + tm-vm/automatic-mime-preview + (or (null vm-preview-lines) + (not (eq vm-system-state 'previewing)) + (and (not vm-preview-read-messages) + (not (vm-new-flag (car vm-message-pointer))) + (not (vm-unread-flag (car vm-message-pointer)))))) (if (or (not tm-vm/strict-mime) (vm-get-header-contents (car vm-message-pointer) "MIME-Version:")) ;; do MIME processing. - (progn - ;; Consider message as shown => update its flags and store them - ;; in folder buffer before entering MIME viewer - (tm-vm/show-current-message) - (set (make-local-variable 'tm-vm/system-state) 'previewing) - (save-window-excursion - (vm-widen-page) - (goto-char (point-max)) - (widen) - (narrow-to-region (point) - (save-excursion - (goto-char - (vm-start-of (car vm-message-pointer)) - ) - (forward-line) - (point) - )) - - (mime/viewer-mode nil nil nil nil nil vm-mode-map) - ;; Highlight message (and display XFace if supported) - (if (or vm-highlighted-header-regexp - (and (vm-xemacs-p) vm-use-lucid-highlighting)) - (vm-highlight-headers)) - ;; Energize URLs and buttons - (if (and tm-vm/use-original-url-button - vm-use-menus (vm-menu-support-possible-p)) - (progn - (vm-energize-urls) - (vm-energize-headers))) - (goto-char (point-min)) - (narrow-to-region (point) (search-forward "\n\n" nil t)) - )) + (progn + (tm-vm/build-preview-buffer) + (save-excursion + (set-buffer mime::article/preview-buffer) + (run-hooks 'tm-vm/select-message-hook))) ;; don't do MIME processing. decode header only. (let (buffer-read-only) - (mime/decode-message-header)) + (mime/decode-message-header) + (run-hooks 'tm-vm/select-message-hook)) ) ;; don't preview; do nothing. - ) - (tm-vm/display-preview-buffer) - (run-hooks 'tm-vm/select-message-hook)) + (run-hooks 'tm-vm/select-message-hook)) + (tm-vm/display-preview-buffer)) + +(defun tm-vm/view-message () + "Decode and view the current VM message as a MIME encoded message. +A MIME Preview buffer using mime/viewer-mode is created. +See mime/viewer-mode for more information" + (interactive) + (vm-follow-summary-cursor) + (vm-select-folder-buffer) + (vm-check-for-killed-summary) + (vm-error-if-folder-empty) + (vm-display (current-buffer) t '(tm-vm/view-message + tm-vm/toggle-preview-mode) + '(tm-vm/view-message reading-message)) + (let ((tm-vm/automatic-mime-preview t)) + (tm-vm/preview-current-message)) +) -(defun tm-vm/show-current-message () - "Update current message display and summary. Remove 'unread' and 'new' flags. " - (if mime::preview/article-buffer - (set-buffer mime::preview/article-buffer) - (vm-select-folder-buffer)) - (if (and mime::article/preview-buffer - (get-buffer mime::article/preview-buffer)) - (save-excursion - (set-buffer mime::article/preview-buffer) - (goto-char (point-min)) - (widen))) - (if (or (and mime::article/preview-buffer - (get-buffer mime::article/preview-buffer) - (vm-get-visible-buffer-window mime::article/preview-buffer)) - (vm-get-visible-buffer-window (current-buffer))) - (progn - (setq tm-vm/system-state 'reading) - (if (vm-new-flag (car vm-message-pointer)) - (vm-set-new-flag (car vm-message-pointer) nil)) - (if (vm-unread-flag (car vm-message-pointer)) - (vm-set-unread-flag (car vm-message-pointer) nil)) - (vm-update-summary-and-mode-line) - (tm-vm/howl-if-eom)) - (vm-update-summary-and-mode-line))) - -(defun tm-vm/toggle-preview-mode () - "Toggle automatic MIME preview on or off. In automatic MIME Preview mode -each newly selected article is MIME processed if it has MIME content without -need for an explicit request from the user. This behaviour is controlled by the -variable tm-vm/automatic-mime-preview." - (interactive) - (if tm-vm/automatic-mime-preview - (progn - (tm-vm/quit-view-message) - (setq tm-vm/automatic-mime-preview nil) - (message "Automatic MIME Preview is now disabled.")) - ;; Enable Automatic MIME Preview - (tm-vm/view-message) - (setq tm-vm/automatic-mime-preview t) - (message "Automatic MIME Preview is now enabled.") - )) +(defun tm-vm/quit-view-message () + "Quit MIME-Viewer and go back to normal VM. +MIME Preview buffer is killed. This function is called by `mime-viewer/quit' +command via `mime-viewer/quitting-method-alist'." + (if (get-buffer mime/output-buffer-name) + (vm-undisplay-buffer mime/output-buffer-name)) + (vm-select-folder-buffer) + (let* ((mbuf (current-buffer)) + (pbuf (and mime::article/preview-buffer + (get-buffer mime::article/preview-buffer))) + (pwin (and pbuf (vm-get-visible-buffer-window pbuf)))) + (if pbuf (kill-buffer pbuf)) + (and pwin + (select-window pwin) + (switch-to-buffer mbuf))) + (setq tm-vm/system-state nil) + (vm-display (current-buffer) t (list this-command) + (list 'reading-message))) (add-hook 'vm-select-message-hook 'tm-vm/preview-current-message) (add-hook 'vm-visit-folder-hook 'tm-vm/preview-current-message) - -;;; tm-vm move commands -;;; - -(defmacro tm-vm/save-window-excursion (&rest forms) - (list 'let '((tm-vm/selected-window (selected-window))) - (list 'unwind-protect - (cons 'progn forms) - '(if (window-live-p tm-vm/selected-window) - (select-window tm-vm/selected-window))))) - -;;; based on vm-scroll-forward [vm-page.el] -(defun tm-vm/scroll-forward (&optional arg) - (interactive "P") - (let ((this-command 'vm-scroll-forward)) - (if (not (tm-vm/system-state)) - (progn - (vm-scroll-forward arg) - (tm-vm/display-preview-buffer)) - (let* ((mp-changed (vm-follow-summary-cursor)) - (mbuf (or (vm-select-folder-buffer) (current-buffer))) - (mwin (vm-get-buffer-window mbuf)) - (pbuf (and mime::article/preview-buffer - (get-buffer mime::article/preview-buffer))) - (pwin (and pbuf (vm-get-buffer-window pbuf))) - (was-invisible (and (null mwin) (null pwin))) - ) - ;; now current buffer is folder buffer. - (if (or mp-changed was-invisible) - (vm-display mbuf t '(vm-scroll-forward vm-scroll-backward) - (list this-command 'reading-message))) - (tm-vm/display-preview-buffer) - (setq mwin (vm-get-buffer-window mbuf) - pwin (and pbuf (vm-get-buffer-window pbuf))) - (cond - ((or mp-changed was-invisible) - nil) - ((null pbuf) - ;; preview buffer is killed. - (tm-vm/preview-current-message) - (vm-update-summary-and-mode-line)) - ((eq (tm-vm/system-state) 'previewing) - (tm-vm/show-current-message)) - (t - (tm-vm/save-window-excursion - (select-window pwin) - (set-buffer pbuf) - (if (pos-visible-in-window-p (point-max) pwin) - (tm-vm/next-message) - ;; not end of message. scroll preview buffer only. - (scroll-up) - (tm-vm/howl-if-eom) - (set-buffer mbuf)) - )))) - ))) - -;;; based on vm-scroll-backward [vm-page.el] -(defun tm-vm/scroll-backward (&optional arg) - (interactive "P") - (let ((this-command 'vm-scroll-backward)) - (if (not (tm-vm/system-state)) - (vm-scroll-backward arg) - (let* ((mp-changed (vm-follow-summary-cursor)) - (mbuf (or (vm-select-folder-buffer) (current-buffer))) - (mwin (vm-get-buffer-window mbuf)) - (pbuf (and mime::article/preview-buffer - (get-buffer mime::article/preview-buffer))) - (pwin (and pbuf (vm-get-buffer-window pbuf))) - (was-invisible (and (null mwin) (null pwin))) - ) - ;; now current buffer is folder buffer. - (if (or mp-changed was-invisible) - (vm-display mbuf t '(vm-scroll-forward vm-scroll-backward) - (list this-command 'reading-message))) - (tm-vm/display-preview-buffer) - (setq mwin (vm-get-buffer-window mbuf) - pwin (and pbuf (vm-get-buffer-window pbuf))) - (cond - (was-invisible - nil - ) - ((null pbuf) - ;; preview buffer is killed. - (tm-vm/preview-current-message) - (vm-update-summary-and-mode-line)) - ((eq (tm-vm/system-state) 'previewing) - (tm-vm/show-current-message)) - (t - (tm-vm/save-window-excursion - (select-window pwin) - (set-buffer pbuf) - (if (pos-visible-in-window-p (point-min) pwin) - nil - ;; scroll preview buffer only. - (scroll-down) - (set-buffer mbuf)) - )))) - ))) - -;;; based on vm-beginning-of-message [vm-page.el] -(defun tm-vm/beginning-of-message () - "Moves to the beginning of the current message." - (interactive) - (if (not (tm-vm/system-state)) - (progn - (setq this-command 'vm-beginning-of-message) - (vm-beginning-of-message)) - (vm-follow-summary-cursor) - (vm-select-folder-buffer) - (vm-check-for-killed-summary) - (vm-error-if-folder-empty) - (let ((mbuf (current-buffer)) - (pbuf (and mime::article/preview-buffer - (get-buffer mime::article/preview-buffer)))) - (if (null pbuf) - (progn - (tm-vm/preview-current-message) - (setq pbuf (get-buffer mime::article/preview-buffer)) - )) - (vm-display mbuf t '(vm-beginning-of-message) - '(vm-beginning-of-message reading-message)) - (tm-vm/display-preview-buffer) - (set-buffer pbuf) - (tm-vm/save-window-excursion - (select-window (vm-get-buffer-window pbuf)) - (push-mark) - (goto-char (point-min)) - )))) - -;;; based on vm-end-of-message [vm-page.el] -(defun tm-vm/end-of-message () - "Moves to the end of the current message." - (interactive) - (if (not (tm-vm/system-state)) - (progn - (setq this-command 'vm-end-of-message) - (vm-end-of-message)) - (vm-follow-summary-cursor) - (vm-select-folder-buffer) - (vm-check-for-killed-summary) - (vm-error-if-folder-empty) - (let ((mbuf (current-buffer)) - (pbuf (and mime::article/preview-buffer - (get-buffer mime::article/preview-buffer)))) - (if (null pbuf) - (progn - (tm-vm/preview-current-message) - (setq pbuf (get-buffer mime::article/preview-buffer)) - )) - (vm-display mbuf t '(vm-end-of-message) - '(vm-end-of-message reading-message)) - (tm-vm/display-preview-buffer) - (set-buffer pbuf) - (tm-vm/save-window-excursion - (select-window (vm-get-buffer-window pbuf)) - (push-mark) - (goto-char (point-max)) - )))) - -;;; based on vm-howl-if-eom [vm-page.el] -(defun tm-vm/howl-if-eom () - (let* ((pbuf (or mime::article/preview-buffer (current-buffer))) - (pwin (and (vm-get-visible-buffer-window pbuf)))) - (and pwin - (save-excursion - (save-window-excursion - (condition-case () - (let ((next-screen-context-lines 0)) - (select-window pwin) - (save-excursion - (save-window-excursion - (let ((scroll-in-place-replace-original nil)) - (scroll-up)))) - nil) - (error t)))) - (tm-vm/emit-eom-blurb) - ))) -;;; based on vm-emit-eom-blurb [vm-page.el] -(defun tm-vm/emit-eom-blurb () - (save-excursion - (if mime::preview/article-buffer - (set-buffer mime::preview/article-buffer)) - (vm-emit-eom-blurb))) -;;; based on vm-quit [vm-folder.el] -(defun tm-vm/quit () - "Quit VM saving the folder buffer and killing the MIME Preview buffer if any" - (interactive) - (save-excursion - (vm-select-folder-buffer) - (if (and mime::article/preview-buffer - (get-buffer mime::article/preview-buffer)) - (kill-buffer mime::article/preview-buffer))) - (vm-quit)) - -(defun tm-vm/quit-no-change () - "Quit VM without saving the folder buffer but killing the MIME Preview buffer -if any" - (interactive) - (save-excursion - (vm-select-folder-buffer) - (if (and mime::article/preview-buffer - (get-buffer mime::article/preview-buffer)) - (kill-buffer mime::article/preview-buffer))) - (vm-quit-no-change)) - -;;; based on vm-next-message [vm-motion.el] -(defun tm-vm/next-message () - (set-buffer mime::preview/article-buffer) - (let ((this-command 'vm-next-message) - (owin (selected-window)) - (vm-preview-lines nil) - ) - (vm-next-message 1 nil t) - (if (window-live-p owin) - (select-window owin)))) - -;;; based on vm-previous-message [vm-motion.el] -(defun tm-vm/previous-message () - (set-buffer mime::preview/article-buffer) - (let ((this-command 'vm-previous-message) - (owin (selected-window)) - (vm-preview-lines nil) - ) - (vm-previous-message 1 nil t) - (if (window-live-p owin) - (select-window owin)))) - -(set-alist 'mime-viewer/over-to-previous-method-alist - 'vm-mode 'tm-vm/previous-message) -(set-alist 'mime-viewer/over-to-next-method-alist - 'vm-mode 'tm-vm/next-message) -(set-alist 'mime-viewer/over-to-previous-method-alist - 'vm-virtual-mode 'tm-vm/previous-message) -(set-alist 'mime-viewer/over-to-next-method-alist - 'vm-virtual-mode 'tm-vm/next-message) - -;;; @@ vm-yank-message -;;; -;; 1996/3/28 by Oscar Figueiredo - -(require 'vm-reply) - -(defvar tm-vm/yank:message-to-restore nil - "For internal use by tm-vm only.") - -(defun vm-yank-message (&optional message) - "Yank message number N into the current buffer at point. -When called interactively N is always read from the minibuffer. When -called non-interactively the first argument is expected to be a -message struct. - -This function originally provided by vm-reply has been patched for TM -in order to provide better citation of MIME messages : if a MIME -Preview buffer exists for the message then its contents are inserted -instead of the raw message. - -This command is meant to be used in VM created Mail mode buffers; the -yanked message comes from the mail buffer containing the message you -are replying to, forwarding, or invoked VM's mail command from. - -All message headers are yanked along with the text. Point is -left before the inserted text, the mark after. Any hook -functions bound to mail-citation-hook are run, after inserting -the text and setting point and mark. For backward compatibility, -if mail-citation-hook is set to nil, `mail-yank-hooks' is run -instead. - -If mail-citation-hook and mail-yank-hooks are both nil, this -default action is taken: the yanked headers are trimmed as -specified by vm-included-text-headers and -vm-included-text-discard-header-regexp, and the value of -vm-included-text-prefix is prepended to every yanked line." - (interactive - (list - ;; What we really want for the first argument is a message struct, - ;; but if called interactively, we let the user type in a message - ;; number instead. - (let (mp default - (result 0) - prompt - (last-command last-command) - (this-command this-command)) - (if (bufferp vm-mail-buffer) - (save-excursion - (vm-select-folder-buffer) - (setq default (and vm-message-pointer - (vm-number-of (car vm-message-pointer))) - prompt (if default - (format "Yank message number: (default %s) " - default) - "Yank message number: ")) - (while (zerop result) - (setq result (read-string prompt)) - (and (string= result "") default (setq result default)) - (setq result (string-to-int result))) - (if (null (setq mp (nthcdr (1- result) vm-message-list))) - (error "No such message.")) - (setq tm-vm/yank:message-to-restore (string-to-int default)) - (save-selected-window - (vm-goto-message result)) - (car mp)) - nil)))) - (if (null message) - (if mail-reply-buffer - (tm-vm/yank-content) - (error "This is not a VM Mail mode buffer.")) - (if (null (buffer-name vm-mail-buffer)) - (error "The folder buffer containing message %d has been killed." - (vm-number-of message))) - (vm-display nil nil '(vm-yank-message) - '(vm-yank-message composing-message)) - (let ((b (current-buffer)) (start (point)) end) - (save-restriction - (widen) - (save-excursion - (set-buffer (vm-buffer-of message)) - (let* ((mbuf (current-buffer)) - pbuf) - (tm-vm/sync-preview-buffer) - (setq pbuf (and mime::article/preview-buffer - (get-buffer mime::article/preview-buffer))) - (if (and pbuf - (not (eq this-command 'tm-vm/forward-message))) - (if running-xemacs - (let ((tmp (generate-new-buffer "tm-vm/tmp"))) - (set-buffer pbuf) - (append-to-buffer tmp (point-min) (point-max)) - (set-buffer tmp) - (map-extents - '(lambda (ext maparg) - (set-extent-property ext 'begin-glyph nil))) - (append-to-buffer b (point-min) (point-max)) - (setq end (vm-marker - (+ start (length (buffer-string))) b)) - (kill-buffer tmp)) - (set-buffer pbuf) - (append-to-buffer b (point-min) (point-max)) - (setq end (vm-marker - (+ start (length (buffer-string))) b))) - (save-restriction - (setq message (vm-real-message-of message)) - (set-buffer (vm-buffer-of message)) - (widen) - (append-to-buffer - b (vm-headers-of message) (vm-text-end-of message)) - (setq end - (vm-marker (+ start (- (vm-text-end-of message) - (vm-headers-of message))) b)))))) - (push-mark end) - (cond (mail-citation-hook (run-hooks 'mail-citation-hook)) - (mail-yank-hooks (run-hooks 'mail-yank-hooks)) - (t (vm-mail-yank-default message))) - )) - (if tm-vm/yank:message-to-restore - (save-selected-window - (vm-goto-message tm-vm/yank:message-to-restore) - (setq tm-vm/yank:message-to-restore nil))) - )) -;;; @ for tm-view -;;; + +;;; @@ for tm-view ;;; based on vm-do-reply [vm-reply.el] (defun tm-vm/do-reply (buf to-all include-text) (save-excursion (set-buffer buf) (let ((dir default-directory) - to cc subject mp in-reply-to references newsgroups) + to cc subject in-reply-to references newsgroups) (cond ((setq to (let ((reply-to (std11-field-body "Reply-To"))) (if (vm-ignored-reply-to reply-to) @@ -829,42 +701,6 @@ (function tm-vm/following-method)) -(defun tm-vm/quit-view-message () - "Quit MIME-Viewer and go back to normal VM. MIME Preview buffer -is killed. This function is called by `mime-viewer/quit' command -via `mime-viewer/quitting-method-alist'." - (if (get-buffer mime/output-buffer-name) - (vm-undisplay-buffer mime/output-buffer-name)) - (vm-select-folder-buffer) - (let* ((mbuf (current-buffer)) - (pbuf (and mime::article/preview-buffer - (get-buffer mime::article/preview-buffer))) - (pwin (and pbuf (vm-get-visible-buffer-window pbuf)))) - (kill-buffer pbuf) - (and pwin - (select-window pwin) - (switch-to-buffer mbuf))) - (setq tm-vm/system-state nil) - (vm-display (current-buffer) t (list this-command) - (list 'reading-message)) - ) - -(defun tm-vm/view-message () - "Decode and view a MIME encoded message under VM. -A MIME Preview buffer using mime/viewer-mode is created. -See mime/viewer-mode for more information" - (interactive) - (vm-follow-summary-cursor) - (vm-select-folder-buffer) - (vm-check-for-killed-summary) - (vm-error-if-folder-empty) - (vm-display (current-buffer) t '(tm-vm/view-message - tm-vm/toggle-preview-mode) - '(tm-vm/view-message reading-message)) - (let ((tm-vm/automatic-mime-preview t)) - (tm-vm/preview-current-message)) -) - (set-alist 'mime-viewer/quitting-method-alist 'vm-mode 'tm-vm/quit-view-message) @@ -873,8 +709,386 @@ 'vm-virtual-mode 'tm-vm/quit-view-message) +;;; @@ Motion commands -;;; @ for tm-partial +(defmacro tm-vm/save-window-excursion (&rest forms) + (list 'let '((tm-vm/selected-window (selected-window))) + (list 'unwind-protect + (cons 'progn forms) + '(if (window-live-p tm-vm/selected-window) + (select-window tm-vm/selected-window))))) + +(defmacro tm-vm/save-frame-excursion (&rest forms) + (list 'let '((tm-vm/selected-frame (vm-selected-frame))) + (list 'unwind-protect + (cons 'progn forms) + '(if (frame-live-p tm-vm/selected-frame) + (vm-select-frame tm-vm/selected-frame))))) + +(defadvice vm-scroll-forward (around tm-aware activate) + "Made TM-aware (handles the MIME-Preview buffer)." + (if (and + (not (save-excursion + (if mime::preview/article-buffer + (set-buffer mime::preview/article-buffer)) + (vm-select-folder-buffer) + (eq vm-system-state 'previewing))) + (not (tm-vm/system-state))) + (progn + ad-do-it + (tm-vm/display-preview-buffer)) + (let* ((mp-changed (vm-follow-summary-cursor)) + (mbuf (or (vm-select-folder-buffer) (current-buffer))) + (mwin (vm-get-buffer-window mbuf)) + (pbuf (and mime::article/preview-buffer + (get-buffer mime::article/preview-buffer))) + (pwin (and pbuf (vm-get-buffer-window pbuf))) + ) + (vm-check-for-killed-summary) + (vm-error-if-folder-empty) + (cond + ; A new message was selected + ; => leave it to tm-vm/preview-current-message + (mp-changed + nil) + ((eq vm-system-state 'previewing) + (vm-display (current-buffer) t (list this-command) '(reading-message)) + (vm-show-current-message) + (tm-vm/preview-current-message)) + ; Preview buffer was killed + ((null pbuf) + (tm-vm/preview-current-message)) + ; Preview buffer was undisplayed + ((null pwin) + (if (null mwin) + (vm-display mbuf t '(vm-scroll-forward vm-scroll-backward) + (list this-command 'reading-message))) + (tm-vm/display-preview-buffer)) + ; Preview buffer is displayed => scroll + (t + (tm-vm/save-window-excursion + (select-window pwin) + (set-buffer pbuf) + (if (pos-visible-in-window-p (point-max) pwin) + (vm-next-message) + ;; not at the end of message. scroll preview buffer only. + (scroll-up) + (tm-vm/howl-if-eom)) + )))) + ) +) + +(defadvice vm-scroll-backward (around tm-aware activate) + "Made TM-aware (handles the MIME-Preview buffer)." + (if (and + (not (save-excursion + (if mime::preview/article-buffer + (set-buffer mime::preview/article-buffer)) + (vm-select-folder-buffer) + (eq vm-system-state 'previewing))) + (not (tm-vm/system-state))) + ad-do-it + (let* ((mp-changed (vm-follow-summary-cursor)) + (mbuf (or (vm-select-folder-buffer) (current-buffer))) + (mwin (vm-get-buffer-window mbuf)) + (pbuf (and mime::article/preview-buffer + (get-buffer mime::article/preview-buffer))) + (pwin (and pbuf (vm-get-buffer-window pbuf))) + ) + (vm-check-for-killed-summary) + (vm-error-if-folder-empty) + (cond + ; A new message was selected + ; => leave it to tm-vm/preview-current-message + (mp-changed + nil) + ((eq vm-system-state 'previewing) + (tm-vm/update-message-status) + (setq vm-system-state 'reading) + (tm-vm/preview-current-message)) + ; Preview buffer was killed + ((null pbuf) + (tm-vm/preview-current-message)) + ; Preview buffer was undisplayed + ((null pwin) + (if (null mwin) + (vm-display mbuf t '(vm-scroll-forward vm-scroll-backward) + (list this-command 'reading-message))) + (tm-vm/display-preview-buffer)) + ; Preview buffer is displayed => scroll + (t + (tm-vm/save-window-excursion + (select-window pwin) + (if (pos-visible-in-window-p (point-min) pwin) + nil + ;; not at the end of message. scroll preview buffer only. + (scroll-down)) + )))) + )) + +(defadvice vm-beginning-of-message (around tm-aware activate) + "Made TM-aware, works properly in MIME-Preview buffers." + (if (not (tm-vm/system-state)) + ad-do-it + (vm-follow-summary-cursor) + (vm-select-folder-buffer) + (vm-check-for-killed-summary) + (vm-error-if-folder-empty) + (let ((mbuf (current-buffer)) + (pbuf (and mime::article/preview-buffer + (get-buffer mime::article/preview-buffer)))) + (if (null pbuf) + (progn + (tm-vm/preview-current-message) + (setq pbuf (get-buffer mime::article/preview-buffer)) + )) + (vm-display mbuf t '(vm-beginning-of-message) + '(vm-beginning-of-message reading-message)) + (tm-vm/display-preview-buffer) + (set-buffer pbuf) + (tm-vm/save-window-excursion + (select-window (vm-get-buffer-window pbuf)) + (push-mark) + (goto-char (point-min)) + )))) + +(defadvice vm-end-of-message (around tm-aware activate) + "Made TM-aware, works properly in MIME-Preview buffers." + (interactive) + (if (not (tm-vm/system-state)) + ad-do-it + (vm-follow-summary-cursor) + (vm-select-folder-buffer) + (vm-check-for-killed-summary) + (vm-error-if-folder-empty) + (let ((mbuf (current-buffer)) + (pbuf (and mime::article/preview-buffer + (get-buffer mime::article/preview-buffer)))) + (if (null pbuf) + (progn + (tm-vm/preview-current-message) + (setq pbuf (get-buffer mime::article/preview-buffer)) + )) + (vm-display mbuf t '(vm-end-of-message) + '(vm-end-of-message reading-message)) + (tm-vm/display-preview-buffer) + (set-buffer pbuf) + (tm-vm/save-window-excursion + (select-window (vm-get-buffer-window pbuf)) + (push-mark) + (goto-char (point-max)) + )))) + +;;; based on vm-howl-if-eom [vm-page.el] +(defun tm-vm/howl-if-eom () + (let* ((pbuf (or mime::article/preview-buffer (current-buffer))) + (pwin (and (vm-get-visible-buffer-window pbuf)))) + (and pwin + (save-excursion + (save-window-excursion + (condition-case () + (let ((next-screen-context-lines 0)) + (tm-vm/save-frame-excursion + (vm-select-frame (vm-window-frame pwin)) + (save-selected-window + (select-window pwin) + (save-excursion + (let ((scroll-in-place-replace-original nil)) + (scroll-up))))) + nil) + (error t)))) + (vm-emit-eom-blurb) + ))) + +(defadvice vm-emit-eom-blurb (around tm-aware activate) + "Made TM-aware, works properly in MIME-Preview buffers." + (save-excursion + (if mime::preview/article-buffer + (set-buffer mime::preview/article-buffer)) + ad-do-it)) + +(defadvice vm-next-message (around tm-aware activate) + "Made TM-aware, works properly in MIME-Preview buffers." + (if mime::preview/article-buffer + (set-buffer mime::preview/article-buffer)) + (tm-vm/save-window-excursion + ad-do-it)) + +(defadvice vm-previous-message (around tm-aware activate) + "Made TM-aware, works properly in MIME-Preview buffers." + (if mime::preview/article-buffer + (set-buffer mime::preview/article-buffer)) + (tm-vm/save-window-excursion + ad-do-it)) + +(defadvice vm-next-message-no-skip (around tm-aware activate) + "Made TM-aware, works properly in MIME-Preview buffers." + (if mime::preview/article-buffer + (set-buffer mime::preview/article-buffer)) + (tm-vm/save-window-excursion + ad-do-it)) + +(defadvice vm-previous-message-no-skip (around tm-aware activate) + "TM wrapper for vm-previous-message-no-skip (which see)." + (if mime::preview/article-buffer + (set-buffer mime::preview/article-buffer)) + (tm-vm/save-window-excursion + ad-do-it)) + +(defadvice vm-next-unread-message (around tm-aware activate) + "Made TM-aware, works properly in MIME-Preview buffers." + (if mime::preview/article-buffer + (set-buffer mime::preview/article-buffer)) + (tm-vm/save-window-excursion + ad-do-it)) + +(defadvice vm-previous-unread-message (around tm-aware activate) + "Made TM-aware, works properly in MIME-Preview buffers." + (if mime::preview/article-buffer + (set-buffer mime::preview/article-buffer)) + (tm-vm/save-window-excursion + ad-do-it)) + + +(set-alist 'mime-viewer/over-to-previous-method-alist + 'vm-mode 'vm-previous-message) +(set-alist 'mime-viewer/over-to-next-method-alist + 'vm-mode 'vm-next-message) +(set-alist 'mime-viewer/over-to-previous-method-alist + 'vm-virtual-mode 'vm-previous-message) +(set-alist 'mime-viewer/over-to-next-method-alist + 'vm-virtual-mode 'vm-next-message) + + + + + + +;;; @ MIME Editor + +;;; @@ vm-yank-message + +(require 'vm-reply) + +(defvar tm-vm/yank:message-to-restore nil + "For internal use by tm-vm only.") + +(defun vm-yank-message (&optional message) + "Yank message number N into the current buffer at point. +When called interactively N is always read from the minibuffer. When +called non-interactively the first argument is expected to be a +message struct. + +This function originally provided by vm-reply has been patched for TM +in order to provide better citation of MIME messages : if a MIME +Preview buffer exists for the message then its contents are inserted +instead of the raw message. + +This command is meant to be used in VM created Mail mode buffers; the +yanked message comes from the mail buffer containing the message you +are replying to, forwarding, or invoked VM's mail command from. + +All message headers are yanked along with the text. Point is +left before the inserted text, the mark after. Any hook +functions bound to mail-citation-hook are run, after inserting +the text and setting point and mark. For backward compatibility, +if mail-citation-hook is set to nil, `mail-yank-hooks' is run +instead. + +If mail-citation-hook and mail-yank-hooks are both nil, this +default action is taken: the yanked headers are trimmed as +specified by vm-included-text-headers and +vm-included-text-discard-header-regexp, and the value of +vm-included-text-prefix is prepended to every yanked line." + (interactive + (list + ;; What we really want for the first argument is a message struct, + ;; but if called interactively, we let the user type in a message + ;; number instead. + (let (mp default + (result 0) + prompt + (last-command last-command) + (this-command this-command)) + (if (bufferp vm-mail-buffer) + (save-excursion + (vm-select-folder-buffer) + (setq default (and vm-message-pointer + (vm-number-of (car vm-message-pointer))) + prompt (if default + (format "Yank message number: (default %s) " + default) + "Yank message number: ")) + (while (zerop result) + (setq result (read-string prompt)) + (and (string= result "") default (setq result default)) + (setq result (string-to-int result))) + (if (null (setq mp (nthcdr (1- result) vm-message-list))) + (error "No such message.")) + (setq tm-vm/yank:message-to-restore (string-to-int default)) + (save-selected-window + (vm-goto-message result)) + (car mp)) + nil)))) + (if (null message) + (if mail-reply-buffer + (tm-vm/yank-content) + (error "This is not a VM Mail mode buffer.")) + (if (null (buffer-name vm-mail-buffer)) + (error "The folder buffer containing message %d has been killed." + (vm-number-of message))) + (vm-display nil nil '(vm-yank-message) + '(vm-yank-message composing-message)) + (let ((b (current-buffer)) (start (point)) end) + (save-restriction + (widen) + (save-excursion + (set-buffer (vm-buffer-of message)) + (let (pbuf) + (tm-vm/sync-preview-buffer) + (setq pbuf (and mime::article/preview-buffer + (get-buffer mime::article/preview-buffer))) + (if (and pbuf + (not (eq this-command 'vm-forward-message))) + ;; Yank contents of MIME Preview buffer + (if running-xemacs + (let ((tmp (generate-new-buffer "tm-vm/tmp"))) + (set-buffer pbuf) + (append-to-buffer tmp (point-min) (point-max)) + (set-buffer tmp) + (map-extents + '(lambda (ext maparg) + (set-extent-property ext 'begin-glyph nil))) + (append-to-buffer b (point-min) (point-max)) + (setq end (vm-marker + (+ start (length (buffer-string))) b)) + (kill-buffer tmp)) + (set-buffer pbuf) + (append-to-buffer b (point-min) (point-max)) + (setq end (vm-marker + (+ start (length (buffer-string))) b))) + ;; Yank contents of raw VM message + (save-restriction + (setq message (vm-real-message-of message)) + (set-buffer (vm-buffer-of message)) + (widen) + (append-to-buffer + b (vm-headers-of message) (vm-text-end-of message)) + (setq end + (vm-marker (+ start (- (vm-text-end-of message) + (vm-headers-of message))) b)))))) + (push-mark end) + (cond (mail-citation-hook (run-hooks 'mail-citation-hook)) + (mail-yank-hooks (run-hooks 'mail-yank-hooks)) + (t (vm-mail-yank-default message))) + )) + (if tm-vm/yank:message-to-restore + (save-selected-window + (vm-goto-message tm-vm/yank:message-to-restore) + (setq tm-vm/yank:message-to-restore nil))) + )) + +;;; @@ for tm-partial ;;; (call-after-loaded @@ -896,23 +1110,18 @@ ))) -;;; @ for tm-edit -;;; - -;;; @@ for multipart/digest +;;; @@ for tm-edit ;;; -(defvar tm-vm/forward-message-hook nil - "*List of functions called after a Mail mode buffer has been -created to forward a message in message/rfc822 type format. -If `vm-forwarding-digest-type' is \"rfc1521\", tm-vm runs this -hook instead of `vm-forward-message-hook'.") +(call-after-loaded + 'mime-setup + (function + (lambda () + (setq vm-forwarding-digest-type "rfc1521") + (setq vm-digest-send-type "rfc1521") + ))) -(defvar tm-vm/send-digest-hook nil - "*List of functions called after a Mail mode buffer has been -created to send a digest in multipart/digest type format. -If `vm-digest-send-type' is \"rfc1521\", tm-vm runs this hook -instead of `vm-send-digest-hook'.") +;;; @@@ multipart/digest (defun tm-vm/enclose-messages (mlist &optional preamble) "Enclose the messages in MLIST as multipart/digest. @@ -951,14 +1160,10 @@ (mime-editor/enclose-digest-region (point-min) (point-max))) )))) -(defun tm-vm/forward-message () - "Forward the current message to one or more recipients. -You will be placed in a Mail mode buffer as you would with a -reply, but you must fill in the To: header and perhaps the -Subject: header manually." - (interactive) +(defadvice vm-forward-message (around tm-aware activate) + "Extended to support rfc1521 multipart digests and to work properly in MIME-Preview buffers." (if (not (equal vm-forwarding-digest-type "rfc1521")) - (vm-forward-message) + ad-do-it (if mime::preview/article-buffer (set-buffer mime::preview/article-buffer)) (vm-follow-summary-cursor) @@ -1010,8 +1215,7 @@ (let ((dir default-directory) (vm-forward-list (if (eq last-command 'vm-next-command-uses-marks) (vm-select-marked-or-prefixed-messages 0) - vm-message-list)) - start) + vm-message-list))) (save-restriction (widen) (vm-mail-internal (format "digest from %s" (buffer-name))) @@ -1028,16 +1232,10 @@ (run-hooks 'tm-vm/send-digest-hook) (run-hooks 'vm-mail-mode-hook))) -(substitute-key-definition 'vm-forward-message - 'tm-vm/forward-message vm-mode-map) (substitute-key-definition 'vm-send-digest 'tm-vm/send-digest vm-mode-map) - -;;; @@ setting -;;; - -(defvar tm-vm/use-xemacs-popup-menu t) +;;; @@@ Menus ;;; modified by Steven L. Baur ;;; 1995/12/6 (c.f. [tm-en:209]) @@ -1050,7 +1248,8 @@ (list "----" mime-editor/popup-menu-for-xemacs))) (remove-hook 'vm-mail-mode-hook 'mime-editor/attach-to-vm-mode-menu) - ))) + )) +) (call-after-loaded 'tm-edit @@ -1066,21 +1265,78 @@ (funcall send-mail-function) ))) (if (and (string-match "XEmacs\\|Lucid" emacs-version) - tm-vm/use-xemacs-popup-menu) + tm-vm/attach-to-popup-menus) (add-hook 'vm-mail-mode-hook 'mime-editor/attach-to-vm-mode-menu) ) ))) -(call-after-loaded - 'mime-setup - (function - (lambda () - (setq vm-forwarding-digest-type "rfc1521") - (setq vm-digest-send-type "rfc1521") - ))) + + +;;; @ VM Integration + +(add-hook 'vm-quit-hook 'tm-vm/quit-view-message) + +;;; @@ Wrappers for miscellaneous VM functions + +(defadvice vm-summarize (around tm-aware activate) + "Made TM aware. Callable from the MIME Preview buffer." + (if mime::preview/article-buffer + (set-buffer mime::preview/article-buffer)) + ad-do-it + (save-excursion + (set-buffer vm-summary-buffer) + (tm-vm/check-for-toolbar)) + (tm-vm/preview-current-message)) + +(defadvice vm-expose-hidden-headers (around tm-aware activate) + "Made TM aware. Callable from the MIME Preview buffer." + (if mime::preview/article-buffer + (set-buffer mime::preview/article-buffer)) + (let ((visible-headers vm-visible-headers)) + (tm-vm/quit-view-message) + ad-do-it + (let ((vm-visible-headers visible-headers)) + (if (= (point-min) (vm-start-of (car vm-message-pointer))) + (setq vm-visible-headers '(".*"))) + (tm-vm/preview-current-message)))) + +(if (vm-mouse-fsfemacs-mouse-p) + (progn + (define-key tm-vm/vm-emulation-map [mouse-3] 'ignore) + (define-key tm-vm/vm-emulation-map [down-mouse-3] 'vm-mouse-button-3) + (defadvice vm-mouse-button-3 (after tm-aware activate) + "Made TM aware. Works in MIME-Preview buffers." + (if (and + vm-use-menus + (eq major-mode 'mime/viewer-mode)) + (vm-menu-popup-mode-menu event)))) +) -;;; @ for BBDB +;;; @@ VM Toolbar Integration + +(require 'vm-toolbar) + +;;; based on vm-toolbar-any-messages-p [vm-toolbar.el] +(defun tm-vm/check-for-toolbar () + "Install VM toolbar if necessary." + (if (and running-xemacs + vm-toolbar-specifier) + (progn + (if (null (specifier-instance vm-toolbar-specifier)) + (vm-toolbar-install-toolbar)) + (vm-toolbar-update-toolbar)))) + +(defun vm-toolbar-any-messages-p () + (save-excursion + (if mime::preview/article-buffer + (set-buffer mime::preview/article-buffer)) + (vm-check-for-killed-folder) + (vm-select-folder-buffer) + vm-message-list)) + + +;;; @ BBDB Integration ;;; (call-after-loaded @@ -1090,26 +1346,24 @@ (require 'bbdb-vm) (require 'tm-bbdb) (defun tm-bbdb/vm-update-record (&optional offer-to-create) - (vm-select-folder-buffer) - (if (and (tm-vm/system-state) - mime::article/preview-buffer - (get-buffer mime::article/preview-buffer)) - (let ((tm-bbdb/auto-create-p bbdb/mail-auto-create-p)) - (tm-bbdb/update-record offer-to-create)) - (or (bbdb/vm-update-record offer-to-create) - (delete-windows-on (get-buffer "*BBDB*"))) - )) + (save-excursion + (vm-select-folder-buffer) + (if (and (tm-vm/system-state) + mime::article/preview-buffer + (get-buffer mime::article/preview-buffer)) + (let ((tm-bbdb/auto-create-p bbdb/mail-auto-create-p)) + (tm-bbdb/update-record offer-to-create)) + (or (bbdb/vm-update-record offer-to-create) + (delete-windows-on (get-buffer "*BBDB*"))) + ))) (remove-hook 'vm-select-message-hook 'bbdb/vm-update-record) (remove-hook 'vm-show-message-hook 'bbdb/vm-update-record) (add-hook 'tm-vm/select-message-hook 'tm-bbdb/vm-update-record) ))) -;;; @ for ps-print (Suggestted by Anders Stenman ) +;;; @ ps-print (Suggested by Anders Stenman ) ;;; -(defvar tm-vm/use-ps-print (not (featurep 'mule)) - "*Use Postscript printing (ps-print) to print MIME messages.") - (if tm-vm/use-ps-print (progn (autoload 'ps-print-buffer-with-faces "ps-print" "Postscript Print" t) @@ -1133,11 +1387,10 @@ Value of tm-vm/strict-mime is also taken into consideration." (interactive) (vm-follow-summary-cursor) - (let* ((mbuf (or (vm-select-folder-buffer) (current-buffer))) - pbuf) - (tm-vm/sync-preview-buffer) - (setq pbuf (and mime::article/preview-buffer - (get-buffer mime::article/preview-buffer))) + (vm-select-folder-buffer) + (tm-vm/sync-preview-buffer) + (let ((pbuf (and mime::article/preview-buffer + (get-buffer mime::article/preview-buffer)))) (if pbuf (save-excursion (set-buffer pbuf) @@ -1146,40 +1399,9 @@ (vm-print-message)))) -;;; @ Substitute VM bindings and menus -;;; - -(substitute-key-definition 'vm-scroll-forward - 'tm-vm/scroll-forward vm-mode-map) -(substitute-key-definition 'vm-scroll-backward - 'tm-vm/scroll-backward vm-mode-map) -(substitute-key-definition 'vm-beginning-of-message - 'tm-vm/beginning-of-message vm-mode-map) -(substitute-key-definition 'vm-end-of-message - 'tm-vm/end-of-message vm-mode-map) -(substitute-key-definition 'vm-forward-message - 'tm-vm/forward-message vm-mode-map) -(substitute-key-definition 'vm-quit - 'tm-vm/quit vm-mode-map) -(substitute-key-definition 'vm-quit-no-change - 'tm-vm/quit-no-change vm-mode-map) - -;; The following function should be modified and called on vm-menu-setup-hook -;; but VM 5.96 does not run that hook on XEmacs -(require 'vm-menu) -(if running-xemacs - (condition-case nil - (aset (car (find-menu-item vm-menu-dispose-menu '("Forward"))) - 1 - 'tm-vm/forward-message) - (t nil))) - ;;; @ end -;;; (provide 'tm-vm) - (run-hooks 'tm-vm-load-hook) ;;; tm-vm.el ends here. - diff -r ad457d5f7d04 -r 0293115a14e9 lisp/tm/tmh-comp.el --- a/lisp/tm/tmh-comp.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/tm/tmh-comp.el Mon Aug 13 08:49:20 2007 +0200 @@ -1,12 +1,12 @@ ;;; tm-mh-e.el --- tm-mh-e functions for composing messages -;; Copyright (C) 1993,1994,1995,1996 Free Software Foundation, Inc. +;; Copyright (C) 1993,1994,1995,1996,1997 Free Software Foundation, Inc. ;; Author: MORIOKA Tomohiko ;; OKABE Yasuo ;; Maintainer: MORIOKA Tomohiko ;; Created: 1996/2/29 (separated from tm-mh-e.el) -;; Version: $Id: tmh-comp.el,v 1.3 1996/12/29 00:15:15 steve Exp $ +;; Version: $Id: tmh-comp.el,v 1.4 1997/02/02 05:06:21 steve Exp $ ;; Keywords: mail, MH, MIME, multimedia, encoded-word, multilingual ;; This file is part of tm (Tools for MIME). @@ -464,14 +464,18 @@ (delete-windows-on mh-show-buffer)) (set-buffer mh-show-buffer) ; Find displayed message (let ((mh-ins-str - (let (mime-viewer/plain-text-preview-hook buf) - (prog1 - (save-window-excursion - (set-buffer mime::preview/article-buffer) - (setq buf (mime/viewer-mode)) - (buffer-string) - ) - (kill-buffer buf))))) + (if mime::preview/article-buffer + (let (mime-viewer/plain-text-preview-hook buf) + (prog1 + (save-window-excursion + (set-buffer mime::preview/article-buffer) + (setq buf (mime/viewer-mode)) + (buffer-string) + ) + (kill-buffer buf) + )) + (buffer-string) + ))) (set-buffer to-buffer) (save-restriction (narrow-to-region to-point to-point) diff -r ad457d5f7d04 -r 0293115a14e9 lisp/utils/annotations.el --- a/lisp/utils/annotations.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/utils/annotations.el Mon Aug 13 08:49:20 2007 +0200 @@ -21,8 +21,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Synched up with: Not in FSF. diff -r ad457d5f7d04 -r 0293115a14e9 lisp/utils/atomic-extents.el --- a/lisp/utils/atomic-extents.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/utils/atomic-extents.el Mon Aug 13 08:49:20 2007 +0200 @@ -18,8 +18,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Point is not allowed to fall inside of an atomic extent. This has ;;; the effect of making all text covered by an atomic extent be diff -r ad457d5f7d04 -r 0293115a14e9 lisp/utils/crontab.el --- a/lisp/utils/crontab.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/utils/crontab.el Mon Aug 13 08:49:20 2007 +0200 @@ -21,8 +21,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Synched up with: Not in FSF. diff -r ad457d5f7d04 -r 0293115a14e9 lisp/utils/find-gc.el --- a/lisp/utils/find-gc.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/utils/find-gc.el Mon Aug 13 08:49:20 2007 +0200 @@ -18,8 +18,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Synched up with: FSF 19.30. diff -r ad457d5f7d04 -r 0293115a14e9 lisp/utils/finder.el --- a/lisp/utils/finder.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/utils/finder.el Mon Aug 13 08:49:20 2007 +0200 @@ -210,7 +210,7 @@ (defun finder-insert-at-column (column &rest strings) "Insert list of STRINGS, at column COLUMN." - (if (> (current-column) column) (insert "\n")) + (if (>= (current-column) column) (insert "\n")) (move-to-column column) (let ((col (current-column))) (if (< col column) diff -r ad457d5f7d04 -r 0293115a14e9 lisp/utils/highlight-headers.el --- a/lisp/utils/highlight-headers.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/utils/highlight-headers.el Mon Aug 13 08:49:20 2007 +0200 @@ -18,8 +18,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Synched up with: Not in FSF. diff -r ad457d5f7d04 -r 0293115a14e9 lisp/utils/lib-complete.el --- a/lisp/utils/lib-complete.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/utils/lib-complete.el Mon Aug 13 08:49:20 2007 +0200 @@ -5,7 +5,7 @@ ;; Last Modified By: Heiko M|nkel ;; Additional XEmacs integration By: Chuck Thompson ;; Last Modified On: Thu Jul 1 14:23:00 1994 -;; RCS Info : $Revision: 1.1.1.1 $ $Locker: $ +;; RCS Info : $Revision: 1.2 $ $Locker: $ ;; ======================================================================== ;; NOTE: this file must be recompiled if changed. ;; @@ -26,8 +26,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Synched up with: Not in FSF. diff -r ad457d5f7d04 -r 0293115a14e9 lisp/utils/live-icon.el --- a/lisp/utils/live-icon.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/utils/live-icon.el Mon Aug 13 08:49:20 2007 +0200 @@ -21,8 +21,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Synched up with: Not in FSF. diff -r ad457d5f7d04 -r 0293115a14e9 lisp/utils/mail-extr.el --- a/lisp/utils/mail-extr.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/utils/mail-extr.el Mon Aug 13 08:49:20 2007 +0200 @@ -20,8 +20,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Synched up with: Not synched with FSF but close to 19.28. diff -r ad457d5f7d04 -r 0293115a14e9 lisp/utils/mail-utils.el --- a/lisp/utils/mail-utils.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/utils/mail-utils.el Mon Aug 13 08:49:20 2007 +0200 @@ -18,8 +18,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Synched up with: FSF 19.30. diff -r ad457d5f7d04 -r 0293115a14e9 lisp/utils/passwd.el --- a/lisp/utils/passwd.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/utils/passwd.el Mon Aug 13 08:49:20 2007 +0200 @@ -20,8 +20,9 @@ ;;; Synched up with: Not in FSF. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Change Log: ;; diff -r ad457d5f7d04 -r 0293115a14e9 lisp/utils/rfc822.el --- a/lisp/utils/rfc822.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/utils/rfc822.el Mon Aug 13 08:49:20 2007 +0200 @@ -17,8 +17,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Synched up with: Not synched with FSF but very close. diff -r ad457d5f7d04 -r 0293115a14e9 lisp/utils/symbol-syntax.el --- a/lisp/utils/symbol-syntax.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/utils/symbol-syntax.el Mon Aug 13 08:49:20 2007 +0200 @@ -23,8 +23,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Synched up with: Not in FSF. diff -r ad457d5f7d04 -r 0293115a14e9 lisp/utils/timezone.el --- a/lisp/utils/timezone.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/utils/timezone.el Mon Aug 13 08:49:20 2007 +0200 @@ -19,8 +19,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Synched up with: FSF 19.30. @@ -128,6 +129,9 @@ "Make time string from HOUR, MINUTE, and SECOND." (format "%02d:%02d:%02d" hour minute second)) +;;;###autoload +(define-error 'invalid-date "Invalid date string") + (defun timezone-parse-date (date) "Parse DATE and return a vector [YEAR MONTH DAY TIME TIMEZONE]. 19 is prepended to year if necessary. Timezone may be nil if nothing. @@ -139,6 +143,8 @@ (5) 22-AUG-1993 10:59:12.82 (6) Thu, 11 Apr 16:17:12 91 [MET] (7) Mon, 6 Jul 16:47:20 T 1992 [MET]" + (condition-case nil + (progn ;; Get rid of any text properties. (and (stringp date) (or (text-properties-at 0 date) @@ -190,7 +196,16 @@ (substring date (match-beginning year) (match-end year))) ;; It is now Dec 1992. 8 years before the end of the World. (if (< (length year) 4) - (setq year (concat "19" (substring year -2 nil)))) + ;; 2 digit years are bogus, so guess the century + (let ((yr (string-to-int year))) + (when (>= yr 100) + ;; What does a three digit year mean? + (setq yr (- yr 100))) + (setq year (format "%d%02d" + (if (< yr 70) + 20 + 19) + yr)))) (let ((string (substring date (match-beginning month) (+ (match-beginning month) 3)))) @@ -209,7 +224,10 @@ (if year (vector year month day time zone) (vector "0" "0" "0" "0" nil)) - )) + ) + ) + (t (signal 'invalid-date (list date)))) +) (defun timezone-parse-time (time) "Parse TIME (HH:MM:SS) and return a vector [hour minute second]. diff -r ad457d5f7d04 -r 0293115a14e9 lisp/utils/with-timeout.el --- a/lisp/utils/with-timeout.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/utils/with-timeout.el Mon Aug 13 08:49:20 2007 +0200 @@ -16,8 +16,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Synched up with: Not in FSF. diff -r ad457d5f7d04 -r 0293115a14e9 lisp/version.el --- a/lisp/version.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/version.el Mon Aug 13 08:49:20 2007 +0200 @@ -26,7 +26,7 @@ (defconst emacs-version "19.15" "\ Version numbers of this version of Emacs.") -(setq emacs-version (purecopy (concat emacs-version " XEmacs Lucid (beta90)"))) +(setq emacs-version (purecopy (concat emacs-version " XEmacs Lucid (beta91)"))) (defconst emacs-major-version (progn (or (string-match "^[0-9]+" emacs-version) diff -r ad457d5f7d04 -r 0293115a14e9 lisp/viper/Makefile --- a/lisp/viper/Makefile Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/viper/Makefile Mon Aug 13 08:49:20 2007 +0200 @@ -26,9 +26,9 @@ # --------- ONLY AUTHORIZED PERSONNEL BEYOND THIS POINT!!! ------------ VIPER = viper.el viper-util.el viper-mous.el viper-ex.el \ - viper-macs.el viper-keym.el + viper-macs.el viper-keym.el viper-init.el VIPERelc = viper-util.elc viper-mous.elc viper-ex.elc viper-macs.elc \ - viper-keym.elc viper.elc + viper-keym.elc viper.elc viper-init.elc all: dvi info hello elc goodbye @@ -89,27 +89,31 @@ @echo "" $(TeX) viperCard.tex -viper-util.elc: viper-util.el +viper-init.elc: viper-init.el + @echo "" + $(EMACS) -batch -f batch-byte-compile viper-init.el + +viper-util.elc: viper-util.el viper-init.el @echo "" $(EMACS) -batch -f batch-byte-compile viper-util.el -viper-ex.elc: viper-ex.el viper-util.el +viper-ex.elc: viper-ex.el viper-util.el viper-init.el @echo "" $(EMACS) -batch -f batch-byte-compile viper-ex.el -viper-mous.elc: viper-mous.el viper-util.el +viper-mous.elc: viper-mous.el viper-util.el viper-init.el @echo "" $(EMACS) -batch -f batch-byte-compile viper-mous.el -viper-macs.elc: viper-macs.el viper-util.el +viper-macs.elc: viper-macs.el viper-util.el viper-init.el @echo "" $(EMACS) -batch -f batch-byte-compile viper-macs.el -viper-keym.elc: viper-keym.el viper-util.el +viper-keym.elc: viper-keym.el viper-util.el viper-init.el @echo "" $(EMACS) -batch -f batch-byte-compile viper-keym.el -viper.elc: viper.el viper-util.el +viper.elc: viper.el viper-util.el viper-init.el @echo "" $(EMACS) -batch -f batch-byte-compile viper.el diff -r ad457d5f7d04 -r 0293115a14e9 lisp/viper/README --- a/lisp/viper/README Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/viper/README Mon Aug 13 08:49:20 2007 +0200 @@ -8,6 +8,7 @@ viper.el -- Viper Emacs Lisp code viper-macs.el -- Viper Emacs Lisp code viper-ex.el -- Viper Emacs Lisp code +viper-init.el -- Viper Emacs Lisp code viper-util.el -- Viper Emacs Lisp code viper-mous.el -- Viper Emacs Lisp code viper-keym.el -- Viper Emacs Lisp code @@ -75,41 +76,7 @@ mentioned in LISPDIR, INFODIR, and ETCDIR. 6. XEmacs users must invoke make with the parameter EMACS=xemacs - or whatever name is used to invoke XEmacs (some sites still use xemacs - for Emacs 18). An even better thing would be to edit Makefile directly - as indicated in the comments there. - -For manual installation, copy viper.elc into a directory on your load-path. - -To install on-line documentation, you need to install the Info files -by copying the files - -viper.info* - -into your Info directory (which is emacs-root-dir/info, -if emacs-root-dir is the root directory of the installation). - -Then edit the file - -emacs-root-dir/info/dir + or whatever name is used to invoke XEmacs (some backward sites + still use xemacs for Emacs 18). An even better thing would be to + edit Makefile directly as indicated in the comments there. -to include the root menu item for Viper (check how other menu -items look like in this file). - -In Emacs, this item should look like this: - -* Viper: (viper.info). A VI Plan to Rescue Emacs and a venomous VI PERil - -In XEmacs, it should look like: - -* Viper:: A VI Plan to Rescue Emacs and a venomous VI PERil - - -If you need a hard copy of the documentation, the files - -viper.dvi -viperCard.dvi - -contain the Viper manual and the quick reference card, respectively. - - diff -r ad457d5f7d04 -r 0293115a14e9 lisp/viper/viper-ex.el --- a/lisp/viper/viper-ex.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/viper/viper-ex.el Mon Aug 13 08:49:20 2007 +0200 @@ -1,6 +1,6 @@ ;;; viper-ex.el --- functions implementing the Ex commands for Viper -;; Copyright (C) 1994, 1995, 1996 Free Software Foundation, Inc. +;; Copyright (C) 1994, 1995, 1996, 1997 Free Software Foundation, Inc. ;; This file is part of GNU Emacs. @@ -36,15 +36,16 @@ (defvar vip-case-fold-search) (eval-when-compile - (let ((load-path (cons "." load-path))) + (let ((load-path (cons (expand-file-name ".") load-path))) (or (featurep 'viper-util) (load "viper-util.el" nil nil 'nosuffix)) (or (featurep 'viper-keym) (load "viper-keym.el" nil nil 'nosuffix)) + (or (featurep 'viper) + (load "viper.el" nil nil 'nosuffix)) )) ;; end pacifier - (require 'viper-util) @@ -657,7 +658,8 @@ ;; Get an ex-address as a marker and set ex-flag if a flag is found (defun vip-get-ex-address () - (let ((address (point-marker)) (cont t)) + (let ((address (point-marker)) + (cont t)) (setq ex-token "") (setq ex-flag nil) (while cont @@ -1872,7 +1874,11 @@ (defun ex-write (q-flag) (vip-default-ex-addresses t) (vip-get-ex-file) - (let ((end (car ex-addresses)) (beg (car (cdr ex-addresses))) + (let ((end (car ex-addresses)) + (beg (car (cdr ex-addresses))) + (orig-buf (current-buffer)) + (orig-buf-file-name (buffer-file-name)) + (buff-changed-p (buffer-modified-p)) temp-buf writing-same-file region file-exists writing-whole-file) (if (> beg end) (error vip-FirstAddrExceedsSecond)) @@ -1895,8 +1901,9 @@ buffer-file-name (not (file-directory-p buffer-file-name))) (setq ex-file - (concat ex-file (file-name-nondirectory buffer-file-name)))) - + (concat (file-name-as-directory ex-file) + (file-name-nondirectory buffer-file-name)))) + (setq file-exists (file-exists-p ex-file) writing-same-file (string= ex-file (buffer-file-name))) @@ -1904,34 +1911,52 @@ (if (not (buffer-modified-p)) (message "(No changes need to be saved)") (save-buffer) - (ex-write-info file-exists ex-file beg end)) - ;; writing some other file or portion of the currents - ;; file---create temp buffer for it - ;; disable undo in that buffer, for efficiency - (buffer-disable-undo (setq temp-buf (create-file-buffer ex-file))) - (unwind-protect - (save-excursion - (if (and file-exists - (not writing-same-file) - (not (yes-or-no-p - (format "File %s exists. Overwrite? " ex-file)))) - (error "Quit") - (vip-enlarge-region beg end) - (setq region (buffer-substring (point) (mark t))) - (set-buffer temp-buf) - (set-visited-file-name ex-file) - (erase-buffer) - (if (and file-exists ex-append) - (insert-file-contents ex-file)) - (goto-char (point-max)) - (insert region) - (save-buffer) - (ex-write-info file-exists ex-file (point-min) (point-max)) - )) - (set-buffer temp-buf) - (set-buffer-modified-p nil) - (kill-buffer temp-buf) - )) + (save-restriction + (widen) + (ex-write-info file-exists ex-file (point-min) (point-max)) + )) + ;; writing some other file or portion of the current file + (cond ((and file-exists + (not writing-same-file) + (not (yes-or-no-p + (format "File %s exists. Overwrite? " ex-file)))) + (error "Quit")) + ((and writing-whole-file (not ex-append)) + (unwind-protect + (progn + (set-visited-file-name ex-file) + (set-buffer-modified-p t) + (save-buffer)) + ;; restore the buffer file name + (set-visited-file-name orig-buf-file-name) + (set-buffer-modified-p buff-changed-p)) + (save-restriction + (widen) + (ex-write-info + file-exists ex-file (point-min) (point-max)))) + (t ; writing a region + (unwind-protect + (save-excursion + (vip-enlarge-region beg end) + (setq region (buffer-substring (point) (mark t))) + ;; create temp buffer for the region + (setq temp-buf (get-buffer-create " *ex-write*")) + (set-buffer temp-buf) + (set-visited-file-name ex-file 'noquerry) + (erase-buffer) + (if (and file-exists ex-append) + (insert-file-contents ex-file)) + (goto-char (point-max)) + (insert region) + (save-buffer) + (ex-write-info + file-exists ex-file (point-min) (point-max)) + )) + (set-buffer temp-buf) + (set-buffer-modified-p nil) + (kill-buffer temp-buf)) + )) + (set-buffer orig-buf) ;; this prevents the loss of data if writing part of the buffer (if (and (buffer-file-name) writing-same-file) (set-visited-file-modtime)) diff -r ad457d5f7d04 -r 0293115a14e9 lisp/viper/viper-init.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/viper/viper-init.el Mon Aug 13 08:49:20 2007 +0200 @@ -0,0 +1,674 @@ +;;; viper-init.el --- some common definitions for Viper + +;; Copyright (C) 1997 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;; Code + +(provide 'viper-init) + +;; compiler pacifier +(defvar mark-even-if-inactive) +;; end pacifier + +;; Is it XEmacs? +(defconst vip-xemacs-p (string-match "\\(Lucid\\|XEmacs\\)" emacs-version)) +;; Is it Emacs? +(defconst vip-emacs-p (not vip-xemacs-p)) +;; Tell whether we are running as a window application or on a TTY +(defsubst vip-device-type () + (if vip-emacs-p + window-system + (device-type (selected-device)))) +;; in XEmacs: device-type is tty on tty and stream in batch. +(defun vip-window-display-p () + (and (vip-device-type) (not (memq (vip-device-type) '(tty stream pc))))) + +(defvar vip-ms-style-os-p (memq system-type '(ms-dos windows-nt windows-95)) + "Tells if Emacs is running under an MS-style OS: ms-dos, windows-nt, W95.") +(defvar vip-vms-os-p (memq system-type '(vax-vms axp-vms)) + "Tells if Emacs is running under VMS.") + +(defvar vip-force-faces nil + "If t, Viper will think that it is running on a display that supports faces. +This is provided as a temporary relief for users of face-capable displays +that Viper doesn't know about.") + +(defun vip-has-face-support-p () + (cond ((vip-window-display-p)) + (vip-force-faces) + (vip-emacs-p (memq (vip-device-type) '(pc))) + (vip-xemacs-p (memq (vip-device-type) '(tty pc))))) + +(defun vip-convert-standard-file-name (fname) + (if vip-emacs-p + (convert-standard-filename fname) + ;; hopefully, XEmacs adds this functionality + fname)) + + +;;; Macros + +(defmacro vip-deflocalvar (var default-value &optional documentation) + (` (progn + (defvar (, var) (, default-value) + (, (format "%s\n\(buffer local\)" documentation))) + (make-variable-buffer-local '(, var)) + ))) + +(defmacro vip-loop (count body) + "(vip-loop COUNT BODY) Execute BODY COUNT times." + (list 'let (list (list 'count count)) + (list 'while '(> count 0) + body + '(setq count (1- count)) + ))) + +(defmacro vip-buffer-live-p (buf) + (` (and (, buf) (get-buffer (, buf)) (buffer-name (get-buffer (, buf)))))) + +;; return buffer-specific macro definition, given a full macro definition +(defmacro vip-kbd-buf-alist (macro-elt) + (` (nth 1 (, macro-elt)))) +;; get a pair: (curr-buffer . macro-definition) +(defmacro vip-kbd-buf-pair (macro-elt) + (` (assoc (buffer-name) (vip-kbd-buf-alist (, macro-elt))))) +;; get macro definition for current buffer +(defmacro vip-kbd-buf-definition (macro-elt) + (` (cdr (vip-kbd-buf-pair (, macro-elt))))) + +;; return mode-specific macro definitions, given a full macro definition +(defmacro vip-kbd-mode-alist (macro-elt) + (` (nth 2 (, macro-elt)))) +;; get a pair: (major-mode . macro-definition) +(defmacro vip-kbd-mode-pair (macro-elt) + (` (assoc major-mode (vip-kbd-mode-alist (, macro-elt))))) +;; get macro definition for the current major mode +(defmacro vip-kbd-mode-definition (macro-elt) + (` (cdr (vip-kbd-mode-pair (, macro-elt))))) + +;; return global macro definition, given a full macro definition +(defmacro vip-kbd-global-pair (macro-elt) + (` (nth 3 (, macro-elt)))) +;; get global macro definition from an elt of macro-alist +(defmacro vip-kbd-global-definition (macro-elt) + (` (cdr (vip-kbd-global-pair (, macro-elt))))) + +;; last elt of a sequence +(defsubst vip-seq-last-elt (seq) + (elt seq (1- (length seq)))) + + +(defvar vip-minibuffer-overlay-priority 300) +(defvar vip-replace-overlay-priority 400) +(defvar vip-search-overlay-priority 500) + + +;;; Viper minor modes + +;; This is not local in Emacs, so we make it local. +;; This must be local because although the stack of minor modes can be the same +;; for all buffers, the associated *keymaps* can be different. In Viper, +;; vip-vi-local-user-map, vip-insert-local-user-map, and others can have +;; different keymaps for different buffers. +;; Also, the keymaps associated with vip-vi/insert-state-modifier-minor-mode +;; can be different. +(make-variable-buffer-local 'minor-mode-map-alist) + +;; Mode for vital things like \e, C-z. +(vip-deflocalvar vip-vi-intercept-minor-mode nil) + +(vip-deflocalvar vip-vi-basic-minor-mode nil + "Viper's minor mode for Vi bindings.") + +(vip-deflocalvar vip-vi-local-user-minor-mode nil + "Auxiliary minor mode for user-defined local bindings in Vi state.") + +(vip-deflocalvar vip-vi-global-user-minor-mode nil + "Auxiliary minor mode for user-defined global bindings in Vi state.") + +(vip-deflocalvar vip-vi-state-modifier-minor-mode nil + "Minor mode used to make major-mode-specific modification to Vi state.") + +(vip-deflocalvar vip-vi-diehard-minor-mode nil + "This minor mode is in effect when the user wants Viper to be Vi.") + +(vip-deflocalvar vip-vi-kbd-minor-mode nil + "Minor mode for Ex command macros in Vi state. +The corresponding keymap stores key bindings of Vi macros defined with +the Ex command :map.") + +;; Mode for vital things like \e, C-z. +(vip-deflocalvar vip-insert-intercept-minor-mode nil) + +(vip-deflocalvar vip-insert-basic-minor-mode nil + "Viper's minor mode for bindings in Insert mode.") + +(vip-deflocalvar vip-insert-local-user-minor-mode nil + "Auxiliary minor mode for buffer-local user-defined bindings in Insert state. +This is a way to overshadow normal Insert mode bindings locally to certain +designated buffers.") + +(vip-deflocalvar vip-insert-global-user-minor-mode nil + "Auxiliary minor mode for global user-defined bindings in Insert state.") + +(vip-deflocalvar vip-insert-state-modifier-minor-mode nil + "Minor mode used to make major-mode-specific modification to Insert state.") + +(vip-deflocalvar vip-insert-diehard-minor-mode nil + "Minor mode that simulates Vi very closely. +Not recommened, except for the novice user.") + +(vip-deflocalvar vip-insert-kbd-minor-mode nil +"Minor mode for Ex command macros Insert state. +The corresponding keymap stores key bindings of Vi macros defined with +the Ex command :map!.") + +(vip-deflocalvar vip-replace-minor-mode nil + "Minor mode in effect in replace state (cw, C, and the like commands).") + +;; Mode for vital things like \C-z and \C-x) +;; This is t, by default. So, any new buffer will have C-z defined as +;; switch to Vi, unless we switched states in this buffer +(vip-deflocalvar vip-emacs-intercept-minor-mode t) + +(vip-deflocalvar vip-emacs-local-user-minor-mode t + "Minor mode for local user bindings effective in Emacs state. +Users can use it to override Emacs bindings when Viper is in its Emacs +state.") + +(vip-deflocalvar vip-emacs-global-user-minor-mode t + "Minor mode for global user bindings in effect in Emacs state. +Users can use it to override Emacs bindings when Viper is in its Emacs +state.") + +(vip-deflocalvar vip-emacs-kbd-minor-mode t + "Minor mode for Vi style macros in Emacs state. +The corresponding keymap stores key bindings of Vi macros defined with +`vip-record-kbd-macro' command. There is no Ex-level command to do this +interactively.") + +(vip-deflocalvar vip-emacs-state-modifier-minor-mode t + "Minor mode used to make major-mode-specific modification to Emacs state. +For instance, a Vi purist may want to bind `dd' in Dired mode to a function +that deletes a file.") + +(vip-deflocalvar vip-vi-minibuffer-minor-mode nil + "Minor mode that forces Vi-style when the Minibuffer is in Vi state.") + +(vip-deflocalvar vip-insert-minibuffer-minor-mode nil + "Minor mode that forces Vi-style when the Minibuffer is in Insert state.") + + + +;; Some common error messages + +(defconst vip-SpuriousText "Spurious text after command" "") +(defconst vip-BadExCommand "Not an editor command" "") +(defconst vip-InvalidCommandArgument "Invalid command argument" "") +(defconst vip-NoPrevSearch "No previous search string" "") +(defconst vip-EmptyRegister "`%c': Nothing in this register" "") +(defconst vip-InvalidRegister "`%c': Invalid register" "") +(defconst vip-EmptyTextmarker "`%c': Text marker doesn't point anywhere" "") +(defconst vip-InvalidTextmarker "`%c': Invalid text marker" "") +(defconst vip-InvalidViCommand "Invalid command" "") +(defconst vip-BadAddress "Ill-formed address" "") +(defconst vip-FirstAddrExceedsSecond "First address exceeds second" "") +(defconst vip-NoFileSpecified "No file specified" "") + +;; Is t until viper-mode executes for the very first time. +;; Prevents recursive descend into startup messages. +(defvar vip-first-time t) + +(defvar vip-expert-level 0 + "User's expert level. +The minor mode vip-vi-diehard-minor-mode is in effect when +vip-expert-level is 1 or 2 or when vip-want-emacs-keys-in-vi is t. +The minor mode vip-insert-diehard-minor-mode is in effect when +vip-expert-level is 1 or 2 or if vip-want-emacs-keys-in-insert is t. +Use `M-x vip-set-expert-level' to change this.") + +;; Max expert level supported by Viper. This is NOT a user option. +;; It is here to make it hard for the user from resetting it. +(defconst vip-max-expert-level 5) + +;; Contains user settings for vars affected by vip-set-expert-level function. +;; Not a user option. +(defvar vip-saved-user-settings nil) + + +;;; ISO characters + +(vip-deflocalvar vip-automatic-iso-accents nil + "*If non-nil, ISO accents will be turned on in insert/replace emacs states and turned off in vi-state. +For some users, this behavior may be too primitive. In this case, use +insert/emacs/vi state hooks.") + + +;; VI-style Undo + +;; Used to 'undo' complex commands, such as replace and insert commands. +(vip-deflocalvar vip-undo-needs-adjustment nil) +(put 'vip-undo-needs-adjustment 'permanent-local t) + +;; A mark that Viper puts on buffer-undo-list. Marks the beginning of a +;; complex command that must be undone atomically. If inserted, it is +;; erased by vip-change-state-to-vi and vip-repeat. +(defconst vip-buffer-undo-list-mark 'viper) + +(defvar vip-keep-point-on-undo nil + "*Non-nil means not to move point while undoing commands. +This style is different from Emacs and Vi. Try it to see if +it better fits your working style.") + +;; Replace mode and changing text + +;; Viper's own after/before change functions, which get vip-add-hook'ed to +;; Emacs's +(vip-deflocalvar vip-after-change-functions nil "") +(vip-deflocalvar vip-before-change-functions nil "") +(vip-deflocalvar vip-post-command-hooks nil "") +(vip-deflocalvar vip-pre-command-hooks nil "") + +;; Can be used to pass global states around for short period of time +(vip-deflocalvar vip-intermediate-command nil "") + +;; Indicates that the current destructive command has started in replace mode. +(vip-deflocalvar vip-began-as-replace nil "") + +(defvar vip-allow-multiline-replace-regions t + "If non-nil, Viper will allow multi-line replace regions. +This is an extension to standard Vi. +If nil, commands that attempt to replace text spanning multiple lines first +delete the text being replaced, as in standard Vi.") + +(defvar vip-replace-overlay-cursor-color "Red" + "*Cursor color to use in Replace state") +(defvar vip-insert-state-cursor-color nil + "Cursor color for Viper insert state.") +(put 'vip-insert-state-cursor-color 'permanent-local t) +;; place to save cursor colow when switching to insert mode +(vip-deflocalvar vip-saved-cursor-color nil "") + +(vip-deflocalvar vip-replace-overlay nil "") +(put 'vip-replace-overlay 'permanent-local t) + +(defvar vip-replace-overlay-pixmap "gray3" + "Pixmap to use for search face on non-color displays.") +(defvar vip-search-face-pixmap "gray3" + "Pixmap to use for search face on non-color displays.") + + +(defvar vip-replace-region-end-delimiter "$" + "A string marking the end of replacement regions. +It is used only with TTYs or if `vip-use-replace-region-delimiters' +is non-nil.") +(defvar vip-replace-region-start-delimiter "" + "A string marking the beginning of replacement regions. +It is used only with TTYs or if `vip-use-replace-region-delimiters' +is non-nil.") +(defvar vip-use-replace-region-delimiters (not (vip-has-face-support-p)) + "*If non-nil, Viper will always use `vip-replace-region-end-delimiter' and +`vip-replace-region-start-delimiter' to delimit replacement regions, even on +color displays. By default, the delimiters are used only on TTYs.") + +;; XEmacs requires glyphs +(if vip-xemacs-p + (progn + (or (glyphp vip-replace-region-end-delimiter) + (setq vip-replace-region-end-delimiter + (make-glyph vip-replace-region-end-delimiter))) + (or (glyphp vip-replace-region-start-delimiter) + (setq vip-replace-region-start-delimiter + (make-glyph vip-replace-region-start-delimiter))) + )) + + +;; These are local marker that must be initialized to nil and moved with +;; `vip-move-marker-locally' +;; +;; Remember the last position inside the replace region. +(vip-deflocalvar vip-last-posn-in-replace-region nil) +;; Remember the last position while inserting +(vip-deflocalvar vip-last-posn-while-in-insert-state nil) +(put 'vip-last-posn-in-replace-region 'permanent-local t) +(put 'vip-last-posn-while-in-insert-state 'permanent-local t) + +(vip-deflocalvar vip-sitting-in-replace nil "") +(put 'vip-sitting-in-replace 'permanent-local t) + +;; Remember the number of characters that have to be deleted in replace +;; mode to compensate for the inserted characters. +(vip-deflocalvar vip-replace-chars-to-delete 0 "") +(vip-deflocalvar vip-replace-chars-deleted 0 "") + +;; Insertion ring and command ring +(defvar vip-insertion-ring-size 14 + "The size of the insertion ring.") +;; The insertion ring. +(defvar vip-insertion-ring nil) +;; This is temp insertion ring. Used to do rotation for display purposes. +;; When rotation just started, it is initialized to vip-insertion-ring. +(defvar vip-temp-insertion-ring nil) +(defvar vip-last-inserted-string-from-insertion-ring "") + +(defvar vip-command-ring-size 14 + "The size of the command ring.") +;; The command ring. +(defvar vip-command-ring nil) +;; This is temp command ring. Used to do rotation for display purposes. +;; When rotation just started, it is initialized to vip-command-ring. +(defvar vip-temp-command-ring nil) + +;; Modes and related variables + +;; Current mode. One of: `emacs-state', `vi-state', `insert-state' +(vip-deflocalvar vip-current-state 'emacs-state) + + +;; Autoindent in insert + +;; Variable that keeps track of whether C-t has been pressed. +(vip-deflocalvar vip-cted nil "") + +;; Preserve the indent value, used by C-d in insert mode. +(vip-deflocalvar vip-current-indent 0) + +;; Whether to preserve the indent, used by C-d in insert mode. +(vip-deflocalvar vip-preserve-indent nil) + +(vip-deflocalvar vip-auto-indent nil + "*Autoindent if t.") +(vip-deflocalvar vip-electric-mode t + "*If t, enable electric behavior. +Currently only enables auto-indentation `according to mode'.") + +(defconst vip-shift-width 8 + "*The shiftwidth variable.") + +;; Variables for repeating destructive commands + +(defconst vip-keep-point-on-repeat t + "*If t, don't move point when repeating previous command. +This is useful for doing repeated changes with the '.' key. +The user can change this to nil, if she likes when the cursor moves +to a new place after repeating previous Vi command.") + +;; Remember insert point as a marker. This is a local marker that must be +;; initialized to nil and moved with `vip-move-marker-locally'. +(vip-deflocalvar vip-insert-point nil) +(put 'vip-insert-point 'permanent-local t) + +;; This remembers the point before dabbrev-expand was called. +;; If vip-insert-point turns out to be bigger than that, it is reset +;; back to vip-pre-command-point. +;; The reason this is needed is because dabbrev-expand (and possibly +;; others) may jump to before the insertion point, delete something and +;; then reinsert a bigger piece. For instance: bla^blo +;; If dabbrev-expand is called after `blo' and ^ undicates vip-insert-point, +;; then point jumps to the beginning of `blo'. If expansion is found, `blablo' +;; is deleted, and we have |^, where | denotes point. Next, dabbrev-expand +;; will insert the expansion, and we get: blablo^ +;; Whatever we insert next goes before the ^, i.e., before the +;; vip-insert-point marker. So, Viper will think that nothing was +;; inserted. Remembering the orig position of the marker circumvents the +;; problem. +;; We don't know of any command, except dabbrev-expand, that has the same +;; problem. However, the same trick can be used if such a command is +;; discovered later. +;; +(vip-deflocalvar vip-pre-command-point nil) +(put 'vip-pre-command-point 'permanent-local t) ; this is probably an overkill + +;; This is used for saving inserted text. +(defvar vip-last-insertion nil) + +;; Remembers the last replaced region. +(defvar vip-last-replace-region "") + +;; Remember com point as a marker. +;; This is a local marker. Should be moved with `vip-move-marker-locally' +(vip-deflocalvar vip-com-point nil) + +;; If non-nil, the value is a list (M-COM VAL COM REG inserted-text cmd-keys) +;; It is used to re-execute last destructive command. +;; M-COM is a Lisp symbol representing the function to be executed. +;; VAL is the prefix argument that was used with that command. +;; COM is an internal descriptor, such as ?r, ?c, ?C, which contains +;; additional information on how the function in M-COM is to be handled. +;; REG is the register used by command +;; INSERTED-TEXT is text inserted by that command (in case of o, c, C, i, r +;; commands). +;; COMMAND-KEYS are the keys that were typed to invoke the command. +(defvar vip-d-com nil) + +;; The character remembered by the Vi `r' command. +(defvar vip-d-char nil) + +;; Name of register to store deleted or yanked strings +(defvar vip-use-register nil) + + + +;; Variables for Moves and Searches + +;; For use by `;' command. +(defvar vip-f-char nil) + +;; For use by `.' command. +(defvar vip-F-char nil) + +;; For use by `;' command. +(defvar vip-f-forward nil) + +;; For use by `;' command. +(defvar vip-f-offset nil) + +;; Last search string +(defvar vip-s-string "") + +(defvar vip-quote-string "> " + "String inserted at the beginning of quoted region.") + +;; If t, search is forward. +(defvar vip-s-forward nil) + +(defconst vip-case-fold-search nil + "*If not nil, search ignores cases.") + +(defconst vip-re-search t + "*If not nil, search is reg-exp search, otherwise vanilla search.") + +(defvar vip-search-scroll-threshold 2 + "*If search lands within this threshnold from the window top/bottom, +the window will be scrolled up or down appropriately, to reveal context. +If you want Viper search to behave as usual in Vi, set this variable to a +negative number.") + +(defconst vip-re-query-replace t + "*If t then do regexp replace, if nil then do string replace.") + +(defconst vip-re-replace t + "*If t, do regexp replace. nil means do string replace.") + +(vip-deflocalvar vip-ex-style-motion t + "*Ex-style: the commands l,h do not cross lines, etc.") + +(vip-deflocalvar vip-ex-style-editing-in-insert t + "*The keys ^H, ^? don't jump lines in insert, ESC moves cursor back, etc. +Note: this doesn't preclude ^H and ^? from deleting characters by moving +past the insertion point. This is a feature, not a bug. ") + +(vip-deflocalvar vip-delete-backwards-in-replace nil + "*If t, DEL key will delete characters while moving the cursor backwards. +If nil, the cursor will move backwards without deleting anything.") + +(defconst vip-buffer-search-char nil + "*Key bound for buffer-searching.") + +(defconst vip-search-wrap-around-t t + "*If t, search wraps around.") + +(vip-deflocalvar vip-related-files-and-buffers-ring nil + "*Ring of file and buffer names that are considered to be related to the +current buffer. +These buffers can be cycled through via :R and :P commands.") +(put 'vip-related-files-and-buffers-ring 'permanent-local t) + +;; Used to find out if we are done with searching the current buffer. +(vip-deflocalvar vip-local-search-start-marker nil) +;; As above, but global +(defvar vip-search-start-marker (make-marker)) + +;; the search overlay +(vip-deflocalvar vip-search-overlay nil) + + +(defvar vip-heading-start + (concat "^\\s-*(\\s-*defun\\s-\\|" ; lisp + "^{\\s-*$\\|^[_a-zA-Z][^()]*[()].*{\\s-*$\\|" ; C/C++ + "^\\s-*class.*{\\|^\\s-*struct.*{\\|^\\s-*enum.*{\\|" + "^\\\\[sb][a-z]*{.*}\\s-*$\\|" ; latex + "^@node\\|@table\\|^@m?enu\\|^@itemize\\|^@if\\|" ; texinfo + "^.+:-") ; prolog + "*Regexps for Headings. Used by \[\[ and \]\].") + +(defvar vip-heading-end + (concat "^}\\|" ; C/C++ + "^\\\\end{\\|" ; latex + "^@end \\|" ; texinfo + ")\n\n[ \t\n]*\\|" ; lisp + "\\.\\s-*$") ; prolog + "*Regexps to end Headings/Sections. Used by \[\].") + + +;; These two vars control the interaction of jumps performed by ' and `. +;; In this new version, '' doesn't erase the marks set by ``, so one can +;; use both kinds of jumps interchangeably and without loosing positions +;; inside the lines. + +;; Remembers position of the last jump done using ``'. +(vip-deflocalvar vip-last-jump nil) +;; Remembers position of the last jump done using `''. +(vip-deflocalvar vip-last-jump-ignore 0) + +;; History variables + +;; History of search strings. +(defvar vip-search-history (list "")) +;; History of query-replace strings used as a source. +(defvar vip-replace1-history nil) +;; History of query-replace strings used as replacement. +(defvar vip-replace2-history nil) +;; History of region quoting strings. +(defvar vip-quote-region-history (list vip-quote-string)) +;; History of Ex-style commands. +(defvar vip-ex-history nil) +;; History of shell commands. +(defvar vip-shell-history nil) + + +;; Last shell command. There are two of these, one for Ex (in viper-ex) +;; and one for Vi. + +;; Last shell command executed with ! command. +(defvar vip-last-shell-com nil) + + + +;;; Miscellaneous + +;; don't bark when mark is inactive +(setq mark-even-if-inactive t) + +(defvar vip-inhibit-startup-message nil + "Whether Viper startup message should be inhibited.") + +(defvar vip-always t + "t means, arrange that vi-state will be a default.") + +(defvar vip-custom-file-name (vip-convert-standard-file-name "~/.vip") + "Viper customisation file. +This variable must be set _before_ loading Viper.") + + +(defvar vip-spell-function 'ispell-region + "Spell function used by #s command to spell.") + +(defvar vip-tags-file-name "TAGS" + "The tags file used by Viper.") + +;; Indicates if we are in the middle of executing a command that takes another +;; command as an argument, e.g., cw, dw, etc. +(defvar vip-inside-command-argument-action nil) + +;; Minibuffer + +(defvar vip-vi-style-in-minibuffer t + "If t, use vi-style editing in minibuffer. +Should be set in `~/.vip' file.") + +;; overlay used in the minibuffer to indicate which state it is in +(vip-deflocalvar vip-minibuffer-overlay nil) + +;; Hook, specific to Viper, which is run just *before* exiting the minibuffer. +;; Beginning with Emacs 19.26, the standard `minibuffer-exit-hook' is run +;; *after* exiting the minibuffer +(defvar vip-minibuffer-exit-hook nil) + +;; setup emacs-supported vi-style feel +(setq next-line-add-newlines nil + require-final-newline t) + +(make-variable-buffer-local 'require-final-newline) + + +;; Mode line +(defconst vip-vi-state-id " " + "Mode line tag identifying the Vi mode of Viper.") +(defconst vip-emacs-state-id " " + "Mode line tag identifying the Emacs mode of Viper.") +(defconst vip-insert-state-id " " + "Mode line tag identifying the Insert mode of Viper.") +(defconst vip-replace-state-id " " + "Mode line tag identifying the Replace mode of Viper.") + +;; Viper changes the default mode-line-buffer-identification +(setq-default mode-line-buffer-identification '(" %b")) + +;; Variable displaying the current Viper state in the mode line. +(vip-deflocalvar vip-mode-string vip-emacs-state-id) +(or (memq 'vip-mode-string global-mode-string) + (setq global-mode-string + (append '("" vip-mode-string) (cdr global-mode-string)))) + + +(defvar vip-vi-state-hook nil + "*Hooks run just before the switch to Vi mode is completed.") +(defvar vip-insert-state-hook nil + "*Hooks run just before the switch to Insert mode is completed.") +(defvar vip-replace-state-hook nil + "*Hooks run just before the switch to Replace mode is completed.") +(defvar vip-emacs-state-hook nil + "*Hooks run just before the switch to Emacs mode is completed.") + +(defvar vip-load-hook nil + "Hooks run just after loading Viper.") + +;;; viper-ex.el ends here diff -r ad457d5f7d04 -r 0293115a14e9 lisp/viper/viper-keym.el --- a/lisp/viper/viper-keym.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/viper/viper-keym.el Mon Aug 13 08:49:20 2007 +0200 @@ -1,6 +1,6 @@ ;;; viper-keym.el --- Viper keymaps -;; Copyright (C) 1994, 1995, 1996 Free Software Foundation, Inc. +;; Copyright (C) 1994, 1995, 1996, 1997 Free Software Foundation, Inc. ;; This file is part of GNU Emacs. @@ -32,7 +32,7 @@ (defvar vip-ex-style-motion) (eval-when-compile - (let ((load-path (cons "." load-path))) + (let ((load-path (cons (expand-file-name ".") load-path))) (or (featurep 'viper-util) (load "viper-util.el" nil nil 'nosuffix)) )) @@ -40,6 +40,7 @@ (require 'viper-util) + ;;; Variables (defvar vip-toggle-key "\C-z" @@ -239,8 +240,8 @@ ;; Replace keymap (define-key vip-replace-map "\C-t" 'vip-forward-indent) -(define-key vip-replace-map "\C-j" 'vip-replace-state-exit-cmd) -(define-key vip-replace-map "\C-m" 'vip-replace-state-exit-cmd) +(define-key vip-replace-map "\C-j" 'vip-replace-state-carriage-return) +(define-key vip-replace-map "\C-m" 'vip-replace-state-carriage-return) (define-key vip-replace-map "\C-?" 'vip-del-backward-char-in-replace) diff -r ad457d5f7d04 -r 0293115a14e9 lisp/viper/viper-macs.el --- a/lisp/viper/viper-macs.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/viper/viper-macs.el Mon Aug 13 08:49:20 2007 +0200 @@ -1,6 +1,6 @@ ;;; viper-macs.el --- functions implementing keyboard macros for Viper -;; Copyright (C) 1994, 1995, 1996 Free Software Foundation, Inc. +;; Copyright (C) 1994, 1995, 1996, 1997 Free Software Foundation, Inc. ;; This file is part of GNU Emacs. @@ -29,13 +29,15 @@ (defvar vip-current-state) (eval-when-compile - (let ((load-path (cons "." load-path))) + (let ((load-path (cons (expand-file-name ".") load-path))) (or (featurep 'viper-util) (load "viper-util.el" nil nil 'nosuffix)) (or (featurep 'viper-keym) (load "viper-keym.el" nil nil 'nosuffix)) (or (featurep 'viper-mous) (load "viper-mous.el" nil nil 'nosuffix)) + (or (featurep 'viper) + (load "viper.el" nil nil 'nosuffix)) )) ;; end pacifier diff -r ad457d5f7d04 -r 0293115a14e9 lisp/viper/viper-mous.el --- a/lisp/viper/viper-mous.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/viper/viper-mous.el Mon Aug 13 08:49:20 2007 +0200 @@ -1,6 +1,6 @@ ;;; viper-mous.el --- mouse support for Viper -;; Copyright (C) 1994, 1995, 1996 Free Software Foundation, Inc. +;; Copyright (C) 1994, 1995, 1996, 1997 Free Software Foundation, Inc. ;; This file is part of GNU Emacs. @@ -33,14 +33,17 @@ (defvar vip-re-search) (eval-when-compile - (let ((load-path (cons "." load-path))) + (let ((load-path (cons (expand-file-name ".") load-path))) (or (featurep 'viper-util) (load "viper-util.el" nil nil 'nosuffix)) + (or (featurep 'viper) + (load "viper.el" nil nil 'nosuffix)) )) ;; end pacifier (require 'viper-util) + ;;; Variables diff -r ad457d5f7d04 -r 0293115a14e9 lisp/viper/viper-util.el --- a/lisp/viper/viper-util.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/viper/viper-util.el Mon Aug 13 08:49:20 2007 +0200 @@ -1,6 +1,6 @@ ;;; viper-util.el --- Utilities used by viper.el -;; Copyright (C) 1994, 1995, 1996 Free Software Foundation, Inc. +;; Copyright (C) 1994, 1995, 1996, 1997 Free Software Foundation, Inc. ;; This file is part of GNU Emacs. @@ -22,254 +22,32 @@ ;; Code -(require 'ring) - ;; Compiler pacifier (defvar vip-overriding-map) (defvar pm-color-alist) (defvar zmacs-region-stays) -(defvar vip-search-face) (defvar vip-minibuffer-current-face) (defvar vip-minibuffer-insert-face) (defvar vip-minibuffer-vi-face) (defvar vip-minibuffer-emacs-face) (defvar vip-replace-overlay-face) -(defvar vip-minibuffer-overlay) -(defvar vip-replace-overlay) -(defvar vip-search-overlay) -(defvar vip-replace-overlay-cursor-color) -(defvar vip-intermediate-command) -(defvar vip-use-replace-region-delimiters) (defvar vip-fast-keyseq-timeout) -(defvar vip-related-files-and-buffers-ring) -(defvar vip-saved-cursor-color) (defvar ex-unix-type-shell) (defvar ex-unix-type-shell-options) (defvar vip-ex-tmp-buf-name) + +(require 'cl) +(require 'ring) + +(and noninteractive + (eval-when-compile + (let ((load-path (cons (expand-file-name ".") load-path))) + (or (featurep 'viper-init) + (load "viper-init.el" nil nil 'nosuffix)) + ))) ;; end pacifier -;; Is it XEmacs? -(defconst vip-xemacs-p (string-match "\\(Lucid\\|XEmacs\\)" emacs-version)) -;; Is it Emacs? -(defconst vip-emacs-p (not vip-xemacs-p)) -;; Tell whether we are running as a window application or on a TTY -(defsubst vip-device-type () - (if vip-emacs-p - window-system - (device-type (selected-device)))) -;; in XEmacs: device-type is tty on tty and stream in batch. -(defun vip-window-display-p () - (and (vip-device-type) (not (memq (vip-device-type) '(tty stream pc))))) - -(defvar vip-ms-style-os-p (memq system-type '(ms-dos windows-nt windows-95)) - "Tells if Emacs is running under an MS-style OS: ms-dos, windows-nt, W95.") -(defvar vip-vms-os-p (memq system-type '(vax-vms axp-vms)) - "Tells if Emacs is running under VMS.") - -(defvar vip-force-faces nil - "If t, Viper will think that it is running on a display that supports faces. -This is provided as a temporary relief for users of face-capable displays -that Viper doesn't know about.") - -(defun vip-has-face-support-p () - (cond ((vip-window-display-p)) - (vip-force-faces) - (vip-emacs-p (memq (vip-device-type) '(pc))) - (vip-xemacs-p (memq (vip-device-type) '(tty pc))))) - - -;;; Macros - -(defmacro vip-deflocalvar (var default-value &optional documentation) - (` (progn - (defvar (, var) (, default-value) - (, (format "%s\n\(buffer local\)" documentation))) - (make-variable-buffer-local '(, var)) - ))) - -(defmacro vip-loop (count body) - "(vip-loop COUNT BODY) Execute BODY COUNT times." - (list 'let (list (list 'count count)) - (list 'while '(> count 0) - body - '(setq count (1- count)) - ))) - -(defmacro vip-buffer-live-p (buf) - (` (and (, buf) (get-buffer (, buf)) (buffer-name (get-buffer (, buf)))))) - -;; return buffer-specific macro definition, given a full macro definition -(defmacro vip-kbd-buf-alist (macro-elt) - (` (nth 1 (, macro-elt)))) -;; get a pair: (curr-buffer . macro-definition) -(defmacro vip-kbd-buf-pair (macro-elt) - (` (assoc (buffer-name) (vip-kbd-buf-alist (, macro-elt))))) -;; get macro definition for current buffer -(defmacro vip-kbd-buf-definition (macro-elt) - (` (cdr (vip-kbd-buf-pair (, macro-elt))))) - -;; return mode-specific macro definitions, given a full macro definition -(defmacro vip-kbd-mode-alist (macro-elt) - (` (nth 2 (, macro-elt)))) -;; get a pair: (major-mode . macro-definition) -(defmacro vip-kbd-mode-pair (macro-elt) - (` (assoc major-mode (vip-kbd-mode-alist (, macro-elt))))) -;; get macro definition for the current major mode -(defmacro vip-kbd-mode-definition (macro-elt) - (` (cdr (vip-kbd-mode-pair (, macro-elt))))) - -;; return global macro definition, given a full macro definition -(defmacro vip-kbd-global-pair (macro-elt) - (` (nth 3 (, macro-elt)))) -;; get global macro definition from an elt of macro-alist -(defmacro vip-kbd-global-definition (macro-elt) - (` (cdr (vip-kbd-global-pair (, macro-elt))))) - -;; last elt of a sequence -(defsubst vip-seq-last-elt (seq) - (elt seq (1- (length seq)))) - -;; Check if arg is a valid character for register -;; TYPE is a list that can contain `letter', `Letter', and `digit'. -;; Letter means lowercase letters, Letter means uppercase letters, and -;; digit means digits from 1 to 9. -;; If TYPE is nil, then down/uppercase letters and digits are allowed. -(defun vip-valid-register (reg &optional type) - (or type (setq type '(letter Letter digit))) - (or (if (memq 'letter type) - (and (<= ?a reg) (<= reg ?z))) - (if (memq 'digit type) - (and (<= ?1 reg) (<= reg ?9))) - (if (memq 'Letter type) - (and (<= ?A reg) (<= reg ?Z))) - )) - -;; checks if object is a marker, has a buffer, and points to within that buffer -(defun vip-valid-marker (marker) - (if (and (markerp marker) (marker-buffer marker)) - (let ((buf (marker-buffer marker)) - (pos (marker-position marker))) - (save-excursion - (set-buffer buf) - (and (<= pos (point-max)) (<= (point-min) pos)))))) - - -(defvar vip-minibuffer-overlay-priority 300) -(defvar vip-replace-overlay-priority 400) -(defvar vip-search-overlay-priority 500) - - -;;; Viper minor modes - -;; This is not local in Emacs, so we make it local. -;; This must be local because although the stack of minor modes can be the same -;; for all buffers, the associated *keymaps* can be different. In Viper, -;; vip-vi-local-user-map, vip-insert-local-user-map, and others can have -;; different keymaps for different buffers. -;; Also, the keymaps associated with vip-vi/insert-state-modifier-minor-mode -;; can be different. -(make-variable-buffer-local 'minor-mode-map-alist) - -;; Mode for vital things like \e, C-z. -(vip-deflocalvar vip-vi-intercept-minor-mode nil) - -(vip-deflocalvar vip-vi-basic-minor-mode nil - "Viper's minor mode for Vi bindings.") - -(vip-deflocalvar vip-vi-local-user-minor-mode nil - "Auxiliary minor mode for user-defined local bindings in Vi state.") - -(vip-deflocalvar vip-vi-global-user-minor-mode nil - "Auxiliary minor mode for user-defined global bindings in Vi state.") - -(vip-deflocalvar vip-vi-state-modifier-minor-mode nil - "Minor mode used to make major-mode-specific modification to Vi state.") - -(vip-deflocalvar vip-vi-diehard-minor-mode nil - "This minor mode is in effect when the user wants Viper to be Vi.") - -(vip-deflocalvar vip-vi-kbd-minor-mode nil - "Minor mode for Ex command macros in Vi state. -The corresponding keymap stores key bindings of Vi macros defined with -the Ex command :map.") - -;; Mode for vital things like \e, C-z. -(vip-deflocalvar vip-insert-intercept-minor-mode nil) - -(vip-deflocalvar vip-insert-basic-minor-mode nil - "Viper's minor mode for bindings in Insert mode.") - -(vip-deflocalvar vip-insert-local-user-minor-mode nil - "Auxiliary minor mode for buffer-local user-defined bindings in Insert state. -This is a way to overshadow normal Insert mode bindings locally to certain -designated buffers.") - -(vip-deflocalvar vip-insert-global-user-minor-mode nil - "Auxiliary minor mode for global user-defined bindings in Insert state.") - -(vip-deflocalvar vip-insert-state-modifier-minor-mode nil - "Minor mode used to make major-mode-specific modification to Insert state.") - -(vip-deflocalvar vip-insert-diehard-minor-mode nil - "Minor mode that simulates Vi very closely. -Not recommened, except for the novice user.") - -(vip-deflocalvar vip-insert-kbd-minor-mode nil -"Minor mode for Ex command macros Insert state. -The corresponding keymap stores key bindings of Vi macros defined with -the Ex command :map!.") - -(vip-deflocalvar vip-replace-minor-mode nil - "Minor mode in effect in replace state (cw, C, and the like commands).") - -;; Mode for vital things like \C-z and \C-x) -;; This is t, by default. So, any new buffer will have C-z defined as -;; switch to Vi, unless we switched states in this buffer -(vip-deflocalvar vip-emacs-intercept-minor-mode t) - -(vip-deflocalvar vip-emacs-local-user-minor-mode t - "Minor mode for local user bindings effective in Emacs state. -Users can use it to override Emacs bindings when Viper is in its Emacs -state.") - -(vip-deflocalvar vip-emacs-global-user-minor-mode t - "Minor mode for global user bindings in effect in Emacs state. -Users can use it to override Emacs bindings when Viper is in its Emacs -state.") - -(vip-deflocalvar vip-emacs-kbd-minor-mode t - "Minor mode for Vi style macros in Emacs state. -The corresponding keymap stores key bindings of Vi macros defined with -`vip-record-kbd-macro' command. There is no Ex-level command to do this -interactively.") - -(vip-deflocalvar vip-emacs-state-modifier-minor-mode t - "Minor mode used to make major-mode-specific modification to Emacs state. -For instance, a Vi purist may want to bind `dd' in Dired mode to a function -that deletes a file.") - -(vip-deflocalvar vip-vi-minibuffer-minor-mode nil - "Minor mode that forces Vi-style when the Minibuffer is in Vi state.") - -(vip-deflocalvar vip-insert-minibuffer-minor-mode nil - "Minor mode that forces Vi-style when the Minibuffer is in Insert state.") - - - -;; Some common error messages - -(defconst vip-SpuriousText "Spurious text after command" "") -(defconst vip-BadExCommand "Not an editor command" "") -(defconst vip-InvalidCommandArgument "Invalid command argument" "") -(defconst vip-NoPrevSearch "No previous search string" "") -(defconst vip-EmptyRegister "`%c': Nothing in this register" "") -(defconst vip-InvalidRegister "`%c': Invalid register" "") -(defconst vip-EmptyTextmarker "`%c': Text marker doesn't point anywhere" "") -(defconst vip-InvalidTextmarker "`%c': Invalid text marker" "") -(defconst vip-InvalidViCommand "Invalid command" "") -(defconst vip-BadAddress "Ill-formed address" "") -(defconst vip-FirstAddrExceedsSecond "First address exceeds second" "") -(defconst vip-NoFileSpecified "No file specified" "") +(require 'viper-init) @@ -360,7 +138,7 @@ (modify-frame-parameters (selected-frame) (list (cons 'cursor-color new-color))))) -(defsubst vip-save-cursor-color () +(defun vip-save-cursor-color () (if (and (vip-window-display-p) (vip-color-display-p)) (let ((color (vip-get-cursor-color))) (if (and (stringp color) (vip-color-defined-p color) @@ -375,6 +153,115 @@ (vip-change-cursor-color vip-saved-cursor-color)) +;; Face-saving tricks + +(defvar vip-search-face + (if (vip-has-face-support-p) + (progn + (make-face 'vip-search-face) + (vip-hide-face 'vip-search-face) + (or (face-differs-from-default-p 'vip-search-face) + ;; face wasn't set in .vip or .Xdefaults + (if (vip-can-use-colors "Black" "khaki") + (progn + (set-face-background 'vip-search-face "khaki") + (set-face-foreground 'vip-search-face "Black")) + (set-face-underline-p 'vip-search-face t) + (vip-set-face-pixmap 'vip-search-face vip-search-face-pixmap))) + 'vip-search-face)) + "*Face used to flash out the search pattern.") + +(defvar vip-replace-overlay-face + (if (vip-has-face-support-p) + (progn + (make-face 'vip-replace-overlay-face) + (vip-hide-face 'vip-replace-overlay-face) + (or (face-differs-from-default-p 'vip-replace-overlay-face) + (progn + (if (vip-can-use-colors "darkseagreen2" "Black") + (progn + (set-face-background + 'vip-replace-overlay-face "darkseagreen2") + (set-face-foreground 'vip-replace-overlay-face "Black"))) + (set-face-underline-p 'vip-replace-overlay-face t) + (vip-set-face-pixmap + 'vip-replace-overlay-face vip-replace-overlay-pixmap))) + 'vip-replace-overlay-face)) + "*Face for highlighting replace regions on a window display.") + +(defvar vip-minibuffer-emacs-face + (if (vip-has-face-support-p) + (progn + (make-face 'vip-minibuffer-emacs-face) + (vip-hide-face 'vip-minibuffer-emacs-face) + (or (face-differs-from-default-p 'vip-minibuffer-emacs-face) + ;; face wasn't set in .vip or .Xdefaults + (if vip-vi-style-in-minibuffer + ;; emacs state is an exception in the minibuffer + (if (vip-can-use-colors "darkseagreen2" "Black") + (progn + (set-face-background + 'vip-minibuffer-emacs-face "darkseagreen2") + (set-face-foreground + 'vip-minibuffer-emacs-face "Black")) + (copy-face 'modeline 'vip-minibuffer-emacs-face)) + ;; emacs state is the main state in the minibuffer + (if (vip-can-use-colors "Black" "pink") + (progn + (set-face-background 'vip-minibuffer-emacs-face "pink") + (set-face-foreground + 'vip-minibuffer-emacs-face "Black")) + (copy-face 'italic 'vip-minibuffer-emacs-face)) + )) + 'vip-minibuffer-emacs-face)) + "Face used in the Minibuffer when it is in Emacs state.") + +(defvar vip-minibuffer-insert-face + (if (vip-has-face-support-p) + (progn + (make-face 'vip-minibuffer-insert-face) + (vip-hide-face 'vip-minibuffer-insert-face) + (or (face-differs-from-default-p 'vip-minibuffer-insert-face) + (if vip-vi-style-in-minibuffer + (if (vip-can-use-colors "Black" "pink") + (progn + (set-face-background 'vip-minibuffer-insert-face "pink") + (set-face-foreground + 'vip-minibuffer-insert-face "Black")) + (copy-face 'italic 'vip-minibuffer-insert-face)) + ;; If Insert state is an exception + (if (vip-can-use-colors "darkseagreen2" "Black") + (progn + (set-face-background + 'vip-minibuffer-insert-face "darkseagreen2") + (set-face-foreground + 'vip-minibuffer-insert-face "Black")) + (copy-face 'modeline 'vip-minibuffer-insert-face)) + (vip-italicize-face 'vip-minibuffer-insert-face))) + 'vip-minibuffer-insert-face)) + "Face used in the Minibuffer when it is in Insert state.") + +(defvar vip-minibuffer-vi-face + (if (vip-has-face-support-p) + (progn + (make-face 'vip-minibuffer-vi-face) + (vip-hide-face 'vip-minibuffer-vi-face) + (or (face-differs-from-default-p 'vip-minibuffer-vi-face) + (if vip-vi-style-in-minibuffer + (if (vip-can-use-colors "Black" "grey") + (progn + (set-face-background 'vip-minibuffer-vi-face "grey") + (set-face-foreground 'vip-minibuffer-vi-face "Black")) + (copy-face 'bold 'vip-minibuffer-vi-face)) + (copy-face 'bold 'vip-minibuffer-vi-face) + (invert-face 'vip-minibuffer-vi-face))) + 'vip-minibuffer-vi-face)) + "Face used in the Minibuffer when it is in Vi state.") + +;; the current face to be used in the minibuffer +(vip-deflocalvar vip-minibuffer-current-face vip-minibuffer-emacs-face "") + + ;; Check the current version against the major and minor version numbers ;; using op: cur-vers op major.minor If emacs-major-version or ;; emacs-minor-version are not defined, we assume that the current version @@ -403,8 +290,8 @@ ((memq op '(< <=)) t)))) ;;;; warn if it is a wrong version of emacs -;;(if (or (vip-check-version '< 19 29 'emacs) -;; (vip-check-version '< 19 12 'xemacs)) +;;(if (or (vip-check-version '< 19 35 'emacs) +;; (vip-check-version '< 19 15 'xemacs)) ;; (progn ;; (with-output-to-temp-buffer " *vip-info*" ;; (switch-to-buffer " *vip-info*") @@ -413,9 +300,9 @@ ;; ;;This version of Viper requires ;; -;;\t Emacs 19.29 and higher +;;\t Emacs 19.35 and higher ;;\t OR -;;\t XEmacs 19.12 and higher +;;\t XEmacs 19.15 and higher ;; ;;It is unlikely to work under Emacs version %s ;;that you are using... " emacs-version)) @@ -674,13 +561,6 @@ (setq tmp (cdr tmp))) (reverse (apply 'append tmp2)))) -(defun vip-convert-standard-file-name (fname) - (if vip-emacs-p - (convert-standard-filename fname) - ;; hopefully, XEmacs adds this functionality - fname)) - - ;;; Insertion ring @@ -892,7 +772,15 @@ (vip-overlay-put vip-replace-overlay (if vip-emacs-p 'evaporate 'detachable) nil) (vip-overlay-put - vip-replace-overlay 'priority vip-replace-overlay-priority)) + vip-replace-overlay 'priority vip-replace-overlay-priority) + ;; If Emacs will start supporting overlay maps, as it currently supports + ;; text-property maps, we could do away with vip-replace-minor-mode and + ;; just have keymap attached to replace overlay. + ;;(vip-overlay-put + ;; vip-replace-overlay + ;; (if vip-xemacs-p 'keymap 'local-map) + ;; vip-replace-map) + ) (if (vip-has-face-support-p) (vip-overlay-put vip-replace-overlay 'face vip-replace-overlay-face)) (vip-save-cursor-color) @@ -900,7 +788,7 @@ ) -(defsubst vip-set-replace-overlay-glyphs (before-glyph after-glyph) +(defun vip-set-replace-overlay-glyphs (before-glyph after-glyph) (if (or (not (vip-has-face-support-p)) vip-use-replace-region-delimiters) (let ((before-name (if vip-xemacs-p 'begin-glyph 'before-string)) @@ -908,7 +796,7 @@ (vip-overlay-put vip-replace-overlay before-name before-glyph) (vip-overlay-put vip-replace-overlay after-name after-glyph)))) -(defsubst vip-hide-replace-overlay () +(defun vip-hide-replace-overlay () (vip-set-replace-overlay-glyphs nil nil) (vip-restore-cursor-color-after-replace) (vip-restore-cursor-color-after-insert) @@ -979,7 +867,15 @@ (let ((ESC-keys '(?\e (control \[) escape)) (key (vip-event-key event))) (member key ESC-keys))) - + +;; checks if object is a marker, has a buffer, and points to within that buffer +(defun vip-valid-marker (marker) + (if (and (markerp marker) (marker-buffer marker)) + (let ((buf (marker-buffer marker)) + (pos (marker-position marker))) + (save-excursion + (set-buffer buf) + (and (<= pos (point-max)) (<= (point-min) pos)))))) (defsubst vip-mark-marker () (if vip-xemacs-p @@ -1004,6 +900,21 @@ (if vip-xemacs-p (setq zmacs-region-stays t))) +;; Check if arg is a valid character for register +;; TYPE is a list that can contain `letter', `Letter', and `digit'. +;; Letter means lowercase letters, Letter means uppercase letters, and +;; digit means digits from 1 to 9. +;; If TYPE is nil, then down/uppercase letters and digits are allowed. +(defun vip-valid-register (reg &optional type) + (or type (setq type '(letter Letter digit))) + (or (if (memq 'letter type) + (and (<= ?a reg) (<= reg ?z))) + (if (memq 'digit type) + (and (<= ?1 reg) (<= reg ?9))) + (if (memq 'Letter type) + (and (<= ?A reg) (<= reg ?Z))) + )) + (defsubst vip-events-to-keys (events) (cond (vip-xemacs-p (events-to-keys events)) @@ -1103,40 +1014,44 @@ (defun vip-event-key (event) (or (and event (eventp event)) (error "vip-event-key: Wrong type argument, eventp, %S" event)) - (let ((mod (event-modifiers event)) - basis) - (setq basis - (cond - (vip-xemacs-p - (cond ((key-press-event-p event) - (event-key event)) - ((button-event-p event) - (concat "mouse-" (prin1-to-string (event-button event)))) - (t - (error "vip-event-key: Unknown event, %S" event)))) - (t - ;; Emacs doesn't handle capital letters correctly, since - ;; \S-a isn't considered the same as A (it behaves as - ;; plain `a' instead). So we take care of this here - (cond ((and (vip-characterp event) (<= ?A event) (<= event ?Z)) - (setq mod nil - event event)) - ;; Emacs has the oddity whereby characters 128+char - ;; represent M-char *if* this appears inside a string. - ;; So, we convert them manually to (meta char). - ((and (vip-characterp event) (< ?\C-? event) (<= event 255)) - (setq mod '(meta) - event (- event ?\C-? 1))) - (t (event-basic-type event))) - ))) - (if (vip-characterp basis) - (setq basis - (if (= basis ?\C-?) - (list 'control '\?) ; taking care of an emacs bug - (intern (char-to-string basis))))) - (if mod - (append mod (list basis)) - basis))) + (when (cond (vip-xemacs-p (or (key-press-event-p event) + (mouse-event-p event))) + (t t)) + (let ((mod (event-modifiers event)) + basis) + (setq basis + (cond + (vip-xemacs-p + (cond ((key-press-event-p event) + (event-key event)) + ((button-event-p event) + (concat "mouse-" (prin1-to-string (event-button event)))) + (t + (error "vip-event-key: Unknown event, %S" event)))) + (t + ;; Emacs doesn't handle capital letters correctly, since + ;; \S-a isn't considered the same as A (it behaves as + ;; plain `a' instead). So we take care of this here + (cond ((and (vip-characterp event) (<= ?A event) (<= event ?Z)) + (setq mod nil + event event)) + ;; Emacs has the oddity whereby characters 128+char + ;; represent M-char *if* this appears inside a string. + ;; So, we convert them manually to (meta char). + ((and (vip-characterp event) + (< ?\C-? event) (<= event 255)) + (setq mod '(meta) + event (- event ?\C-? 1))) + (t (event-basic-type event))) + ))) + (if (vip-characterp basis) + (setq basis + (if (= basis ?\C-?) + (list 'control '\?) ; taking care of an emacs bug + (intern (char-to-string basis))))) + (if mod + (append mod (list basis)) + basis)))) (defun vip-key-to-emacs-key (key) (let (key-name char-p modifiers mod-char-list base-key base-key-name) @@ -1303,7 +1218,7 @@ (append (vconcat vip-ALPHA-char-class) nil))))) )) -(defsubst vip-looking-at-separator () +(defun vip-looking-at-separator () (let ((char (char-after (point)))) (if char (or (eq char ?\n) ; RET is always a separator in Vi @@ -1313,7 +1228,7 @@ (defsubst vip-looking-at-alphasep (&optional addl-chars) (or (vip-looking-at-separator) (vip-looking-at-alpha addl-chars))) -(defsubst vip-skip-alpha-forward (&optional addl-chars) +(defun vip-skip-alpha-forward (&optional addl-chars) (or (stringp addl-chars) (setq addl-chars "")) (vip-skip-syntax 'forward @@ -1324,7 +1239,7 @@ (concat vip-strict-ALPHA-chars addl-chars)) (t addl-chars)))) -(defsubst vip-skip-alpha-backward (&optional addl-chars) +(defun vip-skip-alpha-backward (&optional addl-chars) (or (stringp addl-chars) (setq addl-chars "")) (vip-skip-syntax 'backward @@ -1351,14 +1266,14 @@ (funcall func (concat "^" vip-SEP-char-class) (vip-line-pos (if (eq direction 'forward) 'end 'start))))) -(defsubst vip-skip-nonalphasep-forward () +(defun vip-skip-nonalphasep-forward () (if (eq vip-syntax-preference 'strict-vi) (skip-chars-forward (concat "^" vip-strict-SEP-chars vip-strict-ALPHA-chars)) (skip-syntax-forward (concat "^" vip-ALPHA-char-class vip-SEP-char-class) (vip-line-pos 'end)))) -(defsubst vip-skip-nonalphasep-backward () +(defun vip-skip-nonalphasep-backward () (if (eq vip-syntax-preference 'strict-vi) (skip-chars-backward (concat "^" vip-strict-SEP-chars vip-strict-ALPHA-chars)) diff -r ad457d5f7d04 -r 0293115a14e9 lisp/viper/viper.el --- a/lisp/viper/viper.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/viper/viper.el Mon Aug 13 08:49:20 2007 +0200 @@ -6,9 +6,9 @@ ;; Keywords: emulations ;; Author: Michael Kifer -;; Copyright (C) 1994, 1995, 1996 Free Software Foundation, Inc. - -(defconst viper-version "2.92 of January 3, 1997" +;; Copyright (C) 1994, 1995, 1996, 1997 Free Software Foundation, Inc. + +(defconst viper-version "2.92 of January 10, 1997" "The current version of Viper") ;; This file is part of GNU Emacs. @@ -312,7 +312,7 @@ (defvar mark-even-if-inactive) (eval-when-compile - (let ((load-path (cons "." load-path))) + (let ((load-path (cons (expand-file-name ".") load-path))) (or (featurep 'viper-util) (load "viper-util.el" nil nil 'nosuffix)) (or (featurep 'viper-keym) @@ -326,6 +326,7 @@ )) ;; end pacifier + (require 'viper-util) (require 'viper-keym) (require 'viper-mous) @@ -334,462 +335,6 @@ -;;; Variables - -;; Is t until viper-mode executes for the very first time. -;; Prevents recursive descend into startup messages. -(defvar vip-first-time t) - -(defvar vip-expert-level 0 - "User's expert level. -The minor mode vip-vi-diehard-minor-mode is in effect when -vip-expert-level is 1 or 2 or when vip-want-emacs-keys-in-vi is t. -The minor mode vip-insert-diehard-minor-mode is in effect when -vip-expert-level is 1 or 2 or if vip-want-emacs-keys-in-insert is t. -Use `M-x vip-set-expert-level' to change this.") - -;; Max expert level supported by Viper. This is NOT a user option. -;; It is here to make it hard for the user from resetting it. -(defconst vip-max-expert-level 5) - -;; Contains user settings for vars affected by vip-set-expert-level function. -;; Not a user option. -(defvar vip-saved-user-settings nil) - - -;;; ISO characters - -(vip-deflocalvar vip-automatic-iso-accents nil - "*If non-nil, ISO accents will be turned on in insert/replace emacs states and turned off in vi-state. -For some users, this behavior may be too primitive. In this case, use -insert/emacs/vi state hooks.") - - -;; VI-style Undo - -;; Used to 'undo' complex commands, such as replace and insert commands. -(vip-deflocalvar vip-undo-needs-adjustment nil) -(put 'vip-undo-needs-adjustment 'permanent-local t) - -;; A mark that Viper puts on buffer-undo-list. Marks the beginning of a -;; complex command that must be undone atomically. If inserted, it is -;; erased by vip-change-state-to-vi and vip-repeat. -(defconst vip-buffer-undo-list-mark 'viper) - -(defvar vip-keep-point-on-undo nil - "*Non-nil means not to move point while undoing commands. -This style is different from Emacs and Vi. Try it to see if -it better fits your working style.") - -;; Replace mode and changing text - -;; Viper's own after/before change functions, which get vip-add-hook'ed to -;; Emacs's -(vip-deflocalvar vip-after-change-functions nil "") -(vip-deflocalvar vip-before-change-functions nil "") -(vip-deflocalvar vip-post-command-hooks nil "") -(vip-deflocalvar vip-pre-command-hooks nil "") - -;; Can be used to pass global states around for short period of time -(vip-deflocalvar vip-intermediate-command nil "") - -;; Indicates that the current destructive command has started in replace mode. -(vip-deflocalvar vip-began-as-replace nil "") - -(defvar vip-replace-overlay-cursor-color "Red" - "*Cursor color to use in Replace state") -(defvar vip-insert-state-cursor-color nil - "Cursor color for Viper insert state.") -(put 'vip-insert-state-cursor-color 'permanent-local t) -;; place to save cursor colow when switching to insert mode -(vip-deflocalvar vip-saved-cursor-color nil "") - -(vip-deflocalvar vip-replace-overlay nil "") -(put 'vip-replace-overlay 'permanent-local t) - -(defvar vip-replace-overlay-pixmap "gray3" - "Pixmap to use for search face on non-color displays.") -(defvar vip-search-face-pixmap "gray3" - "Pixmap to use for search face on non-color displays.") - - -(defun vip-set-replace-overlay-face () - (if (vip-has-face-support-p) - (defvar vip-replace-overlay-face - (progn - (make-face 'vip-replace-overlay-face) - (vip-hide-face 'vip-replace-overlay-face) - (or (face-differs-from-default-p 'vip-replace-overlay-face) - (progn - (if (vip-can-use-colors "darkseagreen2" "Black") - (progn - (set-face-background - 'vip-replace-overlay-face "darkseagreen2") - (set-face-foreground 'vip-replace-overlay-face "Black"))) - (set-face-underline-p 'vip-replace-overlay-face t) - (vip-set-face-pixmap - 'vip-replace-overlay-face vip-replace-overlay-pixmap))) - 'vip-replace-overlay-face) - "*Face for highlighting replace regions on a window display.") - )) - -(defvar vip-replace-region-end-delimiter "$" - "A string marking the end of replacement regions. -It is used only with TTYs or if `vip-use-replace-region-delimiters' -is non-nil.") -(defvar vip-replace-region-start-delimiter "" - "A string marking the beginning of replacement regions. -It is used only with TTYs or if `vip-use-replace-region-delimiters' -is non-nil.") -(defvar vip-use-replace-region-delimiters (not (vip-has-face-support-p)) - "*If non-nil, Viper will always use `vip-replace-region-end-delimiter' and -`vip-replace-region-start-delimiter' to delimit replacement regions, even on -color displays. By default, the delimiters are used only on TTYs.") - -;; XEmacs requires glyphs -(if vip-xemacs-p - (progn - (or (glyphp vip-replace-region-end-delimiter) - (setq vip-replace-region-end-delimiter - (make-glyph vip-replace-region-end-delimiter))) - (or (glyphp vip-replace-region-start-delimiter) - (setq vip-replace-region-start-delimiter - (make-glyph vip-replace-region-start-delimiter))) - )) - - -;; These are local marker that must be initialized to nil and moved with -;; `vip-move-marker-locally' -;; -;; Remember the last position inside the replace region. -(vip-deflocalvar vip-last-posn-in-replace-region nil) -;; Remember the last position while inserting -(vip-deflocalvar vip-last-posn-while-in-insert-state nil) -(put 'vip-last-posn-in-replace-region 'permanent-local t) -(put 'vip-last-posn-while-in-insert-state 'permanent-local t) - -(vip-deflocalvar vip-sitting-in-replace nil "") -(put 'vip-sitting-in-replace 'permanent-local t) - -;; Remember the number of characters that have to be deleted in replace -;; mode to compensate for the inserted characters. -(vip-deflocalvar vip-replace-chars-to-delete 0 "") -(vip-deflocalvar vip-replace-chars-deleted 0 "") - -;; Insertion ring and command ring -(defvar vip-insertion-ring-size 14 - "The size of the insertion ring.") -;; The insertion ring. -(defvar vip-insertion-ring nil) -;; This is temp insertion ring. Used to do rotation for display purposes. -;; When rotation just started, it is initialized to vip-insertion-ring. -(defvar vip-temp-insertion-ring nil) -(defvar vip-last-inserted-string-from-insertion-ring "") - -(defvar vip-command-ring-size 14 - "The size of the command ring.") -;; The command ring. -(defvar vip-command-ring nil) -;; This is temp command ring. Used to do rotation for display purposes. -;; When rotation just started, it is initialized to vip-command-ring. -(defvar vip-temp-command-ring nil) - -;; Modes and related variables - -;; Current mode. One of: `emacs-state', `vi-state', `insert-state' -(vip-deflocalvar vip-current-state 'emacs-state) - - -;; Autoindent in insert - -;; Variable that keeps track of whether C-t has been pressed. -(vip-deflocalvar vip-cted nil "") - -;; Preserve the indent value, used by C-d in insert mode. -(vip-deflocalvar vip-current-indent 0) - -;; Whether to preserve the indent, used by C-d in insert mode. -(vip-deflocalvar vip-preserve-indent nil) - -(vip-deflocalvar vip-auto-indent nil - "*Autoindent if t.") -(vip-deflocalvar vip-electric-mode t - "*If t, enable electric behavior. -Currently only enables auto-indentation `according to mode'.") - -(defconst vip-shift-width 8 - "*The shiftwidth variable.") - -;; Variables for repeating destructive commands - -(defconst vip-keep-point-on-repeat t - "*If t, don't move point when repeating previous command. -This is useful for doing repeated changes with the '.' key. -The user can change this to nil, if she likes when the cursor moves -to a new place after repeating previous Vi command.") - -;; Remember insert point as a marker. This is a local marker that must be -;; initialized to nil and moved with `vip-move-marker-locally'. -(vip-deflocalvar vip-insert-point nil) -(put 'vip-insert-point 'permanent-local t) - -;; This remembers the point before dabbrev-expand was called. -;; If vip-insert-point turns out to be bigger than that, it is reset -;; back to vip-pre-command-point. -;; The reason this is needed is because dabbrev-expand (and possibly -;; others) may jump to before the insertion point, delete something and -;; then reinsert a bigger piece. For instance: bla^blo -;; If dabbrev-expand is called after `blo' and ^ undicates vip-insert-point, -;; then point jumps to the beginning of `blo'. If expansion is found, `blablo' -;; is deleted, and we have |^, where | denotes point. Next, dabbrev-expand -;; will insert the expansion, and we get: blablo^ -;; Whatever we insert next goes before the ^, i.e., before the -;; vip-insert-point marker. So, Viper will think that nothing was -;; inserted. Remembering the orig position of the marker circumvents the -;; problem. -;; We don't know of any command, except dabbrev-expand, that has the same -;; problem. However, the same trick can be used if such a command is -;; discovered later. -;; -(vip-deflocalvar vip-pre-command-point nil) -(put 'vip-pre-command-point 'permanent-local t) ; this is probably an overkill - -;; This is used for saving inserted text. -(defvar vip-last-insertion nil) - -;; Remembers the last replaced region. -(defvar vip-last-replace-region "") - -;; Remember com point as a marker. -;; This is a local marker. Should be moved with `vip-move-marker-locally' -(vip-deflocalvar vip-com-point nil) - -;; If non-nil, the value is a list (M-COM VAL COM REG inserted-text cmd-keys) -;; It is used to re-execute last destructive command. -;; M-COM is a Lisp symbol representing the function to be executed. -;; VAL is the prefix argument that was used with that command. -;; COM is an internal descriptor, such as ?r, ?c, ?C, which contains -;; additional information on how the function in M-COM is to be handled. -;; REG is the register used by command -;; INSERTED-TEXT is text inserted by that command (in case of o, c, C, i, r -;; commands). -;; COMMAND-KEYS are the keys that were typed to invoke the command. -(defvar vip-d-com nil) - -;; The character remembered by the Vi `r' command. -(defvar vip-d-char nil) - -;; Name of register to store deleted or yanked strings -(defvar vip-use-register nil) - - - -;; Variables for Moves and Searches - -;; For use by `;' command. -(defvar vip-f-char nil) - -;; For use by `.' command. -(defvar vip-F-char nil) - -;; For use by `;' command. -(defvar vip-f-forward nil) - -;; For use by `;' command. -(defvar vip-f-offset nil) - -;; Last search string -(defvar vip-s-string "") - -(defvar vip-quote-string "> " - "String inserted at the beginning of quoted region.") - -;; If t, search is forward. -(defvar vip-s-forward nil) - -(defconst vip-case-fold-search nil - "*If not nil, search ignores cases.") - -(defconst vip-re-search t - "*If not nil, search is reg-exp search, otherwise vanilla search.") - -(defvar vip-search-scroll-threshold 2 - "*If search lands within this threshnold from the window top/bottom, -the window will be scrolled up or down appropriately, to reveal context. -If you want Viper search to behave as usual in Vi, set this variable to a -negative number.") - -(defconst vip-re-query-replace t - "*If t then do regexp replace, if nil then do string replace.") - -(defconst vip-re-replace t - "*If t, do regexp replace. nil means do string replace.") - -(vip-deflocalvar vip-ex-style-motion t - "*Ex-style: the commands l,h do not cross lines, etc.") - -(vip-deflocalvar vip-ex-style-editing-in-insert t - "*The keys ^H, ^? don't jump lines in insert, ESC moves cursor back, etc. -Note: this doesn't preclude ^H and ^? from deleting characters by moving -past the insertion point. This is a feature, not a bug. ") - -(vip-deflocalvar vip-delete-backwards-in-replace nil - "*If t, DEL key will delete characters while moving the cursor backwards. -If nil, the cursor will move backwards without deleting anything.") - -(defconst vip-buffer-search-char nil - "*Key bound for buffer-searching.") - -(defconst vip-search-wrap-around-t t - "*If t, search wraps around.") - -(vip-deflocalvar vip-related-files-and-buffers-ring nil - "*Ring of file and buffer names that are considered to be related to the -current buffer. -These buffers can be cycled through via :R and :P commands.") -(put 'vip-related-files-and-buffers-ring 'permanent-local t) - -;; Used to find out if we are done with searching the current buffer. -(vip-deflocalvar vip-local-search-start-marker nil) -;; As above, but global -(defvar vip-search-start-marker (make-marker)) - -;; the search overlay -(vip-deflocalvar vip-search-overlay nil) - - -(defvar vip-heading-start - (concat "^\\s-*(\\s-*defun\\s-\\|" ; lisp - "^{\\s-*$\\|^[_a-zA-Z][^()]*[()].*{\\s-*$\\|" ; C/C++ - "^\\s-*class.*{\\|^\\s-*struct.*{\\|^\\s-*enum.*{\\|" - "^\\\\[sb][a-z]*{.*}\\s-*$\\|" ; latex - "^@node\\|@table\\|^@m?enu\\|^@itemize\\|^@if\\|" ; texinfo - "^.+:-") ; prolog - "*Regexps for Headings. Used by \[\[ and \]\].") - -(defvar vip-heading-end - (concat "^}\\|" ; C/C++ - "^\\\\end{\\|" ; latex - "^@end \\|" ; texinfo - ")\n\n[ \t\n]*\\|" ; lisp - "\\.\\s-*$") ; prolog - "*Regexps to end Headings/Sections. Used by \[\].") - - -;; These two vars control the interaction of jumps performed by ' and `. -;; In this new version, '' doesn't erase the marks set by ``, so one can -;; use both kinds of jumps interchangeably and without loosing positions -;; inside the lines. - -;; Remembers position of the last jump done using ``'. -(vip-deflocalvar vip-last-jump nil) -;; Remembers position of the last jump done using `''. -(vip-deflocalvar vip-last-jump-ignore 0) - -;; History variables - -;; History of search strings. -(defvar vip-search-history (list "")) -;; History of query-replace strings used as a source. -(defvar vip-replace1-history nil) -;; History of query-replace strings used as replacement. -(defvar vip-replace2-history nil) -;; History of region quoting strings. -(defvar vip-quote-region-history (list vip-quote-string)) -;; History of Ex-style commands. -(defvar vip-ex-history nil) -;; History of shell commands. -(defvar vip-shell-history nil) - - -;; Last shell command. There are two of these, one for Ex (in viper-ex) -;; and one for Vi. - -;; Last shell command executed with ! command. -(defvar vip-last-shell-com nil) - - - -;;; Miscellaneous - -;; don't bark when mark is inactive -(setq mark-even-if-inactive t) - -(defvar vip-inhibit-startup-message nil - "Whether Viper startup message should be inhibited.") - -(defvar vip-always t - "t means, arrange that vi-state will be a default.") - -(defvar vip-custom-file-name (vip-convert-standard-file-name "~/.vip") - "Viper customisation file. -This variable must be set _before_ loading Viper.") - - -(defvar vip-spell-function 'ispell-region - "Spell function used by #s command to spell.") - -(defvar vip-tags-file-name "TAGS" - "The tags file used by Viper.") - -;; Indicates if we are in the middle of executing a command that takes another -;; command as an argument, e.g., cw, dw, etc. -(defvar vip-inside-command-argument-action nil) - -;; Minibuffer - -(defvar vip-vi-style-in-minibuffer t - "If t, use vi-style editing in minibuffer. -Should be set in `~/.vip' file.") - -;; overlay used in the minibuffer to indicate which state it is in -(vip-deflocalvar vip-minibuffer-overlay nil) - -;; Hook, specific to Viper, which is run just *before* exiting the minibuffer. -;; Beginning with Emacs 19.26, the standard `minibuffer-exit-hook' is run -;; *after* exiting the minibuffer -(defvar vip-minibuffer-exit-hook nil) - -;; setup emacs-supported vi-style feel -(setq next-line-add-newlines nil - require-final-newline t) - -(make-variable-buffer-local 'require-final-newline) - - -;; Mode line -(defconst vip-vi-state-id " " - "Mode line tag identifying the Vi mode of Viper.") -(defconst vip-emacs-state-id " " - "Mode line tag identifying the Emacs mode of Viper.") -(defconst vip-insert-state-id " " - "Mode line tag identifying the Insert mode of Viper.") -(defconst vip-replace-state-id " " - "Mode line tag identifying the Replace mode of Viper.") - -;; Viper changes the default mode-line-buffer-identification -(setq-default mode-line-buffer-identification '(" %b")) - -;; Variable displaying the current Viper state in the mode line. -(vip-deflocalvar vip-mode-string vip-emacs-state-id) -(or (memq 'vip-mode-string global-mode-string) - (setq global-mode-string - (append '("" vip-mode-string) (cdr global-mode-string)))) - - -(defvar vip-vi-state-hook nil - "*Hooks run just before the switch to Vi mode is completed.") -(defvar vip-insert-state-hook nil - "*Hooks run just before the switch to Insert mode is completed.") -(defvar vip-replace-state-hook nil - "*Hooks run just before the switch to Replace mode is completed.") -(defvar vip-emacs-state-hook nil - "*Hooks run just before the switch to Emacs mode is completed.") - -(defvar vip-load-hook nil - "Hooks run just after loading Viper.") - - ;; Generic predicates ;; These test functions are shamelessly lifted from vip 4.4.2 by Aamod Sane @@ -828,6 +373,11 @@ ;; define vip-movement-command-p (vip-test-com-defun vip-movement-command) +(defconst vip-digit-commands '(?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9) + "Digit commands") +;; define vip-digit-command-p +(vip-test-com-defun vip-digit-command) + ;; Commands that can be repeated by . (dotted) (defconst vip-dotable-commands '(?c ?d ?C ?s ?S ?D ?> ?<)) ;; define vip-dotable-command-p @@ -844,6 +394,7 @@ (vip-test-com-defun vip-regsuffix-command) (defconst vip-vi-commands (append vip-movement-commands + vip-digit-commands vip-dotable-commands vip-charpair-commands vip-hash-commands @@ -1490,7 +1041,12 @@ (let ((buff (current-buffer)) result) (vip-set-mode-vars-for 'vi-state) - (setq result (eval form)) + + (condition-case nil + (setq result (eval form)) + (error + (signal 'quit nil))) + (if (not (equal buff (current-buffer))) ; cmd switched buffer (save-excursion (set-buffer buff) @@ -1708,6 +1264,7 @@ (t 'vip-change-state-to-vi) ))) (call-interactively cmd))) + @@ -1838,6 +1395,9 @@ (setq char (read-char))) ;; `char' is a movement command or a digit arg command---so we execute ;; it at the very end + (or (vip-movement-command-p char) + (vip-digit-command-p char) + (error "")) (setq mv-or-digit-cmd (vip-exec-form-in-vi (` (key-binding (char-to-string (, char))))))) @@ -1870,7 +1430,10 @@ (setq last-command-event (vip-copy-event (if vip-xemacs-p (character-to-event char) char))) - (funcall mv-or-digit-cmd cmd-info))) + (condition-case nil + (funcall mv-or-digit-cmd cmd-info) + (error + (error ""))))) )) (defun vip-describe-arg (arg) @@ -2538,100 +2101,6 @@ (command-execute command) (exit-minibuffer)))) - -(defun vip-set-search-face () - (if (vip-has-face-support-p) - (defvar vip-search-face - (progn - (make-face 'vip-search-face) - (vip-hide-face 'vip-search-face) - (or (face-differs-from-default-p 'vip-search-face) - ;; face wasn't set in .vip or .Xdefaults - (if (vip-can-use-colors "Black" "khaki") - (progn - (set-face-background 'vip-search-face "khaki") - (set-face-foreground 'vip-search-face "Black")) - (set-face-underline-p 'vip-search-face t) - (vip-set-face-pixmap 'vip-search-face vip-search-face-pixmap))) - 'vip-search-face) - "*Face used to flash out the search pattern.") - )) - - -(defun vip-set-minibuffer-faces () - (if (not (vip-has-face-support-p)) - () - (defvar vip-minibuffer-emacs-face - (progn - (make-face 'vip-minibuffer-emacs-face) - (vip-hide-face 'vip-minibuffer-emacs-face) - (or (face-differs-from-default-p 'vip-minibuffer-emacs-face) - ;; face wasn't set in .vip or .Xdefaults - (if vip-vi-style-in-minibuffer - ;; emacs state is an exception in the minibuffer - (if (vip-can-use-colors "darkseagreen2" "Black") - (progn - (set-face-background - 'vip-minibuffer-emacs-face "darkseagreen2") - (set-face-foreground - 'vip-minibuffer-emacs-face "Black")) - (copy-face 'modeline 'vip-minibuffer-emacs-face)) - ;; emacs state is the main state in the minibuffer - (if (vip-can-use-colors "Black" "pink") - (progn - (set-face-background 'vip-minibuffer-emacs-face "pink") - (set-face-foreground - 'vip-minibuffer-emacs-face "Black")) - (copy-face 'italic 'vip-minibuffer-emacs-face)) - )) - 'vip-minibuffer-emacs-face) - "Face used in the Minibuffer when it is in Emacs state.") - - (defvar vip-minibuffer-insert-face - (progn - (make-face 'vip-minibuffer-insert-face) - (vip-hide-face 'vip-minibuffer-insert-face) - (or (face-differs-from-default-p 'vip-minibuffer-insert-face) - (if vip-vi-style-in-minibuffer - (if (vip-can-use-colors "Black" "pink") - (progn - (set-face-background 'vip-minibuffer-insert-face "pink") - (set-face-foreground - 'vip-minibuffer-insert-face "Black")) - (copy-face 'italic 'vip-minibuffer-insert-face)) - ;; If Insert state is an exception - (if (vip-can-use-colors "darkseagreen2" "Black") - (progn - (set-face-background - 'vip-minibuffer-insert-face "darkseagreen2") - (set-face-foreground - 'vip-minibuffer-insert-face "Black")) - (copy-face 'modeline 'vip-minibuffer-insert-face)) - (vip-italicize-face 'vip-minibuffer-insert-face))) - 'vip-minibuffer-insert-face) - "Face used in the Minibuffer when it is in Insert state.") - - (defvar vip-minibuffer-vi-face - (progn - (make-face 'vip-minibuffer-vi-face) - (vip-hide-face 'vip-minibuffer-vi-face) - (or (face-differs-from-default-p 'vip-minibuffer-vi-face) - (if vip-vi-style-in-minibuffer - (if (vip-can-use-colors "Black" "grey") - (progn - (set-face-background 'vip-minibuffer-vi-face "grey") - (set-face-foreground 'vip-minibuffer-vi-face "Black")) - (copy-face 'bold 'vip-minibuffer-vi-face)) - (copy-face 'bold 'vip-minibuffer-vi-face) - (invert-face 'vip-minibuffer-vi-face))) - 'vip-minibuffer-vi-face) - "Face used in the Minibuffer when it is in Vi state.") - - ;; the current face used in the minibuffer - (vip-deflocalvar vip-minibuffer-current-face vip-minibuffer-emacs-face "") - )) - - ;;; Reading string with history @@ -2873,6 +2342,10 @@ 'vip-post-command-hooks 'vip-replace-state-post-command-sentinel t) (vip-add-hook 'vip-pre-command-hooks 'vip-replace-state-pre-command-sentinel t) + ;; guard against a smartie who switched from R-replace to normal replace + (vip-remove-hook + 'vip-post-command-hooks 'vip-R-state-post-command-sentinel) + (if overwrite-mode (overwrite-mode nil)) ) @@ -2948,9 +2421,11 @@ )) (setq vip-replace-chars-to-delete - (max 0 (min vip-replace-chars-to-delete - (- (vip-replace-end) - vip-last-posn-in-replace-region)))) + (max 0 + (min vip-replace-chars-to-delete + (- (vip-replace-end) vip-last-posn-in-replace-region) + (- (vip-line-pos 'end) vip-last-posn-in-replace-region) + ))) ))) @@ -3002,6 +2477,9 @@ 'vip-post-command-hooks 'vip-R-state-post-command-sentinel t) (vip-add-hook 'vip-pre-command-hooks 'vip-replace-state-pre-command-sentinel t) + ;; guard against a smartie who switched from R-replace to normal replace + (vip-remove-hook + 'vip-post-command-hooks 'vip-replace-state-post-command-sentinel) ) @@ -3026,6 +2504,29 @@ ) (vip-hide-replace-overlay)) +(defun vip-replace-state-carriage-return () + "Implements carriage return in Viper replace state." + (interactive) + ;; If Emacs start supporting overlay maps, as it currently supports + ;; text-property maps, we could do away with vip-replace-minor-mode and + ;; just have keymap attached to replace overlay. Then the "if part" of this + ;; statement can be deleted. + (if (or (< (point) (vip-replace-start)) + (> (point) (vip-replace-end))) + (let (vip-replace-minor-mode com) + (vip-set-unread-command-events last-input-char) + (setq com (key-binding (read-key-sequence nil))) + (condition-case conds + (command-execute com) + (error + (vip-message-conditions conds)))) + (if (not vip-allow-multiline-replace-regions) + (vip-replace-state-exit-cmd) + (if (vip-same-line (point) (vip-replace-end)) + (vip-replace-state-exit-cmd) + (vip-kill-line nil) + (vip-next-line-at-bol nil))))) + ;; This is the function bound to 'R'---unlimited replace. ;; Similar to Emacs's own overwrite-mode. @@ -4633,8 +4134,9 @@ ;; protect against error while inserting "@" and other disasters ;; (e.g., read-only buff) (condition-case conds - (if (vip-same-line (vip-replace-start) - (vip-replace-end)) + (if (or vip-allow-multiline-replace-regions + (vip-same-line (vip-replace-start) + (vip-replace-end))) (progn ;; tabs cause problems in replace, so untabify (goto-char (vip-replace-end)) @@ -5733,9 +5235,6 @@ (vip-set-minibuffer-style) -(vip-set-minibuffer-faces) -(vip-set-search-face) -(vip-set-replace-overlay-face) (if vip-buffer-search-char (vip-buffer-search-enable)) (vip-update-alphanumeric-class) diff -r ad457d5f7d04 -r 0293115a14e9 lisp/vms/vms-patch.el --- a/lisp/vms/vms-patch.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/vms/vms-patch.el Mon Aug 13 08:49:20 2007 +0200 @@ -16,8 +16,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Functions that need redefinition diff -r ad457d5f7d04 -r 0293115a14e9 lisp/vms/vmsproc.el --- a/lisp/vms/vmsproc.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/vms/vmsproc.el Mon Aug 13 08:49:20 2007 +0200 @@ -19,8 +19,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Code: diff -r ad457d5f7d04 -r 0293115a14e9 lisp/vms/vmsx.el --- a/lisp/vms/vmsx.el Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/vms/vmsx.el Mon Aug 13 08:49:20 2007 +0200 @@ -19,8 +19,9 @@ ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Code: diff -r ad457d5f7d04 -r 0293115a14e9 lisp/w3/ChangeLog --- a/lisp/w3/ChangeLog Mon Aug 13 08:48:43 2007 +0200 +++ b/lisp/w3/ChangeLog Mon Aug 13 08:49:20 2007 +0200 @@ -1,5 +1,411 @@ +Thu Jan 30 20:27:06 1997 William M. Perry + +* w3-display.el (w3-handle-image): When doing table auto layout, don't + start loading the images. + +Wed Jan 29 06:15:37 1997 William M. Perry + +* font.el (x-font-create-name): Yet another fix for not screwing up the + line-height in Emacs 19. + +* w3-display.el (w3-face-for-element): Uhh, oblique seems to work. + +* font.el (set-font-style-by-keywords): now deals with arguments that + aren't lists, for the font-style and font-variant CSS stuff + +* w3-display.el (w3-display-node): Reimplemented tag. +(w3-display-node): Reimplemented tag. + +* url.el (url-insert-file-contents): url-insert-file-contents now + decodes/uncompresses the data before returning. + +* w3-display.el (w3-display-node): Reimplemented tag + +Tue Jan 28 06:22:08 1997 William M. Perry + +* font.el (x-font-create-name): Never take font size into account under + Emacs - too much chance of totally screwing up the users leading by + choosing a bigger font than their default. This sucks. But I can't + find a better solution. + +* w3.el: w3-mode now turns on truncate-lines by default. + +* w3-forms.el (w3-form-create-image): Better image input type support. + +Mon Jan 27 08:21:58 1997 William M. Perry + +* w3-forms.el (w3-form-create-password): Now uses real password entry + widgets provided by 'widget' - you _MUST_USE_ the widget library that + comes with Emacs-W3 for this, otherwise the info won't be hidden + correctly. + (w3-form-add-element): Deal with hidden text areas better when they are + in forms + +* Synch'd up to widget 1.22 + +Sun Jan 26 16:50:09 1997 William M. Perry + +* Emacs-W3 3.0.51 released + +* w3-forms.el (w3-form-create-text): Now uses the real text entry widgets + provided by 'widget' - still can't do this for password fields yet + though. + +* Synch'd up to Widget 1.20 + +Sat Jan 25 13:38:12 1997 William M. Perry + +* url.el (url-expand-file-name): Now strips out spaces as well as + newlines/carriage returns. More fixes for that bastardized microsoft + home page. + +* url-http.el (url-create-mime-request): Make sure that we retrieve the + cookies for the real URL we are retrieving when going through a proxy. + Now the psychotic crap that is the microsoft home page should be + successfully retrieved if going through an HTTP proxy. + +* url-cookie.el (url-cookie-handle-set-cookie): Attempt to deal with + idiotic microsoft home page that sends out set-cookie headers that look + like MC1=ID=abc, and expects two cookies MC1='' and ID='abc' *sigh* + +* w3-forms.el, w3-display.el: Form elements now keep all their attributes + with them. Will be useful when we start allowing scripting. + (w3-form-create-custom): Rudimentary patches to allow embedding 'custom' + widgets into the buffer. Interesting. + +* w3-forms.el (w3-form-determine-size): New function to calculate how big + a form field will be - option lists should look much better now. + +Thu Jan 23 08:48:59 1997 William M. Perry + +* Synch'ed up to custom 1.19 + +* url-parse.el: document extra slots of url-generic-parse-url + +Thu Jan 23 08:34:34 1997 Joe Wells + +* url-file.el (url-file): Patch to tell ange-ftp and/or efs the password + in a file/ftp URL so that you won't be prompted for the password, even + if one was specified in the URL + +* url-parse.el (url-generic-parse-url): Fixed bug where specifying a + username and password in the URL would downcase the username and + password as well as the hostname. + +Wed Jan 22 08:28:13 1997 William M. Perry + +* Emacs-W3 3.0.50 released + +* base64.el (base64-encode-region): Pulled in code from VM for quicker + encoding/decoding + +* mm.el (mm-content-transfer-encodings): Better base64 decoding + +Wed Jan 22 07:31:03 1997 Alf-Ivar Holm + +* w3-emulate.el (w3-lynx-emulation-minor-mode-map): Lynx [up] and [down] + bound to non-existing functions. + +* w3.el (w3-do-setup): Fixed installation of lynx emulation modes keymap. + +Tue Jan 21 07:56:51 1997 William M. Perry + +* url-misc.el (url-data): Make sure to url-decode the data before + inserting it into the buffer. + +* w3-menu.el (w3-toggle-minibuffer): better version + +* w3-forms.el (w3-form-create-integer): New form entry type + (w3-form-create-float): new form entry type + (w3-form-encode-helper): deal with the new integer/float types + +* w3-display.el (w3-display-node): Reimplemented